diff options
author | 2008-11-06 15:37:38 -0500 | |
---|---|---|
committer | 2008-11-06 15:37:38 -0500 | |
commit | 2b028daf3ff279b9c68301c031588ab042edddf5 (patch) | |
tree | 3dc7245cbdb2c517bb9676d83860e4b48f64026a /src | |
parent | 27e3c3ba965513dcb3e447cccf6e77ce8c63e90d (diff) |
Inserted a NULL value
Diffstat (limited to 'src')
-rw-r--r-- | src/c/urweb.c | 35 | ||||
-rw-r--r-- | src/cjr_print.sml | 101 | ||||
-rw-r--r-- | src/elab_env.sml | 31 | ||||
-rw-r--r-- | src/elaborate.sml | 47 | ||||
-rw-r--r-- | src/mono_opt.sml | 5 | ||||
-rw-r--r-- | src/monoize.sml | 24 | ||||
-rw-r--r-- | src/urweb.grm | 5 | ||||
-rw-r--r-- | src/urweb.lex | 1 |
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)); |