From b225596addee1a3cfd6c3189cff923e7f0e8f7c9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 13 Dec 2009 14:20:41 -0500 Subject: Initializers and setval --- CHANGELOG | 1 + lib/ur/basis.urs | 1 + src/checknest.sml | 4 ++++ src/cjr.sml | 3 +++ src/cjr_env.sml | 1 + src/cjr_print.sml | 23 ++++++++++++++++++++++- src/cjrize.sml | 17 +++++++++++++++++ src/core.sml | 1 + src/core_env.sml | 1 + src/core_print.sml | 3 +++ src/core_util.sml | 8 +++++++- src/corify.sml | 6 +++++- src/elab.sml | 1 + src/elab_env.sml | 1 + src/elab_print.sml | 3 +++ src/elab_util.sml | 8 +++++++- src/elaborate.sml | 10 ++++++++++ src/elisp/urweb-defs.el | 8 +++++--- src/elisp/urweb-mode.el | 4 ++-- src/expl.sml | 1 + src/expl_env.sml | 1 + src/expl_print.sml | 3 +++ src/explify.sml | 1 + src/jscomp.sml | 8 ++++++++ src/mono.sml | 3 +++ src/mono_env.sml | 1 + src/mono_print.sml | 9 +++++++++ src/mono_reduce.sml | 3 +++ src/mono_shake.sml | 42 +++++++++++++++++++++++++++++++----------- src/mono_util.sml | 14 +++++++++++++- src/monoize.sml | 15 +++++++++++++++ src/mysql.sml | 3 +++ src/postgres.sml | 43 +++++++++++++++++++++++++++++++++++++++++++ src/prepare.sml | 14 ++++++++++++++ src/reduce.sml | 9 +++++++++ src/reduce_local.sml | 1 + src/scriptcheck.sml | 1 + src/settings.sig | 1 + src/settings.sml | 4 ++++ src/shake.sml | 7 +++++-- src/source.sml | 1 + src/source_print.sml | 3 +++ src/sqlite.sml | 2 ++ src/unnest.sml | 1 + src/urweb.grm | 3 ++- src/urweb.lex | 1 + tests/init.ur | 6 ++++++ tests/init.urp | 5 +++++ 48 files changed, 286 insertions(+), 24 deletions(-) create mode 100644 tests/init.ur create mode 100644 tests/init.urp 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 ", 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]+; "class" => (Tokens.CLASS (pos yypos, pos yypos + size yytext)); "cookie" => (Tokens.COOKIE (pos yypos, pos yypos + size yytext)); "style" => (Tokens.STYLE (pos yypos, pos yypos + size yytext)); + "initializer" => (Tokens.INITIALIZER (pos yypos, pos yypos + size yytext)); "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext)); "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 -- cgit v1.2.3