From a08075494d9c16a349215fbcaefa3e1d14d2e0f9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 20 Dec 2008 14:19:21 -0500 Subject: Start of JsComp --- src/mono_env.sml | 11 +++++++++++ 1 file changed, 11 insertions(+) (limited to 'src/mono_env.sml') diff --git a/src/mono_env.sml b/src/mono_env.sml index 47ffd28d..cce4a4c4 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -122,4 +122,15 @@ fun patBinds env (p, loc) = | PNone _ => env | PSome (_, p) => patBinds env p +fun patBindsN (p, loc) = + case p of + PWild => 0 + | PVar _ => 1 + | PPrim _ => 0 + | PCon (_, _, NONE) => 0 + | PCon (_, _, SOME p) => patBindsN p + | PRecord xps => foldl (fn ((_, p, _), count) => count + patBindsN p) 0 xps + | PNone _ => 0 + | PSome (_, p) => patBindsN p + end -- cgit v1.2.3 From ec745f90fc97e10948dc32ec4f44aabf5c6908db Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 20 Dec 2008 16:19:26 -0500 Subject: Successfully generated a page element from a signal --- Makefile.in | 3 +++ jslib/urweb.js | 1 + src/c/driver.c | 5 ----- src/cjr.sml | 2 ++ src/cjr_env.sml | 1 + src/cjr_print.sml | 20 ++++++++++++++++++++ src/cjrize.sml | 1 + src/config.sig | 1 + src/config.sml.in | 2 ++ src/jscomp.sml | 18 +++++++++++++----- src/mono.sml | 3 +++ src/mono_env.sml | 1 + src/mono_print.sml | 4 ++++ src/mono_shake.sml | 6 ++++-- src/mono_util.sml | 6 +++++- src/monoize.sml | 4 +++- src/prepare.sml | 1 + 17 files changed, 65 insertions(+), 14 deletions(-) create mode 100644 jslib/urweb.js (limited to 'src/mono_env.sml') diff --git a/Makefile.in b/Makefile.in index 57a083bd..ed65ceea 100644 --- a/Makefile.in +++ b/Makefile.in @@ -5,6 +5,7 @@ SITELISP := @SITELISP@ LIB_UR := $(LIB)/ur LIB_C := $(LIB)/c +LIB_JS := $(LIB)/js all: smlnj mlton c @@ -70,6 +71,8 @@ install: cp lib/*.ur $(LIB_UR)/ mkdir -p $(LIB_C) cp clib/*.o $(LIB_C)/ + mkdir -p $(LIB_JS) + cp jslib/*.js $(LIB_JS)/ mkdir -p $(INCLUDE) cp include/*.h $(INCLUDE)/ mkdir -p $(SITELISP) diff --git a/jslib/urweb.js b/jslib/urweb.js new file mode 100644 index 00000000..32912e4c --- /dev/null +++ b/jslib/urweb.js @@ -0,0 +1 @@ +function sreturn(v) { return {v : v} } diff --git a/src/c/driver.c b/src/c/driver.c index a25cd743..34e57a6d 100644 --- a/src/c/driver.c +++ b/src/c/driver.c @@ -193,8 +193,6 @@ static void *worker(void *data) { uw_set_headers(ctx, headers); while (1) { - uw_write(ctx, ""); - if (uw_db_begin(ctx)) { printf("Error running SQL BEGIN\n"); if (retries_left) @@ -211,13 +209,10 @@ static void *worker(void *data) { } uw_write_header(ctx, "HTTP/1.1 200 OK\r\n"); - uw_write_header(ctx, "Content-type: text/html\r\n"); strcpy(path_copy, path); fk = uw_begin(ctx, path_copy); if (fk == SUCCESS) { - uw_write(ctx, ""); - if (uw_db_commit(ctx)) { fk = FATAL; diff --git a/src/cjr.sml b/src/cjr.sml index 84aea54e..43a29a6c 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -109,6 +109,8 @@ datatype decl' = | DDatabase of string | DPreparedStatements of (string * int) list + | DJavaScript of string + withtype decl = decl' located type file = decl list * (Core.export_kind * string * int * typ list) list diff --git a/src/cjr_env.sml b/src/cjr_env.sml index 49e86140..9921ee48 100644 --- a/src/cjr_env.sml +++ b/src/cjr_env.sml @@ -166,6 +166,7 @@ fun declBinds env (d, loc) = | DSequence _ => env | DDatabase _ => env | DPreparedStatements _ => env + | DJavaScript _ => env end diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 8c3c3d86..06f9f5ca 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1800,6 +1800,10 @@ fun p_decl env (dAll as (d, _) : decl) = string "}"] + | DJavaScript s => box [string "static char jslib[] = \"", + string (String.toString s), + string "\";"] + datatype 'a search = Found of 'a | NotFound @@ -2048,6 +2052,10 @@ fun p_file env (ds, ps) = newline, string "if (*request == '/') ++request;", newline, + string "uw_write_header(ctx, \"Content-type: text/html\\r\\n\");", + newline, + string "uw_write(ctx, \"\");", + newline, box [string "{", newline, box (ListUtil.mapi (fn (i, t) => box [p_typ env t, @@ -2070,6 +2078,8 @@ fun p_file env (ds, ps) = inputsVar, string ", uw_unit_v);", newline, + string "uw_write(ctx, \"\");", + newline, string "return;", newline, string "}", @@ -2374,6 +2384,16 @@ fun p_file env (ds, ps) = newline, string "void uw_handle(uw_context ctx, char *request) {", newline, + string "if (!strcmp(request, \"/app.js\")) {", + newline, + box [string "uw_write_header(ctx, \"Content-type: text/javascript\\r\\n\");", + newline, + string "uw_write(ctx, jslib);", + newline, + string "return;", + newline], + string "}", + newline, p_list_sep newline (fn x => x) pds', newline, string "uw_error(ctx, FATAL, \"Unknown page\");", diff --git a/src/cjrize.sml b/src/cjrize.sml index f3c5e5a7..78513ef7 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -528,6 +528,7 @@ fun cifyDecl ((d, loc), sm) = | L.DSequence s => (SOME (L'.DSequence s, loc), NONE, sm) | L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, sm) + | L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm) fun cjrize ds = let diff --git a/src/config.sig b/src/config.sig index 6075482e..90fb72e7 100644 --- a/src/config.sig +++ b/src/config.sig @@ -6,6 +6,7 @@ signature CONFIG = sig val libUr : string val libC : string + val libJs : string val gccArgs : string end diff --git a/src/config.sml.in b/src/config.sml.in index 9e53986b..c7d231d5 100644 --- a/src/config.sml.in +++ b/src/config.sml.in @@ -9,6 +9,8 @@ val libUr = OS.Path.joinDirFile {dir = lib, file = "ur"} val libC = OS.Path.joinDirFile {dir = lib, file = "c"} +val libJs = OS.Path.joinDirFile {dir = lib, + file = "js"} val gccArgs = "@GCCARGS@" diff --git a/src/jscomp.sml b/src/jscomp.sml index b0842c6b..95c18016 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -285,7 +285,7 @@ fun jsExp mode outer = in (strcat [str "document.write(", e, - str ")"], st) + str ".v)"], st) end | ESeq (e1, e2) => @@ -317,9 +317,9 @@ fun jsExp mode outer = let val (e, st) = jsE inner (e, st) in - (strcat [(*str "sreturn(",*) - e(*, - str ")"*)], + (strcat [str "sreturn(", + e, + str ")"], st) end end @@ -369,8 +369,16 @@ fun process file = {decls = [], script = ""} file + + val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.libJs, file = "urweb.js"}) + fun lines acc = + case TextIO.inputLine inf of + NONE => String.concat (rev acc) + | SOME line => lines (line :: acc) + val lines = lines [] in - ds + TextIO.closeIn inf; + (DJavaScript lines, ErrorMsg.dummySpan) :: ds end end diff --git a/src/mono.sml b/src/mono.sml index c6e0ae8a..1a7fde00 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -118,6 +118,9 @@ datatype decl' = | DSequence of string | DDatabase of string + | DJavaScript of string + + withtype decl = decl' located type file = decl list diff --git a/src/mono_env.sml b/src/mono_env.sml index cce4a4c4..248567de 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -110,6 +110,7 @@ fun declBinds env (d, loc) = | DTable _ => env | DSequence _ => env | DDatabase _ => env + | DJavaScript _ => env fun patBinds env (p, loc) = case p of diff --git a/src/mono_print.sml b/src/mono_print.sml index 89b6c35b..e44bb74c 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -379,6 +379,10 @@ fun p_decl env (dAll as (d, _) : decl) = | DDatabase s => box [string "database", space, string s] + | DJavaScript s => box [string "JavaScript(", + string s, + string ")"] + fun p_file env file = let diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 6714718a..34bd98be 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -56,7 +56,8 @@ fun shake file = | ((DExport _, _), acc) => acc | ((DTable _, _), acc) => acc | ((DSequence _, _), acc) => acc - | ((DDatabase _, _), acc) => acc) + | ((DDatabase _, _), acc) => acc + | ((DJavaScript _, _), acc) => acc) (IM.empty, IM.empty) file fun typ (c, s) = @@ -112,7 +113,8 @@ fun shake file = | (DExport _, _) => true | (DTable _, _) => true | (DSequence _, _) => true - | (DDatabase _, _) => true) file + | (DDatabase _, _) => true + | (DJavaScript _, _) => true) file end end diff --git a/src/mono_util.sml b/src/mono_util.sml index 553f802e..9788a551 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -323,6 +323,7 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mfe ctx e, fn e' => (EJavaScript (m, e'), loc)) + | ESignalReturn e => S.map2 (mfe ctx e, fn e' => @@ -421,6 +422,7 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = | DTable _ => S.return2 dAll | DSequence _ => S.return2 dAll | DDatabase _ => S.return2 dAll + | DJavaScript _ => S.return2 dAll and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, @@ -501,6 +503,7 @@ fun mapfoldB (all as {bind, ...}) = | DTable _ => ctx | DSequence _ => ctx | DDatabase _ => ctx + | DJavaScript _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -548,7 +551,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DExport _ => count | DTable _ => count | DSequence _ => count - | DDatabase _ => count) 0 + | DDatabase _ => count + | DJavaScript _ => count) 0 end diff --git a/src/monoize.sml b/src/monoize.sml index 1b7b467d..a0a0df30 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1844,7 +1844,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in case tag of "body" => normal ("body", NONE, - SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc)) + SOME (L'.EStrcat ((L'.EPrim (Prim.String ""), loc), + (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), + loc)), loc)) | "dyn" => (case #1 attrs of diff --git a/src/prepare.sml b/src/prepare.sml index 708bcade..110f6f9a 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -258,6 +258,7 @@ fun prepDecl (d as (_, loc), sns) = | DSequence _ => (d, sns) | DDatabase _ => (d, sns) | DPreparedStatements _ => (d, sns) + | DJavaScript _ => (d, sns) fun prepare (ds, ps) = let -- cgit v1.2.3 From 30eeaff2c92fb1d0ba029a7688fc7b547a60c150 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 12 Apr 2009 10:08:11 -0400 Subject: style declarations --- lib/ur/basis.urs | 4 ++++ src/cjr.sml | 1 + src/cjr_env.sml | 2 +- src/cjr_print.sml | 11 +++++++++++ src/cjrize.sml | 1 + src/core.sml | 1 + src/core_env.sml | 6 ++++++ src/core_print.sml | 11 +++++++++++ src/core_util.sml | 13 ++++++++++++- src/corify.sml | 10 +++++++++- src/elab.sml | 1 + src/elab_env.sml | 6 ++++++ src/elab_print.sml | 7 +++++++ src/elab_util.sml | 8 ++++++++ src/elaborate.sml | 10 ++++++++++ src/elisp/urweb-mode.el | 4 ++-- src/expl.sml | 1 + src/expl_env.sml | 6 ++++++ src/expl_print.sml | 7 +++++++ src/explify.sml | 1 + src/mono.sml | 2 ++ src/mono_env.sml | 1 + src/mono_print.sml | 8 ++++++++ src/mono_shake.sml | 6 ++++-- src/mono_util.sml | 5 ++++- src/monoize.sml | 17 +++++++++++++++++ src/prepare.sml | 1 + src/reduce.sml | 1 + src/reduce_local.sml | 1 + src/shake.sml | 5 ++++- src/source.sml | 1 + src/source_print.sml | 7 +++++++ src/unnest.sml | 1 + src/urweb.grm | 10 +++++++++- src/urweb.lex | 1 + tests/style.ur | 6 ++++++ tests/style.urp | 3 +++ 37 files changed, 177 insertions(+), 10 deletions(-) create mode 100644 tests/style.ur create mode 100644 tests/style.urp (limited to 'src/mono_env.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index f2f378ee..9eeb4891 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -405,6 +405,9 @@ val nextval : sql_sequence -> transaction int (** XML *) +con css_class :: {Unit} -> Type +(* The argument lists categories of properties that this class could set usefully. *) + con tag :: {Type} -> {Unit} -> {Unit} -> {Type} -> {Type} -> Type @@ -440,6 +443,7 @@ con xbody = xml [Body] [] [] con xtr = xml [Body, Tr] [] [] con xform = xml [Body, Form] [] [] + (*** HTML details *) con html = [Html] diff --git a/src/cjr.sml b/src/cjr.sml index 33cf07c9..031a14f8 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -110,6 +110,7 @@ datatype decl' = | DPreparedStatements of (string * int) list | DJavaScript of string + | DStyle of string * string list withtype decl = decl' located diff --git a/src/cjr_env.sml b/src/cjr_env.sml index 9921ee48..cb5caee9 100644 --- a/src/cjr_env.sml +++ b/src/cjr_env.sml @@ -167,6 +167,6 @@ fun declBinds env (d, loc) = | DDatabase _ => env | DPreparedStatements _ => env | DJavaScript _ => env - + | DStyle _ => env end diff --git a/src/cjr_print.sml b/src/cjr_print.sml index f86d4928..cabfc77f 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -2146,6 +2146,17 @@ fun p_decl env (dAll as (d, _) : decl) = | DJavaScript s => box [string "static char jslib[] = \"", string (String.toString s), string "\";"] + | DStyle (s, xs) => box [string "/*", + space, + string "style", + space, + string s, + space, + string ":", + space, + p_list string xs, + space, + string "*/"] datatype 'a search = Found of 'a diff --git a/src/cjrize.sml b/src/cjrize.sml index e0341c64..b432cd44 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -556,6 +556,7 @@ fun cifyDecl ((d, loc), sm) = (SOME (L'.DSequence s, loc), NONE, sm) | L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, sm) | L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm) + | L.DStyle args => (SOME (L'.DStyle args, loc), NONE, sm) fun cjrize ds = let diff --git a/src/core.sml b/src/core.sml index a8e0de13..bbd1a9b6 100644 --- a/src/core.sml +++ b/src/core.sml @@ -134,6 +134,7 @@ datatype decl' = | DSequence of string * int * string | DDatabase of string | DCookie of string * int * con * string + | DStyle of string * int * con * string withtype decl = decl' located diff --git a/src/core_env.sml b/src/core_env.sml index 95226bb7..01a791a0 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -334,6 +334,12 @@ fun declBinds env (d, loc) = in pushENamed env x n t NONE s end + | DStyle (x, n, c, s) => + let + val t = (CApp ((CFfi ("Basis", "css_class"), loc), c), loc) + in + pushENamed env x n t NONE s + end fun patBinds env (p, loc) = case p of diff --git a/src/core_print.sml b/src/core_print.sml index ed401d29..caf55adb 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -586,6 +586,17 @@ fun p_decl env (dAll as (d, _) : decl) = string ":", space, p_con env c] + | DStyle (x, n, c, s) => box [string "style", + space, + p_named x n, + space, + string "as", + space, + string s, + space, + string ":", + space, + p_con env c] fun p_file env file = let diff --git a/src/core_util.sml b/src/core_util.sml index 320a0326..8ccd520a 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -951,6 +951,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} = S.map2 (mfc ctx c, fn c' => (DCookie (x, n, c', s), loc)) + | DStyle (x, n, c, s) => + S.map2 (mfc ctx c, + fn c' => + (DStyle (x, n, c', s), loc)) and mfvi ctx (x, n, t, e, s) = S.bind2 (mfc ctx t, @@ -1088,6 +1092,12 @@ fun mapfoldB (all as {bind, ...}) = in bind (ctx, NamedE (x, n, t, NONE, s)) end + | DStyle (x, n, c, s) => + let + val t = (CApp ((CFfi ("Basis", "css_class"), #2 d'), c), #2 d') + in + bind (ctx, NamedE (x, n, t, NONE, s)) + end in S.map2 (mff ctx' ds', fn ds' => @@ -1148,7 +1158,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DTable (_, n, _, _, _, _, _, _) => Int.max (n, count) | DSequence (_, n, _) => Int.max (n, count) | DDatabase _ => count - | DCookie (_, n, _, _) => Int.max (n, count)) 0 + | DCookie (_, n, _, _) => Int.max (n, count) + | DStyle (_, n, _, _) => Int.max (n, count)) 0 end diff --git a/src/corify.sml b/src/corify.sml index e3b9a365..1a5bab06 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -1002,6 +1002,13 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = in ([(L'.DCookie (x, n, corifyCon st c, s), loc)], st) end + | L.DStyle (_, x, n, c) => + let + val (st, n) = St.bindVal st x n + val s = doRestify (mods, x) + in + ([(L'.DStyle (x, n, corifyCon st c, s), loc)], st) + end and corifyStr mods ((str, _), st) = case str of @@ -1057,7 +1064,8 @@ fun maxName ds = foldl (fn ((d, _), n) => | L.DTable (_, _, n', _, _, _, _, _) => Int.max (n, n') | L.DSequence (_, _, n') => Int.max (n, n') | L.DDatabase _ => n - | L.DCookie (_, _, n', _) => Int.max (n, n')) + | L.DCookie (_, _, n', _) => Int.max (n, n') + | L.DStyle (_, _, n', _) => Int.max (n, n')) 0 ds and maxNameStr (str, _) = diff --git a/src/elab.sml b/src/elab.sml index 83a7f929..cabe0a94 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -171,6 +171,7 @@ datatype decl' = | DClass of string * int * kind * con | DDatabase of string | DCookie of int * string * int * con + | DStyle of int * string * int * con and str' = StrConst of decl list diff --git a/src/elab_env.sml b/src/elab_env.sml index 1c3eb62e..828dface 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1434,6 +1434,12 @@ fun declBinds env (d, loc) = in pushENamedAs env x n t end + | DStyle (tn, x, n, c) => + let + val t = (CApp ((CModProj (tn, [], "css_class"), loc), c), loc) + in + pushENamedAs env x n t + end fun patBinds env (p, loc) = case p of diff --git a/src/elab_print.sml b/src/elab_print.sml index 7eb853af..5028ff44 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -779,6 +779,13 @@ fun p_decl env (dAll as (d, _) : decl) = string ":", space, p_con env c] + | DStyle (_, x, n, c) => box [string "style", + space, + p_named x n, + space, + string ":", + space, + p_con env c] and p_str env (str, _) = case str of diff --git a/src/elab_util.sml b/src/elab_util.sml index 17e67787..24a92e3f 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -796,6 +796,9 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f | DDatabase _ => ctx | DCookie (tn, x, n, c) => bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "cookie"), loc), + c), loc))) + | DStyle (tn, x, n, c) => + bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "css_class"), loc), c), loc))), mfd ctx d)) ctx ds, fn ds' => (StrConst ds', loc)) @@ -911,6 +914,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f S.map2 (mfc ctx c, fn c' => (DCookie (tn, x, n, c'), loc)) + | DStyle (tn, x, n, c) => + S.map2 (mfc ctx c, + fn c' => + (DStyle (tn, x, n, c'), loc)) and mfvi ctx (x, n, c, e) = S.bind2 (mfc ctx c, @@ -1050,6 +1057,7 @@ and maxNameDecl (d, _) = | DSequence (n1, _, n2) => Int.max (n1, n2) | DDatabase _ => 0 | DCookie (n1, _, n2, _) => Int.max (n1, n2) + | DStyle (n1, _, n2, _) => Int.max (n1, n2) and maxNameStr (str, _) = case str of diff --git a/src/elaborate.sml b/src/elaborate.sml index 21b32f40..922c9c32 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1902,6 +1902,7 @@ val hnormSgn = E.hnormSgn fun tableOf () = (L'.CModProj (!basis_r, [], "sql_table"), ErrorMsg.dummySpan) fun sequenceOf () = (L'.CModProj (!basis_r, [], "sql_sequence"), ErrorMsg.dummySpan) fun cookieOf () = (L'.CModProj (!basis_r, [], "http_cookie"), ErrorMsg.dummySpan) +fun styleOf () = (L'.CModProj (!basis_r, [], "css_class"), ErrorMsg.dummySpan) fun dopenConstraints (loc, env, denv) {str, strs} = case E.lookupStr env str of @@ -2401,6 +2402,7 @@ and sgiOfDecl (d, loc) = | L'.DClass (x, n, k, c) => [(L'.SgiClass (x, n, k, c), loc)] | L'.DDatabase _ => [] | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] + | L'.DStyle (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (styleOf (), c), loc)), loc)] and subSgn env sgn1 (sgn2 as (_, loc2)) = ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), @@ -3390,6 +3392,14 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = checkKind env c' k (L'.KType, loc); ([(L'.DCookie (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs)) end + | L.DStyle (x, c) => + let + val (c', k, gs') = elabCon (env, denv) c + val (env, n) = E.pushENamed env x (L'.CApp (styleOf (), c'), loc) + in + checkKind env c' k (L'.KRecord (L'.KUnit, loc), loc); + ([(L'.DStyle (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs)) + end (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) in diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index 1f2a52be..834c28da 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" + "rec" "sequence" "sig" "signature" "cookie" "style" "struct" "structure" "table" "then" "type" "val" "where" "with" @@ -225,7 +225,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\$\\s-+\$\\sw+\\>\\s-*\$?\$\\sw+\$\\s-*[=:]" + ("\\<\$val\\|table\\|sequence\\|cookie\\|style\$\\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 b9cbdaf1..ed4de953 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -145,6 +145,7 @@ datatype decl' = | DSequence of int * string * int | DDatabase of string | DCookie of int * string * int * con + | DStyle of int * string * int * con and str' = StrConst of decl list diff --git a/src/expl_env.sml b/src/expl_env.sml index 64f4edc4..790c3aa8 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -319,6 +319,12 @@ fun declBinds env (d, loc) = in pushENamed env x n t end + | DStyle (tn, x, n, c) => + let + val t = (CApp ((CModProj (tn, [], "css_class"), loc), c), loc) + in + pushENamed env x n t + end fun sgiBinds env (sgi, loc) = case sgi of diff --git a/src/expl_print.sml b/src/expl_print.sml index 84002c00..c912bd66 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -691,6 +691,13 @@ fun p_decl env (dAll as (d, _) : decl) = string ":", space, p_con env c] + | DStyle (_, x, n, c) => box [string "style", + space, + p_named x n, + space, + string ":", + space, + p_con env c] and p_str env (str, _) = case str of diff --git a/src/explify.sml b/src/explify.sml index 01a57d2e..32983619 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -187,6 +187,7 @@ fun explifyDecl (d, loc : EM.span) = (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), explifyCon c), loc) | 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, c) => SOME (L'.DStyle (nt, x, n, explifyCon c), loc) and explifyStr (str, loc) = case str of diff --git a/src/mono.sml b/src/mono.sml index 35db52bd..4723e30a 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -127,6 +127,8 @@ datatype decl' = | DJavaScript of string + | DStyle of string * string list + withtype decl = decl' located diff --git a/src/mono_env.sml b/src/mono_env.sml index 248567de..df255325 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -111,6 +111,7 @@ fun declBinds env (d, loc) = | DSequence _ => env | DDatabase _ => env | DJavaScript _ => env + | DStyle _ => env fun patBinds env (p, loc) = case p of diff --git a/src/mono_print.sml b/src/mono_print.sml index c75e81ba..3870ce41 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -440,6 +440,14 @@ fun p_decl env (dAll as (d, _) : decl) = string s, string ")"] + | DStyle (s, xs) => box [string "style", + space, + string s, + space, + string ":", + space, + p_list string xs] + fun p_file env file = let diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 343ec728..d2426f9f 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -58,7 +58,8 @@ fun shake file = | ((DTable _, _), acc) => acc | ((DSequence _, _), acc) => acc | ((DDatabase _, _), acc) => acc - | ((DJavaScript _, _), acc) => acc) + | ((DJavaScript _, _), acc) => acc + | ((DStyle _, _), acc) => acc) (IM.empty, IM.empty) file fun typ (c, s) = @@ -115,7 +116,8 @@ fun shake file = | (DTable _, _) => true | (DSequence _, _) => true | (DDatabase _, _) => true - | (DJavaScript _, _) => true) file + | (DJavaScript _, _) => true + | (DStyle _, _) => true) file end end diff --git a/src/mono_util.sml b/src/mono_util.sml index 485e64f6..62a2dfe0 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -474,6 +474,7 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = | DSequence _ => S.return2 dAll | DDatabase _ => S.return2 dAll | DJavaScript _ => S.return2 dAll + | DStyle _ => S.return2 dAll and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, @@ -555,6 +556,7 @@ fun mapfoldB (all as {bind, ...}) = | DSequence _ => ctx | DDatabase _ => ctx | DJavaScript _ => ctx + | DStyle _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -603,7 +605,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DTable _ => count | DSequence _ => count | DDatabase _ => count - | DJavaScript _ => count) 0 + | DJavaScript _ => count + | DStyle _ => count) 0 end diff --git a/src/monoize.sml b/src/monoize.sml index bf26fda2..8030b7ba 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2705,6 +2705,23 @@ fun monoDecl (env, fm) (all as (d, loc)) = fm, [(L'.DVal (x, n, t', e, s), loc)]) end + | L.DStyle (x, n, (L.CRecord (_, xcs), _), s) => + let + val xs = map (fn ((L.CName x, _), _) => x + | (x, _) => (E.errorAt (#2 x) "Undetermined style component"; + Print.eprefaces' [("Name", CorePrint.p_con env x)]; + "")) xcs + + val t = (L.CFfi ("Basis", "string"), loc) + val t' = (L'.TFfi ("Basis", "string"), loc) + val e = (L'.EPrim (Prim.String s), loc) + in + SOME (Env.pushENamed env x n t NONE s, + fm, + [(L'.DStyle (s, xs), loc), + (L'.DVal (x, n, t', e, s), loc)]) + end + | L.DStyle _ => poly () end datatype expungable = Client | Channel diff --git a/src/prepare.sml b/src/prepare.sml index 258b9dcf..8e31b73d 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -259,6 +259,7 @@ fun prepDecl (d as (_, loc), sns) = | DDatabase _ => (d, sns) | DPreparedStatements _ => (d, sns) | DJavaScript _ => (d, sns) + | DStyle _ => (d, sns) fun prepare (ds, ps) = let diff --git a/src/reduce.sml b/src/reduce.sml index 25cc6274..714b55d7 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -469,6 +469,7 @@ fun reduce file = | DSequence _ => (d, st) | DDatabase _ => (d, st) | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st) + | DStyle (s, n, c, s') => ((DStyle (s, n, con namedC [] c, s'), loc), st) val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty) file in diff --git a/src/reduce_local.sml b/src/reduce_local.sml index a49d7115..cf602406 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -152,6 +152,7 @@ fun reduce file = | DSequence _ => d | DDatabase _ => d | DCookie _ => d + | DStyle _ => d in map doDecl file end diff --git a/src/shake.sml b/src/shake.sml index 378e8276..9c95d6a3 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -86,6 +86,8 @@ fun shake file = (cdef, IM.insert (edef, n, ([], dummyt, dummye))) | ((DDatabase _, _), acc) => acc | ((DCookie (_, n, c, _), _), (cdef, edef)) => + (cdef, IM.insert (edef, n, ([], c, dummye))) + | ((DStyle (_, n, c, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], c, dummye)))) (IM.empty, IM.empty) file @@ -160,7 +162,8 @@ fun shake file = | (DTable _, _) => true | (DSequence _, _) => true | (DDatabase _, _) => true - | (DCookie _, _) => true) file + | (DCookie _, _) => true + | (DStyle _, _) => true) file end end diff --git a/src/source.sml b/src/source.sml index 3bd8e22a..a35c61be 100644 --- a/src/source.sml +++ b/src/source.sml @@ -164,6 +164,7 @@ datatype decl' = | DClass of string * kind * con | DDatabase of string | DCookie of string * con + | DStyle of string * con and str' = StrConst of decl list diff --git a/src/source_print.sml b/src/source_print.sml index 94a175ac..bc933d57 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -640,6 +640,13 @@ fun p_decl ((d, _) : decl) = string ":", space, p_con c] + | DStyle (x, c) => box [string "style", + space, + string x, + space, + string ":", + space, + p_con c] and p_str (str, _) = case str of diff --git a/src/unnest.sml b/src/unnest.sml index 1d0c2388..c321b34d 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -407,6 +407,7 @@ fun unnest file = | DClass _ => default () | DDatabase _ => default () | DCookie _ => default () + | DStyle _ => default () end and doStr (all as (str, loc), st) = diff --git a/src/urweb.grm b/src/urweb.grm index 7288359a..0d750679 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -194,7 +194,7 @@ datatype prop_kind = Delete | Update | LET | IN | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE - | COOKIE + | COOKIE | STYLE | CASE | IF | THEN | ELSE | XML_BEGIN of string | XML_END | XML_BEGIN_END of string @@ -451,6 +451,7 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let [(DClass (SYMBOL1, kind, c), s (CLASSleft, cexpright))] end) | COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))]) + | STYLE SYMBOL COLON cexp ([(DStyle (SYMBOL, cexp), s (STYLEleft, cexpright))]) kopt : (NONE) | DCOLON kind (SOME kind) @@ -707,6 +708,13 @@ sgi : CON SYMBOL DCOLON kind ((SgiConAbs (SYMBOL, kind), s (CONleft, in (SgiVal (SYMBOL, t), loc) end) + | STYLE SYMBOL COLON cexp (let + val loc = s (STYLEleft, cexpright) + val t = (CApp ((CVar (["Basis"], "css_class"), loc), + cexp), loc) + in + (SgiVal (SYMBOL, t), loc) + end) sgis : ([]) | sgi sgis (sgi :: sgis) diff --git a/src/urweb.lex b/src/urweb.lex index 4b3eb2af..534d51c6 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -319,6 +319,7 @@ notags = [^<{\n]+; "sequence" => (Tokens.SEQUENCE (pos yypos, pos yypos + size yytext)); "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)); "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext)); "Name" => (Tokens.NAME (pos yypos, pos yypos + size yytext)); diff --git a/tests/style.ur b/tests/style.ur new file mode 100644 index 00000000..f622ecfd --- /dev/null +++ b/tests/style.ur @@ -0,0 +1,6 @@ +style q : [] +style r : [Table, List] + +fun main () : transaction page = return + Hi. + diff --git a/tests/style.urp b/tests/style.urp new file mode 100644 index 00000000..fdb25a8b --- /dev/null +++ b/tests/style.urp @@ -0,0 +1,3 @@ +debug + +style -- cgit v1.2.3 From 949880b71b6b3d105ff5d73b1cf6958509b85c1e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 16 Apr 2009 12:07:21 -0400 Subject: Catching duplicate cookie and style paths --- src/cjr.sml | 1 + src/cjr_env.sml | 1 + src/cjr_print.sml | 7 +++++++ src/cjrize.sml | 1 + src/mono.sml | 1 + src/mono_env.sml | 1 + src/mono_print.sml | 3 +++ src/mono_shake.sml | 2 ++ src/mono_util.sml | 3 +++ src/monoize.sml | 3 ++- src/pathcheck.sml | 29 +++++++++++++++++++++++------ src/prepare.sml | 1 + tests/badCookie.ur | 2 ++ tests/badCookie.urp | 3 +++ 14 files changed, 51 insertions(+), 7 deletions(-) create mode 100644 tests/badCookie.ur create mode 100644 tests/badCookie.urp (limited to 'src/mono_env.sml') diff --git a/src/cjr.sml b/src/cjr.sml index 23dfb900..3844ccad 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -110,6 +110,7 @@ datatype decl' = | DPreparedStatements of (string * int) list | DJavaScript of string + | DCookie of string | DStyle of string withtype decl = decl' located diff --git a/src/cjr_env.sml b/src/cjr_env.sml index cb5caee9..7f02a4e9 100644 --- a/src/cjr_env.sml +++ b/src/cjr_env.sml @@ -167,6 +167,7 @@ fun declBinds env (d, loc) = | DDatabase _ => env | DPreparedStatements _ => env | DJavaScript _ => env + | DCookie _ => env | DStyle _ => env end diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 46282410..d6852455 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -2146,6 +2146,13 @@ fun p_decl env (dAll as (d, _) : decl) = | DJavaScript s => box [string "static char jslib[] = \"", string (String.toString s), string "\";"] + | DCookie s => box [string "/*", + space, + string "cookie", + space, + string s, + space, + string "*/"] | DStyle s => box [string "/*", space, string "style", diff --git a/src/cjrize.sml b/src/cjrize.sml index b432cd44..5e0f9bdb 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -556,6 +556,7 @@ fun cifyDecl ((d, loc), sm) = (SOME (L'.DSequence s, loc), NONE, sm) | L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, 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) fun cjrize ds = diff --git a/src/mono.sml b/src/mono.sml index 4a4cb5da..d60c552c 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -127,6 +127,7 @@ datatype decl' = | DJavaScript of string + | DCookie of string | DStyle of string diff --git a/src/mono_env.sml b/src/mono_env.sml index df255325..b3572fbe 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -111,6 +111,7 @@ fun declBinds env (d, loc) = | DSequence _ => env | DDatabase _ => env | DJavaScript _ => env + | DCookie _ => env | DStyle _ => env fun patBinds env (p, loc) = diff --git a/src/mono_print.sml b/src/mono_print.sml index a9e68005..7ad8dada 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -440,6 +440,9 @@ fun p_decl env (dAll as (d, _) : decl) = string s, string ")"] + | DCookie s => box [string "cookie", + space, + string s] | DStyle s => box [string "style", space, string s] diff --git a/src/mono_shake.sml b/src/mono_shake.sml index d2426f9f..0060d036 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -59,6 +59,7 @@ fun shake file = | ((DSequence _, _), acc) => acc | ((DDatabase _, _), acc) => acc | ((DJavaScript _, _), acc) => acc + | ((DCookie _, _), acc) => acc | ((DStyle _, _), acc) => acc) (IM.empty, IM.empty) file @@ -117,6 +118,7 @@ fun shake file = | (DSequence _, _) => true | (DDatabase _, _) => true | (DJavaScript _, _) => true + | (DCookie _, _) => true | (DStyle _, _) => true) file end diff --git a/src/mono_util.sml b/src/mono_util.sml index 62a2dfe0..238f65d3 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -474,6 +474,7 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = | DSequence _ => S.return2 dAll | DDatabase _ => S.return2 dAll | DJavaScript _ => S.return2 dAll + | DCookie _ => S.return2 dAll | DStyle _ => S.return2 dAll and mfvi ctx (x, n, t, e, s) = @@ -556,6 +557,7 @@ fun mapfoldB (all as {bind, ...}) = | DSequence _ => ctx | DDatabase _ => ctx | DJavaScript _ => ctx + | DCookie _ => ctx | DStyle _ => ctx in S.map2 (mff ctx' ds', @@ -606,6 +608,7 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DSequence _ => count | DDatabase _ => count | DJavaScript _ => count + | DCookie _ => count | DStyle _ => count) 0 end diff --git a/src/monoize.sml b/src/monoize.sml index 3fd4f730..7523f2dd 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2725,7 +2725,8 @@ fun monoDecl (env, fm) (all as (d, loc)) = in SOME (Env.pushENamed env x n t NONE s, fm, - [(L'.DVal (x, n, t', e, s), loc)]) + [(L'.DCookie s, loc), + (L'.DVal (x, n, t', e, s), loc)]) end | L.DStyle (x, n, s) => let diff --git a/src/pathcheck.sml b/src/pathcheck.sml index 3f4f6be4..a493595d 100644 --- a/src/pathcheck.sml +++ b/src/pathcheck.sml @@ -36,21 +36,35 @@ structure SS = BinarySetFn(struct val compare = String.compare end) -fun checkDecl ((d, loc), (funcs, rels)) = +fun checkDecl ((d, loc), (funcs, rels, cookies, styles)) = let fun doFunc s = (if SS.member (funcs, s) then E.errorAt loc ("Duplicate function path " ^ s) else (); - (SS.add (funcs, s), rels)) + (SS.add (funcs, s), rels, cookies, styles)) fun doRel s = (if SS.member (rels, s) then E.errorAt loc ("Duplicate table/sequence path " ^ s) else (); - (funcs, SS.add (rels, s))) + (funcs, SS.add (rels, s), cookies, styles)) + + fun doCookie s = + (if SS.member (cookies, s) then + E.errorAt loc ("Duplicate cookie path " ^ s) + else + (); + (funcs, rels, SS.add (cookies, s), styles)) + + fun doStyle s = + (if SS.member (styles, s) then + E.errorAt loc ("Duplicate style path " ^ s) + else + (); + (funcs, rels, cookies, SS.add (styles, s))) in case d of DExport (_, s, _, _, _) => doFunc s @@ -86,13 +100,16 @@ fun checkDecl ((d, loc), (funcs, rels)) = SS.add (rels, s') end in - (funcs, constraints (ce, rels)) + (funcs, constraints (ce, rels), cookies, styles) end | DSequence s => doRel s - | _ => (funcs, rels) + | DCookie s => doCookie s + | DStyle s => doStyle s + + | _ => (funcs, rels, cookies, styles) end -fun check ds = ignore (foldl checkDecl (SS.empty, SS.empty) ds) +fun check ds = ignore (foldl checkDecl (SS.empty, SS.empty, SS.empty, SS.empty) ds) end diff --git a/src/prepare.sml b/src/prepare.sml index 8e31b73d..e1777b11 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -259,6 +259,7 @@ fun prepDecl (d as (_, loc), sns) = | DDatabase _ => (d, sns) | DPreparedStatements _ => (d, sns) | DJavaScript _ => (d, sns) + | DCookie _ => (d, sns) | DStyle _ => (d, sns) fun prepare (ds, ps) = diff --git a/tests/badCookie.ur b/tests/badCookie.ur new file mode 100644 index 00000000..bd9c38ae --- /dev/null +++ b/tests/badCookie.ur @@ -0,0 +1,2 @@ +cookie x : int +cookie x : float diff --git a/tests/badCookie.urp b/tests/badCookie.urp new file mode 100644 index 00000000..3473be8f --- /dev/null +++ b/tests/badCookie.urp @@ -0,0 +1,3 @@ +debug + +badCookie -- cgit v1.2.3 From 51f2a80dac5c3cd25a27fb5abfdfa50d813ab0b2 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 28 Apr 2009 15:04:37 -0400 Subject: A view query works --- src/cjr.sml | 1 + src/cjr_env.sml | 1 + src/cjr_print.sml | 20 ++++++++++++ src/cjrize.sml | 28 +++++++++++++++++ src/core.sml | 1 + src/core_env.sml | 7 +++++ src/core_print.sml | 7 +++++ src/core_util.sml | 15 +++++++++ src/corify.sml | 8 +++++ src/elab.sml | 1 + src/elab_env.sml | 82 ++++++++++++++++++++++++++++++++----------------- src/elab_print.sml | 7 +++++ src/elab_util.sml | 14 +++++++++ src/elaborate.sml | 47 ++++++++++++++++++++++------ src/elisp/urweb-mode.el | 2 +- src/expl.sml | 1 + src/expl_env.sml | 7 +++++ src/expl_print.sml | 7 +++++ src/explify.sml | 2 ++ src/mono.sml | 1 + src/mono_env.sml | 1 + src/mono_opt.sml | 25 +++++++++++++++ src/mono_print.sml | 7 +++++ src/mono_shake.sml | 2 ++ src/mono_util.sml | 6 ++++ src/monoize.sml | 18 +++++++++++ src/prepare.sml | 1 + src/reduce.sml | 1 + src/reduce_local.sml | 1 + src/shake.sml | 5 ++- src/source.sml | 1 + src/source_print.sml | 7 +++++ src/unnest.sml | 1 + src/urweb.grm | 13 +++++++- src/urweb.lex | 1 + tests/view.ur | 10 ++++++ tests/view.urp | 5 +++ tests/view.urs | 1 + 38 files changed, 325 insertions(+), 40 deletions(-) create mode 100644 tests/view.ur create mode 100644 tests/view.urp create mode 100644 tests/view.urs (limited to 'src/mono_env.sml') diff --git a/src/cjr.sml b/src/cjr.sml index 559b7ada..d3fdbc22 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -107,6 +107,7 @@ datatype decl' = | DTable of string * (string * typ) list * string * (string * string) list | DSequence of string + | DView of string * (string * typ) list * string | DDatabase of {name : string, expunge : int, initialize : int} | DPreparedStatements of (string * int) list diff --git a/src/cjr_env.sml b/src/cjr_env.sml index 7f02a4e9..54dbea17 100644 --- a/src/cjr_env.sml +++ b/src/cjr_env.sml @@ -164,6 +164,7 @@ fun declBinds env (d, loc) = end) env vis | DTable _ => env | DSequence _ => env + | DView _ => env | DDatabase _ => env | DPreparedStatements _ => env | DJavaScript _ => env diff --git a/src/cjr_print.sml b/src/cjr_print.sml index c870c3ed..a09dd7f6 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -2069,6 +2069,15 @@ fun p_decl env (dAll as (d, _) : decl) = string x, string " */", newline] + | DView (x, _, s) => box [string "/* SQL view ", + string x, + space, + string "AS", + space, + string s, + space, + string " */", + newline] | DDatabase {name, expunge, initialize} => box [string "static void uw_db_validate(uw_context);", newline, @@ -3089,6 +3098,17 @@ fun p_sql env (ds, _) = string ";", newline, newline] + | DView (s, xts, q) => + box [string "CREATE VIEW", + space, + string s, + space, + string "AS", + space, + string q, + string ";", + newline, + newline] | _ => box [] in (pp, E.declBinds env dAll) diff --git a/src/cjrize.sml b/src/cjrize.sml index ee2ecdb6..19aeee4e 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -562,6 +562,34 @@ fun cifyDecl ((d, loc), sm) = end | L.DSequence s => (SOME (L'.DSequence s, loc), NONE, sm) + | L.DView (s, xts, e) => + let + val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) => + let + val (t, sm) = cifyTyp (t, sm) + in + ((x, t), sm) + end) sm xts + + fun flatten e = + case #1 e of + L.ERecord [] => [] + | L.ERecord [(x, (L.EPrim (Prim.String v), _), _)] => [(x, v)] + | L.EStrcat (e1, e2) => flatten e1 @ flatten e2 + | _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined"; + Print.prefaces "Undetermined constraint" + [("e", MonoPrint.p_exp MonoEnv.empty e)]; + []) + + val e = case #1 e of + L.EPrim (Prim.String s) => s + | _ => (ErrorMsg.errorAt loc "VIEW query has not been fully determined"; + Print.prefaces "Undetermined VIEW query" + [("e", MonoPrint.p_exp MonoEnv.empty e)]; + "") + in + (SOME (L'.DView (s, xts, e), loc), NONE, sm) + end | L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, sm) | L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm) | L.DCookie args => (SOME (L'.DCookie args, loc), NONE, sm) diff --git a/src/core.sml b/src/core.sml index 01cf4ec7..131bcc6f 100644 --- a/src/core.sml +++ b/src/core.sml @@ -130,6 +130,7 @@ datatype decl' = | DExport of export_kind * int | DTable of string * int * con * string * exp * con * exp * con | DSequence of string * int * string + | DView of string * int * string * exp * con | DDatabase of string | DCookie of string * int * con * string | DStyle of string * int * string diff --git a/src/core_env.sml b/src/core_env.sml index caf30349..0630fef2 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -327,6 +327,13 @@ fun declBinds env (d, loc) = in pushENamed env x n t NONE s end + | DView (x, n, s, _, c) => + let + val ct = (CFfi ("Basis", "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + pushENamed env x n ct NONE s + end | DDatabase _ => env | DCookie (x, n, c, s) => let diff --git a/src/core_print.sml b/src/core_print.sml index 9c1c72cd..f2a42a7b 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -566,6 +566,13 @@ fun p_decl env (dAll as (d, _) : decl) = string "as", space, string s] + | DView (x, n, s, e, _) => box [string "view", + space, + p_named x n, + space, + string "as", + space, + p_exp env e] | DDatabase s => box [string "database", space, string s] diff --git a/src/core_util.sml b/src/core_util.sml index d05aaa72..ae956121 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -946,6 +946,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} = fn cc' => (DTable (x, n, c', s, pe', pc', ce', cc'), loc)))))) | DSequence _ => S.return2 dAll + | DView (x, n, s, e, c) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfc ctx c, + fn c' => + (DView (x, n, s, e', c'), loc))) | DDatabase _ => S.return2 dAll | DCookie (x, n, c, s) => S.map2 (mfc ctx c, @@ -1082,6 +1088,14 @@ fun mapfoldB (all as {bind, ...}) = in bind (ctx, NamedE (x, n, t, NONE, s)) end + | DView (x, n, s, _, c) => + let + val loc = #2 d' + val ct = (CFfi ("Basis", "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + bind (ctx, NamedE (x, n, ct, NONE, s)) + end | DDatabase _ => ctx | DCookie (x, n, c, s) => let @@ -1154,6 +1168,7 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DExport _ => count | DTable (_, n, _, _, _, _, _, _) => Int.max (n, count) | DSequence (_, n, _) => Int.max (n, count) + | DView (_, n, _, _, _) => Int.max (n, count) | DDatabase _ => count | DCookie (_, n, _, _) => Int.max (n, count) | DStyle (_, n, _) => Int.max (n, count)) 0 diff --git a/src/corify.sml b/src/corify.sml index c1cd940e..f1895e19 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -992,6 +992,13 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = in ([(L'.DSequence (x, n, s), loc)], st) end + | L.DView (_, x, n, e, c) => + let + val (st, n) = St.bindVal st x n + val s = relify (doRestify (mods, x)) + in + ([(L'.DView (x, n, s, corifyExp st e, corifyCon st c), loc)], st) + end | L.DDatabase s => ([(L'.DDatabase s, loc)], st) @@ -1063,6 +1070,7 @@ fun maxName ds = foldl (fn ((d, _), n) => | L.DExport _ => n | L.DTable (_, _, n', _, _, _, _, _) => Int.max (n, n') | L.DSequence (_, _, n') => Int.max (n, 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')) diff --git a/src/elab.sml b/src/elab.sml index f82a947d..555cc25c 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -165,6 +165,7 @@ datatype decl' = | DExport of int * sgn * str | DTable of int * string * int * con * exp * con * exp * con | DSequence of int * string * int + | DView of int * string * int * exp * con | DClass of string * int * kind * con | DDatabase of string | DCookie of int * string * int * con diff --git a/src/elab_env.sml b/src/elab_env.sml index 0184d0b1..efc2b74e 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -591,6 +591,22 @@ fun unifySubst (rs : con list) = exception Bad of con * con +val hasUnif = U.Con.exists {kind = fn _ => false, + con = fn CUnif (_, _, _, ref NONE) => true + | _ => false} + +fun startsWithUnif c = + let + fun firstArg (c, acc) = + case #1 c of + CApp (f, x) => firstArg (f, SOME x) + | _ => acc + in + case firstArg (c, NONE) of + NONE => false + | SOME x => hasUnif x + end + fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) = let fun resolve c = @@ -671,34 +687,37 @@ fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) = tryGrounds (#ground class) end in - case #1 c of - TRecord c => - (case #1 (hnorm c) of - CRecord (_, xts) => - let - fun resolver (xts, acc) = - case xts of - [] => SOME (ERecord acc, #2 c) - | (x, t) :: xts => - let - val t = hnorm t - - val t = case t of - (CApp (f, x), loc) => (CApp (hnorm f, hnorm x), loc) - | _ => t - in - case resolve t of - NONE => NONE - | SOME e => resolver (xts, (x, e, t) :: acc) - end - in - resolver (xts, []) - end - | _ => NONE) - | _ => - case class_head_in c of - SOME f => doHead f - | _ => NONE + if startsWithUnif c then + NONE + else + case #1 c of + TRecord c => + (case #1 (hnorm c) of + CRecord (_, xts) => + let + fun resolver (xts, acc) = + case xts of + [] => SOME (ERecord acc, #2 c) + | (x, t) :: xts => + let + val t = hnorm t + + val t = case t of + (CApp (f, x), loc) => (CApp (hnorm f, hnorm x), loc) + | _ => t + in + case resolve t of + NONE => NONE + | SOME e => resolver (xts, (x, e, t) :: acc) + end + in + resolver (xts, []) + end + | _ => NONE) + | _ => + case class_head_in c of + SOME f => doHead f + | _ => NONE end in resolve @@ -1482,6 +1501,13 @@ fun declBinds env (d, loc) = in pushENamedAs env x n t end + | DView (tn, x, n, _, c) => + let + val ct = (CModProj (tn, [], "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + pushENamedAs env x n ct + end | DClass (x, n, k, c) => let val k = (KArrow (k, (KType, loc)), loc) diff --git a/src/elab_print.sml b/src/elab_print.sml index e6a2cccb..bbbd9f8d 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -758,6 +758,13 @@ fun p_decl env (dAll as (d, _) : decl) = | DSequence (_, x, n) => box [string "sequence", space, p_named x n] + | DView (_, x, n, e, _) => box [string "view", + space, + p_named x n, + space, + string "as", + space, + p_exp env e] | DClass (x, n, k, c) => box [string "class", space, p_named x n, diff --git a/src/elab_util.sml b/src/elab_util.sml index 0d78951b..f4cbc951 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -791,6 +791,13 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f end | DSequence (tn, x, n) => bind (ctx, NamedE (x, (CModProj (n, [], "sql_sequence"), loc))) + | DView (tn, x, n, _, c) => + let + val ct = (CModProj (n, [], "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + bind (ctx, NamedE (x, ct)) + end | DClass (x, n, k, _) => bind (ctx, NamedC (x, n, (KArrow (k, (KType, loc)), loc))) | DDatabase _ => ctx @@ -899,6 +906,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f fn cc' => (DTable (tn, x, n, c', pe', pc', ce', cc'), loc)))))) | DSequence _ => S.return2 dAll + | DView (tn, x, n, e, c) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfc ctx c, + fn c' => + (DView (tn, x, n, e', c'), loc))) | DClass (x, n, k, c) => S.bind2 (mfk ctx k, @@ -1051,6 +1064,7 @@ and maxNameDecl (d, _) = | DExport _ => 0 | DTable (n1, _, n2, _, _, _, _, _) => Int.max (n1, n2) | DSequence (n1, _, n2) => Int.max (n1, n2) + | DView (n1, _, n2, _, _) => Int.max (n1, n2) | DDatabase _ => 0 | DCookie (n1, _, n2, _) => Int.max (n1, n2) | DStyle (n1, _, n2) => Int.max (n1, n2) diff --git a/src/elaborate.sml b/src/elaborate.sml index 81fcbda1..b9378e1b 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -803,19 +803,22 @@ handle GuessFailure => false end - val (fs1, fs2, others1, others2) = + val (fs1, fs2, others1, others2, unifs1, unifs2) = case (fs1, fs2, others1, others2, unifs1, unifs2) of ([], _, [other1], [], [], _) => if isGuessable (other1, fs2, unifs2) then - ([], [], [], []) + ([], [], [], [], [], []) else - (fs1, fs2, others1, others2) + (fs1, fs2, others1, others2, unifs1, unifs2) | (_, [], [], [other2], _, []) => if isGuessable (other2, fs1, unifs1) then - ([], [], [], []) + ([], [], [], [], [], []) else - (fs1, fs2, others1, others2) - | _ => (fs1, fs2, others1, others2) + (prefaces "Not guessable" [("other2", p_con env other2), + ("fs1", p_con env (L'.CRecord (k, fs1), loc)), + ("#unifs1", PD.string (Int.toString (length unifs1)))]; + (fs1, fs2, others1, others2, unifs1, unifs2)) + | _ => (fs1, fs2, others1, others2, unifs1, unifs2) (*val () = eprefaces "Summaries5" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}), ("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*) @@ -849,7 +852,7 @@ fun unfold (dom, ran, f, r, c) = let fun unfold (r, c) = - case #1 c of + case #1 (hnormCon env c) of L'.CRecord (_, []) => unifyCons env r (L'.CRecord (dom, []), loc) | L'.CRecord (_, [(x, v)]) => let @@ -878,8 +881,7 @@ unfold (r2, c2'); unifyCons env r (L'.CConcat (r1, r2), loc) end - | L'.CUnif (_, _, _, ref (SOME c)) => unfold (r, c) - | L'.CUnif (_, _, _, ur as ref NONE) => + | L'.CUnif (_, _, _, ur) => let val ur' = cunif (loc, (L'.KRecord dom, loc)) in @@ -1935,6 +1937,8 @@ val hnormSgn = E.hnormSgn fun tableOf () = (L'.CModProj (!basis_r, [], "sql_table"), ErrorMsg.dummySpan) fun sequenceOf () = (L'.CModProj (!basis_r, [], "sql_sequence"), ErrorMsg.dummySpan) +fun viewOf () = (L'.CModProj (!basis_r, [], "sql_view"), ErrorMsg.dummySpan) +fun queryOf () = (L'.CModProj (!basis_r, [], "sql_query"), ErrorMsg.dummySpan) fun cookieOf () = (L'.CModProj (!basis_r, [], "http_cookie"), ErrorMsg.dummySpan) fun styleOf () = (L'.CModProj (!basis_r, [], "css_class"), ErrorMsg.dummySpan) @@ -2434,6 +2438,8 @@ and sgiOfDecl (d, loc) = [(L'.SgiVal (x, n, (L'.CApp ((L'.CApp (tableOf (), c), loc), (L'.CConcat (pc, cc), loc)), loc)), loc)] | L'.DSequence (tn, x, n) => [(L'.SgiVal (x, n, sequenceOf ()), loc)] + | L'.DView (tn, x, n, _, c) => + [(L'.SgiVal (x, n, (L'.CApp (viewOf (), c), loc)), loc)] | L'.DClass (x, n, k, c) => [(L'.SgiClass (x, n, k, c), loc)] | L'.DDatabase _ => [] | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] @@ -3405,6 +3411,29 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = in ([(L'.DSequence (!basis_r, x, n), loc)], (env, denv, gs)) end + | L.DView (x, e) => + let + val (e', t, gs') = elabExp (env, denv) e + + val k = (L'.KRecord (L'.KType, loc), loc) + val fs = cunif (loc, k) + val ts = cunif (loc, (L'.KRecord k, loc)) + val tf = (L'.CApp ((L'.CMap (k, k), loc), + (L'.CAbs ("_", k, (L'.CRecord ((L'.KType, loc), []), loc)), loc)), loc) + val ts = (L'.CApp (tf, ts), loc) + + val cv = viewOf () + val cv = (L'.CApp (cv, fs), loc) + val (env', n) = E.pushENamed env x cv + + val ct = queryOf () + val ct = (L'.CApp (ct, ts), loc) + val ct = (L'.CApp (ct, fs), loc) + in + checkCon env e' t ct; + ([(L'.DView (!basis_r, x, n, e', fs), loc)], + (env', denv, gs' @ gs)) + end | L.DClass (x, k, c) => let diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index 2cd27fcc..7f4b0dee 100644 --- a/src/elisp/urweb-mode.el +++ b/src/elisp/urweb-mode.el @@ -137,7 +137,7 @@ See doc for the variable `urweb-mode-info'." "fun" "functor" "if" "include" "of" "open" "let" "in" "rec" "sequence" "sig" "signature" "cookie" "style" - "struct" "structure" "table" "then" "type" "val" "where" + "struct" "structure" "table" "view" "then" "type" "val" "where" "with" "Name" "Type" "Unit") diff --git a/src/expl.sml b/src/expl.sml index e293c36b..cc40e8b4 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -143,6 +143,7 @@ datatype decl' = | DExport of int * sgn * str | DTable of int * string * int * con * exp * con * exp * con | DSequence of int * string * int + | DView of int * string * int * exp * con | DDatabase of string | DCookie of int * string * int * con | DStyle of int * string * int diff --git a/src/expl_env.sml b/src/expl_env.sml index 1e99b36b..2bb049a3 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -312,6 +312,13 @@ fun declBinds env (d, loc) = in pushENamed env x n t end + | DView (tn, x, n, _, c) => + let + val ct = (CModProj (tn, [], "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + pushENamed env x n ct + end | DDatabase _ => env | DCookie (tn, x, n, c) => let diff --git a/src/expl_print.sml b/src/expl_print.sml index 167c6850..e6b28fea 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -681,6 +681,13 @@ fun p_decl env (dAll as (d, _) : decl) = | DSequence (_, x, n) => box [string "sequence", space, p_named x n] + | DView (_, x, n, e, _) => box [string "view", + space, + p_named x n, + space, + string "as", + space, + p_exp env e] | DDatabase s => box [string "database", space, string s] diff --git a/src/explify.sml b/src/explify.sml index 6a33eabc..2e181771 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -182,6 +182,8 @@ fun explifyDecl (d, loc : EM.span) = SOME (L'.DTable (nt, x, n, explifyCon c, explifyExp pe, explifyCon pc, explifyExp ce, explifyCon cc), loc) + | L.DView (nt, x, n, e, c) => + SOME (L'.DView (nt, x, n, explifyExp e, explifyCon c), loc) | L.DSequence (nt, x, n) => SOME (L'.DSequence (nt, x, n), loc) | L.DClass (x, n, k, c) => SOME (L'.DCon (x, n, (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), explifyCon c), loc) diff --git a/src/mono.sml b/src/mono.sml index e9d30181..7a789e2c 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -127,6 +127,7 @@ datatype decl' = | DTable of string * (string * typ) list * exp * exp | DSequence of string + | DView of string * (string * typ) list * exp | DDatabase of {name : string, expunge : int, initialize : int} | DJavaScript of string diff --git a/src/mono_env.sml b/src/mono_env.sml index b3572fbe..739f2f89 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -109,6 +109,7 @@ fun declBinds env (d, loc) = | DExport _ => env | DTable _ => env | DSequence _ => env + | DView _ => env | DDatabase _ => env | DJavaScript _ => env | DCookie _ => env diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 19244e60..41724eb0 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -422,6 +422,31 @@ fun exp e = EPrim (Prim.String s) end + | EFfiApp ("Basis", "viewify", [(EPrim (Prim.String s), loc)]) => + let + fun uwify (cs, acc) = + case cs of + [] => String.concat (rev acc) + | #"A" :: #"S" :: #" " :: #"_" :: cs => uwify (cs, "AS uw_" :: acc) + | #"'" :: cs => + let + fun waitItOut (cs, acc) = + case cs of + [] => raise Fail "MonoOpt: Unterminated SQL string literal" + | #"'" :: cs => uwify (cs, "'" :: acc) + | #"\\" :: #"'" :: cs => waitItOut (cs, "\\'" :: acc) + | #"\\" :: #"\\" :: cs => waitItOut (cs, "\\\\" :: acc) + | c :: cs => waitItOut (cs, str c :: acc) + in + waitItOut (cs, "'" :: acc) + end + | c :: cs => uwify (cs, str c :: acc) + + val s = uwify (String.explode s, []) + in + EPrim (Prim.String s) + end + | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) diff --git a/src/mono_print.sml b/src/mono_print.sml index ffc1d4fe..a233b400 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -438,6 +438,13 @@ fun p_decl env (dAll as (d, _) : decl) = | DSequence s => box [string "(* SQL sequence ", string s, string "*)"] + | DView (s, _, e) => box [string "(* SQL view ", + string s, + space, + string "as", + space, + p_exp env e, + string "*)"] | DDatabase {name, expunge, initialize} => box [string "database", space, string name, diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 0060d036..4764feb7 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -57,6 +57,7 @@ fun shake file = | ((DExport _, _), acc) => acc | ((DTable _, _), acc) => acc | ((DSequence _, _), acc) => acc + | ((DView _, _), acc) => acc | ((DDatabase _, _), acc) => acc | ((DJavaScript _, _), acc) => acc | ((DCookie _, _), acc) => acc @@ -116,6 +117,7 @@ fun shake file = | (DExport _, _) => true | (DTable _, _) => true | (DSequence _, _) => true + | (DView _, _) => true | (DDatabase _, _) => true | (DJavaScript _, _) => true | (DCookie _, _) => true diff --git a/src/mono_util.sml b/src/mono_util.sml index dd848ba6..caf96ac7 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -492,6 +492,10 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = fn ce' => (DTable (s, xts, pe', ce'), loc))) | DSequence _ => S.return2 dAll + | DView (s, xts, e) => + S.map2 (mfe ctx e, + fn e' => + (DView (s, xts, e'), loc)) | DDatabase _ => S.return2 dAll | DJavaScript _ => S.return2 dAll | DCookie _ => S.return2 dAll @@ -575,6 +579,7 @@ fun mapfoldB (all as {bind, ...}) = | DExport _ => ctx | DTable _ => ctx | DSequence _ => ctx + | DView _ => ctx | DDatabase _ => ctx | DJavaScript _ => ctx | DCookie _ => ctx @@ -626,6 +631,7 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DExport _ => count | DTable _ => count | DSequence _ => count + | DView _ => count | DDatabase _ => count | DJavaScript _ => count | DCookie _ => count diff --git a/src/monoize.sml b/src/monoize.sml index ccc5a851..a2048a7d 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2938,6 +2938,24 @@ fun monoDecl (env, fm) (all as (d, loc)) = (L'.DVal (x, n, t', e_name, s), loc)]) end | L.DTable _ => poly () + | L.DView (x, n, s, e, (L.CRecord (_, xts), _)) => + let + val t = (L.CFfi ("Basis", "string"), loc) + val t' = (L'.TFfi ("Basis", "string"), loc) + val s = "uw_" ^ s + val e_name = (L'.EPrim (Prim.String s), loc) + + val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts + + val (e, fm) = monoExp (env, St.empty, fm) e + val e = (L'.EFfiApp ("Basis", "viewify", [e]), loc) + in + SOME (Env.pushENamed env x n t NONE s, + fm, + [(L'.DView (s, xts, e), loc), + (L'.DVal (x, n, t', e_name, s), loc)]) + end + | L.DView _ => poly () | L.DSequence (x, n, s) => let val t = (L.CFfi ("Basis", "string"), loc) diff --git a/src/prepare.sml b/src/prepare.sml index 25306e89..592b00bc 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -266,6 +266,7 @@ fun prepDecl (d as (_, loc), sns) = | DTable _ => (d, sns) | DSequence _ => (d, sns) + | DView _ => (d, sns) | DDatabase _ => (d, sns) | DPreparedStatements _ => (d, sns) | DJavaScript _ => (d, sns) diff --git a/src/reduce.sml b/src/reduce.sml index 914f26c0..665c10b4 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -467,6 +467,7 @@ fun reduce file = exp (namedC, namedE) [] ce, con namedC [] cc), loc), st) | DSequence _ => (d, st) + | DView (s, n, s', e, c) => ((DView (s, n, s', exp (namedC, namedE) [] e, con namedC [] c), loc), st) | 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) diff --git a/src/reduce_local.sml b/src/reduce_local.sml index 265cb2a4..6c25ebf3 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -158,6 +158,7 @@ fun reduce file = | DExport _ => d | DTable _ => d | DSequence _ => d + | DView _ => d | DDatabase _ => d | DCookie _ => d | DStyle _ => d diff --git a/src/shake.sml b/src/shake.sml index 787bfd2f..35af7436 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -84,6 +84,8 @@ fun shake file = (cdef, IM.insert (edef, n, ([], c, dummye))) | ((DSequence (_, n, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], dummyt, dummye))) + | ((DView (_, n, _, _, c), _), (cdef, edef)) => + (cdef, IM.insert (edef, n, ([], c, dummye))) | ((DDatabase _, _), acc) => acc | ((DCookie (_, n, c, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], c, dummye))) @@ -159,8 +161,9 @@ fun shake file = | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n) | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis | (DExport _, _) => true - | (DTable _, _) => true + | (DView _, _) => true | (DSequence _, _) => true + | (DTable _, _) => true | (DDatabase _, _) => true | (DCookie _, _) => true | (DStyle _, _) => true) file diff --git a/src/source.sml b/src/source.sml index 6645ae75..9d3eea79 100644 --- a/src/source.sml +++ b/src/source.sml @@ -161,6 +161,7 @@ datatype decl' = | DExport of str | DTable of string * con * exp * exp | DSequence of string + | DView of string * exp | DClass of string * kind * con | DDatabase of string | DCookie of string * con diff --git a/src/source_print.sml b/src/source_print.sml index 58867f64..0f8b093b 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -621,6 +621,13 @@ fun p_decl ((d, _) : decl) = | DSequence x => box [string "sequence", space, string x] + | DView (x, e) => box [string "view", + space, + string x, + space, + string "=", + space, + p_exp e] | DClass (x, k, c) => box [string "class", space, string x, diff --git a/src/unnest.sml b/src/unnest.sml index c321b34d..51b66aa4 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -404,6 +404,7 @@ fun unnest file = | DExport _ => default () | DTable _ => default () | DSequence _ => default () + | DView _ => default () | DClass _ => default () | DDatabase _ => default () | DCookie _ => default () diff --git a/src/urweb.grm b/src/urweb.grm index ce078279..da817ab3 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -195,7 +195,7 @@ datatype attr = Class of exp | Normal of con * exp | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE | CARET | LET | IN | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL - | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE + | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW | COOKIE | STYLE | CASE | IF | THEN | ELSE @@ -438,6 +438,10 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let | TABLE SYMBOL COLON cterm pkopt commaOpt cstopt([(DTable (SYMBOL, entable cterm, pkopt, cstopt), s (TABLEleft, cstoptright))]) | SEQUENCE SYMBOL ([(DSequence SYMBOL, s (SEQUENCEleft, SYMBOLright))]) + | VIEW SYMBOL EQ query ([(DView (SYMBOL, query), + s (VIEWleft, queryright))]) + | VIEW SYMBOL EQ LBRACE eexp RBRACE ([(DView (SYMBOL, eexp), + s (VIEWleft, RBRACEright))]) | CLASS SYMBOL EQ cexp (let val loc = s (CLASSleft, cexpright) in @@ -674,6 +678,13 @@ sgi : CON SYMBOL DCOLON kind ((SgiConAbs (SYMBOL, kind), s (CONleft, in (SgiVal (SYMBOL, t), loc) end) + | VIEW SYMBOL COLON cexp (let + val loc = s (VIEWleft, cexpright) + val t = (CVar (["Basis"], "sql_view"), loc) + val t = (CApp (t, cexp), loc) + in + (SgiVal (SYMBOL, t), loc) + end) | CLASS SYMBOL (let val loc = s (CLASSleft, SYMBOLright) val k = (KArrow ((KType, loc), (KType, loc)), loc) diff --git a/src/urweb.lex b/src/urweb.lex index bb9004a6..85cf3bcf 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -317,6 +317,7 @@ notags = [^<{\n]+; "export" => (Tokens.EXPORT (pos yypos, pos yypos + size yytext)); "table" => (Tokens.TABLE (pos yypos, pos yypos + size yytext)); "sequence" => (Tokens.SEQUENCE (pos yypos, pos yypos + size yytext)); + "view" => (Tokens.VIEW (pos yypos, pos yypos + size yytext)); "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)); diff --git a/tests/view.ur b/tests/view.ur new file mode 100644 index 00000000..36d77deb --- /dev/null +++ b/tests/view.ur @@ -0,0 +1,10 @@ +table t : { A : int, B : string } + +view v = SELECT t.A AS X FROM t + +fun main () = + rows <- queryX (SELECT * FROM v) + (fn r =>

{[r.V.X]}

); + return + {rows} + diff --git a/tests/view.urp b/tests/view.urp new file mode 100644 index 00000000..3528ec9d --- /dev/null +++ b/tests/view.urp @@ -0,0 +1,5 @@ +debug +database dbname=view +sql view.sql + +view diff --git a/tests/view.urs b/tests/view.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/view.urs @@ -0,0 +1 @@ +val main : unit -> transaction page -- cgit v1.2.3 From c69e0c432107906261ab4c56cd88a8cfab3191fb Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 14 May 2009 13:18:31 -0400 Subject: Proper lifting of MonoEnv stored expressions; avoidance of onchange clobbering --- lib/js/urweb.js | 10 +++++++- lib/ur/list.ur | 10 ++++++++ lib/ur/list.urs | 3 +++ src/especialize.sml | 36 +++++++++++++++++++++------ src/jscomp.sml | 72 ++++++++++++++++++++++++++++++++++++++++++++++++----- src/mono_env.sml | 18 ++++++++++++-- src/mono_reduce.sml | 19 ++++++++++++-- src/monoize.sml | 4 +++ 8 files changed, 154 insertions(+), 18 deletions(-) (limited to 'src/mono_env.sml') diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 2943c897..d0322bff 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -301,11 +301,19 @@ function inp(t, s, content) { return x; } +function addOnChange(x, f) { + var old = x.onchange; + x.onchange = function() { old(); f (); }; +} + // Basic string operations function eh(x) { - return x.split("&").join("&").split("<").join("<").split(">").join(">"); + if (x == null) + return "NULL"; + else + return x.split("&").join("&").split("<").join("<").split(">").join(">"); } function ts(x) { return x.toString() } diff --git a/lib/ur/list.ur b/lib/ur/list.ur index ecec2bec..2ee60538 100644 --- a/lib/ur/list.ur +++ b/lib/ur/list.ur @@ -39,3 +39,13 @@ fun mapX (a ::: Type) (ctx ::: {Unit}) f = in mapX' end + +fun mapM (m ::: (Type -> Type)) (_ : monad m) (a ::: Type) (b ::: Type) f = + let + fun mapM' acc ls = + case ls of + [] => acc + | x :: ls => mapM' (x' <- f x; ls' <- acc; return (x' :: ls')) ls + in + mapM' (return []) + end diff --git a/lib/ur/list.urs b/lib/ur/list.urs index e9e097d4..d27ad997 100644 --- a/lib/ur/list.urs +++ b/lib/ur/list.urs @@ -7,3 +7,6 @@ val rev : a ::: Type -> t a -> t a val mp : a ::: Type -> b ::: Type -> (a -> b) -> t a -> t b val mapX : a ::: Type -> ctx ::: {Unit} -> (a -> xml ctx [] []) -> t a -> xml ctx [] [] + +val mapM : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type + -> (a -> m b) -> list a -> m (list b) diff --git a/src/especialize.sml b/src/especialize.sml index 03be01b1..3ea4dcbd 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -112,6 +112,13 @@ type state = { fun default (_, x, st) = (x, st) +structure SS = BinarySetFn(struct + type ord_key = string + val compare = String.compare + end) + +val mayNotSpec = ref SS.empty + fun specialize' file = let fun bind (env, b) = @@ -179,13 +186,14 @@ fun specialize' file = (ERel _, _) :: _ => true | _ => false in + (*Print.preface ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs');*) if firstRel () orelse List.all (fn (ERel _, _) => true | _ => false) fxs' then (e, st) else - case KM.find (args, fxs') of - SOME f' => + case (KM.find (args, fxs'), SS.member (!mayNotSpec, name)) of + (SOME f', _) => let val e = (ENamed f', loc) val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc)) @@ -197,8 +205,14 @@ fun specialize' file = [("e'", CorePrint.p_exp CoreEnv.empty e)];*) (#1 e, st) end - | NONE => + | (_, true) => (e, st) + | (NONE, false) => let + (*val () = Print.prefaces "New one" + [("f", Print.PD.string (Int.toString f)), + ("mns", Print.p_list Print.PD.string + (SS.listItems (!mayNotSpec)))]*) + fun subBody (body, typ, fxs') = case (#1 body, #1 typ, fxs') of (_, _, []) => SOME (body, typ) @@ -245,7 +259,11 @@ fun specialize' file = (TFun (xt, typ'), loc)) end) (body', typ') fvs + val mns = !mayNotSpec + val () = mayNotSpec := SS.add (mns, name) + (*val () = Print.preface ("body'", CorePrint.p_exp CoreEnv.empty body')*) val (body', st) = specExp env st body' + val () = mayNotSpec := mns val e' = (ENamed f', loc) val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc)) @@ -297,7 +315,13 @@ fun specialize' file = if isPoly d then (d, st) else - specDecl [] st d + (mayNotSpec := (case #1 d of + DValRec vis => foldl (fn ((x, _, _, _, _), mns) => + SS.add (mns, x)) SS.empty vis + | DVal (x, _, _, _, _) => SS.singleton x + | _ => SS.empty); + specDecl [] st d + before mayNotSpec := SS.empty) (*val () = print "/decl\n"*) @@ -324,9 +348,7 @@ fun specialize' file = (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)] | _ => [(DValRec vis, ErrorMsg.dummySpan), d']) in - (*Print.prefaces "doDecl" [("d", CorePrint.p_decl E.empty d), - ("t", Print.PD.string (Real.toString (Time.toReal - (Time.- (Time.now (), befor)))))];*) + (*Print.prefaces "doDecl" [("d", CorePrint.p_decl E.empty d)];*) (ds, ({maxName = #maxName st, funcs = funcs, decls = []}, changed)) diff --git a/src/jscomp.sml b/src/jscomp.sml index c01b9e10..3e8e939e 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -36,11 +36,17 @@ structure U = MonoUtil structure IS = IntBinarySet structure IM = IntBinaryMap +structure TM = BinaryMapFn(struct + type ord_key = typ + val compare = U.Typ.compare + end) + type state = { decls : decl list, script : string list, included : IS.set, injectors : int IM.map, + listInjectors : int TM.map, decoders : int IM.map, maxName : int } @@ -231,6 +237,52 @@ fun process file = st) end + | TList t' => + (case TM.find (#listInjectors st, t') of + SOME n' => ((EApp ((ENamed n', loc), e), loc), st) + | NONE => + let + val rt = (TRecord [("1", t'), ("2", t)], loc) + + val n' = #maxName st + val st = {decls = #decls st, + script = #script st, + included = #included st, + injectors = #injectors st, + listInjectors = TM.insert (#listInjectors st, t', n'), + decoders = #decoders st, + maxName = n' + 1} + + val s = (TFfi ("Basis", "string"), loc) + val (e', st) = quoteExp loc t ((EField ((ERel 0, loc), "1"), loc), st) + + val body = (ECase ((ERel 0, loc), + [((PNone rt, loc), + str loc "null"), + ((PSome (rt, (PVar ("x", rt), loc)), loc), + strcat loc [str loc "{v:{_1:", + e', + str loc ",_2:", + (EApp ((ENamed n', loc), + (EField ((ERel 0, loc), "2"), loc)), loc), + str loc "}}"])], + {disc = t, result = s}), loc) + val body = (EAbs ("x", t, s, body), loc) + + val st = {decls = (DValRec [("jsify", n', (TFun (t, s), loc), + body, "jsify")], loc) :: #decls st, + script = #script st, + included = #included st, + injectors = #injectors st, + listInjectors = #listInjectors st, + decoders= #decoders st, + maxName = #maxName st} + + + in + ((EApp ((ENamed n', loc), e), loc), st) + end) + | TDatatype (n, ref (dk, cs)) => (case IM.find (#injectors st, n) of SOME n' => ((EApp ((ENamed n', loc), e), loc), st) @@ -241,6 +293,7 @@ fun process file = script = #script st, included = #included st, injectors = IM.insert (#injectors st, n, n'), + listInjectors = #listInjectors st, decoders = #decoders st, maxName = n' + 1} @@ -282,6 +335,7 @@ fun process file = script = #script st, included = #included st, injectors = #injectors st, + listInjectors = #listInjectors st, decoders= #decoders st, maxName = #maxName st} in @@ -350,6 +404,7 @@ fun process file = script = #script st, included = #included st, injectors = #injectors st, + listInjectors = #listInjectors st, decoders = IM.insert (#decoders st, n, n'), maxName = n' + 1} @@ -384,6 +439,7 @@ fun process file = script = body :: #script st, included = #included st, injectors = #injectors st, + listInjectors = #listInjectors st, decoders = #decoders st, maxName = #maxName st} in @@ -402,7 +458,7 @@ fun process file = val foundJavaScript = ref false - fun jsExp mode skip outer = + fun jsExp mode outer = let val len = length outer @@ -575,7 +631,7 @@ fun process file = let val n = n - inner in - quoteExp (List.nth (outer, n)) ((ERel (n - skip), loc), st) + quoteExp (List.nth (outer, n)) ((ERel n, loc), st) end | ENamed n => @@ -592,10 +648,11 @@ fun process file = script = #script st, included = IS.add (#included st, n), injectors = #injectors st, + listInjectors = #listInjectors st, decoders = #decoders st, maxName = #maxName st} - val (e, st) = jsExp mode skip [] 0 (e, st) + val (e, st) = jsExp mode [] 0 (e, st) val e = deStrcat 0 e val sc = "_n" ^ Int.toString n ^ "=" ^ e ^ ";\n" @@ -604,6 +661,7 @@ fun process file = script = sc :: #script st, included = #included st, injectors = #injectors st, + listInjectors = #listInjectors st, decoders= #decoders st, maxName = #maxName st} end @@ -988,7 +1046,7 @@ fun process file = U.Decl.foldMapB {typ = fn x => x, exp = fn (env, e, st) => let - fun doCode m skip env orig e = + fun doCode m env orig e = let val len = length env fun str s = (EPrim (Prim.String s), #2 e) @@ -996,7 +1054,7 @@ fun process file = val locals = List.tabulate (varDepth e, fn i => str ("var _" ^ Int.toString (len + i) ^ ";")) - val (e, st) = jsExp m skip env 0 (e, st) + val (e, st) = jsExp m env 0 (e, st) in (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st) end @@ -1004,7 +1062,7 @@ fun process file = case e of EJavaScript (m, orig, NONE) => (foundJavaScript := true; - doCode m 0 env orig orig) + doCode m env orig orig) | _ => (e, st) end, decl = fn (_, e, st) => (e, st), @@ -1021,6 +1079,7 @@ fun process file = script = #script st, included = #included st, injectors = #injectors st, + listInjectors = #listInjectors st, decoders = #decoders st, maxName = #maxName st}) end @@ -1030,6 +1089,7 @@ fun process file = script = [], included = IS.empty, injectors = IM.empty, + listInjectors = TM.empty, decoders = IM.empty, maxName = U.File.maxName file + 1} file diff --git a/src/mono_env.sml b/src/mono_env.sml index 739f2f89..2397637a 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -70,11 +70,25 @@ fun lookupConstructor (env : env) n = NONE => raise UnboundNamed n | SOME x => x +structure U = MonoUtil + +val liftExpInExp = + U.Exp.mapB {typ = fn t => t, + exp = fn bound => fn e => + case e of + ERel xn => + if xn < bound then + e + else + ERel (xn + 1) + | _ => e, + bind = fn (bound, U.Exp.RelE _) => bound + 1 + | (bound, _) => bound} + fun pushERel (env : env) x t eo = {datatypes = #datatypes env, constructors = #constructors env, - - relE = (x, t, eo) :: #relE env, + relE = (x, t, eo) :: map (fn (x, t, eo) => (x, t, Option.map (liftExpInExp 0) eo)) (#relE env), namedE = #namedE env} fun lookupERel (env : env) n = diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 5d8afee3..5a2aca85 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -409,7 +409,15 @@ fun reduce file = case match (env, p, e') of No => search pes | Maybe => push () - | Yes env => #1 (reduceExp env body) + | Yes env' => + let + val r = reduceExp env' body + in + (*Print.prefaces "ECase" + [("body", MonoPrint.p_exp env' body), + ("r", MonoPrint.p_exp env r)];*) + #1 r + end in search pes end @@ -443,7 +451,14 @@ fun reduce file = | ELet (x, t, e', b) => let fun doSub () = - #1 (reduceExp env (subExpInExp (0, e') b)) + let + val r = subExpInExp (0, e') b + in + (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'), + ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), + ("r", MonoPrint.p_exp env r)];*) + #1 (reduceExp env r) + end fun trySub () = case t of diff --git a/src/monoize.sml b/src/monoize.sml index 86a27543..e8d8a122 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2498,6 +2498,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val assgns = List.mapPartial (fn ("Source", _, _) => NONE + | ("Onchange", e, _) => + SOME (strcat [str "addOnChange(d,", + (L'.EJavaScript (L'.Script, e, NONE), loc), + str ")"]) | (x, e, _) => SOME (strcat [str ("d." ^ lowercaseFirst x ^ "="), (L'.EJavaScript (L'.Script, e, NONE), loc), -- cgit v1.2.3 From 30b78a96ae699fa2282c07a2dbf3e6303f99e32c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 May 2009 15:55:15 -0400 Subject: Mutual datatypes through Pathcheck --- src/cjrize.sml | 5 +++-- src/jscomp.sml | 15 +++++++------- src/mono.sml | 2 +- src/mono_env.sml | 19 +++++++++--------- src/mono_print.sml | 8 ++++---- src/mono_shake.sml | 6 +++--- src/mono_util.sml | 59 +++++++++++++++++++++++++++++------------------------- src/monoize.sml | 35 +++++++++++++++++--------------- 8 files changed, 80 insertions(+), 69 deletions(-) (limited to 'src/mono_env.sml') diff --git a/src/cjrize.sml b/src/cjrize.sml index 80d9842a..9c2128bc 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -483,7 +483,8 @@ fun cifyExp (eAll as (e, loc), sm) = fun cifyDecl ((d, loc), sm) = case d of - L.DDatatype (x, n, xncs) => + L.DDatatype _ => raise Fail "Cjrize DDatatype" + (*L.DDatatype (x, n, xncs) => let val dk = ElabUtil.classifyDatatype xncs val (xncs, sm) = ListUtil.foldlMap (fn ((x, n, to), sm) => @@ -497,7 +498,7 @@ fun cifyDecl ((d, loc), sm) = end) sm xncs in (SOME (L'.DDatatype (dk, x, n, xncs), loc), NONE, sm) - end + end*) | L.DVal (x, n, t, e, _) => let diff --git a/src/jscomp.sml b/src/jscomp.sml index e0954ba0..20408cba 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -176,13 +176,14 @@ fun process file = | ((DValRec vis, _), (someTs, nameds)) => (someTs, foldl (fn ((_, n, _, e, _), nameds) => IM.insert (nameds, n, e)) nameds vis) - | ((DDatatype (_, _, cs), _), state as (someTs, nameds)) => - if ElabUtil.classifyDatatype cs = Option then - (foldl (fn ((_, n, SOME t), someTs) => IM.insert (someTs, n, t) - | (_, someTs) => someTs) someTs cs, - nameds) - else - state + | ((DDatatype dts, _), state as (someTs, nameds)) => + (foldl (fn ((_, _, cs), someTs) => + if ElabUtil.classifyDatatype cs = Option then + foldl (fn ((_, n, SOME t), someTs) => IM.insert (someTs, n, t) + | (_, someTs) => someTs) someTs cs + else + someTs) someTs dts, + nameds) | (_, state) => state) (IM.empty, IM.empty) file diff --git a/src/mono.sml b/src/mono.sml index fa149b21..52d24998 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -121,7 +121,7 @@ datatype exp' = withtype exp = exp' located datatype decl' = - DDatatype of string * int * (string * int * typ option) list + DDatatype of (string * int * (string * int * typ option) list) list | DVal of string * int * typ * exp * string | DValRec of (string * int * typ * exp * string) list | DExport of export_kind * string * int * typ list * typ diff --git a/src/mono_env.sml b/src/mono_env.sml index 2397637a..3114176d 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -109,15 +109,16 @@ fun lookupENamed (env : env) n = fun declBinds env (d, loc) = case d of - DDatatype (x, n, xncs) => - let - val env = pushDatatype env x n xncs - val dt = (TDatatype (n, ref (ElabUtil.classifyDatatype xncs, xncs)), loc) - in - foldl (fn ((x', n', NONE), env) => pushENamed env x' n' dt NONE "" - | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, dt), loc) NONE "") - env xncs - end + DDatatype dts => + foldl (fn ((x, n, xncs), env) => + let + val env = pushDatatype env x n xncs + val dt = (TDatatype (n, ref (ElabUtil.classifyDatatype xncs, xncs)), loc) + in + foldl (fn ((x', n', NONE), env) => pushENamed env x' n' dt NONE "" + | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, dt), loc) NONE "") + env xncs + end) env dts | DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s | DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis | DExport _ => env diff --git a/src/mono_print.sml b/src/mono_print.sml index 2299bc56..0395a063 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -377,9 +377,7 @@ fun p_datatype env (x, n, cons) = let val env = E.pushDatatype env x n cons in - box [string "datatype", - space, - string x, + box [string x, space, string "=", space, @@ -393,7 +391,9 @@ fun p_datatype env (x, n, cons) = fun p_decl env (dAll as (d, _) : decl) = case d of - DDatatype x => p_datatype env x + DDatatype x => box [string "datatype", + space, + p_list_sep (box [space, string "and", space]) (p_datatype (E.declBinds env dAll)) x] | DVal vi => box [string "val", space, p_vali env vi] diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 4764feb7..40b83934 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -48,8 +48,8 @@ fun shake file = | ((DDatabase {expunge = n1, initialize = n2, ...}, _), page_es) => n1 :: n2 :: page_es | (_, page_es) => page_es) [] file - val (cdef, edef) = foldl (fn ((DDatatype (_, n, xncs), _), (cdef, edef)) => - (IM.insert (cdef, n, xncs), edef) + val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) => + (foldl (fn ((_, n, xncs), cdef) => IM.insert (cdef, n, xncs)) cdef dts, edef) | ((DVal (_, n, t, e, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, (t, e))) | ((DValRec vis, _), (cdef, edef)) => @@ -111,7 +111,7 @@ fun shake file = NONE => raise Fail "Shake: Couldn't find 'val'" | SOME (t, e) => shakeExp s e) s page_es in - List.filter (fn (DDatatype (_, n, _), _) => IS.member (#con s, n) + List.filter (fn (DDatatype dts, _) => List.exists (fn (_, n, _) => IS.member (#con s, n)) dts | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n) | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis | (DExport _, _) => true diff --git a/src/mono_util.sml b/src/mono_util.sml index ca074d9e..83621c99 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -466,15 +466,17 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = and mfd' ctx (dAll as (d, loc)) = case d of - DDatatype (x, n, xncs) => - S.map2 (ListUtil.mapfold (fn (x, n, c) => - case c of - NONE => S.return2 (x, n, c) - | SOME c => - S.map2 (mft c, - fn c' => (x, n, SOME c'))) xncs, - fn xncs' => - (DDatatype (x, n, xncs'), loc)) + DDatatype dts => + S.map2 (ListUtil.mapfold (fn (x, n, xncs) => + S.map2 (ListUtil.mapfold (fn (x, n, c) => + case c of + NONE => S.return2 (x, n, c) + | SOME c => + S.map2 (mft c, + fn c' => (x, n, SOME c'))) xncs, + fn xncs' => (x, n, xncs'))) dts, + fn dts' => + (DDatatype dts', loc)) | DVal vi => S.map2 (mfvi ctx vi, fn vi' => @@ -566,21 +568,23 @@ fun mapfoldB (all as {bind, ...}) = let val ctx' = case #1 d' of - DDatatype (x, n, xncs) => - let - val ctx = bind (ctx, Datatype (x, n, xncs)) - val t = (TDatatype (n, ref (ElabUtil.classifyDatatype xncs, xncs)), #2 d') - in - foldl (fn ((x, n, to), ctx) => - let - val t = case to of - NONE => t - | SOME t' => (TFun (t', t), #2 d') - in - bind (ctx, NamedE (x, n, t, NONE, "")) - end) - ctx xncs - end + DDatatype dts => + foldl (fn ((x, n, xncs), ctx) => + let + val ctx = bind (ctx, Datatype (x, n, xncs)) + val t = (TDatatype (n, ref (ElabUtil.classifyDatatype xncs, xncs)), + #2 d') + in + foldl (fn ((x, n, to), ctx) => + let + val t = case to of + NONE => t + | SOME t' => (TFun (t', t), #2 d') + in + bind (ctx, NamedE (x, n, t, NONE, "")) + end) + ctx xncs + end) ctx dts | DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s)) | DValRec vis => foldl (fn ((x, n, t, e, s), ctx) => bind (ctx, NamedE (x, n, t, NONE, s))) ctx vis @@ -631,9 +635,10 @@ fun fold {typ, exp, decl} s d = val maxName = foldl (fn ((d, _) : decl, count) => case d of - DDatatype (_, n, ns) => - foldl (fn ((_, n', _), m) => Int.max (n', m)) - (Int.max (n, count)) ns + DDatatype dts => + foldl (fn ((_, n, ns), count) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + (Int.max (n, count)) ns) count dts | DVal (_, n, _, _, _) => Int.max (n, count) | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis | DExport _ => count diff --git a/src/monoize.sml b/src/monoize.sml index e4175015..50bd04e8 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3045,27 +3045,30 @@ fun monoDecl (env, fm) (all as (d, loc)) = in case d of L.DCon _ => NONE - | L.DDatatype _ => raise Fail "Monoize DDatatype" - (*| L.DDatatype (x, n, [], xncs) => + | L.DDatatype [("list", n, [_], [("Nil", _, NONE), + ("Cons", _, SOME (L.TRecord (L.CRecord (_, + [((L.CName "1", _), + (L.CRel 0, _)), + ((L.CName "2", _), + (L.CApp ((L.CNamed n', _), + (L.CRel 0, _)), + _))]), _), _))])] => + if n = n' then + NONE + else + poly () + | L.DDatatype dts => let val env' = Env.declBinds env all - val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env') to)) xncs), loc) + val dts = map (fn (x, n, [], xncs) => + (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env') to)) xncs) + | _ => (E.errorAt loc "Polymorphic datatype needed too late"; + Print.eprefaces' [("Declaration", CorePrint.p_decl env all)]; + ("", 0, []))) dts + val d = (L'.DDatatype dts, loc) in SOME (env', fm, [d]) end - | L.DDatatype ("list", n, [_], [("Nil", _, NONE), - ("Cons", _, SOME (L.TRecord (L.CRecord (_, - [((L.CName "1", _), - (L.CRel 0, _)), - ((L.CName "2", _), - (L.CApp ((L.CNamed n', _), - (L.CRel 0, _)), - _))]), _), _))]) => - if n = n' then - NONE - else - poly () - | L.DDatatype _ => poly ()*) | L.DVal (x, n, t, e, s) => let val (e, fm) = monoExp (env, St.empty, fm) e -- cgit v1.2.3 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 (limited to 'src/mono_env.sml') 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 From 6179a09d47c5af4db1ac41d00b8cb7ec36741c3e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 15 Dec 2009 10:19:05 -0500 Subject: Convert to task syntax --- CHANGELOG | 2 +- lib/ur/basis.urs | 6 ++++++ src/cjr.sml | 4 +++- src/cjr_env.sml | 2 +- src/cjr_print.sml | 4 ++-- src/cjrize.sml | 10 +++++++--- src/core.sml | 2 +- src/core_env.sml | 2 +- src/core_print.sml | 8 ++++++-- src/core_util.sml | 14 ++++++++------ src/corify.sml | 6 +++--- src/elab.sml | 2 +- src/elab_env.sml | 2 +- src/elab_print.sml | 8 ++++++-- src/elab_util.sml | 14 ++++++++------ src/elaborate.sml | 18 +++++++++++------- src/elisp/urweb-defs.el | 6 +++--- src/elisp/urweb-mode.el | 4 ++-- src/expl.sml | 2 +- src/expl_env.sml | 2 +- src/expl_print.sml | 8 ++++++-- src/explify.sml | 2 +- src/mono.sml | 2 +- src/mono_env.sml | 2 +- src/mono_print.sml | 8 ++++++-- src/mono_shake.sml | 6 +++--- src/mono_util.sml | 14 ++++++++------ src/monoize.sml | 7 ++++--- src/prepare.sml | 4 ++-- src/reduce.sml | 7 ++++--- src/reduce_local.sml | 2 +- src/shake.sml | 6 +++--- src/source.sml | 2 +- src/source_print.sml | 8 ++++++-- src/unnest.sml | 2 +- src/urweb.grm | 4 ++-- src/urweb.lex | 2 +- tests/init.ur | 2 +- 38 files changed, 125 insertions(+), 81 deletions(-) (limited to 'src/mono_env.sml') diff --git a/CHANGELOG b/CHANGELOG index e1e14aea..ec2eda90 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -6,7 +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 +- Tasks ======== 20091203 diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index f7e098d4..f550ce67 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -757,3 +757,9 @@ val onDisconnect : transaction unit -> transaction unit val onServerError : (string -> transaction unit) -> transaction unit val show_xml : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> show (xml ctx use bind) + + +(** Tasks *) + +type task_kind +val initialize : task_kind diff --git a/src/cjr.sml b/src/cjr.sml index 9be54670..f5392d49 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -100,6 +100,8 @@ datatype exp' = withtype exp = exp' located +datatype task = Initialize + datatype decl' = DStruct of int * (string * typ) list | DDatatype of (datatype_kind * string * int * (string * int * typ option) list) list @@ -118,7 +120,7 @@ datatype decl' = | DCookie of string | DStyle of string - | DInitializer of exp + | DTask of task * exp withtype decl = decl' located diff --git a/src/cjr_env.sml b/src/cjr_env.sml index e4d978d5..ac83f263 100644 --- a/src/cjr_env.sml +++ b/src/cjr_env.sml @@ -171,6 +171,6 @@ fun declBinds env (d, loc) = | DJavaScript _ => env | DCookie _ => env | DStyle _ => env - | DInitializer _ => env + | DTask _ => env end diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 6a5116ce..2d547519 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -2099,7 +2099,7 @@ fun p_decl env (dAll as (d, _) : decl) = space, string "*/"] - | DInitializer _ => box [] + | DTask _ => box [] datatype 'a search = Found of 'a @@ -2733,7 +2733,7 @@ fun p_file env (ds, ps) = string "}", newline] - val initializers = List.mapPartial (fn (DInitializer e, _) => SOME e | _ => NONE) ds + val initializers = List.mapPartial (fn (DTask (Initialize, e), _) => SOME e | _ => NONE) ds in box [string "#include ", newline, diff --git a/src/cjrize.sml b/src/cjrize.sml index 3936f6a5..0136bdf6 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -660,13 +660,17 @@ 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.DTask (e1, e2) => + (case #1 e2 of L.EAbs (_, _, _, e) => let + val tk = case #1 e1 of + L.EFfi ("Basis", "initialize") => L'.Initialize + | _ => (ErrorMsg.errorAt loc "Task kind not fully determined"; + L'.Initialize) val (e, sm) = cifyExp (e, sm) in - (SOME (L'.DInitializer e, loc), NONE, sm) + (SOME (L'.DTask (tk, e), loc), NONE, sm) end | _ => (ErrorMsg.errorAt loc "Initializer has not been fully determined"; (NONE, NONE, sm))) diff --git a/src/core.sml b/src/core.sml index a60bfd3b..78a1eded 100644 --- a/src/core.sml +++ b/src/core.sml @@ -134,7 +134,7 @@ datatype decl' = | DDatabase of string | DCookie of string * int * con * string | DStyle of string * int * string - | DInitializer of exp + | DTask of exp * exp withtype decl = decl' located diff --git a/src/core_env.sml b/src/core_env.sml index 5e0af98c..4c50bdd7 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -348,7 +348,7 @@ fun declBinds env (d, loc) = in pushENamed env x n t NONE s end - | DInitializer _ => env + | DTask _ => env fun patBinds env (p, loc) = case p of diff --git a/src/core_print.sml b/src/core_print.sml index 7dd43d56..c1f93587 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -611,9 +611,13 @@ fun p_decl env (dAll as (d, _) : decl) = string "as", space, string s] - | DInitializer e => box [string "initializer", + | DTask (e1, e2) => box [string "task", space, - p_exp env e] + p_exp env e1, + space, + string "=", + space, + p_exp env e2] fun p_file env file = let diff --git a/src/core_util.sml b/src/core_util.sml index 7ead1157..599e1abc 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -971,10 +971,12 @@ 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)) + | DTask (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (DTask (e1', e2'), loc))) and mfvi ctx (x, n, t, e, s) = S.bind2 (mfc ctx t, @@ -1129,7 +1131,7 @@ fun mapfoldB (all as {bind, ...}) = in bind (ctx, NamedE (x, n, t, NONE, s)) end - | DInitializer _ => ctx + | DTask _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -1193,7 +1195,7 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DDatabase _ => count | DCookie (_, n, _, _) => Int.max (n, count) | DStyle (_, n, _) => Int.max (n, count) - | DInitializer _ => count) 0 + | DTask _ => count) 0 end diff --git a/src/corify.sml b/src/corify.sml index cc0500af..9259b4f2 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -1064,8 +1064,8 @@ 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) + | L.DTask (e1, e2) => + ([(L'.DTask (corifyExp st e1, corifyExp st e2), loc)], st) and corifyStr mods ((str, _), st) = case str of @@ -1124,7 +1124,7 @@ fun maxName ds = foldl (fn ((d, _), n) => | L.DDatabase _ => n | L.DCookie (_, _, n', _) => Int.max (n, n') | L.DStyle (_, _, n') => Int.max (n, n') - | L.DInitializer _ => n) + | L.DTask _ => n) 0 ds and maxNameStr (str, _) = diff --git a/src/elab.sml b/src/elab.sml index 1cd7aefa..a0f9a4e8 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -170,7 +170,7 @@ datatype decl' = | DDatabase of string | DCookie of int * string * int * con | DStyle of int * string * int - | DInitializer of exp + | DTask of exp * exp and str' = StrConst of decl list diff --git a/src/elab_env.sml b/src/elab_env.sml index 763cf801..5092c6fb 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1622,6 +1622,6 @@ fun declBinds env (d, loc) = in pushENamedAs env x n t end - | DInitializer _ => env + | DTask _ => env end diff --git a/src/elab_print.sml b/src/elab_print.sml index 906c836d..62b5262f 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -799,9 +799,13 @@ fun p_decl env (dAll as (d, _) : decl) = | DStyle (_, x, n) => box [string "style", space, p_named x n] - | DInitializer e => box [string "initializer", + | DTask (e1, e2) => box [string "task", space, - p_exp env e] + p_exp env e1, + space, + string "=", + space, + p_exp env e2] and p_str env (str, _) = case str of diff --git a/src/elab_util.sml b/src/elab_util.sml index 2a044e71..d0e140c5 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -854,7 +854,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f c), loc))) | DStyle (tn, x, n) => bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc))) - | DInitializer _ => ctx, + | DTask _ => ctx, mfd ctx d)) ctx ds, fn ds' => (StrConst ds', loc)) | StrVar _ => S.return2 strAll @@ -979,10 +979,12 @@ 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)) + | DTask (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (DTask (e1', e2'), loc))) and mfvi ctx (x, n, c, e) = S.bind2 (mfc ctx c, @@ -1125,7 +1127,7 @@ and maxNameDecl (d, _) = | DDatabase _ => 0 | DCookie (n1, _, n2, _) => Int.max (n1, n2) | DStyle (n1, _, n2) => Int.max (n1, n2) - | DInitializer _ => 0 + | DTask _ => 0 and maxNameStr (str, _) = case str of StrConst ds => maxName ds diff --git a/src/elaborate.sml b/src/elaborate.sml index d1b9648a..2a237c50 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2548,7 +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 _ => [] + | L'.DTask _ => [] and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), @@ -3669,14 +3669,18 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = in ([(L'.DStyle (!basis_r, x, n), loc)], (env, denv, gs)) end - | L.DInitializer e => + | L.DTask (e1, e2) => 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) + val (e1', t1, gs1) = elabExp (env, denv) e1 + val (e2', t2, gs2) = elabExp (env, denv) e2 + + val t1' = (L'.CModProj (!basis_r, [], "task_kind"), loc) + val t2' = (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' @ gs)) + checkCon env e1' t1 t1'; + checkCon env e2' t2 t2'; + ([(L'.DTask (e1', e2'), loc)], (env, denv, gs2 @ gs1 @ gs)) end (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) diff --git a/src/elisp/urweb-defs.el b/src/elisp/urweb-defs.el index bb0e257d..c697a274 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" "initializer") + "table" "sequence" "class" "cookie" "task") "Symbols starting an sexp.") ;; (defconst urweb-not-arg-start-re @@ -135,7 +135,7 @@ notion of \"the end of an outline\".") (("case" "datatype" "if" "then" "else" "let" "open" "sig" "struct" "type" "val" "con" "constraint" "table" "sequence" "class" "cookie" - "initializer"))))) + "task"))))) (defconst urweb-starters-indent-after (urweb-syms-re "let" "in" "struct" "sig") @@ -190,7 +190,7 @@ for all symbols and in all lines starting with the given symbol." '("datatype" "fun" "open" "type" "val" "and" "con" "constraint" "table" "sequence" "class" "cookie" - "initializer")) + "task")) "The starters of new expressions.") (defconst urweb-exptrail-syms diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index ab274f22..107ea3bc 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" "initializer" + "rec" "sequence" "sig" "signature" "cookie" "style" "task" "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\\|initializer\$\\s-+\$\\sw+\\>\\s-*\$?\$\\sw+\$\\s-*[=:]" + ("\\<\$val\\|table\\|sequence\\|cookie\\|style\\|task\$\\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 eb79e2b0..17797626 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -147,7 +147,7 @@ datatype decl' = | DDatabase of string | DCookie of int * string * int * con | DStyle of int * string * int - | DInitializer of exp + | DTask of exp * exp and str' = StrConst of decl list diff --git a/src/expl_env.sml b/src/expl_env.sml index f16eeb8e..0bf7323f 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -343,7 +343,7 @@ fun declBinds env (d, loc) = in pushENamed env x n t end - | DInitializer _ => env + | DTask _ => env fun sgiBinds env (sgi, loc) = case sgi of diff --git a/src/expl_print.sml b/src/expl_print.sml index 624afa63..5284eecb 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -713,9 +713,13 @@ fun p_decl env (dAll as (d, _) : decl) = | DStyle (_, x, n) => box [string "style", space, p_named x n] - | DInitializer e => box [string "initializer", + | DTask (e1, e2) => box [string "task", space, - p_exp env e] + p_exp env e1, + space, + string "=", + space, + p_exp env e2] and p_str env (str, _) = case str of diff --git a/src/explify.sml b/src/explify.sml index d66b3530..aff91a34 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -195,7 +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) + | L.DTask (e1, e2) => SOME (L'.DTask (explifyExp e1, explifyExp e2), loc) and explifyStr (str, loc) = case str of diff --git a/src/mono.sml b/src/mono.sml index 1962c6c5..e5e68bfa 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -139,7 +139,7 @@ datatype decl' = | DCookie of string | DStyle of string - | DInitializer of exp + | DTask of exp * exp withtype decl = decl' located diff --git a/src/mono_env.sml b/src/mono_env.sml index 6ffab153..c2e6cf02 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -129,7 +129,7 @@ fun declBinds env (d, loc) = | DJavaScript _ => env | DCookie _ => env | DStyle _ => env - | DInitializer _ => env + | DTask _ => env fun patBinds env (p, loc) = case p of diff --git a/src/mono_print.sml b/src/mono_print.sml index 13c45329..da34c220 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -491,9 +491,13 @@ fun p_decl env (dAll as (d, _) : decl) = | DStyle s => box [string "style", space, string s] - | DInitializer e => box [string "initializer", + | DTask (e1, e2) => box [string "task", space, - p_exp env e] + p_exp env e1, + space, + string "=", + space, + p_exp env e2] fun p_file env file = diff --git a/src/mono_shake.sml b/src/mono_shake.sml index fc46cf96..048cc190 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -57,7 +57,7 @@ fun shake file = (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 + | ((DTask (e1, e2), _), st) => usedVars (usedVars st e2) e1 | (_, st) => st) (IS.empty, IS.empty) file val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) => @@ -74,7 +74,7 @@ fun shake file = | ((DJavaScript _, _), acc) => acc | ((DCookie _, _), acc) => acc | ((DStyle _, _), acc) => acc - | ((DInitializer _, _), acc) => acc) + | ((DTask _, _), acc) => acc) (IM.empty, IM.empty) file fun typ (c, s) = @@ -141,7 +141,7 @@ fun shake file = | (DJavaScript _, _) => true | (DCookie _, _) => true | (DStyle _, _) => true - | (DInitializer _, _) => true) file + | (DTask _, _) => true) file end end diff --git a/src/mono_util.sml b/src/mono_util.sml index 184ce168..894e35d0 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -528,10 +528,12 @@ 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)) + | DTask (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (DTask (e1', e2'), loc))) and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, @@ -618,7 +620,7 @@ fun mapfoldB (all as {bind, ...}) = | DJavaScript _ => ctx | DCookie _ => ctx | DStyle _ => ctx - | DInitializer _ => ctx + | DTask _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -672,7 +674,7 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DJavaScript _ => count | DCookie _ => count | DStyle _ => count - | DInitializer _ => count) 0 + | DTask _ => count) 0 end diff --git a/src/monoize.sml b/src/monoize.sml index 503fd6b3..f6a56c33 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3478,13 +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 => + | L.DTask (e1, e2) => let - val (e, fm) = monoExp (env, St.empty, fm) e + val (e1, fm) = monoExp (env, St.empty, fm) e1 + val (e2, fm) = monoExp (env, St.empty, fm) e2 in SOME (env, fm, - [(L'.DInitializer e, loc)]) + [(L'.DTask (e1, e2), loc)]) end end diff --git a/src/prepare.sml b/src/prepare.sml index 7cbd7d76..2d144c67 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -325,11 +325,11 @@ fun prepDecl (d as (_, loc), st) = | DJavaScript _ => (d, st) | DCookie _ => (d, st) | DStyle _ => (d, st) - | DInitializer e => + | DTask (tk, e) => let val (e, st) = prepExp (e, st) in - ((DInitializer e, loc), st) + ((DTask (tk, e), loc), st) end fun prepare (ds, ps) = diff --git a/src/reduce.sml b/src/reduce.sml index cedb79fa..95b26da8 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -804,11 +804,12 @@ 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 => + | DTask (e1, e2) => let - val e = exp (namedC, namedE) [] e + val e1 = exp (namedC, namedE) [] e1 + val e2 = exp (namedC, namedE) [] e2 in - ((DInitializer e, loc), + ((DTask (e1, e2), loc), (polyC, namedC, namedE)) diff --git a/src/reduce_local.sml b/src/reduce_local.sml index 82490118..b040a1ec 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -251,7 +251,7 @@ fun reduce file = | DDatabase _ => d | DCookie _ => d | DStyle _ => d - | DInitializer e => (DInitializer (exp [] e), loc) + | DTask (e1, e2) => (DTask (exp [] e1, exp [] e2), loc) in map doDecl file end diff --git a/src/shake.sml b/src/shake.sml index 787500ea..d1810bea 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -79,7 +79,7 @@ fun shake file = in (usedE, usedC) end - | ((DInitializer e, _), st) => usedVars st e + | ((DTask (e1, e2), _), st) => usedVars (usedVars st e1) e2 | (_, acc) => acc) (IS.empty, IS.empty) file val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef) @@ -106,7 +106,7 @@ fun shake file = (cdef, IM.insert (edef, n, ([], c, dummye))) | ((DStyle (_, n, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], dummyt, dummye))) - | ((DInitializer _, _), acc) => acc) + | ((DTask _, _), acc) => acc) (IM.empty, IM.empty) file fun kind (_, s) = s @@ -186,7 +186,7 @@ fun shake file = | (DDatabase _, _) => true | (DCookie _, _) => true | (DStyle _, _) => true - | (DInitializer _, _) => true) file + | (DTask _, _) => true) file end end diff --git a/src/source.sml b/src/source.sml index e52872f0..dc867026 100644 --- a/src/source.sml +++ b/src/source.sml @@ -167,7 +167,7 @@ datatype decl' = | DDatabase of string | DCookie of string * con | DStyle of string - | DInitializer of exp + | DTask of exp * exp and str' = StrConst of decl list diff --git a/src/source_print.sml b/src/source_print.sml index 31fc2500..e3b4fe94 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -662,9 +662,13 @@ fun p_decl ((d, _) : decl) = | DStyle x => box [string "style", space, string x] - | DInitializer e => box [string "initializer", + | DTask (e1, e2) => box [string "task", space, - p_exp e] + p_exp e1, + space, + string "=", + space, + p_exp e2] and p_str (str, _) = case str of diff --git a/src/unnest.sml b/src/unnest.sml index c4d9a8b5..e030bbc6 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -422,7 +422,7 @@ fun unnest file = | DDatabase _ => default () | DCookie _ => default () | DStyle _ => default () - | DInitializer _ => explore () + | DTask _ => explore () end and doStr (all as (str, loc), st) = diff --git a/src/urweb.grm b/src/urweb.grm index 8780d9f6..afe7be07 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 | INITIALIZER + | COOKIE | STYLE | TASK | CASE | IF | THEN | ELSE | ANDALSO | ORELSE | XML_BEGIN of string | XML_END | XML_BEGIN_END of string @@ -479,7 +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))]) + | TASK eapps EQ eexp ([(DTask (eapps, eexp), s (TASKleft, eexpright))]) dtype : SYMBOL dargs EQ barOpt dcons (SYMBOL, dargs, dcons) diff --git a/src/urweb.lex b/src/urweb.lex index d04822f7..5fb767b1 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -402,7 +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)); + "task" => (Tokens.TASK (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 index 0a44a9e4..aafbb55f 100644 --- a/tests/init.ur +++ b/tests/init.ur @@ -1,6 +1,6 @@ sequence seq table fred : {A : int, B : int} -initializer +task initialize = setval seq 1; dml (INSERT INTO fred (A, B) VALUES (0, 1)) -- cgit v1.2.3 From 6a326e3bb3eb16e04f3cca082f0dd67278e85785 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 4 Apr 2010 12:29:34 -0400 Subject: Pushing policies through --- lib/ur/basis.urs | 9 +++++++++ src/cjrize.sml | 1 + src/core.sml | 1 + src/core_env.sml | 1 + src/core_print.sml | 3 +++ src/core_util.sml | 8 +++++++- src/corify.sml | 6 +++++- src/css.sml | 1 + 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 | 6 +++--- 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/mono.sml | 6 +++++- src/mono_env.sml | 1 + src/mono_print.sml | 9 +++++++++ src/mono_shake.sml | 13 +++++++++++-- src/mono_util.sml | 14 +++++++++++++- src/monoize.sml | 14 ++++++++++++++ src/reduce.sml | 9 +++++++++ src/reduce_local.sml | 1 + src/shake.sml | 11 +++++++++-- src/source.sml | 1 + src/source_print.sml | 3 +++ src/unnest.sml | 1 + src/urweb.grm | 3 ++- src/urweb.lex | 1 + tests/policy.ur | 3 +++ tests/policy.urp | 1 + 35 files changed, 145 insertions(+), 15 deletions(-) create mode 100644 tests/policy.ur create mode 100644 tests/policy.urp (limited to 'src/mono_env.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 8388e107..aad04b5f 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -795,4 +795,13 @@ type task_kind val initialize : task_kind +(** Information flow security *) + +type sql_policy + +val query_policy : tables ::: {{Type}} -> exps ::: {Type} + -> [tables ~ exps] => sql_query [] tables exps + -> sql_policy + + val debug : string -> transaction unit diff --git a/src/cjrize.sml b/src/cjrize.sml index 6e41a69b..b98b3c25 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -674,6 +674,7 @@ fun cifyDecl ((d, loc), sm) = end | _ => (ErrorMsg.errorAt loc "Initializer has not been fully determined"; (NONE, NONE, sm))) + | L.DPolicy _ => (NONE, NONE, sm) fun cjrize ds = let diff --git a/src/core.sml b/src/core.sml index 90005f16..e5358f48 100644 --- a/src/core.sml +++ b/src/core.sml @@ -135,6 +135,7 @@ datatype decl' = | DCookie of string * int * con * string | DStyle of string * int * string | DTask of exp * exp + | DPolicy of exp withtype decl = decl' located diff --git a/src/core_env.sml b/src/core_env.sml index 9001e29c..478ef495 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -349,6 +349,7 @@ fun declBinds env (d, loc) = pushENamed env x n t NONE s end | DTask _ => env + | DPolicy _ => env fun patBinds env (p, loc) = case p of diff --git a/src/core_print.sml b/src/core_print.sml index d6be76a3..fd0556e6 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -618,6 +618,9 @@ fun p_decl env (dAll as (d, _) : decl) = string "=", space, p_exp env e2] + | DPolicy e1 => box [string "policy", + space, + p_exp env e1] fun p_file env file = let diff --git a/src/core_util.sml b/src/core_util.sml index 247dd32e..eedcd2bb 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -992,6 +992,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} = S.map2 (mfe ctx e2, fn e2' => (DTask (e1', e2'), loc))) + | DPolicy e => + S.map2 (mfe ctx e, + fn e' => + (DPolicy e', loc)) and mfvi ctx (x, n, t, e, s) = S.bind2 (mfc ctx t, @@ -1147,6 +1151,7 @@ fun mapfoldB (all as {bind, ...}) = bind (ctx, NamedE (x, n, t, NONE, s)) end | DTask _ => ctx + | DPolicy _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -1210,7 +1215,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DDatabase _ => count | DCookie (_, n, _, _) => Int.max (n, count) | DStyle (_, n, _) => Int.max (n, count) - | DTask _ => count) 0 + | DTask _ => count + | DPolicy _ => count) 0 end diff --git a/src/corify.sml b/src/corify.sml index 6931600e..88473455 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -1080,6 +1080,9 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = | L.DTask (e1, e2) => ([(L'.DTask (corifyExp st e1, corifyExp st e2), loc)], st) + | L.DPolicy e1 => + ([(L'.DPolicy (corifyExp st e1), loc)], st) + and corifyStr mods ((str, _), st) = case str of L.StrConst ds => @@ -1137,7 +1140,8 @@ fun maxName ds = foldl (fn ((d, _), n) => | L.DDatabase _ => n | L.DCookie (_, _, n', _) => Int.max (n, n') | L.DStyle (_, _, n') => Int.max (n, n') - | L.DTask _ => n) + | L.DTask _ => n + | L.DPolicy _ => n) 0 ds and maxNameStr (str, _) = diff --git a/src/css.sml b/src/css.sml index 7189904f..3df35ed1 100644 --- a/src/css.sml +++ b/src/css.sml @@ -287,6 +287,7 @@ fun summarize file = | DCookie _ => st | DStyle (_, n, s) => (IM.insert (globals, n, (SOME s, [])), classes) | DTask _ => st + | DPolicy _ => st end val (globals, classes) = foldl decl (IM.empty, IM.empty) file diff --git a/src/elab.sml b/src/elab.sml index a0f9a4e8..e040a059 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -171,6 +171,7 @@ datatype decl' = | DCookie of int * string * int * con | DStyle of int * string * int | DTask of exp * exp + | DPolicy of exp and str' = StrConst of decl list diff --git a/src/elab_env.sml b/src/elab_env.sml index 5092c6fb..dd050c9e 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1623,5 +1623,6 @@ fun declBinds env (d, loc) = pushENamedAs env x n t end | DTask _ => env + | DPolicy _ => env end diff --git a/src/elab_print.sml b/src/elab_print.sml index 62b5262f..86448659 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -806,6 +806,9 @@ fun p_decl env (dAll as (d, _) : decl) = string "=", space, p_exp env e2] + | DPolicy e1 => box [string "policy", + space, + p_exp env e1] and p_str env (str, _) = case str of diff --git a/src/elab_util.sml b/src/elab_util.sml index d0e140c5..8345e3f3 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -854,7 +854,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f c), loc))) | DStyle (tn, x, n) => bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc))) - | DTask _ => ctx, + | DTask _ => ctx + | DPolicy _ => ctx, mfd ctx d)) ctx ds, fn ds' => (StrConst ds', loc)) | StrVar _ => S.return2 strAll @@ -985,6 +986,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f S.map2 (mfe ctx e2, fn e2' => (DTask (e1', e2'), loc))) + | DPolicy e1 => + S.map2 (mfe ctx e1, + fn e1' => + (DPolicy e1', loc)) and mfvi ctx (x, n, c, e) = S.bind2 (mfc ctx c, @@ -1128,6 +1133,7 @@ and maxNameDecl (d, _) = | DCookie (n1, _, n2, _) => Int.max (n1, n2) | DStyle (n1, _, n2) => Int.max (n1, n2) | DTask _ => 0 + | DPolicy _ => 0 and maxNameStr (str, _) = case str of StrConst ds => maxName ds diff --git a/src/elaborate.sml b/src/elaborate.sml index 1651f344..07818a57 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2595,6 +2595,7 @@ and sgiOfDecl (d, loc) = | 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'.DTask _ => [] + | L'.DPolicy _ => [] and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), @@ -3729,6 +3730,15 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = checkCon env e2' t2 t2'; ([(L'.DTask (e1', e2'), loc)], (env, denv, gs2 @ gs1 @ gs)) end + | L.DPolicy e1 => + let + val (e1', t1, gs1) = elabExp (env, denv) e1 + + val t1' = (L'.CModProj (!basis_r, [], "sql_policy"), loc) + in + checkCon env e1' t1 t1'; + ([(L'.DPolicy e1', loc)], (env, denv, gs1 @ 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 c697a274..8054d829 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" "task") + "table" "sequence" "class" "cookie" "task" "policy") "Symbols starting an sexp.") ;; (defconst urweb-not-arg-start-re @@ -135,7 +135,7 @@ notion of \"the end of an outline\".") (("case" "datatype" "if" "then" "else" "let" "open" "sig" "struct" "type" "val" "con" "constraint" "table" "sequence" "class" "cookie" - "task"))))) + "task" "policy"))))) (defconst urweb-starters-indent-after (urweb-syms-re "let" "in" "struct" "sig") @@ -190,7 +190,7 @@ for all symbols and in all lines starting with the given symbol." '("datatype" "fun" "open" "type" "val" "and" "con" "constraint" "table" "sequence" "class" "cookie" - "task")) + "task" "policy")) "The starters of new expressions.") (defconst urweb-exptrail-syms diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index 107ea3bc..c9fe5f19 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" "task" + "rec" "sequence" "sig" "signature" "cookie" "style" "task" "policy" "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\\|task\$\\s-+\$\\sw+\\>\\s-*\$?\$\\sw+\$\\s-*[=:]" + ("\\<\$val\\|table\\|sequence\\|cookie\\|style\\|task\\|policy\$\\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 17797626..1212383f 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -148,6 +148,7 @@ datatype decl' = | DCookie of int * string * int * con | DStyle of int * string * int | DTask of exp * exp + | DPolicy of exp and str' = StrConst of decl list diff --git a/src/expl_env.sml b/src/expl_env.sml index 0bf7323f..583e4881 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -344,6 +344,7 @@ fun declBinds env (d, loc) = pushENamed env x n t end | DTask _ => env + | DPolicy _ => env fun sgiBinds env (sgi, loc) = case sgi of diff --git a/src/expl_print.sml b/src/expl_print.sml index 5284eecb..15838729 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -720,6 +720,9 @@ fun p_decl env (dAll as (d, _) : decl) = string "=", space, p_exp env e2] + | DPolicy e1 => box [string "policy", + space, + p_exp env e1] and p_str env (str, _) = case str of diff --git a/src/explify.sml b/src/explify.sml index aff91a34..0013906f 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -196,6 +196,7 @@ fun explifyDecl (d, loc : EM.span) = | 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.DTask (e1, e2) => SOME (L'.DTask (explifyExp e1, explifyExp e2), loc) + | L.DPolicy e1 => SOME (L'.DPolicy (explifyExp e1), loc) and explifyStr (str, loc) = case str of diff --git a/src/mono.sml b/src/mono.sml index 898feb9b..33ab5bd4 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008-2010, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -123,6 +123,8 @@ datatype exp' = withtype exp = exp' located +datatype policy = PolQuery of exp + datatype decl' = DDatatype of (string * int * (string * int * typ option) list) list | DVal of string * int * typ * exp * string @@ -141,6 +143,8 @@ datatype decl' = | DTask of exp * exp + | DPolicy of policy + withtype decl = decl' located type file = decl list diff --git a/src/mono_env.sml b/src/mono_env.sml index c2e6cf02..87f96488 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -130,6 +130,7 @@ fun declBinds env (d, loc) = | DCookie _ => env | DStyle _ => env | DTask _ => env + | DPolicy _ => env fun patBinds env (p, loc) = case p of diff --git a/src/mono_print.sml b/src/mono_print.sml index d1f5fc27..50c4717a 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -412,6 +412,12 @@ fun p_datatype env (x, n, cons) = cons] end +fun p_policy env pol = + case pol of + PolQuery e => box [string "query", + space, + p_exp env e] + fun p_decl env (dAll as (d, _) : decl) = case d of DDatatype x => box [string "datatype", @@ -506,6 +512,9 @@ fun p_decl env (dAll as (d, _) : decl) = string "=", space, p_exp env e2] + | DPolicy p => box [string "policy", + space, + p_policy env p] fun p_file env file = diff --git a/src/mono_shake.sml b/src/mono_shake.sml index e53b6930..358b31d2 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -58,6 +58,13 @@ fun shake file = | ((DDatabase {expunge = n1, initialize = n2, ...}, _), (page_cs, page_es)) => (page_cs, IS.addList (page_es, [n1, n2])) | ((DTask (e1, e2), _), st) => usedVars (usedVars st e2) e1 + | ((DPolicy pol, _), st) => + let + val e1 = case pol of + PolQuery e1 => e1 + in + usedVars st e1 + end | (_, st) => st) (IS.empty, IS.empty) file val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) => @@ -74,7 +81,8 @@ fun shake file = | ((DJavaScript _, _), acc) => acc | ((DCookie _, _), acc) => acc | ((DStyle _, _), acc) => acc - | ((DTask _, _), acc) => acc) + | ((DTask _, _), acc) => acc + | ((DPolicy _, _), acc) => acc) (IM.empty, IM.empty) file fun typ (c, s) = @@ -141,7 +149,8 @@ fun shake file = | (DJavaScript _, _) => true | (DCookie _, _) => true | (DStyle _, _) => true - | (DTask _, _) => true) file + | (DTask _, _) => true + | (DPolicy _, _) => true) file end end diff --git a/src/mono_util.sml b/src/mono_util.sml index a75843c4..094f216b 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -534,6 +534,16 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = S.map2 (mfe ctx e2, fn e2' => (DTask (e1', e2'), loc))) + | DPolicy pol => + S.map2 (mfpol ctx pol, + fn p' => + (DPolicy p', loc)) + + and mfpol ctx pol = + case pol of + PolQuery e => + S.map2 (mfe ctx e, + PolQuery) and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, @@ -621,6 +631,7 @@ fun mapfoldB (all as {bind, ...}) = | DCookie _ => ctx | DStyle _ => ctx | DTask _ => ctx + | DPolicy _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -674,7 +685,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DJavaScript _ => count | DCookie _ => count | DStyle _ => count - | DTask _ => count) 0 + | DTask _ => count + | DPolicy _ => count) 0 end diff --git a/src/monoize.sml b/src/monoize.sml index 25ea87f5..6f229766 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3738,6 +3738,20 @@ fun monoDecl (env, fm) (all as (d, loc)) = fm, [(L'.DTask (e1, e2), loc)]) end + | L.DPolicy e => + let + val (e, make) = + case #1 e of + L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "query_policy"), _), _), _), _), _), e) => + (e, L'.PolQuery) + | _ => (poly (); (e, L'.PolQuery)) + + val (e, fm) = monoExp (env, St.empty, fm) e + in + SOME (env, + fm, + [(L'.DPolicy (make e), loc)]) + end end datatype expungable = Client | Channel diff --git a/src/reduce.sml b/src/reduce.sml index b7ad567a..cefe1955 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -746,6 +746,15 @@ fun reduce file = namedC, namedE)) end + | DPolicy e1 => + let + val e1 = exp (namedC, namedE) [] e1 + in + ((DPolicy e1, 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 b040a1ec..4c5ab52e 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -252,6 +252,7 @@ fun reduce file = | DCookie _ => d | DStyle _ => d | DTask (e1, e2) => (DTask (exp [] e1, exp [] e2), loc) + | DPolicy e1 => (DPolicy (exp [] e1), loc) in map doDecl file end diff --git a/src/shake.sml b/src/shake.sml index 686a043c..f679c6e8 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -90,6 +90,11 @@ fun shake file = st else usedVars (usedVars st e1) e2 + | ((DPolicy e1, _), st) => + if !sliceDb then + st + else + usedVars st e1 | (_, acc) => acc) (IS.empty, IS.empty) file val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef) @@ -116,7 +121,8 @@ fun shake file = (cdef, IM.insert (edef, n, ([], c, dummye))) | ((DStyle (_, n, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], dummyt, dummye))) - | ((DTask _, _), acc) => acc) + | ((DTask _, _), acc) => acc + | ((DPolicy _, _), acc) => acc) (IM.empty, IM.empty) file fun kind (_, s) = s @@ -203,7 +209,8 @@ fun shake file = | (DDatabase _, _) => not (!sliceDb) | (DCookie _, _) => not (!sliceDb) | (DStyle _, _) => not (!sliceDb) - | (DTask _, _) => not (!sliceDb)) file + | (DTask _, _) => not (!sliceDb) + | (DPolicy _, _) => not (!sliceDb)) file end end diff --git a/src/source.sml b/src/source.sml index dc867026..9768cfc0 100644 --- a/src/source.sml +++ b/src/source.sml @@ -168,6 +168,7 @@ datatype decl' = | DCookie of string * con | DStyle of string | DTask of exp * exp + | DPolicy of exp and str' = StrConst of decl list diff --git a/src/source_print.sml b/src/source_print.sml index e3b4fe94..590d15d5 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -669,6 +669,9 @@ fun p_decl ((d, _) : decl) = string "=", space, p_exp e2] + | DPolicy e1 => box [string "policy", + space, + p_exp e1] and p_str (str, _) = case str of diff --git a/src/unnest.sml b/src/unnest.sml index e030bbc6..77589bfb 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -423,6 +423,7 @@ fun unnest file = | DCookie _ => default () | DStyle _ => default () | DTask _ => explore () + | DPolicy _ => explore () end and doStr (all as (str, loc), st) = diff --git a/src/urweb.grm b/src/urweb.grm index ad3de6b2..3df9554f 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -202,7 +202,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 | TASK + | COOKIE | STYLE | TASK | POLICY | CASE | IF | THEN | ELSE | ANDALSO | ORELSE | XML_BEGIN of string | XML_END | XML_BEGIN_END of string @@ -481,6 +481,7 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let | COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))]) | STYLE SYMBOL ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))]) | TASK eapps EQ eexp ([(DTask (eapps, eexp), s (TASKleft, eexpright))]) + | POLICY eexp ([(DPolicy eexp, s (POLICYleft, eexpright))]) dtype : SYMBOL dargs EQ barOpt dcons (SYMBOL, dargs, dcons) diff --git a/src/urweb.lex b/src/urweb.lex index 45f555dd..8930c463 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -416,6 +416,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F]; "cookie" => (Tokens.COOKIE (pos yypos, pos yypos + size yytext)); "style" => (Tokens.STYLE (pos yypos, pos yypos + size yytext)); "task" => (Tokens.TASK (pos yypos, pos yypos + size yytext)); + "policy" => (Tokens.POLICY (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/policy.ur b/tests/policy.ur new file mode 100644 index 00000000..db87b582 --- /dev/null +++ b/tests/policy.ur @@ -0,0 +1,3 @@ +table fruit : { Id : int, Nam : string, Weight : float } + +policy query_policy (SELECT * FROM fruit) diff --git a/tests/policy.urp b/tests/policy.urp new file mode 100644 index 00000000..b26ebd4a --- /dev/null +++ b/tests/policy.urp @@ -0,0 +1 @@ +policy -- cgit v1.2.3 From 5545969f485ef2fb944db8e7b0237acbabeb8d4c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 7 Sep 2010 08:28:07 -0400 Subject: Server-side 'onError' --- include/types.h | 4 ++ include/urweb.h | 1 + src/c/request.c | 101 ++++++++++++++++++++++++++++++++------------------- src/c/urweb.c | 18 ++++++++- src/cjr.sml | 1 + src/cjr_env.sml | 1 + src/cjr_print.sml | 26 +++++++++++-- src/cjrize.sml | 1 + src/compiler.sig | 3 +- src/compiler.sml | 23 ++++++++++-- src/core.sml | 1 + src/core_env.sml | 1 + src/core_print.sml | 1 + src/core_util.sml | 6 ++- src/corify.sml | 14 ++++++- src/css.sml | 1 + src/demo.sml | 3 +- src/elab.sml | 1 + src/elab_env.sml | 1 + src/elab_print.sml | 1 + src/elab_util.sml | 5 ++- src/elaborate.sml | 27 ++++++++++++++ src/expl.sml | 1 + src/expl_env.sml | 1 + src/expl_print.sml | 1 + src/explify.sml | 3 +- src/mono.sml | 1 + src/mono_env.sml | 1 + src/mono_print.sml | 2 +- src/mono_shake.sml | 7 +++- src/mono_util.sml | 5 ++- src/monoize.sml | 3 ++ src/prepare.sml | 1 + src/reduce.sml | 1 + src/reduce_local.sml | 1 + src/settings.sig | 2 + src/settings.sml | 4 ++ src/shake.sml | 11 +++++- src/source.sml | 1 + src/source_print.sml | 1 + src/unnest.sml | 1 + tests/onerror.ur | 4 ++ tests/onerror.urp | 4 ++ tests/onerror.urs | 1 + tests/onerrorE.ur | 5 +++ 45 files changed, 244 insertions(+), 59 deletions(-) create mode 100644 tests/onerror.ur create mode 100644 tests/onerror.urp create mode 100644 tests/onerror.urs create mode 100644 tests/onerrorE.ur (limited to 'src/mono_env.sml') diff --git a/include/types.h b/include/types.h index 138760e5..ac70c34f 100644 --- a/include/types.h +++ b/include/types.h @@ -73,6 +73,10 @@ typedef struct { uw_Basis_string (*cookie_sig)(uw_context); int (*check_url)(const char *); int (*check_mime)(const char *); + + void (*on_error)(uw_context, char *); } uw_app; +#define ERROR_BUF_LEN 1024 + #endif diff --git a/include/urweb.h b/include/urweb.h index 32e9b4e1..f254da2a 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -36,6 +36,7 @@ failure_kind uw_begin_init(uw_context); void uw_set_on_success(char *); void uw_set_headers(uw_context, char *(*get_header)(void *, const char *), void *get_header_data); failure_kind uw_begin(uw_context, char *path); +failure_kind uw_begin_onError(uw_context, char *msg); void uw_login(uw_context); void uw_commit(uw_context); int uw_rollback(uw_context); diff --git a/src/c/request.c b/src/c/request.c index 5e57d7b0..f72a3199 100644 --- a/src/c/request.c +++ b/src/c/request.c @@ -131,6 +131,8 @@ request_result uw_request(uw_request_context rc, uw_context ctx, char *inputs; const char *prefix = uw_get_url_prefix(ctx); char *s; + int had_error = 0; + char errmsg[ERROR_BUF_LEN]; for (s = path; *s; ++s) { if (s[0] == '%' && s[1] == '2' && s[2] == '7') { @@ -336,32 +338,42 @@ request_result uw_request(uw_request_context rc, uw_context ctx, log_debug(logger_data, "Serving URI %s....\n", path); while (1) { - size_t path_len = strlen(path); + if (!had_error) { + size_t path_len = strlen(path); - on_success(ctx); + on_success(ctx); + + if (path_len + 1 > rc->path_copy_size) { + rc->path_copy_size = path_len + 1; + rc->path_copy = realloc(rc->path_copy, rc->path_copy_size); + } + strcpy(rc->path_copy, path); + fk = uw_begin(ctx, rc->path_copy); + } else + fk = uw_begin_onError(ctx, errmsg); - if (path_len + 1 > rc->path_copy_size) { - rc->path_copy_size = path_len + 1; - rc->path_copy = realloc(rc->path_copy, rc->path_copy_size); - } - strcpy(rc->path_copy, path); - fk = uw_begin(ctx, rc->path_copy); if (fk == SUCCESS || fk == RETURN_INDIRECTLY) { uw_commit(ctx); - if (uw_has_error(ctx)) { + if (uw_has_error(ctx) && !had_error) { log_error(logger_data, "Fatal error: %s\n", uw_error_message(ctx)); uw_reset_keep_error_message(ctx); on_failure(ctx); - uw_write_header(ctx, "Content-type: text/html\r\n"); - uw_write(ctx, "Fatal Error"); - uw_write(ctx, "Fatal error: "); - uw_write(ctx, uw_error_message(ctx)); - uw_write(ctx, "\n"); + + if (uw_get_app(ctx)->on_error) { + had_error = 1; + strcpy(errmsg, uw_error_message(ctx)); + } else { + uw_write_header(ctx, "Content-type: text/html\r\n"); + uw_write(ctx, "Fatal Error"); + uw_write(ctx, "Fatal error: "); + uw_write(ctx, uw_error_message(ctx)); + uw_write(ctx, "\n"); - return FAILED; + return FAILED; + } } else - return SERVED; + return had_error ? FAILED : SERVED; } else if (fk == BOUNDED_RETRY) { if (retries_left) { log_debug(logger_data, "Error triggers bounded retry: %s\n", uw_error_message(ctx)); @@ -372,14 +384,19 @@ request_result uw_request(uw_request_context rc, uw_context ctx, try_rollback(ctx, logger_data, log_error); - uw_reset_keep_error_message(ctx); - on_failure(ctx); - uw_write_header(ctx, "Content-type: text/plain\r\n"); - uw_write(ctx, "Fatal error (out of retries): "); - uw_write(ctx, uw_error_message(ctx)); - uw_write(ctx, "\n"); - - return FAILED; + if (!had_error && uw_get_app(ctx)->on_error) { + had_error = 1; + strcpy(errmsg, uw_error_message(ctx)); + } else { + uw_reset_keep_error_message(ctx); + on_failure(ctx); + uw_write_header(ctx, "Content-type: text/plain\r\n"); + uw_write(ctx, "Fatal error (out of retries): "); + uw_write(ctx, uw_error_message(ctx)); + uw_write(ctx, "\n"); + + return FAILED; + } } } else if (fk == UNLIMITED_RETRY) log_debug(logger_data, "Error triggers unlimited retry: %s\n", uw_error_message(ctx)); @@ -388,26 +405,36 @@ request_result uw_request(uw_request_context rc, uw_context ctx, try_rollback(ctx, logger_data, log_error); - uw_reset_keep_error_message(ctx); - on_failure(ctx); - uw_write_header(ctx, "Content-type: text/html\r\n"); - uw_write(ctx, "Fatal Error"); - uw_write(ctx, "Fatal error: "); - uw_write(ctx, uw_error_message(ctx)); - uw_write(ctx, "\n"); + if (uw_get_app(ctx)->on_error && !had_error) { + had_error = 1; + strcpy(errmsg, uw_error_message(ctx)); + } else { + uw_reset_keep_error_message(ctx); + on_failure(ctx); + uw_write_header(ctx, "Content-type: text/html\r\n"); + uw_write(ctx, "Fatal Error"); + uw_write(ctx, "Fatal error: "); + uw_write(ctx, uw_error_message(ctx)); + uw_write(ctx, "\n"); - return FAILED; + return FAILED; + } } else { log_error(logger_data, "Unknown uw_handle return code!\n"); try_rollback(ctx, logger_data, log_error); - uw_reset_keep_request(ctx); - on_failure(ctx); - uw_write_header(ctx, "Content-type: text/plain\r\n"); - uw_write(ctx, "Unknown uw_handle return code!\n"); + if (uw_get_app(ctx)->on_error && !had_error) { + had_error = 1; + strcpy(errmsg, "Unknown uw_handle return code"); + } else { + uw_reset_keep_request(ctx); + on_failure(ctx); + uw_write_header(ctx, "Content-type: text/plain\r\n"); + uw_write(ctx, "Unknown uw_handle return code!\n"); - return FAILED; + return FAILED; + } } if (try_rollback(ctx, logger_data, log_error)) diff --git a/src/c/urweb.c b/src/c/urweb.c index 74e1b12e..cac518ec 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -353,8 +353,6 @@ int uw_time = 0; // Single-request state -#define ERROR_BUF_LEN 1024 - typedef struct regions { struct regions *next; } regions; @@ -714,6 +712,22 @@ failure_kind uw_begin(uw_context ctx, char *path) { return r; } +failure_kind uw_begin_onError(uw_context ctx, char *msg) { + int r = setjmp(ctx->jmp_buf); + + if (ctx->app->on_error) { + if (r == 0) { + if (ctx->app->db_begin(ctx)) + uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN"); + + ctx->app->on_error(ctx, msg); + } + + return r; + } else + uw_error(ctx, FATAL, "Tried to run nonexistent onError handler"); +} + uw_Basis_client uw_Basis_self(uw_context ctx) { if (ctx->client == NULL) uw_error(ctx, FATAL, "Call to Basis.self() from page that has only server-side code"); diff --git a/src/cjr.sml b/src/cjr.sml index f34662dc..5013033f 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -124,6 +124,7 @@ datatype decl' = | DStyle of string | DTask of task * exp + | DOnError of int withtype decl = decl' located diff --git a/src/cjr_env.sml b/src/cjr_env.sml index ac83f263..21188b51 100644 --- a/src/cjr_env.sml +++ b/src/cjr_env.sml @@ -172,5 +172,6 @@ fun declBinds env (d, loc) = | DCookie _ => env | DStyle _ => env | DTask _ => env + | DOnError _ => env end diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 7331196f..9b5edab5 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -113,9 +113,11 @@ and p_typ env = p_typ' false env fun p_rel env n = string ("__uwr_" ^ ident (#1 (E.lookupERel env n)) ^ "_" ^ Int.toString (E.countERels env - n - 1)) handle CjrEnv.UnboundRel _ => string ("__uwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1)) -fun p_enamed env n = - string ("__uwn_" ^ ident (#1 (E.lookupENamed env n)) ^ "_" ^ Int.toString n) - handle CjrEnv.UnboundNamed _ => string ("__uwn_UNBOUND_" ^ Int.toString n) +fun p_enamed' env n = + "__uwn_" ^ ident (#1 (E.lookupENamed env n)) ^ "_" ^ Int.toString n + handle CjrEnv.UnboundNamed _ => "__uwn_UNBOUND_" ^ Int.toString n + +fun p_enamed env n = string (p_enamed' env n) fun p_con_named env n = string ("__uwc_" ^ ident (#1 (E.lookupConstructor env n)) ^ "_" ^ Int.toString n) @@ -2156,6 +2158,7 @@ fun p_decl env (dAll as (d, _) : decl) = string "*/"] | DTask _ => box [] + | DOnError _ => box [] datatype 'a search = Found of 'a @@ -2791,6 +2794,8 @@ fun p_file env (ds, ps) = val initializers = List.mapPartial (fn (DTask (Initialize, e), _) => SOME e | _ => NONE) ds + val onError = ListUtil.search (fn (DOnError n, _) => SOME n | _ => NONE) ds + val now = Time.now () val nowD = Date.fromTimeUniv now val rfcFmt = "%a, %d %b %Y %H:%M:%S" @@ -2957,6 +2962,18 @@ fun p_file env (ds, ps) = string "static void uw_initializer(uw_context ctx) { };", newline], + case onError of + NONE => box [] + | SOME n => box [string "static void uw_onError(uw_context ctx, char *msg) {", + newline, + box [string "uw_write(ctx, ", + p_enamed env n, + string "(ctx, msg, uw_unit_v));", + newline], + string "}", + newline, + newline], + string "uw_app uw_application = {", p_list_sep (box [string ",", newline]) string [Int.toString (SM.foldl Int.max 0 fnums + 1), @@ -2965,7 +2982,8 @@ fun p_file env (ds, ps) = "uw_client_init", "uw_initializer", "uw_expunger", "uw_db_init", "uw_db_begin", "uw_db_commit", "uw_db_rollback", "uw_db_close", "uw_handle", - "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime"], + "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime", + case onError of NONE => "NULL" | SOME _ => "uw_onError"], string "};", newline] end diff --git a/src/cjrize.sml b/src/cjrize.sml index 22463cd4..2e7afa43 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -675,6 +675,7 @@ fun cifyDecl ((d, loc), sm) = | _ => (ErrorMsg.errorAt loc "Initializer has not been fully determined"; (NONE, NONE, sm))) | L.DPolicy _ => (NONE, NONE, sm) + | L.DOnError n => (SOME (L'.DOnError n, loc), NONE, sm) fun cjrize ds = let diff --git a/src/compiler.sig b/src/compiler.sig index c9b96a52..d0f6ac72 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -54,7 +54,8 @@ signature COMPILER = sig protocol : string option, dbms : string option, sigFile : string option, - safeGets : string list + safeGets : string list, + onError : (string * string list * string) option } val compile : string -> bool val compiler : string -> unit diff --git a/src/compiler.sml b/src/compiler.sml index 6167f08a..c01024f0 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -58,7 +58,8 @@ type job = { protocol : string option, dbms : string option, sigFile : string option, - safeGets : string list + safeGets : string list, + onError : (string * string list * string) option } type ('src, 'dst) phase = { @@ -396,6 +397,7 @@ fun parseUrp' accLibs fname = val dbms = ref NONE val sigFile = ref (Settings.getSigFile ()) val safeGets = ref [] + val onError = ref NONE fun finish sources = let @@ -425,7 +427,8 @@ fun parseUrp' accLibs fname = protocol = !protocol, dbms = !dbms, sigFile = !sigFile, - safeGets = rev (!safeGets) + safeGets = rev (!safeGets), + onError = !onError } fun mergeO f (old, new) = @@ -469,7 +472,8 @@ fun parseUrp' accLibs fname = protocol = mergeO #2 (#protocol old, #protocol new), dbms = mergeO #2 (#dbms old, #dbms new), sigFile = mergeO #2 (#sigFile old, #sigFile new), - safeGets = #safeGets old @ #safeGets new + safeGets = #safeGets old @ #safeGets new, + onError = mergeO #2 (#onError old, #onError new) } in if accLibs then @@ -631,6 +635,12 @@ fun parseUrp' accLibs fname = (case String.fields (fn ch => ch = #"=") arg of [n, v] => pathmap := M.insert (!pathmap, n, v) | _ => ErrorMsg.error "path argument not of the form name=value'") + | "onError" => + (case String.fields (fn ch => ch = #".") arg of + m1 :: (fs as _ :: _) => + onError := SOME (m1, List.take (fs, length fs - 1), List.last fs) + | _ => ErrorMsg.error "invalid 'onError' argument") + | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); read () end @@ -657,6 +667,7 @@ fun parseUrp' accLibs fname = Option.app Settings.setProtocol (#protocol job); Option.app Settings.setDbms (#dbms job); Settings.setSafeGets (#safeGets job); + Settings.setOnError (#onError job); job end in @@ -709,7 +720,7 @@ structure SS = BinarySetFn(struct end) val parse = { - func = fn {database, sources = fnames, ffi, ...} : job => + func = fn {database, sources = fnames, ffi, onError, ...} : job => let val mrs = !moduleRoots @@ -884,6 +895,10 @@ val parse = { val ds = case database of NONE => ds | SOME s => (Source.DDatabase s, loc) :: ds + + val ds = case onError of + NONE => ds + | SOME v => ds @ [(Source.DOnError v, loc)] in ds end handle Empty => ds diff --git a/src/core.sml b/src/core.sml index e5358f48..6d9e56b6 100644 --- a/src/core.sml +++ b/src/core.sml @@ -136,6 +136,7 @@ datatype decl' = | DStyle of string * int * string | DTask of exp * exp | DPolicy of exp + | DOnError of int withtype decl = decl' located diff --git a/src/core_env.sml b/src/core_env.sml index 478ef495..9a4f9ec7 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -350,6 +350,7 @@ fun declBinds env (d, loc) = end | DTask _ => env | DPolicy _ => env + | DOnError _ => env fun patBinds env (p, loc) = case p of diff --git a/src/core_print.sml b/src/core_print.sml index f18ea4b9..ca8066b3 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -628,6 +628,7 @@ fun p_decl env (dAll as (d, _) : decl) = | DPolicy e1 => box [string "policy", space, p_exp env e1] + | DOnError _ => string "ONERROR" fun p_file env file = let diff --git a/src/core_util.sml b/src/core_util.sml index eedcd2bb..e71d7276 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -997,6 +997,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} = fn e' => (DPolicy e', loc)) + | DOnError _ => S.return2 dAll + and mfvi ctx (x, n, t, e, s) = S.bind2 (mfc ctx t, fn t' => @@ -1152,6 +1154,7 @@ fun mapfoldB (all as {bind, ...}) = end | DTask _ => ctx | DPolicy _ => ctx + | DOnError _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -1216,7 +1219,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DCookie (_, n, _, _) => Int.max (n, count) | DStyle (_, n, _) => Int.max (n, count) | DTask _ => count - | DPolicy _ => count) 0 + | DPolicy _ => count + | DOnError _ => count) 0 end diff --git a/src/corify.sml b/src/corify.sml index 88473455..27e6c4c7 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -1083,6 +1083,17 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = | L.DPolicy e1 => ([(L'.DPolicy (corifyExp st e1), loc)], st) + | L.DOnError (m, ms, x) => + let + val st = St.lookupStrById st m + val st = foldl St.lookupStrByName st ms + in + case St.lookupValByName st x of + St.ENormal n => ([(L'.DOnError n, loc)], st) + | _ => (ErrorMsg.errorAt loc "Wrong type of identifier for 'onError'"; + ([], st)) + end + and corifyStr mods ((str, _), st) = case str of L.StrConst ds => @@ -1141,7 +1152,8 @@ fun maxName ds = foldl (fn ((d, _), n) => | L.DCookie (_, _, n', _) => Int.max (n, n') | L.DStyle (_, _, n') => Int.max (n, n') | L.DTask _ => n - | L.DPolicy _ => n) + | L.DPolicy _ => n + | L.DOnError _ => n) 0 ds and maxNameStr (str, _) = diff --git a/src/css.sml b/src/css.sml index 31c4b9b1..73f180d9 100644 --- a/src/css.sml +++ b/src/css.sml @@ -288,6 +288,7 @@ fun summarize file = | DStyle (_, n, s) => (IM.insert (globals, n, (SOME s, [])), classes) | DTask _ => st | DPolicy _ => st + | DOnError _ => st end val (globals, classes) = foldl decl (IM.empty, IM.empty) file diff --git a/src/demo.sml b/src/demo.sml index a67411de..358815de 100644 --- a/src/demo.sml +++ b/src/demo.sml @@ -115,7 +115,8 @@ fun make' {prefix, dirname, guided} = protocol = mergeWith #2 (#protocol combined, #protocol urp), dbms = mergeWith #2 (#dbms combined, #dbms urp), sigFile = mergeWith #2 (#sigFile combined, #sigFile urp), - safeGets = [] + safeGets = [], + onError = NONE } val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp") diff --git a/src/elab.sml b/src/elab.sml index e040a059..6d405af6 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -172,6 +172,7 @@ datatype decl' = | DStyle of int * string * int | DTask of exp * exp | DPolicy of exp + | DOnError of int * string list * string and str' = StrConst of decl list diff --git a/src/elab_env.sml b/src/elab_env.sml index bb34c345..16596622 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1633,5 +1633,6 @@ fun declBinds env (d, loc) = end | DTask _ => env | DPolicy _ => env + | DOnError _ => env end diff --git a/src/elab_print.sml b/src/elab_print.sml index 42a0a107..4fb7ee73 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -816,6 +816,7 @@ fun p_decl env (dAll as (d, _) : decl) = | DPolicy e1 => box [string "policy", space, p_exp env e1] + | DOnError _ => string "ONERROR" and p_str env (str, _) = case str of diff --git a/src/elab_util.sml b/src/elab_util.sml index ec6c51ba..ccfb86a3 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -883,7 +883,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f | DStyle (tn, x, n) => bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc))) | DTask _ => ctx - | DPolicy _ => ctx, + | DPolicy _ => ctx + | DOnError _ => ctx, mfd ctx d)) ctx ds, fn ds' => (StrConst ds', loc)) | StrVar _ => S.return2 strAll @@ -1018,6 +1019,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f S.map2 (mfe ctx e1, fn e1' => (DPolicy e1', loc)) + | DOnError _ => S.return2 dAll and mfvi ctx (x, n, c, e) = S.bind2 (mfc ctx c, @@ -1162,6 +1164,7 @@ and maxNameDecl (d, _) = | DStyle (n1, _, n2) => Int.max (n1, n2) | DTask _ => 0 | DPolicy _ => 0 + | DOnError _ => 0 and maxNameStr (str, _) = case str of StrConst ds => maxName ds diff --git a/src/elaborate.sml b/src/elaborate.sml index 505699bd..e7848f21 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2679,6 +2679,7 @@ and sgiOfDecl (d, loc) = | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)] | L'.DTask _ => [] | L'.DPolicy _ => [] + | L'.DOnError _ => [] and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), @@ -3858,6 +3859,32 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = ([(L'.DPolicy e1', loc)], (env, denv, gs1 @ gs)) end + | L.DOnError (m1, ms, s) => + (case E.lookupStr env m1 of + NONE => (expError env (UnboundStrInExp (loc, m1)); + ([], (env, denv, []))) + | SOME (n, sgn) => + let + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => (conError env (UnboundStrInCon (loc, m)); + (strerror, sgnerror)) + | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) + ((L'.StrVar n, loc), sgn) ms + + val t = case E.projectVal env {sgn = sgn, str = str, field = s} of + NONE => (expError env (UnboundExp (loc, s)); + cerror) + | SOME t => t + + val page = (L'.CModProj (!basis_r, [], "page"), loc) + val xpage = (L'.CApp ((L'.CModProj (!basis_r, [], "transaction"), loc), page), loc) + val func = (L'.TFun ((L'.CModProj (!basis_r, [], "xbody"), loc), xpage), loc) + in + unifyCons env loc t func; + ([(L'.DOnError (n, ms, s), loc)], (env, denv, gs)) + end) + (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) in (*prefaces "/elabDecl" [("d", SourcePrint.p_decl dAll)];*) diff --git a/src/expl.sml b/src/expl.sml index 1212383f..119c1d92 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -149,6 +149,7 @@ datatype decl' = | DStyle of int * string * int | DTask of exp * exp | DPolicy of exp + | DOnError of int * string list * string and str' = StrConst of decl list diff --git a/src/expl_env.sml b/src/expl_env.sml index 9abe7099..f5a5eb0a 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -345,6 +345,7 @@ fun declBinds env (d, loc) = end | DTask _ => env | DPolicy _ => env + | DOnError _ => env fun sgiBinds env (sgi, loc) = case sgi of diff --git a/src/expl_print.sml b/src/expl_print.sml index 5a914194..d89b0512 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -730,6 +730,7 @@ fun p_decl env (dAll as (d, _) : decl) = | DPolicy e1 => box [string "policy", space, p_exp env e1] + | DOnError _ => string "ONERROR" and p_str env (str, _) = case str of diff --git a/src/explify.sml b/src/explify.sml index 0013906f..4f4f83e1 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008-2010, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -197,6 +197,7 @@ fun explifyDecl (d, loc : EM.span) = | L.DStyle (nt, x, n) => SOME (L'.DStyle (nt, x, n), loc) | L.DTask (e1, e2) => SOME (L'.DTask (explifyExp e1, explifyExp e2), loc) | L.DPolicy e1 => SOME (L'.DPolicy (explifyExp e1), loc) + | L.DOnError v => SOME (L'.DOnError v, loc) and explifyStr (str, loc) = case str of diff --git a/src/mono.sml b/src/mono.sml index 554b1dc5..1d446dda 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -151,6 +151,7 @@ datatype decl' = | DTask of exp * exp | DPolicy of policy + | DOnError of int withtype decl = decl' located diff --git a/src/mono_env.sml b/src/mono_env.sml index 87f96488..1df38db3 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -131,6 +131,7 @@ fun declBinds env (d, loc) = | DStyle _ => env | DTask _ => env | DPolicy _ => env + | DOnError _ => env fun patBinds env (p, loc) = case p of diff --git a/src/mono_print.sml b/src/mono_print.sml index c3f2866e..63c98f44 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -527,7 +527,7 @@ fun p_decl env (dAll as (d, _) : decl) = | DPolicy p => box [string "policy", space, p_policy env p] - + | DOnError _ => string "ONERROR" fun p_file env file = let diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 50c4b387..d8baf07e 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -70,6 +70,7 @@ fun shake file = in usedVars st e1 end + | ((DOnError n, _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n)) | (_, st) => st) (IS.empty, IS.empty) file val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) => @@ -87,7 +88,8 @@ fun shake file = | ((DCookie _, _), acc) => acc | ((DStyle _, _), acc) => acc | ((DTask _, _), acc) => acc - | ((DPolicy _, _), acc) => acc) + | ((DPolicy _, _), acc) => acc + | ((DOnError _, _), acc) => acc) (IM.empty, IM.empty) file fun typ (c, s) = @@ -155,7 +157,8 @@ fun shake file = | (DCookie _, _) => true | (DStyle _, _) => true | (DTask _, _) => true - | (DPolicy _, _) => true) file + | (DPolicy _, _) => true + | (DOnError _, _) => true) file end end diff --git a/src/mono_util.sml b/src/mono_util.sml index 8a567e83..d75b8300 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -538,6 +538,7 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = S.map2 (mfpol ctx pol, fn p' => (DPolicy p', loc)) + | DOnError _ => S.return2 dAll and mfpol ctx pol = case pol of @@ -644,6 +645,7 @@ fun mapfoldB (all as {bind, ...}) = | DStyle _ => ctx | DTask _ => ctx | DPolicy _ => ctx + | DOnError _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -698,7 +700,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DCookie _ => count | DStyle _ => count | DTask _ => count - | DPolicy _ => count) 0 + | DPolicy _ => count + | DOnError _ => count) 0 end diff --git a/src/monoize.sml b/src/monoize.sml index 07e69834..bd5787b4 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3962,6 +3962,9 @@ fun monoDecl (env, fm) (all as (d, loc)) = in SOME (env, fm, ps) end + | L.DOnError n => SOME (env, + fm, + [(L'.DOnError n, loc)]) end datatype expungable = Client | Channel diff --git a/src/prepare.sml b/src/prepare.sml index 81de2fa7..4d81940f 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -331,6 +331,7 @@ fun prepDecl (d as (_, loc), st) = in ((DTask (tk, e), loc), st) end + | DOnError _ => (d, st) fun prepare (ds, ps) = let diff --git a/src/reduce.sml b/src/reduce.sml index 36c9f44e..7a962926 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -803,6 +803,7 @@ fun reduce file = namedC, namedE)) end + | DOnError _ => (d, st) 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 cfa6bfd8..0e87e34a 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -378,6 +378,7 @@ fun reduce file = | DStyle _ => d | DTask (e1, e2) => (DTask (exp [] e1, exp [] e2), loc) | DPolicy e1 => (DPolicy (exp [] e1), loc) + | DOnError _ => d in map doDecl file end diff --git a/src/settings.sig b/src/settings.sig index 51d06902..3ebf9300 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -206,4 +206,6 @@ signature SETTINGS = sig val setSafeGets : string list -> unit val isSafeGet : string -> bool + val setOnError : (string * string list * string) option -> unit + val getOnError : unit -> (string * string list * string) option end diff --git a/src/settings.sml b/src/settings.sml index af16f9ca..5da1a24e 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -486,4 +486,8 @@ val safeGet = ref SS.empty fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls) fun isSafeGet x = SS.member (!safeGet, x) +val onError = ref (NONE : (string * string list * string) option) +fun setOnError x = onError := x +fun getOnError () = !onError + end diff --git a/src/shake.sml b/src/shake.sml index bc81def9..096c31fd 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -101,6 +101,11 @@ fun shake file = st else usedVars st e1 + | ((DOnError n, _), st as (usedE, usedC)) => + if !sliceDb then + st + else + (IS.add (usedE, n), usedC) | (_, acc) => acc) (IS.empty, IS.empty) file val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef) @@ -128,7 +133,8 @@ fun shake file = | ((DStyle (_, n, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], dummyt, dummye))) | ((DTask _, _), acc) => acc - | ((DPolicy _, _), acc) => acc) + | ((DPolicy _, _), acc) => acc + | ((DOnError _, _), acc) => acc) (IM.empty, IM.empty) file fun kind (_, s) = s @@ -216,7 +222,8 @@ fun shake file = | (DCookie _, _) => not (!sliceDb) | (DStyle _, _) => not (!sliceDb) | (DTask _, _) => not (!sliceDb) - | (DPolicy _, _) => not (!sliceDb)) file + | (DPolicy _, _) => not (!sliceDb) + | (DOnError _, _) => not (!sliceDb)) file end end diff --git a/src/source.sml b/src/source.sml index 9768cfc0..b85384ab 100644 --- a/src/source.sml +++ b/src/source.sml @@ -169,6 +169,7 @@ datatype decl' = | DStyle of string | DTask of exp * exp | DPolicy of exp + | DOnError of string * string list * string and str' = StrConst of decl list diff --git a/src/source_print.sml b/src/source_print.sml index 590d15d5..f6218d22 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -672,6 +672,7 @@ fun p_decl ((d, _) : decl) = | DPolicy e1 => box [string "policy", space, p_exp e1] + | DOnError _ => string "ONERROR" and p_str (str, _) = case str of diff --git a/src/unnest.sml b/src/unnest.sml index a2ec32b0..2d6956cb 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -434,6 +434,7 @@ fun unnest file = | DStyle _ => default () | DTask _ => explore () | DPolicy _ => explore () + | DOnError _ => default () end and doStr (all as (str, loc), st) = diff --git a/tests/onerror.ur b/tests/onerror.ur new file mode 100644 index 00000000..9877d8d7 --- /dev/null +++ b/tests/onerror.ur @@ -0,0 +1,4 @@ +fun main n = + case n of + 0 => error Zero is bad! + | _ => return diff --git a/tests/onerror.urp b/tests/onerror.urp new file mode 100644 index 00000000..39d7ac7d --- /dev/null +++ b/tests/onerror.urp @@ -0,0 +1,4 @@ +onError OnerrorE.err + +onerrorE +onerror diff --git a/tests/onerror.urs b/tests/onerror.urs new file mode 100644 index 00000000..38b757ea --- /dev/null +++ b/tests/onerror.urs @@ -0,0 +1 @@ +val main : int -> transaction page diff --git a/tests/onerrorE.ur b/tests/onerrorE.ur new file mode 100644 index 00000000..b2948c71 --- /dev/null +++ b/tests/onerrorE.ur @@ -0,0 +1,5 @@ +fun err x = return +

Bad thing!

+ + {x} + -- cgit v1.2.3 From 5ec949e910342f6212c85c8df75283d091817408 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 15 Jan 2011 14:53:13 -0500 Subject: Allow subqueries to reference aggregate-only columns of free tables; treat non-COUNT aggregate functions as possibly returning NULL --- lib/ur/basis.urs | 54 ++++++++++++++++++++++++--------------------- lib/ur/list.ur | 6 ++--- lib/ur/list.urs | 6 ++--- lib/ur/top.ur | 36 +++++++++++++++--------------- lib/ur/top.urs | 36 +++++++++++++++--------------- src/compiler.sml | 10 +++++++-- src/mono_env.sig | 3 ++- src/mono_env.sml | 13 +++++++++++ src/mono_reduce.sml | 39 +++++++++++++++++++++------------ src/monoize.sml | 63 ++++++++++++++++++++++------------------------------- 10 files changed, 145 insertions(+), 121 deletions(-) (limited to 'src/mono_env.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index a91fd498..8ca2e81c 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -291,8 +291,8 @@ val check : fs ::: {Type} (*** Queries *) -con sql_query :: {{Type}} -> {{Type}} -> {Type} -> Type -con sql_query1 :: {{Type}} -> {{Type}} -> {{Type}} -> {Type} -> Type +con sql_query :: {{Type}} -> {{Type}} -> {{Type}} -> {Type} -> Type +con sql_query1 :: {{Type}} -> {{Type}} -> {{Type}} -> {{Type}} -> {Type} -> Type con sql_subset :: {{Type}} -> {{Type}} -> Type val sql_subset : keep_drop :: {({Type} * {Type})} @@ -314,7 +314,7 @@ val sql_from_table : free ::: {{Type}} -> t ::: Type -> fs ::: {Type} -> fieldsOf t fs -> name :: Name -> t -> sql_from_items free [name = fs] val sql_from_query : free ::: {{Type}} -> fs ::: {Type} -> name :: Name - -> sql_query free [] fs + -> sql_query free [] [] fs -> sql_from_items free [name = fs] val sql_from_comma : free ::: {{Type}} -> tabs1 ::: {{Type}} -> tabs2 ::: {{Type}} -> [tabs1 ~ tabs2] @@ -353,6 +353,7 @@ val sql_full_join : free ::: {{Type}} -> tabs1 ::: {{(Type * Type)}} -> tabs2 :: -> sql_from_items free (map (map (fn p :: (Type * Type) => p.2)) (tabs1 ++ tabs2)) val sql_query1 : free ::: {{Type}} + -> afree ::: {{Type}} -> tables ::: {{Type}} -> grouped ::: {{Type}} -> selectedFields ::: {{Type}} @@ -360,33 +361,35 @@ val sql_query1 : free ::: {{Type}} -> empties :: {Unit} -> [free ~ tables] => [free ~ grouped] + => [afree ~ tables] => [empties ~ selectedFields] => {Distinct : bool, From : sql_from_items free tables, - Where : sql_exp (free ++ tables) [] [] bool, + Where : sql_exp (free ++ tables) afree [] bool, GroupBy : sql_subset tables grouped, - Having : sql_exp (free ++ grouped) tables [] bool, + Having : sql_exp (free ++ grouped) (afree ++ tables) [] bool, SelectFields : sql_subset grouped (map (fn _ => []) empties ++ selectedFields), - SelectExps : $(map (sql_exp (free ++ grouped) tables []) + SelectExps : $(map (sql_exp (free ++ grouped) (afree ++ tables) []) selectedExps) } - -> sql_query1 free tables selectedFields selectedExps + -> sql_query1 free afree tables selectedFields selectedExps type sql_relop val sql_union : sql_relop val sql_intersect : sql_relop val sql_except : sql_relop val sql_relop : free ::: {{Type}} + -> afree ::: {{Type}} -> tables1 ::: {{Type}} -> tables2 ::: {{Type}} -> selectedFields ::: {{Type}} -> selectedExps ::: {Type} -> sql_relop - -> sql_query1 free tables1 selectedFields selectedExps - -> sql_query1 free tables2 selectedFields selectedExps - -> sql_query1 free [] selectedFields selectedExps -val sql_forget_tables : free ::: {{Type}} -> tables ::: {{Type}} -> selectedFields ::: {{Type}} -> selectedExps ::: {Type} - -> sql_query1 free tables selectedFields selectedExps - -> sql_query1 free [] selectedFields selectedExps + -> sql_query1 free afree tables1 selectedFields selectedExps + -> sql_query1 free afree tables2 selectedFields selectedExps + -> sql_query1 free afree [] selectedFields selectedExps +val sql_forget_tables : free ::: {{Type}} -> afree ::: {{Type}} -> tables ::: {{Type}} -> selectedFields ::: {{Type}} -> selectedExps ::: {Type} + -> sql_query1 free afree tables selectedFields selectedExps + -> sql_query1 free afree [] selectedFields selectedExps type sql_direction val sql_asc : sql_direction @@ -408,15 +411,16 @@ val sql_no_offset : sql_offset val sql_offset : int -> sql_offset val sql_query : free ::: {{Type}} + -> afree ::: {{Type}} -> tables ::: {{Type}} -> selectedFields ::: {{Type}} -> selectedExps ::: {Type} -> [free ~ tables] - => {Rows : sql_query1 free tables selectedFields selectedExps, + => {Rows : sql_query1 free afree tables selectedFields selectedExps, OrderBy : sql_order_by (free ++ tables) selectedExps, Limit : sql_limit, Offset : sql_offset} - -> sql_query free selectedFields selectedExps + -> sql_query free afree selectedFields selectedExps val sql_field : otherTabs ::: {{Type}} -> otherFields ::: {Type} -> fieldType ::: Type -> agg ::: {{Type}} @@ -493,8 +497,8 @@ class sql_summable val sql_summable_int : sql_summable int val sql_summable_float : sql_summable float val sql_summable_option : t ::: Type -> sql_summable t -> sql_summable (option t) -val sql_avg : t ::: Type -> sql_summable t -> sql_aggregate t t -val sql_sum : t ::: Type -> sql_summable t -> sql_aggregate t t +val sql_avg : t ::: Type -> nt ::: Type -> sql_summable t -> nullify t nt -> sql_aggregate t nt +val sql_sum : t ::: Type -> nt ::: Type -> sql_summable t -> nullify t nt -> sql_aggregate t nt class sql_maxable val sql_maxable_int : sql_maxable int @@ -502,8 +506,8 @@ val sql_maxable_float : sql_maxable float val sql_maxable_string : sql_maxable string val sql_maxable_time : sql_maxable time val sql_maxable_option : t ::: Type -> sql_maxable t -> sql_maxable (option t) -val sql_max : t ::: Type -> sql_maxable t -> sql_aggregate t t -val sql_min : t ::: Type -> sql_maxable t -> sql_aggregate t t +val sql_max : t ::: Type -> nt ::: Type -> sql_maxable t -> nullify t nt -> sql_aggregate t nt +val sql_min : t ::: Type -> nt ::: Type -> sql_maxable t -> nullify t nt -> sql_aggregate t nt con sql_nfunc :: Type -> Type val sql_nfunc : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} @@ -526,7 +530,7 @@ val sql_nullable : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> -> sql_exp tables agg exps (option t) val sql_subquery : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> nm ::: Name -> t ::: Type - -> sql_query tables [] [nm = t] + -> sql_query tables agg [] [nm = t] -> sql_exp tables agg exps t (*** Executing queries *) @@ -534,7 +538,7 @@ val sql_subquery : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> val query : tables ::: {{Type}} -> exps ::: {Type} -> [tables ~ exps] => state ::: Type - -> sql_query [] tables exps + -> sql_query [] [] tables exps -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> state -> transaction state) @@ -838,21 +842,21 @@ val periodic : int -> task_kind unit type sql_policy val sendClient : tables ::: {{Type}} -> exps ::: {Type} - -> [tables ~ exps] => sql_query [] tables exps + -> [tables ~ exps] => sql_query [] [] tables exps -> sql_policy val sendOwnIds : sql_sequence -> sql_policy val mayInsert : fs ::: {Type} -> tables ::: {{Type}} -> [[New] ~ tables] - => sql_query [] ([New = fs] ++ tables) [] + => sql_query [] [] ([New = fs] ++ tables) [] -> sql_policy val mayDelete : fs ::: {Type} -> tables ::: {{Type}} -> [[Old] ~ tables] - => sql_query [] ([Old = fs] ++ tables) [] + => sql_query [] [] ([Old = fs] ++ tables) [] -> sql_policy val mayUpdate : fs ::: {Type} -> tables ::: {{Type}} -> [[Old, New] ~ tables] - => sql_query [] ([Old = fs, New = fs] ++ tables) [] + => sql_query [] [] ([Old = fs, New = fs] ++ tables) [] -> sql_policy val also : sql_policy -> sql_policy -> sql_policy diff --git a/lib/ur/list.ur b/lib/ur/list.ur index 3153cc32..d0c2e7a1 100644 --- a/lib/ur/list.ur +++ b/lib/ur/list.ur @@ -254,7 +254,7 @@ fun app [m] (_ : monad m) [a] f = end fun mapQuery [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type] - [tables ~ exps] (q : sql_query [] tables exps) + [tables ~ exps] (q : sql_query [] [] tables exps) (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> t) = ls <- query q (fn fs acc => return (f fs :: acc)) @@ -262,7 +262,7 @@ fun mapQuery [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type] return (rev ls) fun mapQueryM [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type] - [tables ~ exps] (q : sql_query [] tables exps) + [tables ~ exps] (q : sql_query [] [] tables exps) (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction t) = ls <- query q (fn fs acc => v <- f fs; return (v :: acc)) @@ -270,7 +270,7 @@ fun mapQueryM [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type] return (rev ls) fun mapQueryPartialM [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type] - [tables ~ exps] (q : sql_query [] tables exps) + [tables ~ exps] (q : sql_query [] [] tables exps) (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction (option t)) = ls <- query q (fn fs acc => v <- f fs; diff --git a/lib/ur/list.urs b/lib/ur/list.urs index 9ad738f1..8284510d 100644 --- a/lib/ur/list.urs +++ b/lib/ur/list.urs @@ -53,19 +53,19 @@ val app : m ::: (Type -> Type) -> monad m -> a ::: Type val mapQuery : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type -> [tables ~ exps] => - sql_query [] tables exps + sql_query [] [] tables exps -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> t) -> transaction (list t) val mapQueryM : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type -> [tables ~ exps] => - sql_query [] tables exps + sql_query [] [] tables exps -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction t) -> transaction (list t) val mapQueryPartialM : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type -> [tables ~ exps] => - sql_query [] tables exps + sql_query [] [] tables exps -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction (option t)) -> transaction (list t) diff --git a/lib/ur/top.ur b/lib/ur/top.ur index 83d5b6af..0fdbae7a 100644 --- a/lib/ur/top.ur +++ b/lib/ur/top.ur @@ -215,40 +215,40 @@ fun mapX3 [K] [tf1 :: K -> Type] [tf2 :: K -> Type] [tf3 :: K -> Type] [ctx :: { {f [nm] [t] [rest] ! r1 r2 r3}{acc}) -fun query1 [t ::: Name] [fs ::: {Type}] [state ::: Type] (q : sql_query [] [t = fs] []) +fun query1 [t ::: Name] [fs ::: {Type}] [state ::: Type] (q : sql_query [] [] [t = fs] []) (f : $fs -> state -> transaction state) (i : state) = query q (fn r => f r.t) i -fun query1' [t ::: Name] [fs ::: {Type}] [state ::: Type] (q : sql_query [] [t = fs] []) +fun query1' [t ::: Name] [fs ::: {Type}] [state ::: Type] (q : sql_query [] [] [t = fs] []) (f : $fs -> state -> state) (i : state) = query q (fn r s => return (f r.t s)) i -fun queryL [tables] [exps] [tables ~ exps] (q : sql_query [] tables exps) = +fun queryL [tables] [exps] [tables ~ exps] (q : sql_query [] [] tables exps) = query q (fn r ls => return (r :: ls)) [] -fun queryL1 [t ::: Name] [fs ::: {Type}] (q : sql_query [] [t = fs] []) = +fun queryL1 [t ::: Name] [fs ::: {Type}] (q : sql_query [] [] [t = fs] []) = query q (fn r ls => return (r.t :: ls)) [] fun queryI [tables ::: {{Type}}] [exps ::: {Type}] - [tables ~ exps] (q : sql_query [] tables exps) + [tables ~ exps] (q : sql_query [] [] tables exps) (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction unit) = query q (fn fs _ => f fs) () -fun queryI1 [nm ::: Name] [fs ::: {Type}] (q : sql_query [] [nm = fs] []) +fun queryI1 [nm ::: Name] [fs ::: {Type}] (q : sql_query [] [] [nm = fs] []) (f : $fs -> transaction unit) = query q (fn fs _ => f fs.nm) () fun queryX [tables ::: {{Type}}] [exps ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}] - [tables ~ exps] (q : sql_query [] tables exps) + [tables ~ exps] (q : sql_query [] [] tables exps) (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> xml ctx inp []) = query q @@ -256,14 +256,14 @@ fun queryX [tables ::: {{Type}}] [exps ::: {Type}] [ctx ::: {Unit}] [inp ::: {Ty fun queryX1 [nm ::: Name] [fs ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}] - (q : sql_query [] [nm = fs] []) + (q : sql_query [] [] [nm = fs] []) (f : $fs -> xml ctx inp []) = query q (fn fs acc => return {acc}{f fs.nm}) fun queryX' [tables ::: {{Type}}] [exps ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}] - [tables ~ exps] (q : sql_query [] tables exps) + [tables ~ exps] (q : sql_query [] [] tables exps) (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction (xml ctx inp [])) = query q @@ -273,7 +273,7 @@ fun queryX' [tables ::: {{Type}}] [exps ::: {Type}] [ctx ::: {Unit}] [inp ::: {T fun queryX1' [nm ::: Name] [fs ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}] - (q : sql_query [] [nm = fs] []) + (q : sql_query [] [] [nm = fs] []) (f : $fs -> transaction (xml ctx inp [])) = query q (fn fs acc => @@ -282,7 +282,7 @@ fun queryX1' [nm ::: Name] [fs ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}] fun queryXE' [exps ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}] - (q : sql_query [] [] exps) + (q : sql_query [] [] [] exps) (f : $exps -> transaction (xml ctx inp [])) = query q (fn fs acc => @@ -292,42 +292,42 @@ fun queryXE' [exps ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}] fun hasRows [tables ::: {{Type}}] [exps ::: {Type}] [tables ~ exps] - (q : sql_query [] tables exps) = + (q : sql_query [] [] tables exps) = query q (fn _ _ => return True) False fun oneOrNoRows [tables ::: {{Type}}] [exps ::: {Type}] [tables ~ exps] - (q : sql_query [] tables exps) = + (q : sql_query [] [] tables exps) = query q (fn fs _ => return (Some fs)) None -fun oneOrNoRows1 [nm ::: Name] [fs ::: {Type}] (q : sql_query [] [nm = fs] []) = +fun oneOrNoRows1 [nm ::: Name] [fs ::: {Type}] (q : sql_query [] [] [nm = fs] []) = query q (fn fs _ => return (Some fs.nm)) None -fun oneOrNoRowsE1 [tabs ::: {Unit}] [nm ::: Name] [t ::: Type] [tabs ~ [nm]] (q : sql_query [] (mapU [] tabs) [nm = t]) = +fun oneOrNoRowsE1 [tabs ::: {Unit}] [nm ::: Name] [t ::: Type] [tabs ~ [nm]] (q : sql_query [] [] (mapU [] tabs) [nm = t]) = query q (fn fs _ => return (Some fs.nm)) None fun oneRow [tables ::: {{Type}}] [exps ::: {Type}] - [tables ~ exps] (q : sql_query [] tables exps) = + [tables ~ exps] (q : sql_query [] [] tables exps) = o <- oneOrNoRows q; return (case o of None => error Query returned no rows | Some r => r) -fun oneRow1 [nm ::: Name] [fs ::: {Type}] (q : sql_query [] [nm = fs] []) = +fun oneRow1 [nm ::: Name] [fs ::: {Type}] (q : sql_query [] [] [nm = fs] []) = o <- oneOrNoRows q; return (case o of None => error Query returned no rows | Some r => r.nm) -fun oneRowE1 [tabs ::: {Unit}] [nm ::: Name] [t ::: Type] [tabs ~ [nm]] (q : sql_query [] (mapU [] tabs) [nm = t]) = +fun oneRowE1 [tabs ::: {Unit}] [nm ::: Name] [t ::: Type] [tabs ~ [nm]] (q : sql_query [] [] (mapU [] tabs) [nm = t]) = o <- oneOrNoRows q; return (case o of None => error Query returned no rows diff --git a/lib/ur/top.urs b/lib/ur/top.urs index d86ae553..ed3b4c14 100644 --- a/lib/ur/top.urs +++ b/lib/ur/top.urs @@ -126,100 +126,100 @@ val mapX3 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> tf3 :: (K -> Type) val queryL : tables ::: {{Type}} -> exps ::: {Type} -> [tables ~ exps] => - sql_query [] tables exps + sql_query [] [] tables exps -> transaction (list $(exps ++ map (fn fields :: {Type} => $fields) tables)) val queryL1 : t ::: Name -> fs ::: {Type} - -> sql_query [] [t = fs] [] + -> sql_query [] [] [t = fs] [] -> transaction (list $fs) val query1 : t ::: Name -> fs ::: {Type} -> state ::: Type - -> sql_query [] [t = fs] [] + -> sql_query [] [] [t = fs] [] -> ($fs -> state -> transaction state) -> state -> transaction state val query1' : t ::: Name -> fs ::: {Type} -> state ::: Type - -> sql_query [] [t = fs] [] + -> sql_query [] [] [t = fs] [] -> ($fs -> state -> state) -> state -> transaction state val queryI : tables ::: {{Type}} -> exps ::: {Type} -> [tables ~ exps] => - sql_query [] tables exps + sql_query [] [] tables exps -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction unit) -> transaction unit val queryI1 : nm ::: Name -> fs ::: {Type} - -> sql_query [] [nm = fs] [] + -> sql_query [] [] [nm = fs] [] -> ($fs -> transaction unit) -> transaction unit val queryX : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} -> inp ::: {Type} -> [tables ~ exps] => - sql_query [] tables exps + sql_query [] [] tables exps -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> xml ctx inp []) -> transaction (xml ctx inp []) val queryX1 : nm ::: Name -> fs ::: {Type} -> ctx ::: {Unit} -> inp ::: {Type} - -> sql_query [] [nm = fs] [] + -> sql_query [] [] [nm = fs] [] -> ($fs -> xml ctx inp []) -> transaction (xml ctx inp []) val queryX' : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} -> inp ::: {Type} -> [tables ~ exps] => - sql_query [] tables exps + sql_query [] [] tables exps -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction (xml ctx inp [])) -> transaction (xml ctx inp []) val queryX1' : nm ::: Name -> fs ::: {Type} -> ctx ::: {Unit} -> inp ::: {Type} - -> sql_query [] [nm = fs] [] + -> sql_query [] [] [nm = fs] [] -> ($fs -> transaction (xml ctx inp [])) -> transaction (xml ctx inp []) val queryXE' : exps ::: {Type} -> ctx ::: {Unit} -> inp ::: {Type} - -> sql_query [] [] exps + -> sql_query [] [] [] exps -> ($exps -> transaction (xml ctx inp [])) -> transaction (xml ctx inp []) val hasRows : tables ::: {{Type}} -> exps ::: {Type} -> [tables ~ exps] => - sql_query [] tables exps + sql_query [] [] tables exps -> transaction bool val oneOrNoRows : tables ::: {{Type}} -> exps ::: {Type} -> [tables ~ exps] => - sql_query [] tables exps + sql_query [] [] tables exps -> transaction (option $(exps ++ map (fn fields :: {Type} => $fields) tables)) val oneOrNoRows1 : nm ::: Name -> fs ::: {Type} - -> sql_query [] [nm = fs] [] + -> sql_query [] [] [nm = fs] [] -> transaction (option $fs) val oneOrNoRowsE1 : tabs ::: {Unit} -> nm ::: Name -> t ::: Type -> [tabs ~ [nm]] => - sql_query [] (mapU [] tabs) [nm = t] + sql_query [] [] (mapU [] tabs) [nm = t] -> transaction (option t) val oneRow : tables ::: {{Type}} -> exps ::: {Type} -> [tables ~ exps] => - sql_query [] tables exps + sql_query [] [] tables exps -> transaction $(exps ++ map (fn fields :: {Type} => $fields) tables) val oneRow1 : nm ::: Name -> fs ::: {Type} - -> sql_query [] [nm = fs] [] + -> sql_query [] [] [nm = fs] [] -> transaction $fs val oneRowE1 : tabs ::: {Unit} -> nm ::: Name -> t ::: Type -> [tabs ~ [nm]] => - sql_query [] (mapU [] tabs) [nm = t] + sql_query [] [] (mapU [] tabs) [nm = t] -> transaction t val nonempty : fs ::: {Type} -> us ::: {{Unit}} -> sql_table fs us diff --git a/src/compiler.sml b/src/compiler.sml index c8bb036a..61fa23b1 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1311,9 +1311,15 @@ fun compileC {cname, oname, ename, libs, profile, debug, link = link'} = (compile, link) val link = foldl (fn (s, link) => link ^ " " ^ s) link link' + + fun system s = + (if debug then + print (s ^ "\n") + else + (); + OS.Process.isSuccess (OS.Process.system s)) in - OS.Process.isSuccess (OS.Process.system compile) - andalso OS.Process.isSuccess (OS.Process.system link) + system compile andalso system link end fun compile job = diff --git a/src/mono_env.sig b/src/mono_env.sig index c5ca7c0b..97d7d9ea 100644 --- a/src/mono_env.sig +++ b/src/mono_env.sig @@ -50,5 +50,6 @@ signature MONO_ENV = sig val patBindsN : Mono.pat -> int val liftExpInExp : int -> Mono.exp -> Mono.exp - + val subExpInExp : (int * Mono.exp) -> Mono.exp -> Mono.exp + end diff --git a/src/mono_env.sml b/src/mono_env.sml index 1df38db3..7f9a6e62 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -85,6 +85,19 @@ val liftExpInExp = bind = fn (bound, U.Exp.RelE _) => bound + 1 | (bound, _) => bound} +val subExpInExp = + U.Exp.mapB {typ = fn t => t, + exp = fn (xn, rep) => fn e => + case e of + ERel xn' => + (case Int.compare (xn', xn) of + EQUAL => #1 rep + | GREATER=> ERel (xn' - 1) + | LESS => e) + | _ => e, + bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep) + | (ctx, _) => ctx} + fun pushERel (env : env) x t eo = {datatypes = #datatypes env, constructors = #constructors env, diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index e61ed237..82d0a63d 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -57,7 +57,6 @@ fun simpleImpure (tsyms, syms) = | ERecv _ => true | ESleep _ => true | ENamed n => IS.member (syms, n) - | EError _ => true | ERel n => let val (_, t, _) = E.lookupERel env n @@ -398,7 +397,10 @@ fun reduce file = summarize d e @ [ReadCookie] | EFfiApp (m, x, es) => if Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x) then - List.concat (map (summarize d) es) @ [Unsure] + List.concat (map (summarize d) es) @ [if m = "Basis" andalso String.isSuffix "_w" x then + WritePage + else + Unsure] else List.concat (map (summarize d) es) | EApp ((EFfi _, _), e) => summarize d e @@ -429,6 +431,7 @@ fun reduce file = | EApp (f, x) => unravel (#1 f, passed + 1, List.revAppend (summarize d x, ls)) + | EError _ => [Abort] | _ => [Unsure] in unravel (e, 0, []) @@ -445,17 +448,25 @@ fun reduce file = | ECase (e, pes, _) => let val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes + + fun splitRel ls acc = + case ls of + [] => (acc, false, ls) + | UseRel :: ls => (acc, true, ls) + | v :: ls => splitRel ls (v :: acc) + + val (pre, used, post) = foldl (fn (ls, (pre, used, post)) => + let + val (pre', used', post') = splitRel ls [] + in + (pre' @ pre, used' orelse used, post' @ post) + end) + ([], false, []) lss in - case lss of - [] => summarize d e - | ls :: lss => - summarize d e - @ (if List.all (fn ls' => ls' = ls) lss then - ls - else if length (List.filter (not o List.null) (ls :: lss)) <= 1 then - valOf (List.find (not o List.null) (ls :: lss)) - else - [Unsure]) + summarize d e + @ pre + @ (if used then [UseRel] else []) + @ post end | EStrcat (e1, e2) => summarize d e1 @ summarize d e2 @@ -534,8 +545,8 @@ fun reduce file = val effs_e' = List.filter (fn x => x <> UseRel) effs_e' val effs_b = summarize 0 b - (*val () = Print.prefaces "Try" - [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)), + (*val () = Print.fprefaces outf "Try" + [(*("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),*) ("e'", MonoPrint.p_exp env e'), ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), ("e'_eff", p_events effs_e'), diff --git a/src/monoize.sml b/src/monoize.sml index 30dfdd46..4295811a 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -236,9 +236,9 @@ fun monoType env = (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "sql_sequence") => (L'.TFfi ("Basis", "string"), loc) - | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query"), _), _), _), _), _), _) => + | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query"), _), _), _), _), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) - | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query1"), _), _), _), _), _), _), _), _) => + | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query1"), _), _), _), _), _), _), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_from_items"), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) @@ -1908,7 +1908,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = end | _ => poly ()) - | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_query"), _), _), _), _), _), _), _), _) => + | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_query"), _), _), _), _), _), _), _), _), _), _) => let fun sc s = (L'.EPrim (Prim.String s), loc) val s = (L'.TFfi ("Basis", "string"), loc) @@ -1934,7 +1934,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.ECApp ( (L.ECApp ( (L.ECApp ( - (L.EFfi ("Basis", "sql_query1"), _), + (L.ECApp ( + (L.EFfi ("Basis", "sql_query1"), _), + _), _), _), _), (L.CRecord (_, tables), _)), _), (L.CRecord (_, grouped), _)), _), @@ -2592,7 +2594,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.ECApp ( (L.ECApp ( (L.ECApp ( - (L.EFfi ("Basis", "sql_forget_tables"), _), + (L.ECApp ( + (L.EFfi ("Basis", "sql_forget_tables"), _), + _), _), _), _), _), _), _), _), @@ -2625,7 +2629,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.EFfi ("Basis", "sql_count"), _), _), _), _), _), - _) => ((L'.EPrim (Prim.String "COALESCE(COUNT(*),0)"), loc), + _) => ((L'.EPrim (Prim.String "COUNT(*)"), loc), fm) | L.ECApp ( @@ -2640,18 +2644,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _), _), t) => let - val default = - case #1 t of - L.CFfi ("Basis", s) => - SOME (case s of - "int" => "0" - | "float" => "0.0" - | "string" => "''" - | "time" => "0" - | _ => raise Fail "Illegal type of sql_aggregate [1]") - | L.CApp ((L.CFfi ("Basis", "option"), _), _) => NONE - | _ => raise Fail "Illegal type of sql_aggregate [2]" - val s = (L'.TFfi ("Basis", "string"), loc) fun sc s = (L'.EPrim (Prim.String s), loc) @@ -2659,13 +2651,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) = sc "(", (L'.ERel 0, loc), sc ")"] - - val main = case default of - NONE => main - | SOME default => - strcat [sc "COALESCE(", - main, - sc ("," ^ default ^ ")")] in ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), main), loc)), loc), @@ -2682,13 +2667,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), (L'.ERecord [], loc)), loc), fm) - | L.ECApp ((L.EFfi ("Basis", "sql_avg"), _), _) => - ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "AVG"), loc)), loc), + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_avg"), _), _), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EPrim (Prim.String "AVG"), loc)), loc)), loc), fm) - | L.ECApp ((L.EFfi ("Basis", "sql_sum"), _), _) => - ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "SUM"), loc)), loc), + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_sum"), _), _), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EPrim (Prim.String "SUM"), loc)), loc)), loc), fm) | L.EFfi ("Basis", "sql_arith_int") => ((L'.ERecord [], loc), fm) @@ -2701,13 +2688,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), (L'.ERecord [], loc)), loc), fm) - | L.ECApp ((L.EFfi ("Basis", "sql_max"), _), _) => - ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "MAX"), loc)), loc), + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_max"), _), _), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EPrim (Prim.String "MAX"), loc)), loc)), loc), fm) - | L.ECApp ((L.EFfi ("Basis", "sql_min"), _), _) => - ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "MIN"), loc)), loc), + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_min"), _), _), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EPrim (Prim.String "MIN"), loc)), loc)), loc), fm) | L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm) -- cgit v1.2.3 From f8d7c70d8f52003e14a66144a48bb4f06a1c185f Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Sun, 27 Sep 2015 03:52:14 -0400 Subject: Pure caching sort of works. --- src/mono_env.sig | 4 +- src/mono_env.sml | 4 +- src/mono_fooify.sig | 9 ++- src/mono_fooify.sml | 56 ++++++++++++------ src/monoize.sml | 7 ++- src/sqlcache.sml | 162 +++++++++++++++++++++++++++++++++++++--------------- 6 files changed, 166 insertions(+), 76 deletions(-) (limited to 'src/mono_env.sml') diff --git a/src/mono_env.sig b/src/mono_env.sig index 97d7d9ea..9805c0d1 100644 --- a/src/mono_env.sig +++ b/src/mono_env.sig @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -42,6 +42,8 @@ signature MONO_ENV = sig val pushERel : env -> string -> Mono.typ -> Mono.exp option -> env val lookupERel : env -> int -> string * Mono.typ * Mono.exp option + val typeContext : env -> Mono.typ list + val pushENamed : env -> string -> int -> Mono.typ -> Mono.exp option -> string -> env val lookupENamed : env -> int -> string * Mono.typ * Mono.exp option * string diff --git a/src/mono_env.sml b/src/mono_env.sml index 7f9a6e62..8617425e 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -108,6 +108,8 @@ fun lookupERel (env : env) n = (List.nth (#relE env, n)) handle Subscript => raise UnboundRel n +fun typeContext (env : env) = map #2 (#relE env) + fun pushENamed (env : env) x n t eo s = {datatypes = #datatypes env, constructors = #constructors env, diff --git a/src/mono_fooify.sig b/src/mono_fooify.sig index 9eb8038b..ef8f09c2 100644 --- a/src/mono_fooify.sig +++ b/src/mono_fooify.sig @@ -19,9 +19,6 @@ structure Fm : sig val decls : t -> Mono.decl list val freshName : t -> int * t - - (* Set at the end of [Monoize]. *) - val canonical : t ref end (* General form used in [Monoize]. *) @@ -32,7 +29,9 @@ val fooifyExp : foo_kind -> Mono.exp * Mono.typ -> Mono.exp * Fm.t -(* Easy-to-use special case used in [Sqlcache]. *) -val urlify : MonoEnv.env -> Mono.exp * Mono.typ -> Mono.exp +(* Easy-to-use interface in [Sqlcache]. Uses [Fm.canonical]. *) +val canonicalFm : Fm.t ref (* Set at the end of [Monoize]. *) +val urlify : MonoEnv.env -> Mono.exp * Mono.typ -> Mono.exp option +val getNewFmDecls : unit -> Mono.decl list end diff --git a/src/mono_fooify.sml b/src/mono_fooify.sml index d7cb9f59..2e32b248 100644 --- a/src/mono_fooify.sml +++ b/src/mono_fooify.sml @@ -1,4 +1,4 @@ -structure MonoFooify :> MONO_FOOIFY = struct +structure MonoFooify (* :> MONO_FOOIFY *) = struct open Mono @@ -112,9 +112,6 @@ fun lookupList (t as {count, map, listMap, decls}) k tp thunk = | SOME n' => (t, n') end -(* Has to be set at the end of [Monoize]. *) -val canonical = ref (empty 0 : t) - end fun fk2s fk = @@ -166,7 +163,12 @@ fun fooifyExp fk lookupENamed lookupDatatype = | _ => case t of TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) - | TFfi (m, x) => ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm) + | TFfi (m, x) => (if Settings.mayClientToServer (m, x) + (* TODO: better error message. (Then again, user should never see this.) *) + then () + else (E.errorAt loc "MonoFooify: can't pass type from client to server"; + Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]); + ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)) | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) | TRecord ((x, t) :: xts) => @@ -296,22 +298,38 @@ fun fooifyExp fk lookupENamed lookupDatatype = fooify end +(* Has to be set at the end of [Monoize]. *) +val canonicalFm = ref (Fm.empty 0 : Fm.t) + fun urlify env expTyp = + if ErrorMsg.anyErrors () + then ((* DEBUG *) print "already error"; NONE) + else + let + val (exp, fm) = + fooifyExp + Url + (fn n => + let + val (_, t, _, s) = MonoEnv.lookupENamed env n + in + (t, s) + end) + (fn n => MonoEnv.lookupDatatype env n) + (!canonicalFm) + expTyp + in + if ErrorMsg.anyErrors () + then ((* DEBUG *) print "why"; (ErrorMsg.resetErrors (); NONE)) + else (canonicalFm := fm; SOME exp) + end + +fun getNewFmDecls () = let - val (exp, fm) = - fooifyExp - Url - (fn n => - let - val (_, t, _, s) = MonoEnv.lookupENamed env n - in - (t, s) - end) - (fn n => MonoEnv.lookupDatatype env n) - (!Fm.canonical) - expTyp + val fm = !canonicalFm in - Fm.canonical := fm; - exp + (* canonicalFm := Fm.enter fm; *) + Fm.decls fm end + end diff --git a/src/monoize.sml b/src/monoize.sml index 8f6b298d..4208f594 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -4484,13 +4484,14 @@ fun monoize env file = (L'.DDatatype (dts @ !pvarDefs), loc) :: Fm.decls fm @ ds | _ => ds' @ Fm.decls fm @ (L'.DDatatype (!pvarDefs), loc) :: ds))) - (env, Fm.empty mname, []) file + (env, Fm.empty mname, []) file + val monoFile = (rev ds, []) in pvars := RM.empty; pvarDefs := []; pvarOldDefs := []; - Fm.canonical := fm; - (rev ds, []) + MonoFooify.canonicalFm := Fm.empty (MonoUtil.File.maxName monoFile); + monoFile end end diff --git a/src/sqlcache.sml b/src/sqlcache.sml index 6b4216ea..eaa94685 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -493,27 +493,34 @@ fun incRels inc = bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound} 0 -fun cacheWrap (env, query, i, resultTyp, args) = +fun cacheWrap (env, exp, resultTyp, args, i) = let - val () = ffiInfo := {index = i, params = length args} :: !ffiInfo val loc = dummyLoc val rel0 = (ERel 0, loc) - (* We ensure before this step that all arguments aren't effectful. - by turning them into local variables as needed. *) - val argsInc = map (incRels 1) args - val check = (check (i, args), dummyLoc) - val store = (store (i, argsInc, MonoFooify.urlify env (rel0, resultTyp)), dummyLoc) in - ECase (check, - [((PNone stringTyp, loc), - (ELet (varName "q", resultTyp, query, (ESeq (store, rel0), loc)), loc)), - ((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc), - (* Boolean is false because we're not unurlifying from a cookie. *) - (EUnurlify (rel0, resultTyp, false), loc))], - {disc = stringTyp, result = resultTyp}) + case MonoFooify.urlify env (rel0, resultTyp) of + NONE => NONE + | SOME urlified => + let + val () = ffiInfo := {index = i, params = length args} :: !ffiInfo + (* We ensure before this step that all arguments aren't effectful. + by turning them into local variables as needed. *) + val argsInc = map (incRels 1) args + val check = (check (i, args), loc) + val store = (store (i, argsInc, urlified), loc) + in + SOME (ECase + (check, + [((PNone stringTyp, loc), + (ELet (varName "q", resultTyp, exp, (ESeq (store, rel0), loc)), loc)), + ((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc), + (* Boolean is false because we're not unurlifying from a cookie. *) + (EUnurlify (rel0, resultTyp, false), loc))], + {disc = (TOption stringTyp, loc), result = resultTyp})) + end end -fun fileMapfold doExp file start = +fun fileMapfoldB doExp file start = case MonoUtil.File.mapfoldB {typ = Search.return2, exp = fn env => fn e' => fn s => Search.Continue (doExp env e' s), @@ -523,7 +530,7 @@ fun fileMapfold doExp file start = Search.Continue x => x | Search.Return _ => raise Match -fun fileMap doExp file = #1 (fileMapfold (fn _ => fn e => fn _ => (doExp e, ())) file ()) +fun fileMap doExp file = #1 (fileMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ()) fun factorOutNontrivial text = let @@ -561,6 +568,7 @@ fun factorOutNontrivial text = fun addChecking file = let + val effs = effectfulDecls file fun doExp env (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) = fn e' as EQuery {query = origQueryText, state = resultTyp, @@ -582,7 +590,6 @@ fun addChecking file = val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc)) fun bind x f = Option.mapPartial f x fun guard b x = if b then x else NONE - val effs = effectfulDecls file (* We use dummyTyp here. I think this is okay because databases don't store (effectful) functions, but perhaps there's some pathalogical corner case missing.... *) @@ -596,12 +603,13 @@ fun addChecking file = (* Ziv misses Haskell's do notation.... *) guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) ( bind (Sql.parse Sql.query queryText) (fn queryParsed => - SOME (wrapLets (cacheWrap (env, queryExp, index, resultTyp, args)), + bind (cacheWrap (env, queryExp, resultTyp, args, index)) (fn cachedExp => + SOME (wrapLets cachedExp, (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index)) tableToIndices (tablesQuery queryParsed), IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)), - index + 1)))) + index + 1))))) in case attempt of SOME pair => pair @@ -609,9 +617,10 @@ fun addChecking file = end | e' => (e', queryInfo) in - fileMapfold (fn env => fn exp => fn state => doExp env state exp) - file - (SIMM.empty, IM.empty, 0) + (fileMapfoldB (fn env => fn exp => fn state => doExp env state exp) + file + (SIMM.empty, IM.empty, 0), + effs) end structure Invalidations = struct @@ -662,7 +671,7 @@ val invalidations = Invalidations.invalidations (* DEBUG *) val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] -fun addFlushing (file, (tableToIndices, indexToQueryNumArgs, _)) = +fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) = let val flushes = List.concat o map (fn (i, argss) => map (fn args => flush (i, args)) argss) @@ -694,7 +703,7 @@ fun addFlushing (file, (tableToIndices, indexToQueryNumArgs, _)) = in (* DEBUG *) gunk := []; - fileMap doExp file + (fileMap doExp file, index, effs) end val inlineSql = @@ -713,25 +722,11 @@ val inlineSql = fileMap doExp end -fun go file = - let - (* TODO: do something nicer than [Sql] being in one of two modes. *) - val () = (resetFfiInfo (); Sql.sqlcacheMode := true) - val file' = addFlushing (addChecking (inlineSql file)) - val () = Sql.sqlcacheMode := false - in - file' - end - (**********************) (* Mono Type Checking *) (**********************) -val typOfPrim = - fn Prim.Int _ => TFfi ("Basis", "int") - | Prim.Float _ => TFfi ("Basis", "int") - fun typOfExp' (env : MonoEnv.env) : exp' -> typ option = fn EPrim p => SOME (TFfi ("Basis", case p of Prim.Int _ => "int" @@ -779,6 +774,7 @@ fun typOfExp' (env : MonoEnv.env) : exp' -> typ option = | ELet (s, t, e1, e2) => typOfExp (MonoEnv.pushERel env s t (SOME e1)) e2 | EClosure _ => NONE | EUnurlify (_, t, _) => SOME t + | _ => NONE and typOfExp env (e', loc) = typOfExp' env e' @@ -797,17 +793,35 @@ val expOfSubexp = fn Pure f => f () | Impure e => e -val makeCache : MonoEnv.env -> exp' -> exp' = fn _ => fn _ => raise Fail "TODO" - -fun pureCache (effs : IS.set) (env : MonoEnv.env) (exp as (exp', loc)) : subexp = +fun makeCache (env, exp', index) = + case typOfExp' env exp' of + NONE => NONE + | SOME (TFun _, _) => NONE + | SOME typ => + case ListUtil.foldri (fn (_, _, NONE) => NONE + | (n, typ, SOME args) => + case MonoFooify.urlify env ((ERel n, dummyLoc), typ) of + NONE => NONE + | SOME arg => SOME (arg :: args)) + (SOME []) + (MonoEnv.typeContext env) of + NONE => NONE + | SOME args => cacheWrap (env, (exp', dummyLoc), typ, args, index) + +fun pureCache (effs : IS.set) ((env, exp as (exp', loc)), index) : subexp * int = let fun wrapBindN f (args : (MonoEnv.env * exp) list) = let - val subexps = map (fn (env, exp) => pureCache effs env exp) args + val (subexps, index) = ListUtil.foldlMap (pureCache effs) index args + fun mkExp () = (f (map expOfSubexp subexps), loc) in if List.exists isImpure subexps - then Impure (f (map expOfSubexp subexps), loc) - else Pure (fn () => (makeCache env (f (map #2 args)), loc)) + then (Impure (mkExp ()), index) + else (Pure (fn () => case makeCache (env, f (map #2 args), index) of + NONE => mkExp () + | SOME e' => (e', loc)), + (* Conservatively increment index. *) + index + 1) end fun wrapBind1 f arg = wrapBindN (fn [arg] => f arg | _ => raise Match) [arg] @@ -837,7 +851,8 @@ fun pureCache (effs : IS.set) (env : MonoEnv.env) (exp as (exp', loc)) : subexp wrapBindN (fn (e::es) => ECase (e, (ListPair.map (fn (e, (p, _)) => (p, e)) (es, cases)), - {disc = disc, result = result})) + {disc = disc, result = result}) + | _ => raise Match) ((env, e) :: map (fn (p, e) => (MonoEnv.patBinds env p, e)) cases) | EStrcat (e1, e2) => wrap2 EStrcat (e1, e2) (* We record page writes, so they're cachable. *) @@ -849,8 +864,61 @@ fun pureCache (effs : IS.set) (env : MonoEnv.env) (exp as (exp', loc)) : subexp (* ASK: | EClosure (n, es) => ? *) | EUnurlify (e, t, b) => wrap1 (fn e => EUnurlify (e, t, b)) e | _ => if effectful effs env exp - then Impure exp - else Pure (fn () => (makeCache env exp', loc)) + then (Impure exp, index) + else (Pure (fn () => (case makeCache (env, exp', index) of + NONE => exp' + | SOME e' => e', + loc)), + index + 1) + end + +fun addPure ((decls, sideInfo), index, effs) = + let + fun doVal ((x, n, t, exp, s), index) = + let + val (subexp, index) = pureCache effs ((MonoEnv.empty, exp), index) + in + ((x, n, t, expOfSubexp subexp, s), index) + end + fun doDecl' (decl', index) = + case decl' of + DVal v => + let + val (v, index) = (doVal (v, index)) + in + (DVal v, index) + end + | DValRec vs => + let + val (vs, index) = ListUtil.foldlMap doVal index vs + in + (DValRec vs, index) + end + | _ => (decl', index) + fun doDecl ((decl', loc), index) = + let + val (decl', index) = doDecl' (decl', index) + in + ((decl', loc), index) + end + val decls = #1 (ListUtil.foldlMap doDecl index decls) + (* Important that this happens after the MonoFooify.urlify calls! *) + val fmDecls = MonoFooify.getNewFmDecls () + in + print (Int.toString (length fmDecls)); + (decls @ fmDecls, sideInfo) + end + +val go' = addPure o addFlushing o addChecking o inlineSql + +fun go file = + let + (* TODO: do something nicer than [Sql] being in one of two modes. *) + val () = (resetFfiInfo (); Sql.sqlcacheMode := true) + val file' = go' file + val () = Sql.sqlcacheMode := false + in + file' end end -- cgit v1.2.3 From 067c8cd3b908eb057f6721453a5c3801965d43b8 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Sun, 27 Sep 2015 14:46:12 -0400 Subject: Use referenced (rather than all) free variables as keys for pure caches. --- src/mono_env.sig | 2 -- src/mono_env.sml | 2 -- src/sqlcache.sml | 34 ++++++++++++++++++++++++---------- 3 files changed, 24 insertions(+), 14 deletions(-) (limited to 'src/mono_env.sml') diff --git a/src/mono_env.sig b/src/mono_env.sig index 9805c0d1..db6fdc95 100644 --- a/src/mono_env.sig +++ b/src/mono_env.sig @@ -42,8 +42,6 @@ signature MONO_ENV = sig val pushERel : env -> string -> Mono.typ -> Mono.exp option -> env val lookupERel : env -> int -> string * Mono.typ * Mono.exp option - val typeContext : env -> Mono.typ list - val pushENamed : env -> string -> int -> Mono.typ -> Mono.exp option -> string -> env val lookupENamed : env -> int -> string * Mono.typ * Mono.exp option * string diff --git a/src/mono_env.sml b/src/mono_env.sml index 8617425e..52e07893 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -108,8 +108,6 @@ fun lookupERel (env : env) n = (List.nth (#relE env, n)) handle Subscript => raise UnboundRel n -fun typeContext (env : env) = map #2 (#relE env) - fun pushENamed (env : env) x n t eo s = {datatypes = #datatypes env, constructors = #constructors env, diff --git a/src/sqlcache.sml b/src/sqlcache.sml index eaa94685..fa4a0d22 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -673,8 +673,8 @@ val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) = let - val flushes = List.concat o - map (fn (i, argss) => map (fn args => flush (i, args)) argss) + val flushes = List.concat + o map (fn (i, argss) => map (fn args => flush (i, args)) argss) val doExp = fn EDml (origDmlText, failureMode) => let @@ -783,6 +783,18 @@ and typOfExp env (e', loc) = typOfExp' env e' (* Caching Pure Subexpressions *) (*******************************) +val freeVars = + IS.listItems + o MonoUtil.Exp.foldB + {typ = #2, + exp = fn (bound, ERel n, vars) => if n < bound + then vars + else IS.add (vars, n - bound) + | (_, _, vars) => vars, + bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound} + 0 + IS.empty + datatype subexp = Pure of unit -> exp | Impure of exp val isImpure = @@ -798,13 +810,14 @@ fun makeCache (env, exp', index) = NONE => NONE | SOME (TFun _, _) => NONE | SOME typ => - case ListUtil.foldri (fn (_, _, NONE) => NONE - | (n, typ, SOME args) => - case MonoFooify.urlify env ((ERel n, dummyLoc), typ) of - NONE => NONE - | SOME arg => SOME (arg :: args)) - (SOME []) - (MonoEnv.typeContext env) of + case List.foldr (fn ((_, _), NONE) => NONE + | ((n, typ), SOME args) => + case MonoFooify.urlify env ((ERel n, dummyLoc), typ) of + NONE => NONE + | SOME arg => SOME (arg :: args)) + (SOME []) + (map (fn n => (n, #2 (MonoEnv.lookupERel env n))) + (freeVars (exp', dummyLoc))) of NONE => NONE | SOME args => cacheWrap (env, (exp', dummyLoc), typ, args, index) @@ -906,7 +919,8 @@ fun addPure ((decls, sideInfo), index, effs) = val fmDecls = MonoFooify.getNewFmDecls () in print (Int.toString (length fmDecls)); - (decls @ fmDecls, sideInfo) + (* ASK: fmDecls before or after? *) + (fmDecls @ decls, sideInfo) end val go' = addPure o addFlushing o addChecking o inlineSql -- cgit v1.2.3