Mercurial > urweb
changeset 704:70cbdcf5989b
UNIQUE constraints
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 07 Apr 2009 12:24:31 -0400 |
| parents | a5d8b470d7ca |
| children | e6706a1df013 |
| files | lib/ur/basis.urs src/cjr.sml src/cjr_print.sml src/cjrize.sml src/core.sml src/core_env.sml src/core_print.sml src/core_util.sml src/corify.sml src/elab.sml src/elab_env.sml src/elab_print.sml src/elab_util.sml src/elaborate.sml src/expl.sml src/expl_env.sml src/expl_print.sml src/explify.sml src/mono.sml src/mono_print.sml src/mono_util.sml src/monoize.sml src/pathcheck.sml src/reduce.sml src/shake.sml src/source.sml src/source_print.sml src/urweb.grm src/urweb.lex tests/cst.ur tests/cst.urp |
| diffstat | 31 files changed, 342 insertions(+), 116 deletions(-) [+] |
line wrap: on
line diff
--- a/lib/ur/basis.urs Sun Apr 05 16:17:32 2009 -0400 +++ b/lib/ur/basis.urs Tue Apr 07 12:24:31 2009 -0400 @@ -124,6 +124,20 @@ con sql_table :: {Type} -> Type +(*** Constraints *) + +con sql_constraints :: {Unit} -> {Type} -> Type +con sql_constraint :: {Type} -> Type + +val no_constraint : fs ::: {Type} -> sql_constraints [] fs +val one_constraint : fs ::: {Type} -> name :: Name -> sql_constraint fs -> sql_constraints [name] fs +val join_constraints : names1 ::: {Unit} -> names2 ::: {Unit} -> fs ::: {Type} -> [names1 ~ names2] + => sql_constraints names1 fs -> sql_constraints names2 fs + -> sql_constraints (names1 ++ names2) fs + +val unique : rest ::: {Type} -> unique :: {Type} -> [unique ~ rest] => sql_constraint (unique ++ rest) + + (*** Queries *) con sql_query :: {{Type}} -> {Type} -> Type
--- a/src/cjr.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/cjr.sml Tue Apr 07 12:24:31 2009 -0400 @@ -104,7 +104,7 @@ | DFun of string * int * (string * typ) list * typ * exp | DFunRec of (string * int * (string * typ) list * typ * exp) list - | DTable of string * (string * typ) list + | DTable of string * (string * typ) list * (string * string) list | DSequence of string | DDatabase of {name : string, expunge : int, initialize : int} | DPreparedStatements of (string * int) list
--- a/src/cjr_print.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/cjr_print.sml Tue Apr 07 12:24:31 2009 -0400 @@ -1435,7 +1435,7 @@ val wontLeakAnything = notLeaky env false state in box [if wontLeakAnything then - string "uw_begin_region(ctx), " + string "(uw_begin_region(ctx), " else box [], string "({", @@ -1585,7 +1585,11 @@ box [], string "acc;", newline, - string "})"] + string "})", + if wontLeakAnything then + string ")" + else + box []] end | EDml {dml, prepared} => @@ -1937,10 +1941,19 @@ p_list_sep newline (p_fun env) vis, newline] end - | DTable (x, _) => box [string "/* SQL table ", - string x, - string " */", - newline] + | DTable (x, _, csts) => box [string "/* SQL table ", + string x, + space, + string "constraints", + space, + p_list (fn (x, v) => box [string x, + space, + string ":", + space, + string v]) csts, + space, + string " */", + newline] | DSequence x => box [string "/* SQL sequence ", string x, string " */", @@ -2454,7 +2467,7 @@ val pds' = map p_page ps - val tables = List.mapPartial (fn (DTable (s, xts), _) => SOME (s, xts) + val tables = List.mapPartial (fn (DTable (s, xts, _), _) => SOME (s, xts) | _ => NONE) ds val sequences = List.mapPartial (fn (DSequence s, _) => SOME s | _ => NONE) ds @@ -2798,7 +2811,7 @@ (fn (dAll as (d, _), env) => let val pp = case d of - DTable (s, xts) => + DTable (s, xts, csts) => box [string "CREATE TABLE ", string s, string "(", @@ -2807,6 +2820,20 @@ string (CharVector.map Char.toLower x), space, p_sqltype env (t, ErrorMsg.dummySpan)]) xts, + case csts of + [] => box [] + | _ => box [string ","], + cut, + p_list_sep (box [string ",", newline]) + (fn (x, c) => + box [string "CONSTRAINT", + space, + string s, + string "_", + string x, + space, + string c]) csts, + newline, string ");", newline, newline]
--- a/src/cjrize.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/cjrize.sml Tue Apr 07 12:24:31 2009 -0400 @@ -524,7 +524,7 @@ (NONE, SOME (ek, "/" ^ s, n, ts, t, L'.ServerAndPullAndPush), sm) end - | L.DTable (s, xts) => + | L.DTable (s, xts, e) => let val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) => let @@ -532,8 +532,18 @@ in ((x, t), sm) end) sm xts + + fun flatten e = + case #1 e of + L.ERecord [] => [] + | L.ERecord [(x, (L.EPrim (Prim.String v), _), _)] => [(x, v)] + | L.EStrcat (e1, e2) => flatten e1 @ flatten e2 + | _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined"; + Print.prefaces "Undetermined constraint" + [("e", MonoPrint.p_exp MonoEnv.empty e)]; + []) in - (SOME (L'.DTable (s, xts), loc), NONE, sm) + (SOME (L'.DTable (s, xts, flatten e), loc), NONE, sm) end | L.DSequence s => (SOME (L'.DSequence s, loc), NONE, sm)
--- a/src/core.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/core.sml Tue Apr 07 12:24:31 2009 -0400 @@ -130,7 +130,7 @@ | DVal of string * int * con * exp * string | DValRec of (string * int * con * exp * string) list | DExport of export_kind * int - | DTable of string * int * con * string + | DTable of string * int * con * string * exp | DSequence of string * int * string | DDatabase of string | DCookie of string * int * con * string
--- a/src/core_env.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/core_env.sml Tue Apr 07 12:24:31 2009 -0400 @@ -313,7 +313,7 @@ | DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s | DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis | DExport _ => env - | DTable (x, n, c, s) => + | DTable (x, n, c, s, _) => let val t = (CApp ((CFfi ("Basis", "sql_table"), loc), c), loc) in
--- a/src/core_print.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/core_print.sml Tue Apr 07 12:24:31 2009 -0400 @@ -546,17 +546,21 @@ space, (p_con env (#2 (E.lookupENamed env n)) handle E.UnboundNamed _ => string "UNBOUND")] - | DTable (x, n, c, s) => box [string "table", - space, - p_named x n, - space, - string "as", - space, - string s, - space, - string ":", - space, - p_con env c] + | DTable (x, n, c, s, e) => box [string "table", + space, + p_named x n, + space, + string "as", + space, + string s, + space, + string ":", + space, + p_con env c, + space, + string "constraints", + space, + p_exp env e] | DSequence (x, n, s) => box [string "sequence", space, p_named x n,
--- a/src/core_util.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/core_util.sml Tue Apr 07 12:24:31 2009 -0400 @@ -933,10 +933,12 @@ (DValRec vis', loc)) end | DExport _ => S.return2 dAll - | DTable (x, n, c, s) => - S.map2 (mfc ctx c, + | DTable (x, n, c, s, e) => + S.bind2 (mfc ctx c, fn c' => - (DTable (x, n, c', s), loc)) + S.map2 (mfe ctx e, + fn e' => + (DTable (x, n, c', s, e'), loc))) | DSequence _ => S.return2 dAll | DDatabase _ => S.return2 dAll | DCookie (x, n, c, s) => @@ -1058,7 +1060,7 @@ foldl (fn ((x, n, t, e, s), ctx) => bind (ctx, NamedE (x, n, t, NONE, s))) ctx vis | DExport _ => ctx - | DTable (x, n, c, s) => + | DTable (x, n, c, s, _) => let val t = (CApp ((CFfi ("Basis", "sql_table"), #2 d'), c), #2 d') in @@ -1134,7 +1136,7 @@ | DVal (_, n, _, _, _) => Int.max (n, count) | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis | DExport _ => count - | DTable (_, n, _, _) => Int.max (n, count) + | DTable (_, n, _, _, _) => Int.max (n, count) | DSequence (_, n, _) => Int.max (n, count) | DDatabase _ => count | DCookie (_, n, _, _) => Int.max (n, count)) 0
--- a/src/corify.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/corify.sml Tue Apr 07 12:24:31 2009 -0400 @@ -976,12 +976,12 @@ end | _ => raise Fail "Non-const signature for 'export'") - | L.DTable (_, x, n, c) => + | L.DTable (_, x, n, c, e) => let val (st, n) = St.bindVal st x n val s = relify (doRestify (mods, x)) in - ([(L'.DTable (x, n, corifyCon st c, s), loc)], st) + ([(L'.DTable (x, n, corifyCon st c, s, corifyExp st e), loc)], st) end | L.DSequence (_, x, n) => let @@ -1052,7 +1052,7 @@ | L.DStr (_, n', _, str) => Int.max (n, Int.max (n', maxNameStr str)) | L.DFfiStr (_, n', _) => Int.max (n, n') | L.DExport _ => n - | L.DTable (_, _, n', _) => Int.max (n, n') + | L.DTable (_, _, n', _, _) => Int.max (n, n') | L.DSequence (_, _, n') => Int.max (n, n') | L.DDatabase _ => n | L.DCookie (_, _, n', _) => Int.max (n, n'))
--- a/src/elab.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/elab.sml Tue Apr 07 12:24:31 2009 -0400 @@ -166,7 +166,7 @@ | DFfiStr of string * int * sgn | DConstraint of con * con | DExport of int * sgn * str - | DTable of int * string * int * con + | DTable of int * string * int * con * exp | DSequence of int * string * int | DClass of string * int * kind * con | DDatabase of string
--- a/src/elab_env.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/elab_env.sml Tue Apr 07 12:24:31 2009 -0400 @@ -1532,7 +1532,7 @@ | DFfiStr (x, n, sgn) => pushStrNamedAs env x n sgn | DConstraint _ => env | DExport _ => env - | DTable (tn, x, n, c) => + | DTable (tn, x, n, c, _) => let val t = (CApp ((CModProj (tn, [], "sql_table"), loc), c), loc) in
--- a/src/elab_print.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/elab_print.sml Tue Apr 07 12:24:31 2009 -0400 @@ -740,13 +740,17 @@ string ":", space, p_sgn env sgn] - | DTable (_, x, n, c) => box [string "table", - space, - p_named x n, - space, - string ":", - space, - p_con env c] + | DTable (_, x, n, c, e) => box [string "table", + space, + p_named x n, + space, + string ":", + space, + p_con env c, + space, + string "constraints", + space, + p_exp env e] | DSequence (_, x, n) => box [string "sequence", space, p_named x n]
--- a/src/elab_util.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/elab_util.sml Tue Apr 07 12:24:31 2009 -0400 @@ -766,7 +766,7 @@ bind (ctx, Str (x, sgn)) | DConstraint _ => ctx | DExport _ => ctx - | DTable (tn, x, n, c) => + | DTable (tn, x, n, c, _) => bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "sql_table"), loc), c), loc))) | DSequence (tn, x, n) => @@ -864,10 +864,12 @@ fn str' => (DExport (en, sgn', str'), loc))) - | DTable (tn, x, n, c) => - S.map2 (mfc ctx c, + | DTable (tn, x, n, c, e) => + S.bind2 (mfc ctx c, fn c' => - (DTable (tn, x, n, c'), loc)) + S.map2 (mfe ctx e, + fn e' => + (DTable (tn, x, n, c', e'), loc))) | DSequence _ => S.return2 dAll | DClass (x, n, k, c) => @@ -1018,7 +1020,7 @@ | DConstraint _ => 0 | DClass (_, n, _, _) => n | DExport _ => 0 - | DTable (n1, _, n2, _) => Int.max (n1, n2) + | DTable (n1, _, n2, _, _) => Int.max (n1, n2) | DSequence (n1, _, n2) => Int.max (n1, n2) | DDatabase _ => 0 | DCookie (n1, _, n2, _) => Int.max (n1, n2)
--- a/src/elaborate.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/elaborate.sml Tue Apr 07 12:24:31 2009 -0400 @@ -1126,11 +1126,11 @@ else (e, t, []) | t => (e, t, []) - in - case infer of - L.DontInfer => (e, t, []) - | _ => unravel (t, e) - end + in + case infer of + L.DontInfer => (e, t, []) + | _ => unravel (t, e) + end fun elabPat (pAll as (p, loc), (env, bound)) = let @@ -2319,7 +2319,7 @@ | L'.DFfiStr (x, n, sgn) => [(L'.SgiStr (x, n, sgn), loc)] | L'.DConstraint cs => [(L'.SgiConstraint cs, loc)] | L'.DExport _ => [] - | L'.DTable (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (tableOf (), c), loc)), loc)] + | L'.DTable (tn, x, n, c, _) => [(L'.SgiVal (x, n, (L'.CApp (tableOf (), c), loc)), loc)] | L'.DSequence (tn, x, n) => [(L'.SgiVal (x, n, sequenceOf ()), loc)] | L'.DClass (x, n, k, c) => [(L'.SgiClass (x, n, k, c), loc)] | L'.DDatabase _ => [] @@ -3265,13 +3265,20 @@ ([(L'.DExport (E.newNamed (), sgn, str'), loc)], (env, denv, gs' @ gs)) end - | L.DTable (x, c) => + | L.DTable (x, c, e) => let val (c', k, gs') = elabCon (env, denv) c val (env, n) = E.pushENamed env x (L'.CApp (tableOf (), c'), loc) + val (e', et, gs'') = elabExp (env, denv) e + + val names = cunif (loc, (L'.KRecord (L'.KUnit, loc), loc)) + val cst = (L'.CModProj (!basis_r, [], "sql_constraints"), loc) + val cst = (L'.CApp (cst, names), loc) + val cst = (L'.CApp (cst, c'), loc) in checkKind env c' k (L'.KRecord (L'.KType, loc), loc); - ([(L'.DTable (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs)) + checkCon env e' et cst; + ([(L'.DTable (!basis_r, x, n, c', e'), loc)], (env, denv, gs'' @ enD gs' @ gs)) end | L.DSequence x => let
--- a/src/expl.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/expl.sml Tue Apr 07 12:24:31 2009 -0400 @@ -141,7 +141,7 @@ | DStr of string * int * sgn * str | DFfiStr of string * int * sgn | DExport of int * sgn * str - | DTable of int * string * int * con + | DTable of int * string * int * con * exp | DSequence of int * string * int | DDatabase of string | DCookie of int * string * int * con
--- a/src/expl_env.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/expl_env.sml Tue Apr 07 12:24:31 2009 -0400 @@ -298,7 +298,7 @@ | DStr (x, n, sgn, _) => pushStrNamed env x n sgn | DFfiStr (x, n, sgn) => pushStrNamed env x n sgn | DExport _ => env - | DTable (tn, x, n, c) => + | DTable (tn, x, n, c, _) => let val t = (CApp ((CModProj (tn, [], "sql_table"), loc), c), loc) in
--- a/src/expl_print.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/expl_print.sml Tue Apr 07 12:24:31 2009 -0400 @@ -663,13 +663,17 @@ string ":", space, p_sgn env sgn] - | DTable (_, x, n, c) => box [string "table", - space, - p_named x n, - space, - string ":", - space, - p_con env c] + | DTable (_, x, n, c, e) => box [string "table", + space, + p_named x n, + space, + string ":", + space, + p_con env c, + space, + string "constraints", + space, + p_exp env e] | DSequence (_, x, n) => box [string "sequence", space, p_named x n]
--- a/src/explify.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/explify.sml Tue Apr 07 12:24:31 2009 -0400 @@ -178,7 +178,7 @@ | L.DFfiStr (x, n, sgn) => SOME (L'.DFfiStr (x, n, explifySgn sgn), loc) | L.DConstraint (c1, c2) => NONE | L.DExport (en, sgn, str) => SOME (L'.DExport (en, explifySgn sgn, explifyStr str), loc) - | L.DTable (nt, x, n, c) => SOME (L'.DTable (nt, x, n, explifyCon c), loc) + | L.DTable (nt, x, n, c, e) => SOME (L'.DTable (nt, x, n, explifyCon c, explifyExp e), loc) | L.DSequence (nt, x, n) => SOME (L'.DSequence (nt, x, n), loc) | L.DClass (x, n, k, c) => SOME (L'.DCon (x, n, (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), explifyCon c), loc)
--- a/src/mono.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/mono.sml Tue Apr 07 12:24:31 2009 -0400 @@ -121,7 +121,7 @@ | DValRec of (string * int * typ * exp * string) list | DExport of Core.export_kind * string * int * typ list * typ - | DTable of string * (string * typ) list + | DTable of string * (string * typ) list * exp | DSequence of string | DDatabase of {name : string, expunge : int, initialize : int}
--- a/src/mono_print.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/mono_print.sml Tue Apr 07 12:24:31 2009 -0400 @@ -403,18 +403,22 @@ space, p_typ env t] - | DTable (s, xts) => box [string "(* SQL table ", - string s, - space, - string ":", - space, - p_list (fn (x, t) => box [string x, - space, - string ":", - space, - p_typ env t]) xts, - space, - string "*)"] + | DTable (s, xts, e) => box [string "(* SQL table ", + string s, + space, + string ":", + space, + p_list (fn (x, t) => box [string x, + space, + string ":", + space, + p_typ env t]) xts, + space, + string "constraints", + space, + p_exp env e, + space, + string "*)"] | DSequence s => box [string "(* SQL sequence ", string s, string "*)"]
--- a/src/mono_util.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/mono_util.sml Tue Apr 07 12:24:31 2009 -0400 @@ -465,7 +465,10 @@ S.map2 (mft t, fn t' => (DExport (ek, s, n, ts', t'), loc))) - | DTable _ => S.return2 dAll + | DTable (s, xts, e) => + S.map2 (mfe ctx e, + fn e' => + (DTable (s, xts, e'), loc)) | DSequence _ => S.return2 dAll | DDatabase _ => S.return2 dAll | DJavaScript _ => S.return2 dAll
--- a/src/monoize.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/monoize.sml Tue Apr 07 12:24:31 2009 -0400 @@ -149,6 +149,10 @@ (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraints"), _), _), _), _) => + (L'.TFfi ("Basis", "sql_constraints"), loc) + | L.CApp ((L.CFfi ("Basis", "sql_constraint"), _), _) => + (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_subset"), _), _), _), _) => (L'.TRecord [], loc) @@ -1155,6 +1159,32 @@ fm) end + | L.ECApp ((L.EFfi ("Basis", "no_constraint"), _), _) => + ((L'.ERecord [], loc), + fm) + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "one_constraint"), _), _), _), (L.CName name, _)) => + ((L'.EAbs ("c", + (L'.TFfi ("Basis", "string"), loc), + (L'.TFfi ("Basis", "sql_constraints"), loc), + (L'.ERecord [(name, (L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))], loc)), loc), + fm) + | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "join_constraints"), _), _), _), _), _), _) => + let + val constraints = (L'.TFfi ("Basis", "sql_constraints"), loc) + in + ((L'.EAbs ("cs1", constraints, (L'.TFun (constraints, constraints), loc), + (L'.EAbs ("cs2", constraints, constraints, + (L'.EStrcat ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + fm) + end + + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "unique"), _), _), _), + (L.CRecord (_, unique), _)) => + ((L'.EPrim (Prim.String ("UNIQUE (" + ^ String.concatWith ", " (map (fn (x, _) => "uw_" ^ monoName env x) unique) + ^ ")")), loc), + fm) + | L.EFfiApp ("Basis", "dml", [e]) => let val (e, fm) = monoExp (env, st, fm) e @@ -2451,19 +2481,21 @@ in SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)]) end - | L.DTable (x, n, (L.CRecord (_, xts), _), s) => + | L.DTable (x, n, (L.CRecord (_, xts), _), s, e) => let val t = (L.CFfi ("Basis", "string"), loc) val t' = (L'.TFfi ("Basis", "string"), loc) val s = "uw_" ^ s - val e = (L'.EPrim (Prim.String s), loc) + val e_name = (L'.EPrim (Prim.String s), loc) val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts + + val (e, fm) = monoExp (env, St.empty, fm) e in SOME (Env.pushENamed env x n t NONE s, fm, - [(L'.DTable (s, xts), loc), - (L'.DVal (x, n, t', e, s), loc)]) + [(L'.DTable (s, xts, e), loc), + (L'.DVal (x, n, t', e_name, s), loc)]) end | L.DTable _ => poly () | L.DSequence (x, n, s) => @@ -2583,7 +2615,7 @@ in foldl (fn ((d, _), e) => case d of - L.DTable (_, _, xts, tab) => doTable (tab, #1 xts, e) + L.DTable (_, _, xts, tab, _) => doTable (tab, #1 xts, e) | _ => e) e file end @@ -2628,7 +2660,7 @@ in foldl (fn ((d, _), e) => case d of - L.DTable (_, _, xts, tab) => doTable (tab, #1 xts, e) + L.DTable (_, _, xts, tab, _) => doTable (tab, #1 xts, e) | _ => e) e file end
--- a/src/pathcheck.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/pathcheck.sml Tue Apr 07 12:24:31 2009 -0400 @@ -38,6 +38,13 @@ fun checkDecl ((d, loc), (funcs, rels)) = let + fun doFunc s = + (if SS.member (funcs, s) then + E.errorAt loc ("Duplicate function path " ^ s) + else + (); + (SS.add (funcs, s), rels)) + fun doRel s = (if SS.member (rels, s) then E.errorAt loc ("Duplicate table/sequence path " ^ s) @@ -46,14 +53,27 @@ (funcs, SS.add (rels, s))) in case d of - DExport (_, s, _, _, _) => - (if SS.member (funcs, s) then - E.errorAt loc ("Duplicate function path " ^ s) - else - (); - (SS.add (funcs, s), rels)) + DExport (_, s, _, _, _) => doFunc s - | DTable (s, _) => doRel s + | DTable (s, _, e) => + let + fun constraints (e, rels) = + case #1 e of + ERecord [(s', _, _)] => + let + val s' = s ^ "_" ^ s' + in + if SS.member (rels, s') then + E.errorAt loc ("Duplicate constraint path " ^ s') + else + (); + SS.add (rels, s') + end + | EStrcat (e1, e2) => constraints (e2, constraints (e1, rels)) + | _ => rels + in + (funcs, constraints (e, #2 (doRel s))) + end | DSequence s => doRel s | _ => (funcs, rels)
--- a/src/reduce.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/reduce.sml Tue Apr 07 12:24:31 2009 -0400 @@ -461,7 +461,8 @@ ((DValRec (map (fn (x, n, t, e, s) => (x, n, con namedC [] t, exp (namedC, namedE) [] e, s)) vis), loc), st) | DExport _ => (d, st) - | DTable (s, n, c, s') => ((DTable (s, n, con namedC [] c, s'), loc), st) + | DTable (s, n, c, s', e) => ((DTable (s, n, con namedC [] c, s', + exp (namedC, namedE) [] e), loc), st) | DSequence _ => (d, st) | DDatabase _ => (d, st) | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st)
--- a/src/shake.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/shake.sml Tue Apr 07 12:24:31 2009 -0400 @@ -46,11 +46,26 @@ fun shake file = let - val (page_es, table_cs) = + val usedVars = U.Exp.fold {kind = fn (_, st) => st, + con = fn (c, st as (es, cs)) => + case c of + CNamed n => (es, IS.add (cs, n)) + | _ => st, + exp = fn (e, st as (es, cs)) => + case e of + ENamed n => (IS.add (es, n), cs) + | _ => st} + + val (usedE, usedC, table_cs) = List.foldl - (fn ((DExport (_, n), _), (page_es, table_cs)) => (n :: page_es, table_cs) - | ((DTable (_, _, c, _), _), (page_es, table_cs)) => (page_es, c :: table_cs) - | (_, acc) => acc) ([], []) file + (fn ((DExport (_, n), _), (usedE, usedC, table_cs)) => (IS.add (usedE, n), usedE, table_cs) + | ((DTable (_, _, c, _, e), _), (usedE, usedC, table_cs)) => + let + val (usedE, usedC) = usedVars (usedE, usedC) e + in + (usedE, usedC, c :: table_cs) + end + | (_, acc) => acc) (IS.empty, IS.empty, []) file val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef) | ((DDatatype (_, n, _, xncs), _), (cdef, edef)) => @@ -64,7 +79,7 @@ IM.insert (edef, n, (all_ns, t, e))) edef vis) end | ((DExport _, _), acc) => acc - | ((DTable (_, n, c, _), _), (cdef, edef)) => + | ((DTable (_, n, c, _, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], c, dummye))) | ((DSequence (_, n, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], dummyt, dummye))) @@ -122,17 +137,17 @@ and shakeExp s = U.Exp.fold {kind = kind, con = con, exp = exp} s - val s = {con = IS.empty, exp = IS.addList (IS.empty, page_es)} + val s = {con = usedC, exp = usedE} - val s = foldl (fn (n, s) => - case IM.find (edef, n) of - NONE => raise Fail "Shake: Couldn't find 'val'" - | SOME (ns, t, e) => - let - val s = shakeExp (shakeCon s t) e - in - foldl (fn (n, s) => exp (ENamed n, s)) s ns - end) s page_es + val s = IS.foldl (fn (n, s) => + case IM.find (edef, n) of + NONE => raise Fail "Shake: Couldn't find 'val'" + | SOME (ns, t, e) => + let + val s = shakeExp (shakeCon s t) e + in + foldl (fn (n, s) => exp (ENamed n, s)) s ns + end) s usedE val s = foldl (fn (c, s) => shakeCon s c) s table_cs in
--- a/src/source.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/source.sml Tue Apr 07 12:24:31 2009 -0400 @@ -160,7 +160,7 @@ | DConstraint of con * con | DOpenConstraints of string * string list | DExport of str - | DTable of string * con + | DTable of string * con * exp | DSequence of string | DClass of string * kind * con | DDatabase of string
--- a/src/source_print.sml Sun Apr 05 16:17:32 2009 -0400 +++ b/src/source_print.sml Tue Apr 07 12:24:31 2009 -0400 @@ -588,13 +588,17 @@ | DExport str => box [string "export", space, p_str str] - | DTable (x, c) => box [string "table", - space, - string x, - space, - string ":", - space, - p_con c] + | DTable (x, c, e) => box [string "table", + space, + string x, + space, + string ":", + space, + p_con c, + space, + string "constraints", + space, + p_exp e] | DSequence x => box [string "sequence", space, string x]
--- a/src/urweb.grm Sun Apr 05 16:17:32 2009 -0400 +++ b/src/urweb.grm Tue Apr 07 12:24:31 2009 -0400 @@ -208,6 +208,7 @@ | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS | CURRENT_TIMESTAMP | NE | LT | LE | GT | GE + | CCONSTRAINT | UNIQUE %nonterm file of decl list @@ -222,6 +223,10 @@ | dcons of (string * con option) list | dcon of string * con option + | cst of exp + | csts of exp + | cstopt of exp + | sgn of sgn | sgntm of sgn | sgi of sgn_item @@ -289,6 +294,9 @@ | query1 of exp | tables of (con * exp) list | tname of con + | tnameW of (con * con) + | tnames of con + | tnames' of (con * con) list | table of con * exp | tident of con | fident of con @@ -410,7 +418,7 @@ | m :: ms => [(DOpenConstraints (m, ms), s (OPENleft, mpathright))]) | CONSTRAINT cterm TWIDDLE cterm ([(DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))]) | EXPORT spath ([(DExport spath, s (EXPORTleft, spathright))]) - | TABLE SYMBOL COLON cexp ([(DTable (SYMBOL, entable cexp), s (TABLEleft, cexpright))]) + | TABLE SYMBOL COLON cterm cstopt([(DTable (SYMBOL, entable cterm, cstopt), s (TABLEleft, cstoptright))]) | SEQUENCE SYMBOL ([(DSequence SYMBOL, s (SEQUENCEleft, SYMBOLright))]) | CLASS SYMBOL EQ cexp (let val loc = s (CLASSleft, cexpright) @@ -460,6 +468,50 @@ copt : (NONE) | COLON cexp (SOME cexp) +cstopt : (EVar (["Basis"], "no_constraint", Infer), dummy) + | csts (csts) + +csts : CCONSTRAINT tname cst (let + val loc = s (CCONSTRAINTleft, cstright) + + val e = (EVar (["Basis"], "one_constraint", Infer), loc) + val e = (ECApp (e, tname), loc) + in + (EApp (e, cst), loc) + end) + | csts COMMA csts (let + val loc = s (csts1left, csts2right) + + val e = (EVar (["Basis"], "join_constraints", Infer), loc) + val e = (EApp (e, csts1), loc) + in + (EApp (e, csts2), loc) + end) + | LBRACE LBRACE eexp RBRACE RBRACE (eexp) + +cst : UNIQUE tnames (let + val loc = s (UNIQUEleft, tnamesright) + + val e = (EVar (["Basis"], "unique", Infer), loc) + val e = (ECApp (e, tnames), loc) + in + (EDisjointApp e, loc) + end) + | LBRACE eexp RBRACE (eexp) + +tnameW : tname (let + val loc = s (tnameleft, tnameright) + in + (tname, (CWild (KType, loc), loc)) + end) + +tnames : tnameW (CRecord [tnameW], s (tnameWleft, tnameWright)) + | LPAREN tnames' RPAREN (CRecord tnames', s (LPARENleft, RPARENright)) + | LBRACE LBRACE cexp RBRACE RBRACE (cexp) + +tnames': tnameW ([tnameW]) + | tnameW COMMA tnames' (tnameW :: tnames') + valis : vali ([vali]) | vali AND valis (vali :: valis)
--- a/src/urweb.lex Sun Apr 05 16:17:32 2009 -0400 +++ b/src/urweb.lex Tue Apr 07 12:24:31 2009 -0400 @@ -365,6 +365,9 @@ <INITIAL> "NULL" => (Tokens.NULL (pos yypos, pos yypos + size yytext)); <INITIAL> "IS" => (Tokens.IS (pos yypos, pos yypos + size yytext)); +<INITIAL> "CONSTRAINT"=> (Tokens.CCONSTRAINT (pos yypos, pos yypos + size yytext)); +<INITIAL> "UNIQUE" => (Tokens.UNIQUE (pos yypos, pos yypos + size yytext)); + <INITIAL> "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext)); <INITIAL> {id} => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext));
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/cst.ur Tue Apr 07 12:24:31 2009 -0400 @@ -0,0 +1,13 @@ +table t : {A : int, B : int} + CONSTRAINT UniA UNIQUE A, + CONSTRAINT UniB UNIQUE B, + CONSTRAINT UniBoth UNIQUE (A, B), + + CONSTRAINT UniAm UNIQUE {#A}, + CONSTRAINT UniAm2 UNIQUE {{[A = _]}}, + CONSTRAINT UniAm3 {unique [[A = _]] !}, + {{one_constraint [#UniAm4] (unique [[A = _]] !)}} + +fun main () : transaction page = + queryI (SELECT * FROM t) (fn _ => return ()); + return <xml/>