Inserted a NULL value

8 files changed, 205 insertions, 44 deletions

diff --git a/src/c/urweb.c b/src/c/urweb.c
index 638fbb16..1530c138 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -872,6 +872,13 @@ char *uw_Basis_sqlifyInt(uw_context ctx, uw_Basis_int n) {
   return r;
 }
 
+char *uw_Basis_sqlifyIntN(uw_context ctx, uw_Basis_int *n) {
+  if (n == NULL)
+    return "NULL";
+  else
+    return uw_Basis_sqlifyInt(ctx, *n);
+}
+
 char *uw_Basis_sqlifyFloat(uw_context ctx, uw_Basis_float n) {
   int len;
   char *r;
@@ -883,6 +890,13 @@ char *uw_Basis_sqlifyFloat(uw_context ctx, uw_Basis_float n) {
   return r;
 }
 
+char *uw_Basis_sqlifyFloatN(uw_context ctx, uw_Basis_float *n) {
+  if (n == NULL)
+    return "NULL";
+  else
+    return uw_Basis_sqlifyFloat(ctx, *n);
+}
+
 
 uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) {
   char *r, *s2;
@@ -920,6 +934,13 @@ uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) {
   return r;
 }
 
+uw_Basis_string uw_Basis_sqlifyStringN(uw_context ctx, uw_Basis_string s) {
+  if (s == NULL)
+    return "NULL";
+  else
+    return uw_Basis_sqlifyString(ctx, s);
+}
+
 char *uw_Basis_sqlifyBool(uw_context ctx, uw_Basis_bool b) {
   if (b == uw_Basis_False)
     return "FALSE";
@@ -927,6 +948,13 @@ char *uw_Basis_sqlifyBool(uw_context ctx, uw_Basis_bool b) {
     return "TRUE";
 }
 
+char *uw_Basis_sqlifyBoolN(uw_context ctx, uw_Basis_bool *b) {
+  if (b == NULL)
+    return "NULL";
+  else
+    return uw_Basis_sqlifyBool(ctx, *b);
+}
+
 char *uw_Basis_sqlifyTime(uw_context ctx, uw_Basis_time t) {
   size_t len;
   char *r;
@@ -942,6 +970,13 @@ char *uw_Basis_sqlifyTime(uw_context ctx, uw_Basis_time t) {
     return "<Invalid time>";
 }
 
+char *uw_Basis_sqlifyTimeN(uw_context ctx, uw_Basis_time *t) {
+  if (t == NULL)
+    return "NULL";
+  else
+    return uw_Basis_sqlifyTime(ctx, *t);
+}
+
 char *uw_Basis_ensqlBool(uw_Basis_bool b) {
   static uw_Basis_int true = 1;
   static uw_Basis_int false = 0;
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 06154b91..d7e426c3 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -408,24 +408,61 @@ fun p_unsql wontLeakStrings env (tAll as (t, loc)) e =
             box [string "uw_Basis_strdup(ctx, ", e, string ")"]
       | TFfi ("Basis", "bool") => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"]
       | TFfi ("Basis", "time") => box [string "uw_Basis_stringToTime_error(ctx, ", e, string ")"]
+
       | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL";
               Print.eprefaces' [("Type", p_typ env tAll)];
               string "ERROR")
 
+fun p_getcol wontLeakStrings env (tAll as (t, loc)) i =
+    case t of
+        TOption t =>
+        box [string "(PQgetisnull (res, i, ",
+             string (Int.toString i),
+             string ") ? NULL : ",
+             case t of
+                 (TFfi ("Basis", "string"), _) => p_getcol wontLeakStrings env t i
+               | _ => box [string "({",
+                           newline,
+                           p_typ env t,
+                           space,
+                           string "*tmp = uw_malloc(ctx, sizeof(",
+                           p_typ env t,
+                           string "));",
+                           newline,
+                           string "*tmp = ",
+                           p_getcol wontLeakStrings env t i,
+                           string ";",
+                           newline,
+                           string "tmp;",
+                           newline,
+                           string "})"],
+             string ")"]
+             
+      | _ =>
+        p_unsql wontLeakStrings env tAll
+                (box [string "PQgetvalue(res, i, ",
+                      string (Int.toString i),
+                      string ")"])
+
 datatype sql_type =
          Int
        | Float
        | String
        | Bool
        | Time
+       | Nullable of sql_type
+
+fun p_sql_type' t =
+    case t of
+        Int => "uw_Basis_int"
+      | Float => "uw_Basis_float"
+      | String => "uw_Basis_string"
+      | Bool => "uw_Basis_bool"
+      | Time => "uw_Basis_time"
+      | Nullable String => "uw_Basis_string"
+      | Nullable t => p_sql_type' t ^ "*"
 
-fun p_sql_type t =
-    string (case t of
-                Int => "uw_Basis_int"
-              | Float => "uw_Basis_float"
-              | String => "uw_Basis_string"
-              | Bool => "uw_Basis_bool"
-              | Time => "uw_Basis_time")
+fun p_sql_type t = string (p_sql_type' t)
 
 fun getPargs (e, _) =
     case e of
@@ -448,6 +485,12 @@ fun p_ensql t e =
       | String => e
       | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"]
       | Time => box [string "uw_Basis_sqlifyTime(ctx, ", e, string ")"]
+      | Nullable String => e
+      | Nullable t => box [string "(",
+                           e,
+                           string " == NULL ? NULL : ",
+                           p_ensql t (box [string "*", e]),
+                           string ")"]
 
 fun notLeaky env allowHeapAllocated =
     let
@@ -1169,10 +1212,7 @@ fun p_exp' par env (e, loc) =
                                                     space,
                                                     string "=",
                                                     space,
-                                                    p_unsql wontLeakStrings env t
-                                                            (box [string "PQgetvalue(res, i, ",
-                                                                  string (Int.toString i),
-                                                                  string ")"]),
+                                                    p_getcol wontLeakStrings env t i,
                                                     string ";",
                                                     newline]) outputs,
              
@@ -1660,7 +1700,10 @@ fun p_decl env (dAll as (d, _) : decl) =
                             string "}",
                             newline]
 
-      | DPreparedStatements [] => box []
+      | DPreparedStatements [] =>
+        box [string "static void uw_db_prepare(uw_context ctx) {",
+             newline,
+             string "}"]
       | DPreparedStatements ss =>
         box [string "static void uw_db_prepare(uw_context ctx) {",
              newline,
@@ -1708,7 +1751,7 @@ datatype 'a search =
        | NotFound
        | Error
 
-fun p_sqltype' env (tAll as (t, loc)) =
+fun p_sqltype'' env (tAll as (t, loc)) =
     case t of
         TFfi ("Basis", "int") => "int8"
       | TFfi ("Basis", "float") => "float8"
@@ -1719,8 +1762,25 @@ fun p_sqltype' env (tAll as (t, loc)) =
               Print.eprefaces' [("Type", p_typ env tAll)];
               "ERROR")
 
+fun p_sqltype' env (tAll as (t, loc)) =
+    case t of
+        (TOption t, _) => p_sqltype'' env t
+      | _ => p_sqltype'' env t ^ " NOT NULL"
+
 fun p_sqltype env t = string (p_sqltype' env t)
 
+fun p_sqltype_base' env t =
+    case t of
+        (TOption t, _) => p_sqltype'' env t
+      | _ => p_sqltype'' env t
+
+fun p_sqltype_base env t = string (p_sqltype_base' env t)
+
+fun is_not_null t =
+    case t of
+        (TOption _, _) => false
+      | _ => true
+
 fun p_file env (ds, ps) =
     let
         val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
@@ -1997,8 +2057,13 @@ fun p_file env (ds, ps) =
                                                                                           Char.toLower (ident x),
                                                                                       "' AND atttypid = (SELECT oid FROM pg_type",
                                                                                       " WHERE typname = '",
-                                                                                      p_sqltype' env t,
-                                                                                      "'))"]) xts),
+                                                                                      p_sqltype_base' env t,
+                                                                                      "') AND attnotnull = ",
+                                                                                      if is_not_null t then
+                                                                                          "TRUE"
+                                                                                      else
+                                                                                          "FALSE",
+                                                                                      ")"]) xts),
                                                             ")"]
 
                                     val q'' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '",
@@ -2295,11 +2360,7 @@ fun p_sql env (ds, _) =
                                                             box [string "uw_",
                                                                  string (CharVector.map Char.toLower x),
                                                                  space,
-                                                                 p_sqltype env t,
-                                                                 space,
-                                                                 string "NOT",
-                                                                 space,
-                                                                 string "NULL"]) xts,
+                                                                 p_sqltype env (t, ErrorMsg.dummySpan)]) xts,
                                                  string ");",
                                                  newline,
                                                  newline]
diff --git a/src/elab_env.sml b/src/elab_env.sml
index b14cd06c..46f62727 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -150,12 +150,14 @@ datatype class_key =
          CkNamed of int
        | CkRel of int
        | CkProj of int * string list * string
+       | CkApp of class_key * class_key
 
 fun ck2s ck =
     case ck of
         CkNamed n => "Named(" ^ Int.toString n ^ ")"
       | CkRel n => "Rel(" ^ Int.toString n ^ ")"
       | CkProj (m, ms, x) => "Proj(" ^ Int.toString m ^ "," ^ String.concatWith "," ms ^ "," ^ x ^ ")"
+      | CkApp (ck1, ck2) => "App(" ^ ck2s ck1 ^ ", " ^ ck2s ck2 ^ ")"
 
 fun cp2s (cn, ck) = "(" ^ cn2s cn ^ "," ^ ck2s ck ^ ")"
 
@@ -176,6 +178,12 @@ fun compare x =
         join (Int.compare (m1, m2),
               fn () => join (joinL String.compare (ms1, ms2),
                              fn () => String.compare (x1, x2)))
+      | (CkProj _, _) => LESS
+      | (_, CkProj _) => GREATER
+
+      | (CkApp (f1, x1), CkApp (f2, x2)) =>
+        join (compare (f1, f2),
+              fn () => compare (x1, x2))
 end
 
 structure KM = BinaryMapFn(KK)
@@ -251,6 +259,7 @@ fun liftClassKey ck =
         CkNamed _ => ck
       | CkRel n => CkRel (n + 1)
       | CkProj _ => ck
+      | CkApp (ck1, ck2) => CkApp (liftClassKey ck1, liftClassKey ck2)
 
 fun pushCRel (env : env) x k =
     let
@@ -411,6 +420,10 @@ fun class_key_in (c, _) =
       | CNamed n => SOME (CkNamed n)
       | CModProj x => SOME (CkProj x)
       | CUnif (_, _, _, ref (SOME c)) => class_key_in c
+      | CApp (c1, c2) =>
+        (case (class_key_in c1, class_key_in c2) of
+             (SOME k1, SOME k2) => SOME (CkApp (k1, k2))
+           | _ => NONE)
       | _ => NONE
 
 fun class_pair_in (c, _) =
@@ -653,7 +666,7 @@ fun sgnS_con (str, (sgns, strs, cons)) c =
              end)
       | _ => c
 
-fun sgnS_con' (m1, ms', (sgns, strs, cons)) c =
+fun sgnS_con' (arg as (m1, ms', (sgns, strs, cons))) c =
     case c of
         CModProj (m1, ms, x) =>
         (case IM.find (strs, m1) of
@@ -663,6 +676,8 @@ fun sgnS_con' (m1, ms', (sgns, strs, cons)) c =
         (case IM.find (cons, n) of
              NONE => c
            | SOME nx => CModProj (m1, ms', nx))
+      | CApp (c1, c2) => CApp ((sgnS_con' arg (#1 c1), #2 c1),
+                               (sgnS_con' arg (#1 c2), #2 c2))
       | _ => c
 
 fun sgnS_sgn (str, (sgns, strs, cons)) sgn =
@@ -1033,13 +1048,21 @@ fun projectVal env {sgn, str, field} =
                 ListUtil.search (fn (x, _, to) =>
                                     if x = field then
                                         SOME (let
+                                                  val base = (CNamed n, #2 sgn)
+                                                  val nxs = length xs
+                                                  val base = ListUtil.foldli (fn (i, _, base) =>
+                                                                                 (CApp (base,
+                                                                                       (CRel (nxs - i - 1), #2 sgn)),
+                                                                                  #2 sgn))
+                                                                             base xs
+
                                                   val t =
                                                       case to of
-                                                          NONE => (CNamed n, #2 sgn)
-                                                        | SOME t => (TFun (t, (CNamed n, #2 sgn)), #2 sgn)
+                                                          NONE => base
+                                                        | SOME t => (TFun (t, base), #2 sgn)
                                                   val k = (KType, #2 sgn)
                                               in
-                                                  foldr (fn (x, t) => (TCFun (Explicit, x, k, t), #2 sgn))
+                                                  foldr (fn (x, t) => (TCFun (Implicit, x, k, t), #2 sgn))
                                                   t xs
                                               end)
                                     else
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 3b70c623..a6edc0ed 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1389,17 +1389,32 @@ fun unmodCon env (c, loc) =
         end
       | _ => (c, loc)
 
-fun normClassConstraint envs (c, loc) =
+fun normClassKey envs c =
+    let
+        val c = ElabOps.hnormCon envs c
+    in
+        case #1 c of
+            L'.CApp (c1, c2) =>
+            let
+                val c1 = normClassKey envs c1
+                val c2 = normClassKey envs c2
+            in
+                (L'.CApp (c1, c2), #2 c)
+            end
+          | _ => c
+    end
+
+fun normClassConstraint env (c, loc) =
     case c of
         L'.CApp (f, x) =>
         let
-            val f = unmodCon (#1 envs) f
-            val (x, gs) = hnormCon envs x
+            val f = unmodCon env f
+            val x = normClassKey env x
         in
-            ((L'.CApp (f, x), loc), gs)
+            (L'.CApp (f, x), loc)
         end
-      | L'.CUnif (_, _, _, ref (SOME c)) => normClassConstraint envs c
-      | _ => ((c, loc), [])
+      | L'.CUnif (_, _, _, ref (SOME c)) => normClassConstraint env c
+      | _ => (c, loc)
 
 
 val makeInstantiable =
@@ -1491,12 +1506,12 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
                                         checkKind env t' tk ktype;
                                         (t', gs)
                                     end
-                val (dom, gs2) = normClassConstraint (env, denv) t'
-                val (e', et, gs3) = elabExp (E.pushERel env x dom, denv) e
+                val dom = normClassConstraint env t'
+                val (e', et, gs2) = elabExp (E.pushERel env x dom, denv) e
             in
                 ((L'.EAbs (x, t', et, e'), loc),
                  (L'.TFun (t', et), loc),
-                 enD gs1 @ enD gs2 @ gs3)
+                 enD gs1 @ gs2)
             end
           | L.ECApp (e, c) =>
             let
@@ -1708,11 +1723,11 @@ and elabEdecl denv (dAll as (d, loc), (env, gs : constraint list)) =
 
                     val (e', et, gs2) = elabExp (env, denv) e
                     val gs3 = checkCon (env, denv) e' et c'
-                    val (c', gs4) = normClassConstraint (env, denv) c'
+                    val c' = normClassConstraint env c'
                     val env' = E.pushERel env x c'
                     val c' = makeInstantiable c'
                 in
-                    ((L'.EDVal (x, c', e'), loc), (env', enD gs1 @ gs2 @ enD gs3 @ enD gs4 @ gs))
+                    ((L'.EDVal (x, c', e'), loc), (env', enD gs1 @ gs2 @ enD gs3 @ gs))
                 end
               | L.EDValRec vis =>
                 let
@@ -1884,12 +1899,12 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) =
             val (c', ck, gs') = elabCon (env, denv) c
 
             val (env', n) = E.pushENamed env x c'
-            val (c', gs'') = normClassConstraint (env, denv) c'
+            val c' = normClassConstraint env c'
         in
             (unifyKinds ck ktype
              handle KUnify ue => strError env (NotType (ck, ue)));
 
-            ([(L'.SgiVal (x, n, c'), loc)], (env', denv, gs' @ gs'' @ gs))
+            ([(L'.SgiVal (x, n, c'), loc)], (env', denv, gs' @ gs))
         end
 
       | L.SgiStr (x, sgn) =>
@@ -2875,13 +2890,13 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) =
 
                     val (e', et, gs2) = elabExp (env, denv) e
                     val gs3 = checkCon (env, denv) e' et c'
-                    val (c', gs4) = normClassConstraint (env, denv) c'
+                    val c = normClassConstraint env c'
                     val (env', n) = E.pushENamed env x c'
                     val c' = makeInstantiable c'
                 in
                     (*prefaces "DVal" [("x", Print.PD.string x),
                                      ("c'", p_con env c')];*)
-                    ([(L'.DVal (x, n, c', e'), loc)], (env', denv, enD gs1 @ gs2 @ enD gs3 @ enD gs4 @ gs))
+                    ([(L'.DVal (x, n, c', e'), loc)], (env', denv, enD gs1 @ gs2 @ enD gs3 @ gs))
                 end
               | L.DValRec vis =>
                 let
@@ -3404,7 +3419,7 @@ fun elabFile basis topStr topSgn env file =
                                       ("Hnormed 2", p_con env (ElabOps.hnormCon env c2))]))
                   | TypeClass (env, c, r, loc) =>
                     let
-                        val c = ElabOps.hnormCon env c
+                        val c = normClassKey env c
                     in
                         case E.resolveClass env c of
                             SOME e => r := SOME e
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index b22f053b..93cb888b 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -268,6 +268,11 @@ fun exp e =
 
       | EFfiApp ("Basis", "sqlifyInt", [(EPrim (Prim.Int n), _)]) =>
         EPrim (Prim.String (sqlifyInt n))
+      | EFfiApp ("Basis", "sqlifyIntN", [(ENone _, _)]) =>
+        EPrim (Prim.String "NULL")
+      | EFfiApp ("Basis", "sqlifyIntN", [(ESome (_, (EPrim (Prim.Int n), _)), _)]) =>
+        EPrim (Prim.String (sqlifyInt n))
+
       | EFfiApp ("Basis", "sqlifyFloat", [(EPrim (Prim.Float n), _)]) =>
         EPrim (Prim.String (sqlifyFloat n))
       | EFfiApp ("Basis", "sqlifyBool", [b as (_, loc)]) =>
diff --git a/src/monoize.sml b/src/monoize.sml
index c4c296bd..83da382b 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -982,10 +982,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
           | L.EFfiApp ("Basis", "dml", [e]) =>
             let
                 val (e, fm) = monoExp (env, st, fm) e
-                val un = (L'.TRecord [], loc)
             in
-                ((L'.EAbs ("_", un, un,
-                           (L'.EDml (liftExpInExp 0 e), loc)), loc),
+                ((L'.EDml (liftExpInExp 0 e), loc),
                  fm)
             end
 
@@ -1274,6 +1272,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "string"), loc),
                        (L'.EFfiApp ("Basis", "sqlifyTime", [(L'.ERel 0, loc)]), loc)), loc),
              fm)
+          | L.EFfi ("Basis", "sql_option_int") =>
+            ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "int"), loc), loc), (L'.TFfi ("Basis", "string"), loc),
+                       (L'.EFfiApp ("Basis", "sqlifyIntN", [(L'.ERel 0, loc)]), loc)), loc),
+             fm)
+          | L.EFfi ("Basis", "sql_option_float") =>
+            ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "float"), loc), loc), (L'.TFfi ("Basis", "string"), loc),
+                       (L'.EFfiApp ("Basis", "sqlifyFloatN", [(L'.ERel 0, loc)]), loc)), loc),
+             fm)
+          | L.EFfi ("Basis", "sql_option_bool") =>
+            ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "bool"), loc), loc), (L'.TFfi ("Basis", "string"), loc),
+                       (L'.EFfiApp ("Basis", "sqlifyBoolN", [(L'.ERel 0, loc)]), loc)), loc),
+             fm)
+          | L.EFfi ("Basis", "sql_option_string") =>
+            ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "string"), loc), loc), (L'.TFfi ("Basis", "string"), loc),
+                       (L'.EFfiApp ("Basis", "sqlifyStringN", [(L'.ERel 0, loc)]), loc)), loc),
+             fm)
+          | L.EFfi ("Basis", "sql_option_time") =>
+            ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "time"), loc), loc), (L'.TFfi ("Basis", "string"), loc),
+                       (L'.EFfiApp ("Basis", "sqlifyTimeN", [(L'.ERel 0, loc)]), loc)), loc),
+             fm)
 
           | L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) =>
             ((L'.ERecord [], loc), fm)
diff --git a/src/urweb.grm b/src/urweb.grm
index b2f2d486..2482be1b 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -214,7 +214,7 @@ fun tagIn bt =
  | TRUE | FALSE | CAND | OR | NOT
  | COUNT | AVG | SUM | MIN | MAX
  | ASC | DESC
- | INSERT | INTO | VALUES | UPDATE | SET | DELETE
+ | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL
  | CURRENT_TIMESTAMP
  | NE | LT | LE | GT | GE
 
@@ -1251,6 +1251,9 @@ sqlexp : TRUE                           (sql_inject (EVar (["Basis"], "True", In
                                                      s (LBRACEleft, RBRACEright)))
        | LPAREN sqlexp RPAREN           (sqlexp)
 
+       | NULL                           (sql_inject ((EVar (["Basis"], "None", Infer), 
+                                                      s (NULLleft, NULLright))))
+
        | COUNT LPAREN STAR RPAREN       (let
                                              val loc = s (COUNTleft, RPARENright)
                                          in
diff --git a/src/urweb.lex b/src/urweb.lex
index f5ea558a..f4ae3a85 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -357,6 +357,7 @@ notags = [^<{\n]+;
 <INITIAL> "UPDATE"    => (Tokens.UPDATE (pos yypos, pos yypos + size yytext));
 <INITIAL> "SET"       => (Tokens.SET (pos yypos, pos yypos + size yytext));
 <INITIAL> "DELETE"    => (Tokens.DELETE (pos yypos, pos yypos + size yytext));
+<INITIAL> "NULL"      => (Tokens.NULL (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext));