Mercurial > urweb
changeset 338:e976b187d73a
SQL sequences
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 14 Sep 2008 11:02:18 -0400 |
| parents | 18d5affa790d |
| children | 075b36dbb1a4 |
| files | lib/basis.urs src/cjr.sml src/cjr_env.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/expl_util.sml src/explify.sml src/mono.sml src/mono_env.sml src/mono_print.sml src/mono_reduce.sml src/mono_shake.sml src/mono_util.sml src/monoize.sml src/prepare.sml src/shake.sml src/source.sml src/source_print.sml src/urweb.grm src/urweb.lex tests/sequence.ur tests/sequence.urp |
| diffstat | 35 files changed, 342 insertions(+), 13 deletions(-) [+] |
line wrap: on
line diff
--- a/lib/basis.urs Sat Sep 13 20:15:30 2008 -0400 +++ b/lib/basis.urs Sun Sep 14 11:02:18 2008 -0400 @@ -221,6 +221,11 @@ -> sql_exp [T = fields] [] [] bool -> dml +(*** Sequences *) + +type sql_sequence +val nextval : sql_sequence -> transaction int + (** XML *)
--- a/src/cjr.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/cjr.sml Sun Sep 14 11:02:18 2008 -0400 @@ -87,6 +87,8 @@ prepared : int option } | EDml of { dml : exp, prepared : int option } + | ENextval of { seq : exp, + prepared : int option } withtype exp = exp' located @@ -99,6 +101,7 @@ | DFunRec of (string * int * (string * typ) list * typ * exp) list | DTable of string * (string * typ) list + | DSequence of string | DDatabase of string | DPreparedStatements of (string * int) list
--- a/src/cjr_env.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/cjr_env.sml Sun Sep 14 11:02:18 2008 -0400 @@ -163,6 +163,7 @@ pushENamed env fx n t end) env vis | DTable _ => env + | DSequence _ => env | DDatabase _ => env | DPreparedStatements _ => env
--- a/src/cjr_print.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/cjr_print.sml Sun Sep 14 11:02:18 2008 -0400 @@ -976,6 +976,87 @@ newline, string "}))"] + | ENextval {seq, prepared} => + let + val query = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) + val query = (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), query]), loc) + in + box [string "(uw_begin_region(ctx), ", + string "({", + newline, + string "PGconn *conn = uw_get_db(ctx);", + newline, + case prepared of + NONE => box [string "char *query = ", + p_exp env query, + string ";", + newline] + | SOME _ => + box [], + newline, + string "PGresult *res = ", + case prepared of + NONE => string "PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);" + | SOME n => box [string "PQexecPrepared(conn, \"uw", + string (Int.toString n), + string "\", 0, NULL, NULL, NULL, 0);"], + newline, + string "uw_Basis_int n;", + newline, + newline, + + string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating nextval result.\");", + newline, + newline, + + string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", + newline, + box [string "PQclear(res);", + newline, + string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": Query failed:\\n%s\\n%s\", ", + case prepared of + NONE => string "query" + | SOME _ => p_exp env query, + string ", PQerrorMessage(conn));", + newline], + string "}", + newline, + newline, + + string "uw_end_region(ctx);", + newline, + string "n = PQntuples(res);", + newline, + string "if (n != 1) {", + newline, + box [string "PQclear(res);", + newline, + string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": Wrong number of result rows:\\n%s\\n%s\", ", + case prepared of + NONE => string "query" + | SOME _ => p_exp env query, + string ", PQerrorMessage(conn));", + newline], + string "}", + newline, + newline, + + string "n = ", + p_unsql true env (TFfi ("Basis", "int"), loc) + (string "PQgetvalue(res, 0, 0)"), + string ";", + newline, + string "PQclear(res);", + newline, + string "n;", + newline, + string "}))"] + end + and p_exp env = p_exp' false env fun p_fun env (fx, n, args, ran, e) = @@ -1119,6 +1200,10 @@ string x, string " */", newline] + | DSequence x => box [string "/* SQL sequence ", + string x, + string " */", + newline] | DDatabase s => box [string "static void uw_db_validate(uw_context);", newline, string "static void uw_db_prepare(uw_context);", @@ -1938,6 +2023,12 @@ string ");", newline, newline] + | DSequence s => + box [string "CREATE SEQUENCE ", + string s, + string ";", + newline, + newline] | _ => box [] in (pp, E.declBinds env dAll)
--- a/src/cjrize.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/cjrize.sml Sun Sep 14 11:02:18 2008 -0400 @@ -388,6 +388,13 @@ ((L'.EDml {dml = e, prepared = NONE}, loc), sm) end + | L.ENextval e => + let + val (e, sm) = cifyExp (e, sm) + in + ((L'.ENextval {seq = e, prepared = NONE}, loc), sm) + end + fun cifyDecl ((d, loc), sm) = case d of @@ -490,6 +497,8 @@ in (SOME (L'.DTable (s, xts), loc), NONE, sm) end + | L.DSequence s => + (SOME (L'.DSequence s, loc), NONE, sm) | L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, sm) fun cjrize ds =
--- a/src/core.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/core.sml Sun Sep 14 11:02:18 2008 -0400 @@ -115,6 +115,7 @@ | DValRec of (string * int * con * exp * string) list | DExport of export_kind * int | DTable of string * int * con * string + | DSequence of string * int * string | DDatabase of string withtype decl = decl' located
--- a/src/core_env.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/core_env.sml Sun Sep 14 11:02:18 2008 -0400 @@ -217,7 +217,13 @@ | DExport _ => env | DTable (x, n, c, s) => let - val t = (CApp ((CFfi ("Basis", "table"), loc), c), loc) + val t = (CApp ((CFfi ("Basis", "sql_table"), loc), c), loc) + in + pushENamed env x n t NONE s + end + | DSequence (x, n, s) => + let + val t = (CFfi ("Basis", "sql_sequence"), loc) in pushENamed env x n t NONE s end
--- a/src/core_print.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/core_print.sml Sun Sep 14 11:02:18 2008 -0400 @@ -458,6 +458,13 @@ string ":", space, p_con env c] + | DSequence (x, n, s) => box [string "sequence", + space, + p_named x n, + space, + string "as", + space, + string s] | DDatabase s => box [string "database", space, string s]
--- a/src/core_util.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/core_util.sml Sun Sep 14 11:02:18 2008 -0400 @@ -631,6 +631,7 @@ S.map2 (mfc ctx c, fn c' => (DTable (x, n, c', s), loc)) + | DSequence _ => S.return2 dAll | DDatabase _ => S.return2 dAll and mfvi ctx (x, n, t, e, s) = @@ -716,7 +717,13 @@ | DExport _ => ctx | DTable (x, n, c, s) => let - val t = (CApp ((CFfi ("Basis", "table"), #2 d'), c), #2 d') + val t = (CApp ((CFfi ("Basis", "sql_table"), #2 d'), c), #2 d') + in + bind (ctx, NamedE (x, n, t, NONE, s)) + end + | DSequence (x, n, s) => + let + val t = (CFfi ("Basis", "sql_sequence"), #2 d') in bind (ctx, NamedE (x, n, t, NONE, s)) end @@ -770,6 +777,7 @@ | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis | DExport _ => count | DTable (_, n, _, _) => Int.max (n, count) + | DSequence (_, n, _) => Int.max (n, count) | DDatabase _ => count) 0 end
--- a/src/corify.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/corify.sml Sun Sep 14 11:02:18 2008 -0400 @@ -863,6 +863,13 @@ in ([(L'.DTable (x, n, corifyCon st c, s), loc)], st) end + | L.DSequence (_, x, n) => + let + val (st, n) = St.bindVal st x n + val s = x + in + ([(L'.DSequence (x, n, s), loc)], st) + end | L.DDatabase s => ([(L'.DDatabase s, loc)], st) @@ -917,6 +924,7 @@ | L.DFfiStr (_, n', _) => Int.max (n, n') | L.DExport _ => n | L.DTable (_, _, n', _) => Int.max (n, n') + | L.DSequence (_, _, n') => Int.max (n, n') | L.DDatabase _ => n) 0 ds
--- a/src/elab.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/elab.sml Sun Sep 14 11:02:18 2008 -0400 @@ -129,6 +129,7 @@ | SgiSgn of string * int * sgn | SgiConstraint of con * con | SgiTable of int * string * int * con + | SgiSequence of int * string * int | SgiClassAbs of string * int | SgiClass of string * int * con @@ -155,6 +156,7 @@ | DConstraint of con * con | DExport of int * sgn * str | DTable of int * string * int * con + | DSequence of int * string * int | DClass of string * int * con | DDatabase of string
--- a/src/elab_env.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/elab_env.sml Sun Sep 14 11:02:18 2008 -0400 @@ -546,6 +546,7 @@ | SgiStr (x, n, _) => (sgns, IM.insert (strs, n, x), cons) | SgiConstraint _ => (sgns, strs, cons) | SgiTable _ => (sgns, strs, cons) + | SgiSequence _ => (sgns, strs, cons) | SgiClassAbs (x, n) => (sgns, strs, IM.insert (cons, n, x)) | SgiClass (x, n, _) => (sgns, strs, IM.insert (cons, n, x)) @@ -835,7 +836,13 @@ | SgiTable (tn, x, n, c) => let - val t = (CApp ((CModProj (tn, [], "table"), loc), c), loc) + val t = (CApp ((CModProj (tn, [], "sql_table"), loc), c), loc) + in + pushENamedAs env x n t + end + | SgiSequence (tn, x, n) => + let + val t = (CModProj (tn, [], "sql_sequence"), loc) in pushENamedAs env x n t end @@ -975,6 +982,7 @@ | SgiSgn (x, n, _) => seek (sgis, IM.insert (sgns, n, x), strs, cons, acc) | SgiStr (x, n, _) => seek (sgis, sgns, IM.insert (strs, n, x), cons, acc) | SgiTable _ => seek (sgis, sgns, strs, cons, acc) + | SgiSequence _ => seek (sgis, sgns, strs, cons, acc) | SgiClassAbs (x, n) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) | SgiClass (x, n, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) in @@ -1049,7 +1057,13 @@ | DExport _ => env | DTable (tn, x, n, c) => let - val t = (CApp ((CModProj (tn, [], "table"), loc), c), loc) + val t = (CApp ((CModProj (tn, [], "sql_table"), loc), c), loc) + in + pushENamedAs env x n t + end + | DSequence (tn, x, n) => + let + val t = (CModProj (tn, [], "sql_sequence"), loc) in pushENamedAs env x n t end
--- a/src/elab_print.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/elab_print.sml Sun Sep 14 11:02:18 2008 -0400 @@ -466,6 +466,9 @@ string ":", space, p_con env c] + | SgiSequence (_, x, n) => box [string "sequence", + space, + p_named x n] | SgiClassAbs (x, n) => box [string "class", space, p_named x n] @@ -632,6 +635,9 @@ string ":", space, p_con env c] + | DSequence (_, x, n) => box [string "sequence", + space, + p_named x n] | DClass (x, n, c) => box [string "class", space, p_named x n,
--- a/src/elab_util.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/elab_util.sml Sun Sep 14 11:02:18 2008 -0400 @@ -465,6 +465,7 @@ S.map2 (con ctx c, fn c' => (SgiTable (tn, x, n, c'), loc)) + | SgiSequence _ => S.return2 siAll | SgiClassAbs _ => S.return2 siAll | SgiClass (x, n, c) => S.map2 (con ctx c, @@ -494,6 +495,7 @@ bind (ctx, Sgn (x, sgn)) | SgiConstraint _ => ctx | SgiTable _ => ctx + | SgiSequence _ => ctx | SgiClassAbs (x, n) => bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))) | SgiClass (x, n, _) => @@ -635,8 +637,10 @@ | DConstraint _ => ctx | DExport _ => ctx | DTable (tn, x, n, c) => - bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "table"), loc), + bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "sql_table"), loc), c), loc))) + | DSequence (tn, x, n) => + bind (ctx, NamedE (x, (CModProj (n, [], "sql_sequence"), loc))) | DClass (x, n, _) => bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))) | DDatabase _ => ctx, @@ -731,13 +735,14 @@ S.map2 (mfc ctx c, fn c' => (DTable (tn, x, n, c'), loc)) + | DSequence _ => S.return2 dAll - | DClass (x, n, c) => + | DClass (x, n, c) => S.map2 (mfc ctx c, - fn c' => - (DClass (x, n, c'), loc)) + fn c' => + (DClass (x, n, c'), loc)) - | DDatabase _ => S.return2 dAll + | DDatabase _ => S.return2 dAll and mfvi ctx (x, n, c, e) = S.bind2 (mfc ctx c,
--- a/src/elaborate.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/elaborate.sml Sun Sep 14 11:02:18 2008 -0400 @@ -1648,6 +1648,7 @@ val hnormSgn = E.hnormSgn fun tableOf () = (L'.CModProj (!basis_r, [], "sql_table"), ErrorMsg.dummySpan) +fun sequenceOf () = (L'.CModProj (!basis_r, [], "sql_sequence"), ErrorMsg.dummySpan) fun elabSgn_item ((sgi, loc), (env, denv, gs)) = case sgi of @@ -1828,6 +1829,13 @@ ([(L'.SgiTable (!basis_r, x, n, c'), loc)], (env, denv, gs)) end + | L.SgiSequence x => + let + val (env, n) = E.pushENamed env x (sequenceOf ()) + in + ([(L'.SgiSequence (!basis_r, x, n), loc)], (env, denv, gs)) + end + | L.SgiClassAbs x => let val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) @@ -1915,6 +1923,12 @@ else (); (cons, SS.add (vals, x), sgns, strs)) + | L'.SgiSequence (_, x, _) => + (if SS.member (vals, x) then + sgnError env (DuplicateVal (loc, x)) + else + (); + (cons, SS.add (vals, x), sgns, strs)) | L'.SgiClassAbs (x, _) => (if SS.member (cons, x) then sgnError env (DuplicateCon (loc, x)) @@ -2061,6 +2075,9 @@ | L'.SgiTable (_, x, n, c) => (L'.DVal (x, n, (L'.CApp (tableOf (), c), loc), (L'.EModProj (str, strs, x), loc)), loc) + | L'.SgiSequence (_, x, n) => + (L'.DVal (x, n, sequenceOf (), + (L'.EModProj (str, strs, x), loc)), loc) | L'.SgiClassAbs (x, n) => let val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) @@ -2128,6 +2145,7 @@ | L'.DConstraint cs => [(L'.SgiConstraint cs, loc)] | L'.DExport _ => [] | L'.DTable (tn, x, n, c) => [(L'.SgiTable (tn, x, n, c), loc)] + | L'.DSequence (tn, x, n) => [(L'.SgiSequence (tn, x, n), loc)] | L'.DClass (x, n, c) => [(L'.SgiClass (x, n, c), loc)] | L'.DDatabase _ => [] @@ -2355,6 +2373,16 @@ SOME (env, denv)) else NONE + | L'.SgiSequence (_, x', n1) => + if x = x' then + (case unifyCons (env, denv) (sequenceOf ()) c2 of + [] => SOME (env, denv) + | _ => NONE) + handle CUnify (c1, c2, err) => + (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)); + SOME (env, denv)) + else + NONE | _ => NONE) | L'.SgiStr (x, n2, sgn2) => @@ -2432,6 +2460,16 @@ NONE | _ => NONE) + | L'.SgiSequence (_, x, n2) => + seek (fn sgi1All as (sgi1, _) => + case sgi1 of + L'.SgiSequence (_, x', n1) => + if x = x' then + SOME (env, denv) + else + NONE + | _ => NONE) + | L'.SgiClassAbs (x, n2) => seek (fn sgi1All as (sgi1, _) => let @@ -3024,6 +3062,12 @@ checkKind env c' k (L'.KRecord (L'.KType, loc), loc); ([(L'.DTable (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs)) end + | L.DSequence x => + let + val (env, n) = E.pushENamed env x (sequenceOf ()) + in + ([(L'.DSequence (!basis_r, x, n), loc)], (env, denv, gs)) + end | L.DClass (x, c) => let @@ -3147,6 +3191,16 @@ in ((L'.SgiTable (tn, x, n, c), loc) :: sgis, cons, vals, sgns, strs) end + | L'.SgiSequence (tn, x, n) => + let + val (vals, x) = + if SS.member (vals, x) then + (vals, "?" ^ x) + else + (SS.add (vals, x), x) + in + ((L'.SgiSequence (tn, x, n), loc) :: sgis, cons, vals, sgns, strs) + end | L'.SgiClassAbs (x, n) => let val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc)
--- a/src/expl.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/expl.sml Sun Sep 14 11:02:18 2008 -0400 @@ -108,6 +108,7 @@ | SgiSgn of string * int * sgn | SgiStr of string * int * sgn | SgiTable of int * string * int * con + | SgiSequence of int * string * int and sgn' = SgnConst of sgn_item list @@ -130,6 +131,7 @@ | DFfiStr of string * int * sgn | DExport of int * sgn * str | DTable of int * string * int * con + | DSequence of int * string * int | DDatabase of string and str' =
--- a/src/expl_env.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/expl_env.sml Sun Sep 14 11:02:18 2008 -0400 @@ -284,7 +284,13 @@ | DExport _ => env | DTable (tn, x, n, c) => let - val t = (CApp ((CModProj (tn, [], "table"), loc), c), loc) + val t = (CApp ((CModProj (tn, [], "sql_table"), loc), c), loc) + in + pushENamed env x n t + end + | DSequence (tn, x, n) => + let + val t = (CModProj (tn, [], "sql_sequence"), loc) in pushENamed env x n t end @@ -337,7 +343,13 @@ | SgiTable (tn, x, n, c) => let - val t = (CApp ((CModProj (tn, [], "table"), loc), c), loc) + val t = (CApp ((CModProj (tn, [], "sql_table"), loc), c), loc) + in + pushENamed env x n t + end + | SgiSequence (tn, x, n) => + let + val t = (CModProj (tn, [], "sql_sequence"), loc) in pushENamed env x n t end
--- a/src/expl_print.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/expl_print.sml Sun Sep 14 11:02:18 2008 -0400 @@ -436,6 +436,9 @@ string ":", space, p_con env c] + | SgiSequence (_, x, n) => box [string "sequence", + space, + p_named x n] and p_sgn env (sgn, loc) = case sgn of @@ -584,6 +587,9 @@ string ":", space, p_con env c] + | DSequence (_, x, n) => box [string "sequence", + space, + p_named x n] | DDatabase s => box [string "database", space, string s]
--- a/src/expl_util.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/expl_util.sml Sun Sep 14 11:02:18 2008 -0400 @@ -416,6 +416,7 @@ S.map2 (con ctx c, fn c' => (SgiTable (tn, x, n, c'), loc)) + | SgiSequence _ => S.return2 siAll and sg ctx s acc = S.bindP (sg' ctx s acc, sgn ctx) @@ -438,7 +439,8 @@ bind (ctx, Str (x, sgn)) | SgiSgn (x, _, sgn) => bind (ctx, Sgn (x, sgn)) - | SgiTable _ => ctx, + | SgiTable _ => ctx + | SgiSequence _ => ctx, sgi ctx si)) ctx sgis, fn sgis' => (SgnConst sgis', loc))
--- a/src/explify.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/explify.sml Sun Sep 14 11:02:18 2008 -0400 @@ -130,6 +130,7 @@ | L.SgiSgn (x, n, sgn) => SOME (L'.SgiSgn (x, n, explifySgn sgn), loc) | L.SgiConstraint _ => NONE | L.SgiTable (nt, x, n, c) => SOME (L'.SgiTable (nt, x, n, explifyCon c), loc) + | L.SgiSequence (nt, x, n) => SOME (L'.SgiSequence (nt, x, n), loc) | L.SgiClassAbs (x, n) => SOME (L'.SgiConAbs (x, n, (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc)), loc) | L.SgiClass (x, n, c) => SOME (L'.SgiCon (x, n, (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc), explifyCon c), loc) @@ -162,6 +163,7 @@ | 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.DSequence (nt, x, n) => SOME (L'.DSequence (nt, x, n), loc) | L.DClass (x, n, c) => SOME (L'.DCon (x, n, (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc), explifyCon c), loc) | L.DDatabase s => SOME (L'.DDatabase s, loc)
--- a/src/mono.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/mono.sml Sun Sep 14 11:02:18 2008 -0400 @@ -89,6 +89,7 @@ body : exp, initial : exp } | EDml of exp + | ENextval of exp withtype exp = exp' located @@ -100,6 +101,7 @@ | DExport of Core.export_kind * string * int * typ list | DTable of string * (string * typ) list + | DSequence of string | DDatabase of string withtype decl = decl' located
--- a/src/mono_env.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/mono_env.sml Sun Sep 14 11:02:18 2008 -0400 @@ -108,6 +108,7 @@ | DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis | DExport _ => env | DTable _ => env + | DSequence _ => env | DDatabase _ => env fun patBinds env (p, loc) =
--- a/src/mono_print.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/mono_print.sml Sun Sep 14 11:02:18 2008 -0400 @@ -260,6 +260,9 @@ | EDml e => box [string "dml(", p_exp env e, string ")"] + | ENextval e => box [string "nextval(", + p_exp env e, + string ")"] and p_exp env = p_exp' false env @@ -348,6 +351,9 @@ p_typ env t]) xts, space, string "*)"] + | DSequence s => box [string "(* SQL sequence ", + string s, + string "*)"] | DDatabase s => box [string "database", space, string s]
--- a/src/mono_reduce.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/mono_reduce.sml Sun Sep 14 11:02:18 2008 -0400 @@ -40,6 +40,7 @@ EWrite _ => true | EQuery _ => true | EDml _ => true + | ENextval _ => true | EAbs _ => false | EPrim _ => false @@ -250,6 +251,7 @@ [ReadDb]] | EDml e => summarize d e @ [WriteDb] + | ENextval e => summarize d e @ [WriteDb] fun exp env e = case e of
--- a/src/mono_shake.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/mono_shake.sml Sun Sep 14 11:02:18 2008 -0400 @@ -55,6 +55,7 @@ (cdef, foldl (fn ((_, n, t, e, _), edef) => IM.insert (edef, n, (t, e))) edef vis) | ((DExport _, _), acc) => acc | ((DTable _, _), acc) => acc + | ((DSequence _, _), acc) => acc | ((DDatabase _, _), acc) => acc) (IM.empty, IM.empty) file @@ -110,6 +111,7 @@ | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis | (DExport _, _) => true | (DTable _, _) => true + | (DSequence _, _) => true | (DDatabase _, _) => true) file end
--- a/src/mono_util.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/mono_util.sml Sun Sep 14 11:02:18 2008 -0400 @@ -290,6 +290,10 @@ S.map2 (mfe ctx e, fn e' => (EDml e', loc)) + | ENextval e => + S.map2 (mfe ctx e, + fn e' => + (ENextval e', loc)) in mfe end @@ -375,6 +379,7 @@ fn ts' => (DExport (ek, s, n, ts'), loc)) | DTable _ => S.return2 dAll + | DSequence _ => S.return2 dAll | DDatabase _ => S.return2 dAll and mfvi ctx (x, n, t, e, s) = @@ -439,6 +444,7 @@ bind (ctx, NamedE (x, n, t, NONE, s))) ctx vis | DExport _ => ctx | DTable _ => ctx + | DSequence _ => ctx | DDatabase _ => ctx in S.map2 (mff ctx' ds',
--- a/src/monoize.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/monoize.sml Sun Sep 14 11:02:18 2008 -0400 @@ -106,6 +106,8 @@ (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc) | L.CApp ((L.CFfi ("Basis", "sql_table"), _), _) => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "sql_sequence") => + (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query"), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query1"), _), _), _), _), _), _) => @@ -1151,6 +1153,17 @@ | L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm) | L.EFfi ("Basis", "sql_desc") => ((L'.EPrim (Prim.String " DESC"), loc), fm) + | L.EFfiApp ("Basis", "nextval", [e]) => + let + val un = (L'.TRecord [], loc) + val int = (L'.TFfi ("Basis", "int"), loc) + val (e, fm) = monoExp (env, st, fm) e + in + ((L'.EAbs ("_", un, int, + (L'.ENextval (liftExpInExp 0 e), loc)), loc), + fm) + end + | L.EApp ( (L.ECApp ( (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _), @@ -1618,6 +1631,18 @@ (L'.DVal (x, n, t', e, s), loc)]) end | L.DTable _ => poly () + | L.DSequence (x, n, s) => + 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) + in + SOME (Env.pushENamed env x n t NONE s, + fm, + [(L'.DSequence s, loc), + (L'.DVal (x, n, t', e, s), loc)]) + end | L.DDatabase s => SOME (env, fm, [(L'.DDatabase s, loc)]) end
--- a/src/prepare.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/prepare.sml Sun Sep 14 11:02:18 2008 -0400 @@ -163,6 +163,18 @@ ((EDml {dml = dml, prepared = SOME (#2 sns)}, loc), ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1))) + | ENextval {seq, ...} => + let + val s = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) + val s = (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), s]), loc) + in + case prepString (s, [], 0) of + NONE => (e, sns) + | SOME (ss, n) => + ((ENextval {seq = seq, prepared = SOME (#2 sns)}, loc), + ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1)) + end + fun prepDecl (d as (_, loc), sns) = case #1 d of DStruct _ => (d, sns) @@ -193,6 +205,7 @@ end | DTable _ => (d, sns) + | DSequence _ => (d, sns) | DDatabase _ => (d, sns) | DPreparedStatements _ => (d, sns)
--- a/src/shake.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/shake.sml Sun Sep 14 11:02:18 2008 -0400 @@ -41,6 +41,7 @@ exp : IS.set } +val dummyt = (TRecord (CRecord ((KType, ErrorMsg.dummySpan), []), ErrorMsg.dummySpan), ErrorMsg.dummySpan) val dummye = (EPrim (Prim.String ""), ErrorMsg.dummySpan) fun shake file = @@ -60,6 +61,8 @@ | ((DExport _, _), acc) => acc | ((DTable (_, n, c, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, (c, dummye))) + | ((DSequence (_, n, _), _), (cdef, edef)) => + (cdef, IM.insert (edef, n, (dummyt, dummye))) | ((DDatabase _, _), acc) => acc) (IM.empty, IM.empty) file @@ -116,6 +119,7 @@ | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis | (DExport _, _) => true | (DTable _, _) => true + | (DSequence _, _) => true | (DDatabase _, _) => true) file end
--- a/src/source.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/source.sml Sun Sep 14 11:02:18 2008 -0400 @@ -83,6 +83,7 @@ | SgiInclude of sgn | SgiConstraint of con * con | SgiTable of string * con + | SgiSequence of string | SgiClassAbs of string | SgiClass of string * con @@ -141,6 +142,7 @@ | DOpenConstraints of string * string list | DExport of str | DTable of string * con + | DSequence of string | DClass of string * con | DDatabase of string
--- a/src/source_print.sml Sat Sep 13 20:15:30 2008 -0400 +++ b/src/source_print.sml Sun Sep 14 11:02:18 2008 -0400 @@ -380,6 +380,9 @@ string ":", space, p_con c] + | SgiSequence x => box [string "sequence", + space, + string x] | SgiClassAbs x => box [string "class", space, string x] @@ -542,6 +545,9 @@ string ":", space, p_con c] + | DSequence x => box [string "sequence", + space, + string x] | DClass (x, c) => box [string "class", space, string x,
--- a/src/urweb.grm Sat Sep 13 20:15:30 2008 -0400 +++ b/src/urweb.grm Sun Sep 14 11:02:18 2008 -0400 @@ -173,7 +173,7 @@ | ARROW | LARROW | DARROW | STAR | SEMI | FN | PLUSPLUS | MINUSMINUS | DOLLAR | TWIDDLE | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN - | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE + | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | CASE | IF | THEN | ELSE | XML_BEGIN of string | XML_END @@ -385,6 +385,7 @@ | 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))]) + | SEQUENCE SYMBOL ([(DSequence SYMBOL, s (SEQUENCEleft, SYMBOLright))]) | CLASS SYMBOL EQ cexp ([(DClass (SYMBOL, cexp), s (CLASSleft, cexpright))]) | CLASS SYMBOL SYMBOL EQ cexp (let val loc = s (CLASSleft, cexpright) @@ -463,6 +464,7 @@ | INCLUDE sgn (SgiInclude sgn, s (INCLUDEleft, sgnright)) | CONSTRAINT cterm TWIDDLE cterm (SgiConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright)) | TABLE SYMBOL COLON cexp (SgiTable (SYMBOL, entable cexp), s (TABLEleft, cexpright)) + | SEQUENCE SYMBOL (SgiSequence SYMBOL, s (SEQUENCEleft, SYMBOLright)) | CLASS SYMBOL (SgiClassAbs SYMBOL, s (CLASSleft, SYMBOLright)) | CLASS SYMBOL EQ cexp (SgiClass (SYMBOL, cexp), s (CLASSleft, cexpright)) | CLASS SYMBOL SYMBOL EQ cexp (let
--- a/src/urweb.lex Sat Sep 13 20:15:30 2008 -0400 +++ b/src/urweb.lex Sun Sep 14 11:02:18 2008 -0400 @@ -298,6 +298,7 @@ <INITIAL> "constraints"=> (Tokens.CONSTRAINTS (pos yypos, pos yypos + size yytext)); <INITIAL> "export" => (Tokens.EXPORT (pos yypos, pos yypos + size yytext)); <INITIAL> "table" => (Tokens.TABLE (pos yypos, pos yypos + size yytext)); +<INITIAL> "sequence" => (Tokens.SEQUENCE (pos yypos, pos yypos + size yytext)); <INITIAL> "class" => (Tokens.CLASS (pos yypos, pos yypos + size yytext)); <INITIAL> "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext));