summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/basis.urs5
-rw-r--r--src/cjr.sml3
-rw-r--r--src/cjr_env.sml1
-rw-r--r--src/cjr_print.sml91
-rw-r--r--src/cjrize.sml9
-rw-r--r--src/core.sml1
-rw-r--r--src/core_env.sml8
-rw-r--r--src/core_print.sml7
-rw-r--r--src/core_util.sml10
-rw-r--r--src/corify.sml8
-rw-r--r--src/elab.sml2
-rw-r--r--src/elab_env.sml18
-rw-r--r--src/elab_print.sml6
-rw-r--r--src/elab_util.sml15
-rw-r--r--src/elaborate.sml54
-rw-r--r--src/expl.sml2
-rw-r--r--src/expl_env.sml16
-rw-r--r--src/expl_print.sml6
-rw-r--r--src/expl_util.sml4
-rw-r--r--src/explify.sml2
-rw-r--r--src/mono.sml2
-rw-r--r--src/mono_env.sml1
-rw-r--r--src/mono_print.sml6
-rw-r--r--src/mono_reduce.sml2
-rw-r--r--src/mono_shake.sml2
-rw-r--r--src/mono_util.sml6
-rw-r--r--src/monoize.sml25
-rw-r--r--src/prepare.sml13
-rw-r--r--src/shake.sml4
-rw-r--r--src/source.sml2
-rw-r--r--src/source_print.sml6
-rw-r--r--src/urweb.grm4
-rw-r--r--src/urweb.lex1
-rw-r--r--tests/sequence.ur7
-rw-r--r--tests/sequence.urp6
35 files changed, 342 insertions, 13 deletions
diff --git a/lib/basis.urs b/lib/basis.urs
index f5bfa740..672153b6 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -221,6 +221,11 @@ val delete : fields ::: {Type}
-> sql_exp [T = fields] [] [] bool
-> dml
+(*** Sequences *)
+
+type sql_sequence
+val nextval : sql_sequence -> transaction int
+
(** XML *)
diff --git a/src/cjr.sml b/src/cjr.sml
index 9b6765dc..8dca6b46 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -87,6 +87,8 @@ datatype exp' =
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 @@ datatype decl' =
| 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
diff --git a/src/cjr_env.sml b/src/cjr_env.sml
index fc4833da..49e86140 100644
--- a/src/cjr_env.sml
+++ b/src/cjr_env.sml
@@ -163,6 +163,7 @@ fun declBinds env (d, loc) =
pushENamed env fx n t
end) env vis
| DTable _ => env
+ | DSequence _ => env
| DDatabase _ => env
| DPreparedStatements _ => env
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index f784f3d4..fdd02a3b 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -976,6 +976,87 @@ fun p_exp' par env (e, loc) =
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 @@ fun p_decl env (dAll as (d, _) : decl) =
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 @@ fun p_sql env (ds, _) =
string ");",
newline,
newline]
+ | DSequence s =>
+ box [string "CREATE SEQUENCE ",
+ string s,
+ string ";",
+ newline,
+ newline]
| _ => box []
in
(pp, E.declBinds env dAll)
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 9e426751..606be3eb 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -388,6 +388,13 @@ fun cifyExp (eAll as (e, loc), sm) =
((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 @@ fun cifyDecl ((d, loc), sm) =
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 =
diff --git a/src/core.sml b/src/core.sml
index 0eef7e96..1fcf26c4 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -115,6 +115,7 @@ datatype decl' =
| 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
diff --git a/src/core_env.sml b/src/core_env.sml
index a4d5fc50..a4b48b8d 100644
--- a/src/core_env.sml
+++ b/src/core_env.sml
@@ -217,7 +217,13 @@ fun declBinds env (d, loc) =
| 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
diff --git a/src/core_print.sml b/src/core_print.sml
index cfd01e2d..6e32dde3 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -458,6 +458,13 @@ fun p_decl env (dAll as (d, _) : decl) =
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]
diff --git a/src/core_util.sml b/src/core_util.sml
index dfd6fa77..9b6b7d39 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -631,6 +631,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} =
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 @@ fun mapfoldB (all as {bind, ...}) =
| 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 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
| 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
diff --git a/src/corify.sml b/src/corify.sml
index fac83ee3..92c429ef 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -863,6 +863,13 @@ fun corifyDecl ((d, loc : EM.span), st) =
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 @@ fun maxName ds = foldl (fn ((d, _), n) =>
| 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
diff --git a/src/elab.sml b/src/elab.sml
index 6fcb857a..2e8d12f6 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -129,6 +129,7 @@ datatype sgn_item' =
| 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 @@ datatype decl' =
| 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
diff --git a/src/elab_env.sml b/src/elab_env.sml
index 6c3d7802..3f32ed21 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -546,6 +546,7 @@ fun sgiSeek (sgi, (sgns, strs, cons)) =
| 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 @@ fun sgiBinds env (sgi, loc) =
| 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 @@ fun sgnSeekConstraints (str, sgis) =
| 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 @@ fun declBinds env (d, loc) =
| 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
diff --git a/src/elab_print.sml b/src/elab_print.sml
index bb1c2a85..4dc41ca7 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -466,6 +466,9 @@ fun p_sgn_item env (sgi, _) =
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 @@ fun p_decl env (dAll as (d, _) : decl) =
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,
diff --git a/src/elab_util.sml b/src/elab_util.sml
index 242ffdbc..02b95130 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -465,6 +465,7 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} =
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 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} =
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 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
| 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 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
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,
diff --git a/src/elaborate.sml b/src/elaborate.sml
index e6e5453d..0c313f14 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1648,6 +1648,7 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
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 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) =
([(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 @@ and elabSgn (env, denv) (sgn, loc) =
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 @@ fun dopen (env, denv) {str, strs, sgn} =
| 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 @@ fun sgiOfDecl (d, loc) =
| 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 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
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 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
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 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) =
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 @@ and elabStr (env, denv) (str, loc) =
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)
diff --git a/src/expl.sml b/src/expl.sml
index 3bb7beff..c55461fc 100644
--- a/src/expl.sml
+++ b/src/expl.sml
@@ -108,6 +108,7 @@ datatype sgn_item' =
| 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 @@ datatype decl' =
| 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' =
diff --git a/src/expl_env.sml b/src/expl_env.sml
index fdb4d995..43456c41 100644
--- a/src/expl_env.sml
+++ b/src/expl_env.sml
@@ -284,7 +284,13 @@ fun declBinds env (d, loc) =
| 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 @@ fun sgiBinds env (sgi, loc) =
| 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
diff --git a/src/expl_print.sml b/src/expl_print.sml
index 10819fbc..dd328bb5 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -436,6 +436,9 @@ fun p_sgn_item env (sgi, _) =
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 @@ fun p_decl env (dAll as (d, _) : decl) =
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]
diff --git a/src/expl_util.sml b/src/expl_util.sml
index ee4b6dc2..b8376b5b 100644
--- a/src/expl_util.sml
+++ b/src/expl_util.sml
@@ -416,6 +416,7 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} =
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 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} =
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))
diff --git a/src/explify.sml b/src/explify.sml
index 76ef9551..c45e7305 100644
--- a/src/explify.sml
+++ b/src/explify.sml
@@ -130,6 +130,7 @@ fun explifySgi (sgi, loc) =
| 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 @@ fun explifyDecl (d, loc : EM.span) =
| 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)
diff --git a/src/mono.sml b/src/mono.sml
index b10f651c..4742c541 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -89,6 +89,7 @@ datatype exp' =
body : exp,
initial : exp }
| EDml of exp
+ | ENextval of exp
withtype exp = exp' located
@@ -100,6 +101,7 @@ datatype decl' =
| 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
diff --git a/src/mono_env.sml b/src/mono_env.sml
index 9981ec01..47ffd28d 100644
--- a/src/mono_env.sml
+++ b/src/mono_env.sml
@@ -108,6 +108,7 @@ fun declBinds env (d, loc) =
| 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) =
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 40abf7d7..f7adfd70 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -260,6 +260,9 @@ fun p_exp' par env (e, _) =
| 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 @@ fun p_decl env (dAll as (d, _) : decl) =
p_typ env t]) xts,
space,
string "*)"]
+ | DSequence s => box [string "(* SQL sequence ",
+ string s,
+ string "*)"]
| DDatabase s => box [string "database",
space,
string s]
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index b66e9b04..c7b727ee 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -40,6 +40,7 @@ fun impure (e, _) =
EWrite _ => true
| EQuery _ => true
| EDml _ => true
+ | ENextval _ => true
| EAbs _ => false
| EPrim _ => false
@@ -250,6 +251,7 @@ fun summarize d (e, _) =
[ReadDb]]
| EDml e => summarize d e @ [WriteDb]
+ | ENextval e => summarize d e @ [WriteDb]
fun exp env e =
case e of
diff --git a/src/mono_shake.sml b/src/mono_shake.sml
index dddb1d9a..6714718a 100644
--- a/src/mono_shake.sml
+++ b/src/mono_shake.sml
@@ -55,6 +55,7 @@ fun shake file =
(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 @@ fun shake file =
| (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis
| (DExport _, _) => true
| (DTable _, _) => true
+ | (DSequence _, _) => true
| (DDatabase _, _) => true) file
end
diff --git a/src/mono_util.sml b/src/mono_util.sml
index e9f8e033..a56e5287 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -290,6 +290,10 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
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 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
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 @@ fun mapfoldB (all as {bind, ...}) =
bind (ctx, NamedE (x, n, t, NONE, s))) ctx vis
| DExport _ => ctx
| DTable _ => ctx
+ | DSequence _ => ctx
| DDatabase _ => ctx
in
S.map2 (mff ctx' ds',
diff --git a/src/monoize.sml b/src/monoize.sml
index e750c381..13feae36 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -106,6 +106,8 @@ fun monoType env =
(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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| 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 @@ fun monoDecl (env, fm) (all as (d, loc)) =
(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
diff --git a/src/prepare.sml b/src/prepare.sml
index 20a09c9b..3c5aa2aa 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -163,6 +163,18 @@ fun prepExp (e as (_, loc), sns) =
((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 @@ fun prepDecl (d as (_, loc), sns) =
end
| DTable _ => (d, sns)
+ | DSequence _ => (d, sns)
| DDatabase _ => (d, sns)
| DPreparedStatements _ => (d, sns)
diff --git a/src/shake.sml b/src/shake.sml
index 6395bfdc..38d72cc5 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -41,6 +41,7 @@ type free = {
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 @@ fun shake file =
| ((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 @@ fun shake file =
| (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis
| (DExport _, _) => true
| (DTable _, _) => true
+ | (DSequence _, _) => true
| (DDatabase _, _) => true) file
end
diff --git a/src/source.sml b/src/source.sml
index 70738c1a..bfb54194 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -83,6 +83,7 @@ datatype sgn_item' =
| 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 @@ datatype decl' =
| DOpenConstraints of string * string list
| DExport of str
| DTable of string * con
+ | DSequence of string
| DClass of string * con
| DDatabase of string
diff --git a/src/source_print.sml b/src/source_print.sml
index c37505d0..4844e508 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -380,6 +380,9 @@ fun p_sgn_item (sgi, _) =
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 @@ fun p_decl ((d, _) : decl) =
string ":",
space,
p_con c]
+ | DSequence x => box [string "sequence",
+ space,
+ string x]
| DClass (x, c) => box [string "class",
space,
string x,
diff --git a/src/urweb.grm b/src/urweb.grm
index ff53b4b8..e9d081a5 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -173,7 +173,7 @@ fun tagIn bt =
| 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 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let
| 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 @@ sgi : CON SYMBOL DCOLON kind (SgiConAbs (SYMBOL, kind), s (CONleft, k
| 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
diff --git a/src/urweb.lex b/src/urweb.lex
index 9cb4d642..8d861082 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -298,6 +298,7 @@ notags = [^<{\n]+;
<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));
diff --git a/tests/sequence.ur b/tests/sequence.ur
new file mode 100644
index 00000000..4d37d05a
--- /dev/null
+++ b/tests/sequence.ur
@@ -0,0 +1,7 @@
+sequence seq
+
+fun main () : transaction page =
+ n <- nextval seq;
+ return <html><body>
+ {txt _ n}
+ </body></html>
diff --git a/tests/sequence.urp b/tests/sequence.urp
new file mode 100644
index 00000000..5edfb18e
--- /dev/null
+++ b/tests/sequence.urp
@@ -0,0 +1,6 @@
+debug
+database dbname=test
+exe /tmp/webapp
+sql /tmp/urweb.sql
+
+sequence
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-04 23:17:11 +0000