summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-12-13 14:20:41 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-12-13 14:20:41 -0500
commitb225596addee1a3cfd6c3189cff923e7f0e8f7c9 (patch)
tree14b2deefac4e078e2d5e4e5bdd076749de8659d8
parent1063981355a5a041793c095c6fd89b91fa0bd579 (diff)
Initializers and setval
-rw-r--r--CHANGELOG1
-rw-r--r--lib/ur/basis.urs1
-rw-r--r--src/checknest.sml4
-rw-r--r--src/cjr.sml3
-rw-r--r--src/cjr_env.sml1
-rw-r--r--src/cjr_print.sml23
-rw-r--r--src/cjrize.sml17
-rw-r--r--src/core.sml1
-rw-r--r--src/core_env.sml1
-rw-r--r--src/core_print.sml3
-rw-r--r--src/core_util.sml8
-rw-r--r--src/corify.sml6
-rw-r--r--src/elab.sml1
-rw-r--r--src/elab_env.sml1
-rw-r--r--src/elab_print.sml3
-rw-r--r--src/elab_util.sml8
-rw-r--r--src/elaborate.sml10
-rw-r--r--src/elisp/urweb-defs.el8
-rw-r--r--src/elisp/urweb-mode.el4
-rw-r--r--src/expl.sml1
-rw-r--r--src/expl_env.sml1
-rw-r--r--src/expl_print.sml3
-rw-r--r--src/explify.sml1
-rw-r--r--src/jscomp.sml8
-rw-r--r--src/mono.sml3
-rw-r--r--src/mono_env.sml1
-rw-r--r--src/mono_print.sml9
-rw-r--r--src/mono_reduce.sml3
-rw-r--r--src/mono_shake.sml42
-rw-r--r--src/mono_util.sml14
-rw-r--r--src/monoize.sml15
-rw-r--r--src/mysql.sml3
-rw-r--r--src/postgres.sml43
-rw-r--r--src/prepare.sml14
-rw-r--r--src/reduce.sml9
-rw-r--r--src/reduce_local.sml1
-rw-r--r--src/scriptcheck.sml1
-rw-r--r--src/settings.sig1
-rw-r--r--src/settings.sml4
-rw-r--r--src/shake.sml7
-rw-r--r--src/source.sml1
-rw-r--r--src/source_print.sml3
-rw-r--r--src/sqlite.sml2
-rw-r--r--src/unnest.sml1
-rw-r--r--src/urweb.grm3
-rw-r--r--src/urweb.lex1
-rw-r--r--tests/init.ur6
-rw-r--r--tests/init.urp5
48 files changed, 286 insertions, 24 deletions
diff --git a/CHANGELOG b/CHANGELOG
index 15e92fd5..e1e14aea 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -6,6 +6,7 @@ Next
- More syntactic sugar for SQL
- Typing of SQL queries no longer exposes which tables were used in joins but
had none of their fields projected
+- Module-level initializers
========
20091203
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index b9d1f55f..f7e098d4 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -523,6 +523,7 @@ val delete : fields ::: {Type} -> uniques ::: {{Unit}}
type sql_sequence
val nextval : sql_sequence -> transaction int
+val setval : sql_sequence -> int -> transaction unit
(** XML *)
diff --git a/src/checknest.sml b/src/checknest.sml
index 49519705..c0f843d6 100644
--- a/src/checknest.sml
+++ b/src/checknest.sml
@@ -87,6 +87,7 @@ fun expUses globals =
SOME {id, ...} => IS.add (s, id)
| _ => s
end
+ | ESetval {seq, count} => IS.union (eu seq, eu count)
| EUnurlify (e, _) => eu e
in
@@ -144,6 +145,9 @@ fun annotateExp globals =
| ENextval {seq, prepared} =>
(ENextval {seq = ae seq,
prepared = prepared}, loc)
+ | ESetval {seq, count} =>
+ (ESetval {seq = ae seq,
+ count = ae count}, loc)
| EUnurlify (e, t) => (EUnurlify (ae e, t), loc)
in
diff --git a/src/cjr.sml b/src/cjr.sml
index 2b8ce6fe..9be54670 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -95,6 +95,7 @@ datatype exp' =
prepared : {id : int, dml : string} option }
| ENextval of { seq : exp,
prepared : {id : int, query : string} option }
+ | ESetval of { seq : exp, count : exp }
| EUnurlify of exp * typ
withtype exp = exp' located
@@ -117,6 +118,8 @@ datatype decl' =
| DCookie of string
| DStyle of string
+ | DInitializer of exp
+
withtype decl = decl' located
datatype sidedness =
diff --git a/src/cjr_env.sml b/src/cjr_env.sml
index 217efb3a..e4d978d5 100644
--- a/src/cjr_env.sml
+++ b/src/cjr_env.sml
@@ -171,5 +171,6 @@ fun declBinds env (d, loc) =
| DJavaScript _ => env
| DCookie _ => env
| DStyle _ => env
+ | DInitializer _ => env
end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index a1d5ed2c..6a5116ce 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1849,6 +1849,20 @@ fun p_exp' par env (e, loc) =
newline,
string "})"]
+ | ESetval {seq, count} =>
+ box [string "({",
+ newline,
+
+ #setval (Settings.currentDbms ()) {loc = loc,
+ seqE = p_exp env seq,
+ count = p_exp env count},
+ newline,
+ newline,
+
+ string "uw_unit_v;",
+ newline,
+ string "})"]
+
| EUnurlify (e, t) =>
let
fun getIt () =
@@ -2085,6 +2099,8 @@ fun p_decl env (dAll as (d, _) : decl) =
space,
string "*/"]
+ | DInitializer _ => box []
+
datatype 'a search =
Found of 'a
| NotFound
@@ -2716,6 +2732,8 @@ fun p_file env (ds, ps) =
newline],
string "}",
newline]
+
+ val initializers = List.mapPartial (fn (DInitializer e, _) => SOME e | _ => NONE) ds
in
box [string "#include <stdio.h>",
newline,
@@ -2849,7 +2867,10 @@ fun p_file env (ds, ps) =
string "void uw_initializer(uw_context ctx) {",
newline,
- box [p_enamed env (!initialize),
+ box [p_list_sep (box []) (fn e => box [p_exp env e,
+ string ";",
+ newline]) initializers,
+ p_enamed env (!initialize),
string "(ctx, uw_unit_v);",
newline],
string "}",
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 703b9477..3936f6a5 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -468,6 +468,13 @@ fun cifyExp (eAll as (e, loc), sm) =
in
((L'.ENextval {seq = e, prepared = NONE}, loc), sm)
end
+ | L.ESetval (e1, e2) =>
+ let
+ val (e1, sm) = cifyExp (e1, sm)
+ val (e2, sm) = cifyExp (e2, sm)
+ in
+ ((L'.ESetval {seq = e1, count = e2}, loc), sm)
+ end
| L.EUnurlify (e, t) =>
let
@@ -653,6 +660,16 @@ fun cifyDecl ((d, loc), sm) =
| L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm)
| L.DCookie args => (SOME (L'.DCookie args, loc), NONE, sm)
| L.DStyle args => (SOME (L'.DStyle args, loc), NONE, sm)
+ | L.DInitializer e =>
+ (case #1 e of
+ L.EAbs (_, _, _, e) =>
+ let
+ val (e, sm) = cifyExp (e, sm)
+ in
+ (SOME (L'.DInitializer e, loc), NONE, sm)
+ end
+ | _ => (ErrorMsg.errorAt loc "Initializer has not been fully determined";
+ (NONE, NONE, sm)))
fun cjrize ds =
let
diff --git a/src/core.sml b/src/core.sml
index 6bead3dc..a60bfd3b 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -134,6 +134,7 @@ datatype decl' =
| DDatabase of string
| DCookie of string * int * con * string
| DStyle of string * int * string
+ | DInitializer of exp
withtype decl = decl' located
diff --git a/src/core_env.sml b/src/core_env.sml
index e8cd139f..5e0af98c 100644
--- a/src/core_env.sml
+++ b/src/core_env.sml
@@ -348,6 +348,7 @@ fun declBinds env (d, loc) =
in
pushENamed env x n t NONE s
end
+ | DInitializer _ => env
fun patBinds env (p, loc) =
case p of
diff --git a/src/core_print.sml b/src/core_print.sml
index 02407f01..7dd43d56 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -611,6 +611,9 @@ fun p_decl env (dAll as (d, _) : decl) =
string "as",
space,
string s]
+ | DInitializer e => box [string "initializer",
+ space,
+ p_exp env e]
fun p_file env file =
let
diff --git a/src/core_util.sml b/src/core_util.sml
index cedde841..7ead1157 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -971,6 +971,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} =
fn c' =>
(DCookie (x, n, c', s), loc))
| DStyle _ => S.return2 dAll
+ | DInitializer e =>
+ S.map2 (mfe ctx e,
+ fn e' =>
+ (DInitializer e', loc))
and mfvi ctx (x, n, t, e, s) =
S.bind2 (mfc ctx t,
@@ -1125,6 +1129,7 @@ fun mapfoldB (all as {bind, ...}) =
in
bind (ctx, NamedE (x, n, t, NONE, s))
end
+ | DInitializer _ => ctx
in
S.map2 (mff ctx' ds',
fn ds' =>
@@ -1187,7 +1192,8 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
| DView (_, n, _, _, _) => Int.max (n, count)
| DDatabase _ => count
| DCookie (_, n, _, _) => Int.max (n, count)
- | DStyle (_, n, _) => Int.max (n, count)) 0
+ | DStyle (_, n, _) => Int.max (n, count)
+ | DInitializer _ => count) 0
end
diff --git a/src/corify.sml b/src/corify.sml
index 9bf322f3..cc0500af 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -1064,6 +1064,9 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
([(L'.DStyle (x, n, s), loc)], st)
end
+ | L.DInitializer e =>
+ ([(L'.DInitializer (corifyExp st e), loc)], st)
+
and corifyStr mods ((str, _), st) =
case str of
L.StrConst ds =>
@@ -1120,7 +1123,8 @@ fun maxName ds = foldl (fn ((d, _), n) =>
| L.DView (_, _, n', _, _) => Int.max (n, n')
| L.DDatabase _ => n
| L.DCookie (_, _, n', _) => Int.max (n, n')
- | L.DStyle (_, _, n') => Int.max (n, n'))
+ | L.DStyle (_, _, n') => Int.max (n, n')
+ | L.DInitializer _ => n)
0 ds
and maxNameStr (str, _) =
diff --git a/src/elab.sml b/src/elab.sml
index 76ea6725..1cd7aefa 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -170,6 +170,7 @@ datatype decl' =
| DDatabase of string
| DCookie of int * string * int * con
| DStyle of int * string * int
+ | DInitializer of exp
and str' =
StrConst of decl list
diff --git a/src/elab_env.sml b/src/elab_env.sml
index 4636fda8..763cf801 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -1622,5 +1622,6 @@ fun declBinds env (d, loc) =
in
pushENamedAs env x n t
end
+ | DInitializer _ => env
end
diff --git a/src/elab_print.sml b/src/elab_print.sml
index 3e4ea659..906c836d 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -799,6 +799,9 @@ fun p_decl env (dAll as (d, _) : decl) =
| DStyle (_, x, n) => box [string "style",
space,
p_named x n]
+ | DInitializer e => box [string "initializer",
+ space,
+ p_exp env e]
and p_str env (str, _) =
case str of
diff --git a/src/elab_util.sml b/src/elab_util.sml
index e7985026..2a044e71 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -853,7 +853,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "cookie"), loc),
c), loc)))
| DStyle (tn, x, n) =>
- bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc))),
+ bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc)))
+ | DInitializer _ => ctx,
mfd ctx d)) ctx ds,
fn ds' => (StrConst ds', loc))
| StrVar _ => S.return2 strAll
@@ -978,6 +979,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
fn c' =>
(DCookie (tn, x, n, c'), loc))
| DStyle _ => S.return2 dAll
+ | DInitializer e =>
+ S.map2 (mfe ctx e,
+ fn e' =>
+ (DInitializer e', loc))
and mfvi ctx (x, n, c, e) =
S.bind2 (mfc ctx c,
@@ -1120,6 +1125,7 @@ and maxNameDecl (d, _) =
| DDatabase _ => 0
| DCookie (n1, _, n2, _) => Int.max (n1, n2)
| DStyle (n1, _, n2) => Int.max (n1, n2)
+ | DInitializer _ => 0
and maxNameStr (str, _) =
case str of
StrConst ds => maxName ds
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 71842ec2..327004e2 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -2548,6 +2548,7 @@ and sgiOfDecl (d, loc) =
| L'.DDatabase _ => []
| L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)]
| L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)]
+ | L'.DInitializer _ => []
and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) =
((*prefaces "subSgn" [("sgn1", p_sgn env sgn1),
@@ -3668,6 +3669,15 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
in
([(L'.DStyle (!basis_r, x, n), loc)], (env, denv, gs))
end
+ | L.DInitializer e =>
+ let
+ val (e', t, gs) = elabExp (env, denv) e
+ val t' = (L'.CApp ((L'.CModProj (!basis_r, [], "transaction"), loc),
+ (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc)), loc)
+ in
+ checkCon env e' t t';
+ ([(L'.DInitializer e', loc)], (env, denv, gs))
+ end
(*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*)
in
diff --git a/src/elisp/urweb-defs.el b/src/elisp/urweb-defs.el
index e1382692..bb0e257d 100644
--- a/src/elisp/urweb-defs.el
+++ b/src/elisp/urweb-defs.el
@@ -108,7 +108,7 @@ notion of \"the end of an outline\".")
"datatype" "type" "open" "include"
urweb-module-head-syms
"con" "map" "where" "extern" "constraint" "constraints"
- "table" "sequence" "class" "cookie")
+ "table" "sequence" "class" "cookie" "initializer")
"Symbols starting an sexp.")
;; (defconst urweb-not-arg-start-re
@@ -134,7 +134,8 @@ notion of \"the end of an outline\".")
(,urweb-=-starter-syms nil)
(("case" "datatype" "if" "then" "else"
"let" "open" "sig" "struct" "type" "val"
- "con" "constraint" "table" "sequence" "class" "cookie")))))
+ "con" "constraint" "table" "sequence" "class" "cookie"
+ "initializer")))))
(defconst urweb-starters-indent-after
(urweb-syms-re "let" "in" "struct" "sig")
@@ -188,7 +189,8 @@ for all symbols and in all lines starting with the given symbol."
(append urweb-module-head-syms
'("datatype" "fun"
"open" "type" "val" "and"
- "con" "constraint" "table" "sequence" "class" "cookie"))
+ "con" "constraint" "table" "sequence" "class" "cookie"
+ "initializer"))
"The starters of new expressions.")
(defconst urweb-exptrail-syms
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index 72005af9..ab274f22 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -136,7 +136,7 @@ See doc for the variable `urweb-mode-info'."
"datatype" "else" "end" "extern" "fn" "map"
"fun" "functor" "if" "include"
"of" "open" "let" "in"
- "rec" "sequence" "sig" "signature" "cookie" "style"
+ "rec" "sequence" "sig" "signature" "cookie" "style" "initializer"
"struct" "structure" "table" "view" "then" "type" "val" "where"
"with"
@@ -226,7 +226,7 @@ See doc for the variable `urweb-mode-info'."
("\\<\\(\\(data\\)?type\\|con\\|class\\)\\s-+\\(\\sw+\\)"
(1 font-lock-keyword-face)
(3 (amAttribute font-lock-type-def-face)))
- ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
+ ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\|initializer\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
(1 font-lock-keyword-face)
(3 (amAttribute font-lock-variable-name-face)))
("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)"
diff --git a/src/expl.sml b/src/expl.sml
index 4a9acd8a..eb79e2b0 100644
--- a/src/expl.sml
+++ b/src/expl.sml
@@ -147,6 +147,7 @@ datatype decl' =
| DDatabase of string
| DCookie of int * string * int * con
| DStyle of int * string * int
+ | DInitializer of exp
and str' =
StrConst of decl list
diff --git a/src/expl_env.sml b/src/expl_env.sml
index 836af42c..f16eeb8e 100644
--- a/src/expl_env.sml
+++ b/src/expl_env.sml
@@ -343,6 +343,7 @@ fun declBinds env (d, loc) =
in
pushENamed env x n t
end
+ | DInitializer _ => env
fun sgiBinds env (sgi, loc) =
case sgi of
diff --git a/src/expl_print.sml b/src/expl_print.sml
index 0783facc..624afa63 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -713,6 +713,9 @@ fun p_decl env (dAll as (d, _) : decl) =
| DStyle (_, x, n) => box [string "style",
space,
p_named x n]
+ | DInitializer e => box [string "initializer",
+ space,
+ p_exp env e]
and p_str env (str, _) =
case str of
diff --git a/src/explify.sml b/src/explify.sml
index 3ec588fa..d66b3530 100644
--- a/src/explify.sml
+++ b/src/explify.sml
@@ -195,6 +195,7 @@ fun explifyDecl (d, loc : EM.span) =
| L.DDatabase s => SOME (L'.DDatabase s, loc)
| L.DCookie (nt, x, n, c) => SOME (L'.DCookie (nt, x, n, explifyCon c), loc)
| L.DStyle (nt, x, n) => SOME (L'.DStyle (nt, x, n), loc)
+ | L.DInitializer e => SOME (L'.DInitializer (explifyExp e), loc)
and explifyStr (str, loc) =
case str of
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 471711d2..ca20e71d 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -868,6 +868,7 @@ fun process file =
| EQuery _ => unsupported "Query"
| EDml _ => unsupported "DML"
| ENextval _ => unsupported "Nextval"
+ | ESetval _ => unsupported "Nextval"
| EUnurlify _ => unsupported "EUnurlify"
| EReturnBlob _ => unsupported "EUnurlify"
| ERedirect _ => unsupported "ERedirect"
@@ -1142,6 +1143,13 @@ fun process file =
in
((ENextval e, loc), st)
end
+ | ESetval (e1, e2) =>
+ let
+ val (e1, st) = exp outer (e1, st)
+ val (e2, st) = exp outer (e2, st)
+ in
+ ((ESetval (e1, e2), loc), st)
+ end
| EUnurlify (e, t) =>
let
diff --git a/src/mono.sml b/src/mono.sml
index 92424ee3..1962c6c5 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -106,6 +106,7 @@ datatype exp' =
initial : exp }
| EDml of exp
| ENextval of exp
+ | ESetval of exp * exp
| EUnurlify of exp * typ
@@ -138,6 +139,8 @@ datatype decl' =
| DCookie of string
| DStyle of string
+ | DInitializer of exp
+
withtype decl = decl' located
type file = decl list
diff --git a/src/mono_env.sml b/src/mono_env.sml
index 3114176d..6ffab153 100644
--- a/src/mono_env.sml
+++ b/src/mono_env.sml
@@ -129,6 +129,7 @@ fun declBinds env (d, loc) =
| DJavaScript _ => env
| DCookie _ => env
| DStyle _ => env
+ | DInitializer _ => env
fun patBinds env (p, loc) =
case p of
diff --git a/src/mono_print.sml b/src/mono_print.sml
index cfaa410b..13c45329 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -320,6 +320,12 @@ fun p_exp' par env (e, _) =
| ENextval e => box [string "nextval(",
p_exp env e,
string ")"]
+ | ESetval (e1, e2) => box [string "setval(",
+ p_exp env e1,
+ string ",",
+ space,
+ p_exp env e2,
+ string ")"]
| EUnurlify (e, _) => box [string "unurlify(",
p_exp env e,
string ")"]
@@ -485,6 +491,9 @@ fun p_decl env (dAll as (d, _) : decl) =
| DStyle s => box [string "style",
space,
string s]
+ | DInitializer e => box [string "initializer",
+ space,
+ p_exp env e]
fun p_file env file =
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index f29117cf..aa6b7051 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -51,6 +51,7 @@ fun simpleImpure (tsyms, syms) =
| EQuery _ => true
| EDml _ => true
| ENextval _ => true
+ | ESetval _ => true
| EFfiApp (m, x, _) => Settings.isEffectful (m, x)
| EServerCall _ => true
| ERecv _ => true
@@ -75,6 +76,7 @@ fun impure (e, _) =
| EQuery _ => true
| EDml _ => true
| ENextval _ => true
+ | ESetval _ => true
| EUnurlify _ => true
| EAbs _ => false
@@ -448,6 +450,7 @@ fun reduce file =
| EDml e => summarize d e @ [WriteDb]
| ENextval e => summarize d e @ [WriteDb]
+ | ESetval (e1, e2) => summarize d e1 @ summarize d e2 @ [WriteDb]
| EUnurlify (e, _) => summarize d e
| EJavaScript (_, e) => summarize d e
| ESignalReturn e => summarize d e
diff --git a/src/mono_shake.sml b/src/mono_shake.sml
index 40b83934..fc46cf96 100644
--- a/src/mono_shake.sml
+++ b/src/mono_shake.sml
@@ -43,10 +43,22 @@ type free = {
fun shake file =
let
- val page_es = List.foldl
- (fn ((DExport (_, _, n, _, _), _), page_es) => n :: page_es
- | ((DDatabase {expunge = n1, initialize = n2, ...}, _), page_es) => n1 :: n2 :: page_es
- | (_, page_es) => page_es) [] file
+ val usedVars = U.Exp.fold {typ = fn (c, st as (cs, es)) =>
+ case c of
+ TDatatype (n, _) => (IS.add (cs, n), es)
+ | _ => st,
+ exp = fn (e, st as (cs, es)) =>
+ case e of
+ ENamed n => (cs, IS.add (es, n))
+ | _ => st}
+
+ val (page_cs, page_es) =
+ List.foldl
+ (fn ((DExport (_, _, n, _, _), _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n))
+ | ((DDatabase {expunge = n1, initialize = n2, ...}, _), (page_cs, page_es)) =>
+ (page_cs, IS.addList (page_es, [n1, n2]))
+ | ((DInitializer e, _), st) => usedVars st e
+ | (_, st) => st) (IS.empty, IS.empty) file
val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) =>
(foldl (fn ((_, n, xncs), cdef) => IM.insert (cdef, n, xncs)) cdef dts, edef)
@@ -61,7 +73,8 @@ fun shake file =
| ((DDatabase _, _), acc) => acc
| ((DJavaScript _, _), acc) => acc
| ((DCookie _, _), acc) => acc
- | ((DStyle _, _), acc) => acc)
+ | ((DStyle _, _), acc) => acc
+ | ((DInitializer _, _), acc) => acc)
(IM.empty, IM.empty) file
fun typ (c, s) =
@@ -104,12 +117,18 @@ fun shake file =
and shakeExp s = U.Exp.fold {typ = typ, exp = exp} s
- val s = {con = IS.empty, exp = IS.addList (IS.empty, page_es)}
+ val s = {con = page_cs, exp = page_es}
+
+ val s = IS.foldl (fn (n, s) =>
+ case IM.find (cdef, n) of
+ NONE => raise Fail "MonoShake: Couldn't find 'datatype'"
+ | SOME xncs => foldl (fn ((_, _, SOME c), s) => shakeTyp s c
+ | _ => s) s xncs) s page_cs
- val s = foldl (fn (n, s) =>
- case IM.find (edef, n) of
- NONE => raise Fail "Shake: Couldn't find 'val'"
- | SOME (t, e) => shakeExp s e) s page_es
+ val s = IS.foldl (fn (n, s) =>
+ case IM.find (edef, n) of
+ NONE => raise Fail "MonoShake: Couldn't find 'val'"
+ | SOME (t, e) => shakeExp s e) s page_es
in
List.filter (fn (DDatatype dts, _) => List.exists (fn (_, n, _) => IS.member (#con s, n)) dts
| (DVal (_, n, _, _, _), _) => IS.member (#exp s, n)
@@ -121,7 +140,8 @@ fun shake file =
| (DDatabase _, _) => true
| (DJavaScript _, _) => true
| (DCookie _, _) => true
- | (DStyle _, _) => true) file
+ | (DStyle _, _) => true
+ | (DInitializer _, _) => true) file
end
end
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 91b4412e..184ce168 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -340,6 +340,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
S.map2 (mfe ctx e,
fn e' =>
(ENextval e', loc))
+ | ESetval (e1, e2) =>
+ S.bind2 (mfe ctx e1,
+ fn e1' =>
+ S.map2 (mfe ctx e2,
+ fn e2' =>
+ (ESetval (e1', e2'), loc)))
| EUnurlify (e, t) =>
S.bind2 (mfe ctx e,
fn e' =>
@@ -522,6 +528,10 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
| DJavaScript _ => S.return2 dAll
| DCookie _ => S.return2 dAll
| DStyle _ => S.return2 dAll
+ | DInitializer e =>
+ S.map2 (mfe ctx e,
+ fn e' =>
+ (DInitializer e', loc))
and mfvi ctx (x, n, t, e, s) =
S.bind2 (mft t,
@@ -608,6 +618,7 @@ fun mapfoldB (all as {bind, ...}) =
| DJavaScript _ => ctx
| DCookie _ => ctx
| DStyle _ => ctx
+ | DInitializer _ => ctx
in
S.map2 (mff ctx' ds',
fn ds' =>
@@ -660,7 +671,8 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
| DDatabase _ => count
| DJavaScript _ => count
| DCookie _ => count
- | DStyle _ => count) 0
+ | DStyle _ => count
+ | DInitializer _ => count) 0
end
diff --git a/src/monoize.sml b/src/monoize.sml
index b92b9c70..503fd6b3 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2475,6 +2475,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
in
((L'.ENextval e, loc), fm)
end
+ | L.EFfiApp ("Basis", "setval", [e1, e2]) =>
+ let
+ val (e1, fm) = monoExp (env, st, fm) e1
+ val (e2, fm) = monoExp (env, st, fm) e2
+ in
+ ((L'.ESetval (e1, e2), loc), fm)
+ end
| L.EApp (
(L.ECApp (
@@ -3471,6 +3478,14 @@ fun monoDecl (env, fm) (all as (d, loc)) =
[(L'.DStyle s, loc),
(L'.DVal (x, n, t', e, s), loc)])
end
+ | L.DInitializer e =>
+ let
+ val (e, fm) = monoExp (env, St.empty, fm) e
+ in
+ SOME (env,
+ fm,
+ [(L'.DInitializer e, loc)])
+ end
end
datatype expungable = Client | Channel
diff --git a/src/mysql.sml b/src/mysql.sml
index 514a9257..40409ff0 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -1503,6 +1503,8 @@ fun nextval {loc, seqE, seqName} =
fun nextvalPrepared _ = raise Fail "MySQL.nextvalPrepared called"
+fun setval _ = raise Fail "MySQL.setval called"
+
fun sqlifyString s = "'" ^ String.translate (fn #"'" => "\\'"
| #"\\" => "\\\\"
| ch =>
@@ -1529,6 +1531,7 @@ val () = addDbms {name = "mysql",
dmlPrepared = dmlPrepared,
nextval = nextval,
nextvalPrepared = nextvalPrepared,
+ setval = setval,
sqlifyString = sqlifyString,
p_cast = p_cast,
p_blank = p_blank,
diff --git a/src/postgres.sml b/src/postgres.sml
index 51e856db..c4bbb067 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -867,6 +867,48 @@ fun nextvalPrepared {loc, id, query} =
string (String.toString query),
string "\""]}]
+fun setvalCommon {loc, query} =
+ box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating setval 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\", ",
+ query,
+ string ", PQerrorMessage(conn));",
+ newline],
+ string "}",
+ newline,
+ newline,
+
+ string "PQclear(res);",
+ newline]
+
+fun setval {loc, seqE, count} =
+ let
+ val query = box [string "uw_Basis_strcat(ctx, \"SELECT SETVAL('\", uw_Basis_strcat(ctx, ",
+ seqE,
+ string ", uw_Basis_strcat(ctx, \"', \", uw_Basis_strcat(ctx, uw_Basis_sqlifyInt(ctx, ",
+ count,
+ string "), \")\"))))"]
+ in
+ box [string "char *query = ",
+ query,
+ string ";",
+ newline,
+ string "PGconn *conn = uw_get_db(ctx);",
+ newline,
+ string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);",
+ newline,
+ newline,
+ setvalCommon {loc = loc, query = string "query"}]
+ end
+
fun sqlifyString s = "E'" ^ String.translate (fn #"'" => "\\'"
| #"\\" => "\\\\"
| ch =>
@@ -892,6 +934,7 @@ val () = addDbms {name = "postgres",
dmlPrepared = dmlPrepared,
nextval = nextval,
nextvalPrepared = nextvalPrepared,
+ setval = setval,
sqlifyString = sqlifyString,
p_cast = p_cast,
p_blank = p_blank,
diff --git a/src/prepare.sml b/src/prepare.sml
index 58344a1f..7cbd7d76 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -273,6 +273,14 @@ fun prepExp (e as (_, loc), st) =
else
(e, st)
+ | ESetval {seq = e1, count = e2} =>
+ let
+ val (e1, st) = prepExp (e1, st)
+ val (e2, st) = prepExp (e2, st)
+ in
+ ((ESetval {seq = e1, count = e2}, loc), st)
+ end
+
| EUnurlify (e, t) =>
let
val (e, st) = prepExp (e, st)
@@ -317,6 +325,12 @@ fun prepDecl (d as (_, loc), st) =
| DJavaScript _ => (d, st)
| DCookie _ => (d, st)
| DStyle _ => (d, st)
+ | DInitializer e =>
+ let
+ val (e, st) = prepExp (e, st)
+ in
+ ((DInitializer e, loc), st)
+ end
fun prepare (ds, ps) =
let
diff --git a/src/reduce.sml b/src/reduce.sml
index 1310c7d0..cedb79fa 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -804,6 +804,15 @@ fun reduce file =
| DDatabase _ => (d, st)
| DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st)
| DStyle (s, n, s') => ((DStyle (s, n, s'), loc), st)
+ | DInitializer e =>
+ let
+ val e = exp (namedC, namedE) [] e
+ in
+ ((DInitializer e, loc),
+ (polyC,
+ namedC,
+ namedE))
+ end
val (file, _) = ListUtil.foldlMap doDecl (IS.empty, IM.empty, IM.empty) file
in
diff --git a/src/reduce_local.sml b/src/reduce_local.sml
index 4ddddfbf..82490118 100644
--- a/src/reduce_local.sml
+++ b/src/reduce_local.sml
@@ -251,6 +251,7 @@ fun reduce file =
| DDatabase _ => d
| DCookie _ => d
| DStyle _ => d
+ | DInitializer e => (DInitializer (exp [] e), loc)
in
map doDecl file
end
diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml
index 6dc11c65..5cd056d5 100644
--- a/src/scriptcheck.sml
+++ b/src/scriptcheck.sml
@@ -114,6 +114,7 @@ fun classify (ds, ps) =
orelse hasClient initial
| EDml {dml, ...} => hasClient dml
| ENextval {seq, ...} => hasClient seq
+ | ESetval {seq, count, ...} => hasClient seq orelse hasClient count
| EUnurlify (e, _) => hasClient e
in
hasClient
diff --git a/src/settings.sig b/src/settings.sig
index 61095ff8..574832a2 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -147,6 +147,7 @@ signature SETTINGS = sig
inputs : sql_type list} -> Print.PD.pp_desc,
nextval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, seqName : string option} -> Print.PD.pp_desc,
nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc,
+ setval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, count : Print.PD.pp_desc} -> Print.PD.pp_desc,
sqlifyString : string -> string,
p_cast : string * sql_type -> string,
p_blank : int * sql_type -> string (* Prepared statement input *),
diff --git a/src/settings.sml b/src/settings.sml
index f5d5a3ab..a7f2cc9f 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -79,6 +79,7 @@ fun mayClientToServer x = S.member (!clientToServer, x)
val effectfulBase = basis ["dml",
"nextval",
+ "setval",
"set_cookie",
"clear_cookie",
"new_client_source",
@@ -120,6 +121,7 @@ val serverBase = basis ["requestHeader",
"query",
"dml",
"nextval",
+ "setval",
"channel",
"send"]
val server = ref serverBase
@@ -355,6 +357,7 @@ type dbms = {
inputs : sql_type list} -> Print.PD.pp_desc,
nextval : {loc : ErrorMsg.span, seqName : string option, seqE : Print.PD.pp_desc} -> Print.PD.pp_desc,
nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc,
+ setval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, count : Print.PD.pp_desc} -> Print.PD.pp_desc,
sqlifyString : string -> string,
p_cast : string * sql_type -> string,
p_blank : int * sql_type -> string,
@@ -382,6 +385,7 @@ val curDb = ref ({name = "",
dmlPrepared = fn _ => Print.box [],
nextval = fn _ => Print.box [],
nextvalPrepared = fn _ => Print.box [],
+ setval = fn _ => Print.box [],
sqlifyString = fn s => s,
p_cast = fn _ => "",
p_blank = fn _ => "",
diff --git a/src/shake.sml b/src/shake.sml
index dde131fc..787500ea 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -79,6 +79,7 @@ fun shake file =
in
(usedE, usedC)
end
+ | ((DInitializer e, _), st) => usedVars st e
| (_, acc) => acc) (IS.empty, IS.empty) file
val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef)
@@ -104,7 +105,8 @@ fun shake file =
| ((DCookie (_, n, c, _), _), (cdef, edef)) =>
(cdef, IM.insert (edef, n, ([], c, dummye)))
| ((DStyle (_, n, _), _), (cdef, edef)) =>
- (cdef, IM.insert (edef, n, ([], dummyt, dummye))))
+ (cdef, IM.insert (edef, n, ([], dummyt, dummye)))
+ | ((DInitializer _, _), acc) => acc)
(IM.empty, IM.empty) file
fun kind (_, s) = s
@@ -183,7 +185,8 @@ fun shake file =
| (DTable _, _) => true
| (DDatabase _, _) => true
| (DCookie _, _) => true
- | (DStyle _, _) => true) file
+ | (DStyle _, _) => true
+ | (DInitializer _, _) => true) file
end
end
diff --git a/src/source.sml b/src/source.sml
index c5950b36..e52872f0 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -167,6 +167,7 @@ datatype decl' =
| DDatabase of string
| DCookie of string * con
| DStyle of string
+ | DInitializer of exp
and str' =
StrConst of decl list
diff --git a/src/source_print.sml b/src/source_print.sml
index 7ec584d7..31fc2500 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -662,6 +662,9 @@ fun p_decl ((d, _) : decl) =
| DStyle x => box [string "style",
space,
string x]
+ | DInitializer e => box [string "initializer",
+ space,
+ p_exp e]
and p_str (str, _) =
case str of
diff --git a/src/sqlite.sml b/src/sqlite.sml
index 8a61c25e..440c7c28 100644
--- a/src/sqlite.sml
+++ b/src/sqlite.sml
@@ -757,6 +757,7 @@ fun nextval {loc, seqE, seqName} =
newline]
fun nextvalPrepared _ = raise Fail "SQLite.nextvalPrepared called"
+fun setval _ = raise Fail "SQLite.setval called"
fun sqlifyString s = "'" ^ String.translate (fn #"'" => "''"
| ch =>
@@ -783,6 +784,7 @@ val () = addDbms {name = "sqlite",
dmlPrepared = dmlPrepared,
nextval = nextval,
nextvalPrepared = nextvalPrepared,
+ setval = setval,
sqlifyString = sqlifyString,
p_cast = p_cast,
p_blank = p_blank,
diff --git a/src/unnest.sml b/src/unnest.sml
index a4bdb7a9..c4d9a8b5 100644
--- a/src/unnest.sml
+++ b/src/unnest.sml
@@ -422,6 +422,7 @@ fun unnest file =
| DDatabase _ => default ()
| DCookie _ => default ()
| DStyle _ => default ()
+ | DInitializer _ => explore ()
end
and doStr (all as (str, loc), st) =
diff --git a/src/urweb.grm b/src/urweb.grm
index 87a8547d..8780d9f6 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -201,7 +201,7 @@ fun patType loc (p : pat) =
| LET | IN
| STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | SELECT1
| INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW
- | COOKIE | STYLE
+ | COOKIE | STYLE | INITIALIZER
| CASE | IF | THEN | ELSE | ANDALSO | ORELSE
| XML_BEGIN of string | XML_END | XML_BEGIN_END of string
@@ -479,6 +479,7 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let
end)
| COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))])
| STYLE SYMBOL ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))])
+ | INITIALIZER eexp ([(DInitializer eexp, s (INITIALIZERleft, eexpright))])
dtype : SYMBOL dargs EQ barOpt dcons (SYMBOL, dargs, dcons)
diff --git a/src/urweb.lex b/src/urweb.lex
index ed6e310b..d04822f7 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -402,6 +402,7 @@ notags = [^<{\n]+;
<INITIAL> "class" => (Tokens.CLASS (pos yypos, pos yypos + size yytext));
<INITIAL> "cookie" => (Tokens.COOKIE (pos yypos, pos yypos + size yytext));
<INITIAL> "style" => (Tokens.STYLE (pos yypos, pos yypos + size yytext));
+<INITIAL> "initializer" => (Tokens.INITIALIZER (pos yypos, pos yypos + size yytext));
<INITIAL> "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext));
<INITIAL> "Name" => (Tokens.NAME (pos yypos, pos yypos + size yytext));
diff --git a/tests/init.ur b/tests/init.ur
new file mode 100644
index 00000000..0a44a9e4
--- /dev/null
+++ b/tests/init.ur
@@ -0,0 +1,6 @@
+sequence seq
+table fred : {A : int, B : int}
+
+initializer
+ setval seq 1;
+ dml (INSERT INTO fred (A, B) VALUES (0, 1))
diff --git a/tests/init.urp b/tests/init.urp
new file mode 100644
index 00000000..a2166e44
--- /dev/null
+++ b/tests/init.urp
@@ -0,0 +1,5 @@
+debug
+database dbname=init
+sql init.sql
+
+init