Mercurial > urweb
changeset 1073:b2311dfb3158
Initializers and setval
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 13 Dec 2009 14:20:41 -0500 |
| parents | 9001966ae1c8 |
| children | d89f98f0b4bb |
| files | CHANGELOG lib/ur/basis.urs src/checknest.sml src/cjr.sml src/cjr_env.sml src/cjr_print.sml src/cjrize.sml src/core.sml src/core_env.sml src/core_print.sml src/core_util.sml src/corify.sml src/elab.sml src/elab_env.sml src/elab_print.sml src/elab_util.sml src/elaborate.sml src/elisp/urweb-defs.el src/elisp/urweb-mode.el src/expl.sml src/expl_env.sml src/expl_print.sml src/explify.sml src/jscomp.sml src/mono.sml src/mono_env.sml src/mono_print.sml src/mono_reduce.sml src/mono_shake.sml src/mono_util.sml src/monoize.sml src/mysql.sml src/postgres.sml src/prepare.sml src/reduce.sml src/reduce_local.sml src/scriptcheck.sml src/settings.sig src/settings.sml src/shake.sml src/source.sml src/source_print.sml src/sqlite.sml src/unnest.sml src/urweb.grm src/urweb.lex tests/init.ur tests/init.urp |
| diffstat | 48 files changed, 286 insertions(+), 24 deletions(-) [+] |
line wrap: on
line diff
--- a/CHANGELOG Sun Dec 13 13:00:55 2009 -0500 +++ b/CHANGELOG Sun Dec 13 14:20:41 2009 -0500 @@ -6,6 +6,7 @@ - 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
--- a/lib/ur/basis.urs Sun Dec 13 13:00:55 2009 -0500 +++ b/lib/ur/basis.urs Sun Dec 13 14:20:41 2009 -0500 @@ -523,6 +523,7 @@ type sql_sequence val nextval : sql_sequence -> transaction int +val setval : sql_sequence -> int -> transaction unit (** XML *)
--- a/src/checknest.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/checknest.sml Sun Dec 13 14:20:41 2009 -0500 @@ -87,6 +87,7 @@ 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 @@ | 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
--- a/src/cjr.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/cjr.sml Sun Dec 13 14:20:41 2009 -0500 @@ -95,6 +95,7 @@ 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 @@ | DCookie of string | DStyle of string + | DInitializer of exp + withtype decl = decl' located datatype sidedness =
--- a/src/cjr_env.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/cjr_env.sml Sun Dec 13 14:20:41 2009 -0500 @@ -171,5 +171,6 @@ | DJavaScript _ => env | DCookie _ => env | DStyle _ => env + | DInitializer _ => env end
--- a/src/cjr_print.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/cjr_print.sml Sun Dec 13 14:20:41 2009 -0500 @@ -1849,6 +1849,20 @@ 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 @@ space, string "*/"] + | DInitializer _ => box [] + datatype 'a search = Found of 'a | NotFound @@ -2716,6 +2732,8 @@ 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 @@ 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 "}",
--- a/src/cjrize.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/cjrize.sml Sun Dec 13 14:20:41 2009 -0500 @@ -468,6 +468,13 @@ 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 @@ | 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
--- a/src/core.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/core.sml Sun Dec 13 14:20:41 2009 -0500 @@ -134,6 +134,7 @@ | DDatabase of string | DCookie of string * int * con * string | DStyle of string * int * string + | DInitializer of exp withtype decl = decl' located
--- a/src/core_env.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/core_env.sml Sun Dec 13 14:20:41 2009 -0500 @@ -348,6 +348,7 @@ in pushENamed env x n t NONE s end + | DInitializer _ => env fun patBinds env (p, loc) = case p of
--- a/src/core_print.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/core_print.sml Sun Dec 13 14:20:41 2009 -0500 @@ -611,6 +611,9 @@ string "as", space, string s] + | DInitializer e => box [string "initializer", + space, + p_exp env e] fun p_file env file = let
--- a/src/core_util.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/core_util.sml Sun Dec 13 14:20:41 2009 -0500 @@ -971,6 +971,10 @@ 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 @@ in bind (ctx, NamedE (x, n, t, NONE, s)) end + | DInitializer _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -1187,7 +1192,8 @@ | 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
--- a/src/corify.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/corify.sml Sun Dec 13 14:20:41 2009 -0500 @@ -1064,6 +1064,9 @@ ([(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 @@ | 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, _) =
--- a/src/elab.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/elab.sml Sun Dec 13 14:20:41 2009 -0500 @@ -170,6 +170,7 @@ | DDatabase of string | DCookie of int * string * int * con | DStyle of int * string * int + | DInitializer of exp and str' = StrConst of decl list
--- a/src/elab_env.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/elab_env.sml Sun Dec 13 14:20:41 2009 -0500 @@ -1622,5 +1622,6 @@ in pushENamedAs env x n t end + | DInitializer _ => env end
--- a/src/elab_print.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/elab_print.sml Sun Dec 13 14:20:41 2009 -0500 @@ -799,6 +799,9 @@ | 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
--- a/src/elab_util.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/elab_util.sml Sun Dec 13 14:20:41 2009 -0500 @@ -853,7 +853,8 @@ 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 @@ 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 @@ | 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
--- a/src/elaborate.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/elaborate.sml Sun Dec 13 14:20:41 2009 -0500 @@ -2548,6 +2548,7 @@ | 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 @@ 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
--- a/src/elisp/urweb-defs.el Sun Dec 13 13:00:55 2009 -0500 +++ b/src/elisp/urweb-defs.el Sun Dec 13 14:20:41 2009 -0500 @@ -108,7 +108,7 @@ "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 @@ (,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 @@ (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
--- a/src/elisp/urweb-mode.el Sun Dec 13 13:00:55 2009 -0500 +++ b/src/elisp/urweb-mode.el Sun Dec 13 14:20:41 2009 -0500 @@ -136,7 +136,7 @@ "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 @@ ("\\<\\(\\(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+\\)"
--- a/src/expl.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/expl.sml Sun Dec 13 14:20:41 2009 -0500 @@ -147,6 +147,7 @@ | DDatabase of string | DCookie of int * string * int * con | DStyle of int * string * int + | DInitializer of exp and str' = StrConst of decl list
--- a/src/expl_env.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/expl_env.sml Sun Dec 13 14:20:41 2009 -0500 @@ -343,6 +343,7 @@ in pushENamed env x n t end + | DInitializer _ => env fun sgiBinds env (sgi, loc) = case sgi of
--- a/src/expl_print.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/expl_print.sml Sun Dec 13 14:20:41 2009 -0500 @@ -713,6 +713,9 @@ | 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
--- a/src/explify.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/explify.sml Sun Dec 13 14:20:41 2009 -0500 @@ -195,6 +195,7 @@ | 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
--- a/src/jscomp.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/jscomp.sml Sun Dec 13 14:20:41 2009 -0500 @@ -868,6 +868,7 @@ | 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 @@ 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
--- a/src/mono.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/mono.sml Sun Dec 13 14:20:41 2009 -0500 @@ -106,6 +106,7 @@ initial : exp } | EDml of exp | ENextval of exp + | ESetval of exp * exp | EUnurlify of exp * typ @@ -138,6 +139,8 @@ | DCookie of string | DStyle of string + | DInitializer of exp + withtype decl = decl' located type file = decl list
--- a/src/mono_env.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/mono_env.sml Sun Dec 13 14:20:41 2009 -0500 @@ -129,6 +129,7 @@ | DJavaScript _ => env | DCookie _ => env | DStyle _ => env + | DInitializer _ => env fun patBinds env (p, loc) = case p of
--- a/src/mono_print.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/mono_print.sml Sun Dec 13 14:20:41 2009 -0500 @@ -320,6 +320,12 @@ | 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 @@ | DStyle s => box [string "style", space, string s] + | DInitializer e => box [string "initializer", + space, + p_exp env e] fun p_file env file =
--- a/src/mono_reduce.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/mono_reduce.sml Sun Dec 13 14:20:41 2009 -0500 @@ -51,6 +51,7 @@ | EQuery _ => true | EDml _ => true | ENextval _ => true + | ESetval _ => true | EFfiApp (m, x, _) => Settings.isEffectful (m, x) | EServerCall _ => true | ERecv _ => true @@ -75,6 +76,7 @@ | EQuery _ => true | EDml _ => true | ENextval _ => true + | ESetval _ => true | EUnurlify _ => true | EAbs _ => false @@ -448,6 +450,7 @@ | 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
--- a/src/mono_shake.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/mono_shake.sml Sun Dec 13 14:20:41 2009 -0500 @@ -43,10 +43,22 @@ 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 @@ | ((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 @@ 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 = 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 (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 = 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 @@ | (DDatabase _, _) => true | (DJavaScript _, _) => true | (DCookie _, _) => true - | (DStyle _, _) => true) file + | (DStyle _, _) => true + | (DInitializer _, _) => true) file end end
--- a/src/mono_util.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/mono_util.sml Sun Dec 13 14:20:41 2009 -0500 @@ -340,6 +340,12 @@ 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 @@ | 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 @@ | DJavaScript _ => ctx | DCookie _ => ctx | DStyle _ => ctx + | DInitializer _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -660,7 +671,8 @@ | DDatabase _ => count | DJavaScript _ => count | DCookie _ => count - | DStyle _ => count) 0 + | DStyle _ => count + | DInitializer _ => count) 0 end
--- a/src/monoize.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/monoize.sml Sun Dec 13 14:20:41 2009 -0500 @@ -2475,6 +2475,13 @@ 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 @@ [(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
--- a/src/mysql.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/mysql.sml Sun Dec 13 14:20:41 2009 -0500 @@ -1503,6 +1503,8 @@ 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 @@ dmlPrepared = dmlPrepared, nextval = nextval, nextvalPrepared = nextvalPrepared, + setval = setval, sqlifyString = sqlifyString, p_cast = p_cast, p_blank = p_blank,
--- a/src/postgres.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/postgres.sml Sun Dec 13 14:20:41 2009 -0500 @@ -867,6 +867,48 @@ 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 @@ dmlPrepared = dmlPrepared, nextval = nextval, nextvalPrepared = nextvalPrepared, + setval = setval, sqlifyString = sqlifyString, p_cast = p_cast, p_blank = p_blank,
--- a/src/prepare.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/prepare.sml Sun Dec 13 14:20:41 2009 -0500 @@ -273,6 +273,14 @@ 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 @@ | 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
--- a/src/reduce.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/reduce.sml Sun Dec 13 14:20:41 2009 -0500 @@ -804,6 +804,15 @@ | 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
--- a/src/reduce_local.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/reduce_local.sml Sun Dec 13 14:20:41 2009 -0500 @@ -251,6 +251,7 @@ | DDatabase _ => d | DCookie _ => d | DStyle _ => d + | DInitializer e => (DInitializer (exp [] e), loc) in map doDecl file end
--- a/src/scriptcheck.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/scriptcheck.sml Sun Dec 13 14:20:41 2009 -0500 @@ -114,6 +114,7 @@ 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
--- a/src/settings.sig Sun Dec 13 13:00:55 2009 -0500 +++ b/src/settings.sig Sun Dec 13 14:20:41 2009 -0500 @@ -147,6 +147,7 @@ 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 *),
--- a/src/settings.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/settings.sml Sun Dec 13 14:20:41 2009 -0500 @@ -79,6 +79,7 @@ val effectfulBase = basis ["dml", "nextval", + "setval", "set_cookie", "clear_cookie", "new_client_source", @@ -120,6 +121,7 @@ "query", "dml", "nextval", + "setval", "channel", "send"] val server = ref serverBase @@ -355,6 +357,7 @@ 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 @@ 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 _ => "",
--- a/src/shake.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/shake.sml Sun Dec 13 14:20:41 2009 -0500 @@ -79,6 +79,7 @@ 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 @@ | ((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 @@ | (DTable _, _) => true | (DDatabase _, _) => true | (DCookie _, _) => true - | (DStyle _, _) => true) file + | (DStyle _, _) => true + | (DInitializer _, _) => true) file end end
--- a/src/source.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/source.sml Sun Dec 13 14:20:41 2009 -0500 @@ -167,6 +167,7 @@ | DDatabase of string | DCookie of string * con | DStyle of string + | DInitializer of exp and str' = StrConst of decl list
--- a/src/source_print.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/source_print.sml Sun Dec 13 14:20:41 2009 -0500 @@ -662,6 +662,9 @@ | DStyle x => box [string "style", space, string x] + | DInitializer e => box [string "initializer", + space, + p_exp e] and p_str (str, _) = case str of
--- a/src/sqlite.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/sqlite.sml Sun Dec 13 14:20:41 2009 -0500 @@ -757,6 +757,7 @@ 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 @@ dmlPrepared = dmlPrepared, nextval = nextval, nextvalPrepared = nextvalPrepared, + setval = setval, sqlifyString = sqlifyString, p_cast = p_cast, p_blank = p_blank,
--- a/src/unnest.sml Sun Dec 13 13:00:55 2009 -0500 +++ b/src/unnest.sml Sun Dec 13 14:20:41 2009 -0500 @@ -422,6 +422,7 @@ | DDatabase _ => default () | DCookie _ => default () | DStyle _ => default () + | DInitializer _ => explore () end and doStr (all as (str, loc), st) =
--- a/src/urweb.grm Sun Dec 13 13:00:55 2009 -0500 +++ b/src/urweb.grm Sun Dec 13 14:20:41 2009 -0500 @@ -201,7 +201,7 @@ | 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 @@ 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)
--- a/src/urweb.lex Sun Dec 13 13:00:55 2009 -0500 +++ b/src/urweb.lex Sun Dec 13 14:20:41 2009 -0500 @@ -402,6 +402,7 @@ <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));