summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--CHANGELOG9
-rw-r--r--include/urweb.h6
-rw-r--r--lib/basis.urs5
-rw-r--r--src/c/urweb.c35
-rw-r--r--src/cjr_print.sml101
-rw-r--r--src/elab_env.sml31
-rw-r--r--src/elaborate.sml47
-rw-r--r--src/mono_opt.sml5
-rw-r--r--src/monoize.sml24
-rw-r--r--src/urweb.grm5
-rw-r--r--src/urweb.lex1
-rw-r--r--tests/sql_option.ur22
-rw-r--r--tests/sql_option.urp5
13 files changed, 252 insertions, 44 deletions
diff --git a/CHANGELOG b/CHANGELOG
index aca01ea7..0f8d0f09 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,4 +1,13 @@
========
+NEXT
+========
+
+- Nested function definitions
+- Primitive "time" type
+- Nullable SQL columns (via "option")
+- Cookies
+
+========
20081028
========
diff --git a/include/urweb.h b/include/urweb.h
index 7db66ed4..7e16fd40 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -80,6 +80,12 @@ uw_Basis_string uw_Basis_sqlifyString(uw_context, uw_Basis_string);
uw_Basis_string uw_Basis_sqlifyBool(uw_context, uw_Basis_bool);
uw_Basis_string uw_Basis_sqlifyTime(uw_context, uw_Basis_time);
+uw_Basis_string uw_Basis_sqlifyIntN(uw_context, uw_Basis_int*);
+uw_Basis_string uw_Basis_sqlifyFloatN(uw_context, uw_Basis_float*);
+uw_Basis_string uw_Basis_sqlifyStringN(uw_context, uw_Basis_string);
+uw_Basis_string uw_Basis_sqlifyBoolN(uw_context, uw_Basis_bool*);
+uw_Basis_string uw_Basis_sqlifyTimeN(uw_context, uw_Basis_time*);
+
char *uw_Basis_ensqlBool(uw_Basis_bool);
uw_Basis_string uw_Basis_intToString(uw_context, uw_Basis_int);
diff --git a/lib/basis.urs b/lib/basis.urs
index 84fb4e4c..f68bedee 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -188,6 +188,11 @@ val sql_int : sql_injectable int
val sql_float : sql_injectable float
val sql_string : sql_injectable string
val sql_time : sql_injectable time
+val sql_option_bool : sql_injectable (option bool)
+val sql_option_int : sql_injectable (option int)
+val sql_option_float : sql_injectable (option float)
+val sql_option_string : sql_injectable (option string)
+val sql_option_time : sql_injectable (option time)
val sql_inject : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-> t ::: Type
-> sql_injectable t -> t -> sql_exp tables agg exps t
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));
diff --git a/tests/sql_option.ur b/tests/sql_option.ur
new file mode 100644
index 00000000..257f8c55
--- /dev/null
+++ b/tests/sql_option.ur
@@ -0,0 +1,22 @@
+table t : { O : option int }
+
+fun addNull () =
+ dml (INSERT INTO t (O) VALUES (NULL));
+ return <xml>Done</xml>
+
+(*fun add42 () =
+ dml (INSERT INTO t (O) VALUES (42));
+ return <xml>Done</xml>*)
+
+fun main () : transaction page =
+ xml <- queryX (SELECT * FROM t)
+ (fn r => case r.T.O of
+ None => <xml>Nada<br/></xml>
+ | Some n => <xml>Num: {[n]}<br/></xml>);
+ return <xml><body>
+ {xml}
+
+ <a link={addNull ()}>Add a null</a><br/>
+ </body></xml>
+
+(* <a link={add42 ()}>Add a 42</a><br/>*)
diff --git a/tests/sql_option.urp b/tests/sql_option.urp
new file mode 100644
index 00000000..543c32a8
--- /dev/null
+++ b/tests/sql_option.urp
@@ -0,0 +1,5 @@
+debug
+database dbname=option
+sql option.sql
+
+sql_option
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-18 20:51:57 +0000