From d321a012ed51bf14ce6271198ccb29784efb7bd5 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 30 Oct 2008 14:36:48 -0400 Subject: time type --- src/mono_opt.sml | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'src/mono_opt.sml') diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 843bdf90..8d11fe1a 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -197,6 +197,13 @@ fun exp e = | EWrite (EFfiApp ("Basis", "htmlifyBool", [e]), _) => EFfiApp ("Basis", "htmlifyBool_w", [e]) + | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "timeToString"), _), e), _)]) => + EFfiApp ("Basis", "htmlifyTime", [e]) + | EFfiApp ("Basis", "htmlifyString_w", [(EApp ((EFfi ("Basis", "timeToString"), _), e), _)]) => + EFfiApp ("Basis", "htmlifyTime_w", [e]) + | EWrite (EFfiApp ("Basis", "htmlifyTime", [e]), _) => + EFfiApp ("Basis", "htmlifyTime_w", [e]) + | EFfiApp ("Basis", "htmlifyString", [(EPrim (Prim.String s), _)]) => EPrim (Prim.String (htmlifyString s)) | EWrite (EFfiApp ("Basis", "htmlifyString", [(EPrim (Prim.String s), _)]), loc) => -- cgit v1.2.3 From 36a9df5f71b954949b92520c6e472548aa5ebfb1 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 1 Nov 2008 16:50:28 -0400 Subject: Remove empty writes --- src/mono_opt.sml | 3 +++ 1 file changed, 3 insertions(+) (limited to 'src/mono_opt.sml') diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 8d11fe1a..3cf2bcd4 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -311,6 +311,9 @@ fun exp e = | EWrite (ELet (x, t, e1, e2), loc) => optExp (ELet (x, t, e1, (EWrite e2, loc)), loc) + | EWrite (EPrim (Prim.String ""), loc) => + ERecord [] + | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) -- cgit v1.2.3 From 047a2f193646e08db526768dca8376b7270eecb5 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 1 Nov 2008 21:19:43 -0400 Subject: Almost have that nested save function compiling --- src/cjrize.sml | 19 ++++--- src/core_util.sml | 2 +- src/elab_util.sml | 21 +++++--- src/especialize.sml | 149 +++++++++++++++++++++++++++++++++++++--------------- src/expl_print.sml | 1 + src/expl_util.sml | 2 +- src/mono_opt.sml | 15 +++++- src/mono_reduce.sig | 4 +- src/shake.sml | 28 +++++++--- src/sources | 6 +-- src/termination.sml | 10 +++- src/unnest.sml | 35 +++++++----- tests/blog.ur | 16 ++++++ tests/blog.urp | 4 ++ tests/blog.urs | 1 + tests/nest.ur | 22 +++++++- tests/nest2.ur | 15 ++++++ tests/nest2.urp | 3 ++ 18 files changed, 268 insertions(+), 85 deletions(-) create mode 100644 tests/blog.ur create mode 100644 tests/blog.urp create mode 100644 tests/blog.urs create mode 100644 tests/nest2.ur create mode 100644 tests/nest2.urp (limited to 'src/mono_opt.sml') diff --git a/src/cjrize.sml b/src/cjrize.sml index 05ceb0f9..db2bd48f 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -39,6 +39,7 @@ structure Sm :> sig val find : t * (string * L.typ) list * (string * L'.typ) list -> t * int val declares : t -> (int * (string * L'.typ) list) list + val clearDeclares : t -> t end = struct structure FM = BinaryMapFn(struct @@ -61,6 +62,8 @@ fun find ((n, m, ds), xts, xts') = fun declares (_, _, ds) = ds +fun clearDeclares (n, m, _) = (n, m, []) + end fun cifyTyp x = @@ -520,23 +523,25 @@ fun cjrize ds = val (dsF, ds, ps, sm) = foldl (fn (d, (dsF, ds, ps, sm)) => let val (dop, pop, sm) = cifyDecl (d, sm) + val (dsF, ds) = case dop of NONE => (dsF, ds) - | SOME (d as (L'.DDatatype (dk, x, n, _), loc)) => - ((L'.DDatatypeForward (dk, x, n), loc) :: dsF, - d :: ds) + | SOME (d as (L'.DDatatype _, loc)) => + (d :: dsF, ds) | SOME d => (dsF, d :: ds) + + val dsF = map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm) + @ dsF + val ps = case pop of NONE => ps | SOME p => p :: ps in - (dsF, ds, ps, sm) + (dsF, ds, ps, Sm.clearDeclares sm) end) ([], [], [], Sm.empty) ds in - (List.revAppend (dsF, - List.revAppend (map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm), - rev ds)), + (List.revAppend (dsF, rev ds), ps) end diff --git a/src/core_util.sml b/src/core_util.sml index 2a690736..2450562f 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -492,7 +492,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = fn t' => S.bind2 (mfe ctx e1, fn e1' => - S.map2 (mfe ctx e2, + S.map2 (mfe (bind (ctx, RelE (x, t'))) e2, fn e2' => (ELet (x, t', e1', e2'), loc)))) diff --git a/src/elab_util.sml b/src/elab_util.sml index 2e190d1e..57a94486 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -375,14 +375,19 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = | ELet (des, e) => let val (des, ctx) = foldl (fn (ed, (des, ctx)) => - (S.bind2 (des, - fn des' => - S.map2 (mfed ctx ed, + let + val ctx' = + case #1 ed of + EDVal (x, t, _) => bind (ctx, RelE (x, t)) + | EDValRec vis => + foldl (fn ((x, t, _), ctx) => bind (ctx, RelE (x, t))) ctx vis + in + (S.bind2 (des, + fn des' => + S.map2 (mfed ctx ed, fn ed' => des' @ [ed'])), - case #1 ed of - EDVal (x, t, _) => bind (ctx, RelE (x, t)) - | EDValRec vis => - foldl (fn ((x, t, _), env) => bind (ctx, RelE (x, t))) ctx vis)) + ctx') + end) (S.return2 [], ctx) des in S.bind2 (des, @@ -400,7 +405,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = (EDVal vi', loc)) | EDValRec vis => let - val ctx = foldl (fn ((x, t, _), env) => bind (ctx, RelE (x, t))) ctx vis + val ctx = foldl (fn ((x, t, _), ctx) => bind (ctx, RelE (x, t))) ctx vis in S.map2 (ListUtil.mapfold (mfvi ctx) vis, fn vis' => diff --git a/src/especialize.sml b/src/especialize.sml index b2f0c7e6..d5e93680 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -32,17 +32,43 @@ open Core structure E = CoreEnv structure U = CoreUtil -structure ILK = struct -type ord_key = int list -val compare = Order.joinL Int.compare +datatype skey = + Named of int + | App of skey * skey + +structure K = struct +type ord_key = skey list +fun compare' (k1, k2) = + case (k1, k2) of + (Named n1, Named n2) => Int.compare (n1, n2) + | (Named _, _) => LESS + | (_, Named _) => GREATER + + | (App (x1, y1), App (x2, y2)) => Order.join (compare' (x1, x2), fn () => compare' (y1, y2)) + +val compare = Order.joinL compare' end -structure ILM = BinaryMapFn(ILK) +structure KM = BinaryMapFn(K) structure IM = IntBinaryMap +fun skeyIn (e, _) = + case e of + ENamed n => SOME (Named n) + | EApp (e1, e2) => + (case (skeyIn e1, skeyIn e2) of + (SOME k1, SOME k2) => SOME (App (k1, k2)) + | _ => NONE) + | _ => NONE + +fun skeyOut (k, loc) = + case k of + Named n => (ENamed n, loc) + | App (k1, k2) => (EApp (skeyOut (k1, loc), skeyOut (k2, loc)), loc) + type func = { name : string, - args : int ILM.map, + args : int KM.map, body : exp, typ : con, tag : string @@ -62,14 +88,21 @@ fun exp (e, st : state) = fun getApp e = case e of ENamed f => SOME (f, [], []) - | EApp (e1, (ENamed x, _)) => - (case getApp (#1 e1) of - NONE => NONE - | SOME (f, xs, xs') => SOME (f, xs @ [x], xs')) | EApp (e1, e2) => (case getApp (#1 e1) of NONE => NONE - | SOME (f, xs, xs') => SOME (f, xs, xs' @ [e2])) + | SOME (f, xs, xs') => + let + val k = + if List.null xs' then + skeyIn e2 + else + NONE + in + case k of + NONE => SOME (f, xs, xs' @ [e2]) + | SOME k => SOME (f, xs @ [k], xs') + end) | _ => NONE in case getApp e of @@ -77,21 +110,30 @@ fun exp (e, st : state) = | SOME (_, [], _) => (e, st) | SOME (f, xs, xs') => case IM.find (#funcs st, f) of - NONE => (e, st) + NONE => ((*print "SHOT DOWN!\n";*) (e, st)) | SOME {name, args, body, typ, tag} => - case ILM.find (args, xs) of - SOME f' => (#1 (foldl (fn (e, arg) => (EApp (e, arg), ErrorMsg.dummySpan)) - (ENamed f', ErrorMsg.dummySpan) xs'), - st) + case KM.find (args, xs) of + SOME f' => ((*Print.prefaces "Pre-existing" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))];*) + (#1 (foldl (fn (e, arg) => (EApp (e, arg), ErrorMsg.dummySpan)) + (ENamed f', ErrorMsg.dummySpan) xs'), + st)) | NONE => let + (*val () = Print.prefaces "New" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))]*) + fun subBody (body, typ, xs) = case (#1 body, #1 typ, xs) of (_, _, []) => SOME (body, typ) | (EAbs (_, _, _, body'), TFun (_, typ'), x :: xs) => - subBody (E.subExpInExp (0, (ENamed x, ErrorMsg.dummySpan)) body', - typ', - xs) + let + val body'' = E.subExpInExp (0, skeyOut (x, #2 body)) body' + in + (*Print.prefaces "espec" [("body'", CorePrint.p_exp CoreEnv.empty body'), + ("body''", CorePrint.p_exp CoreEnv.empty body'')];*) + subBody (body'', + typ', + xs) + end | _ => NONE in case subBody (body, typ, xs) of @@ -99,8 +141,9 @@ fun exp (e, st : state) = | SOME (body', typ') => let val f' = #maxName st + (*val () = print ("f' = " ^ Int.toString f' ^ "\n")*) val funcs = IM.insert (#funcs st, f, {name = name, - args = ILM.insert (args, xs, f'), + args = KM.insert (args, xs, f'), body = body, typ = typ, tag = tag}) @@ -128,10 +171,27 @@ fun decl (d, st) = (d, st) val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl} -fun specialize file = +fun specialize' file = let - fun doDecl (d, st) = + fun doDecl (d, (st : state, changed)) = let + val funcs = #funcs st + val funcs = + case #1 d of + DValRec vis => + foldl (fn ((x, n, c, e, tag), funcs) => + IM.insert (funcs, n, {name = x, + args = KM.empty, + body = e, + typ = c, + tag = tag})) + funcs vis + | _ => funcs + + val st = {maxName = #maxName st, + funcs = funcs, + decls = []} + val (d', st) = specDecl st d val funcs = #funcs st @@ -139,37 +199,42 @@ fun specialize file = case #1 d of DVal (x, n, c, e as (EAbs _, _), tag) => IM.insert (funcs, n, {name = x, - args = ILM.empty, + args = KM.empty, body = e, typ = c, tag = tag}) - | DValRec vis => - foldl (fn ((x, n, c, e, tag), funcs) => - IM.insert (funcs, n, {name = x, - args = ILM.empty, - body = e, - typ = c, - tag = tag})) - funcs vis | _ => funcs - val ds = + val (changed, ds) = case #decls st of - [] => [d'] - | vis => [(DValRec vis, ErrorMsg.dummySpan), d'] + [] => (changed, [d']) + | vis => + (true, case d' of + (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)] + | _ => [(DValRec vis, ErrorMsg.dummySpan), d']) in - (ds, {maxName = #maxName st, - funcs = funcs, - decls = []}) + (ds, ({maxName = #maxName st, + funcs = funcs, + decls = []}, changed)) end - val (ds, _) = ListUtil.foldlMapConcat doDecl - {maxName = U.File.maxName file + 1, - funcs = IM.empty, - decls = []} - file + val (ds, (_, changed)) = ListUtil.foldlMapConcat doDecl + ({maxName = U.File.maxName file + 1, + funcs = IM.empty, + decls = []}, false) + file + in + (changed, ds) + end + +fun specialize file = + let + val (changed, file) = specialize' file in - ds + if changed then + specialize file + else + file end diff --git a/src/expl_print.sml b/src/expl_print.sml index b19a6eff..aecc3a84 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -370,6 +370,7 @@ fun p_exp' par env (e, loc) = string x, space, string ":", + space, p_con env t, space, string "=", diff --git a/src/expl_util.sml b/src/expl_util.sml index e12186b0..337ea8d6 100644 --- a/src/expl_util.sml +++ b/src/expl_util.sml @@ -331,7 +331,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = fn t' => S.bind2 (mfe ctx e1, fn e1' => - S.map2 (mfe ctx e2, + S.map2 (mfe (bind (ctx, RelE (x, t))) e2, fn e2' => (ELet (x, t', e1', e2'), loc)))) in diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 3cf2bcd4..b22f053b 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -89,7 +89,7 @@ fun sqlifyFloat n = attrifyFloat n ^ "::float8" fun sqlifyString s = "E'" ^ String.translate (fn #"'" => "\\'" | ch => str ch) (String.toString s) ^ "'::text" - + fun exp e = case e of EPrim (Prim.String s) => @@ -287,6 +287,19 @@ fun exp e = {disc = disc, result = (TRecord [], loc)}), loc) + | EApp ((ECase (discE, pes, {disc, ...}), loc), arg as (ERecord [], _)) => + let + fun doBody e = + case #1 e of + EAbs (_, _, _, body) => MonoReduce.subExpInExp (0, arg) body + | _ => (EApp (e, arg), loc) + in + optExp (ECase (discE, + map (fn (p, e) => (p, doBody e)) pes, + {disc = disc, + result = (TRecord [], loc)}), loc) + end + | EWrite (EQuery {exps, tables, state, query, initial = (EPrim (Prim.String ""), _), body = (EStrcat ((EPrim (Prim.String s), _), diff --git a/src/mono_reduce.sig b/src/mono_reduce.sig index 3769a0f5..2495c7f9 100644 --- a/src/mono_reduce.sig +++ b/src/mono_reduce.sig @@ -30,5 +30,7 @@ signature MONO_REDUCE = sig val reduce : Mono.file -> Mono.file - + + val subExpInExp : int * Mono.exp -> Mono.exp -> Mono.exp + end diff --git a/src/shake.sml b/src/shake.sml index 38d72cc5..4ebd1b0b 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -55,14 +55,19 @@ fun shake file = val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef) | ((DDatatype (_, n, _, xncs), _), (cdef, edef)) => (IM.insert (cdef, n, List.mapPartial #3 xncs), edef) - | ((DVal (_, n, t, e, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, (t, e))) + | ((DVal (_, n, t, e, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], t, e))) | ((DValRec vis, _), (cdef, edef)) => - (cdef, foldl (fn ((_, n, t, e, _), edef) => IM.insert (edef, n, (t, e))) edef vis) + let + val all_ns = map (fn (_, n, _, _, _) => n) vis + in + (cdef, foldl (fn ((_, n, t, e, _), edef) => + IM.insert (edef, n, (all_ns, t, e))) edef vis) + end | ((DExport _, _), acc) => acc | ((DTable (_, n, c, _), _), (cdef, edef)) => - (cdef, IM.insert (edef, n, (c, dummye))) + (cdef, IM.insert (edef, n, ([], c, dummye))) | ((DSequence (_, n, _), _), (cdef, edef)) => - (cdef, IM.insert (edef, n, (dummyt, dummye))) + (cdef, IM.insert (edef, n, ([], dummyt, dummye))) | ((DDatabase _, _), acc) => acc) (IM.empty, IM.empty) file @@ -96,9 +101,15 @@ fun shake file = val s' = {exp = IS.add (#exp s, n), con = #con s} in + (*print ("Need " ^ Int.toString n ^ "\n");*) case IM.find (edef, n) of NONE => s' - | SOME (t, e) => shakeExp (shakeCon s' t) e + | SOME (ns, t, e) => + let + val s' = shakeExp (shakeCon s' t) e + in + foldl (fn (n, s') => exp (ENamed n, s')) s' ns + end end | _ => s @@ -109,7 +120,12 @@ fun shake file = val s = foldl (fn (n, s) => case IM.find (edef, n) of NONE => raise Fail "Shake: Couldn't find 'val'" - | SOME (t, e) => shakeExp (shakeCon s t) e) s page_es + | SOME (ns, t, e) => + let + val s = shakeExp (shakeCon s t) e + in + foldl (fn (n, s) => exp (ENamed n, s)) s ns + end) s page_es val s = foldl (fn (c, s) => shakeCon s c) s table_cs in diff --git a/src/sources b/src/sources index 984b5e23..504013d8 100644 --- a/src/sources +++ b/src/sources @@ -116,15 +116,15 @@ mono_print.sml monoize.sig monoize.sml +mono_reduce.sig +mono_reduce.sml + mono_opt.sig mono_opt.sml untangle.sig untangle.sml -mono_reduce.sig -mono_reduce.sml - mono_shake.sig mono_shake.sml diff --git a/src/termination.sml b/src/termination.sml index 6ed4d92f..2db5bb11 100644 --- a/src/termination.sml +++ b/src/termination.sml @@ -293,7 +293,15 @@ fun declOk' env (d, loc) = | EUnif (ref (SOME e)) => exp parent (penv, calls) e | EUnif (ref NONE) => (Rabble, calls) - | ELet (_, e) => exp parent (penv, calls) e + | ELet (eds, e) => + let + fun extPenv ((ed, _), penv) = + case ed of + EDVal _ => Rabble :: penv + | EDValRec vis => foldl (fn (_, penv) => Rabble :: penv) penv vis + in + exp parent (foldl extPenv penv eds, calls) e + end end fun doVali (i, (_, f, _, e), calls) = diff --git a/src/unnest.sml b/src/unnest.sml index b305b467..f226a678 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -124,7 +124,7 @@ fun squishExp (nr, cfv, efv) = case e of ERel n => if n >= eb then - ERel (positionOf (n - eb) efv + eb) + ERel (positionOf (n - eb) efv + eb) else e | _ => e, @@ -142,17 +142,21 @@ type state = { fun kind (k, st) = (k, st) -fun exp ((ks, ts), e, st : state) = +fun exp ((ks, ts), e as old, st : state) = case e of ELet (eds, e) => let + (*val () = Print.prefaces "let" [("e", ElabPrint.p_exp E.empty (old, ErrorMsg.dummySpan))]*) + val doSubst = foldl (fn (p, e) => E.subExpInExp p e) - val (eds, (maxName, ds, subs)) = + val (eds, (ts, maxName, ds, subs)) = ListUtil.foldlMapConcat - (fn (ed, (maxName, ds, subs)) => + (fn (ed, (ts, maxName, ds, subs)) => case #1 ed of - EDVal _ => ([ed], (maxName, ds, map (fn (n, e) => (n + 1, E.liftExpInExp 0 e)) subs)) + EDVal (x, t, _) => ([ed], + ((x, t) :: ts, + maxName, ds, map (fn (n, e) => (n + 1, E.liftExpInExp 0 e)) subs)) | EDValRec vis => let val loc = #2 ed @@ -174,7 +178,10 @@ fun exp ((ks, ts), e, st : state) = end) (IS.empty, IS.empty) vis - (*val () = print ("A: " ^ Int.toString (length ts) ^ ", " ^ Int.toString (length ks) ^ "\n")*) + (*val () = print ("A: " ^ Int.toString (length ts) ^ ", " ^ Int.toString (length ks) ^ "\n") + val () = app (fn (x, t) => + Print.prefaces "Var" [("x", Print.PD.string x), + ("t", ElabPrint.p_con E.empty t)]) ts*) val cfv = IS.foldl (fn (x, cfv) => let (*val () = print (Int.toString x ^ "\n")*) @@ -193,11 +200,11 @@ fun exp ((ks, ts), e, st : state) = fun apply e = let - val e = IS.foldl (fn (x, e) => + val e = IS.foldr (fn (x, e) => (ECApp (e, (CRel x, loc)), loc)) e cfv in - IS.foldl (fn (x, e) => + IS.foldr (fn (x, e) => (EApp (e, (ERel x, loc)), loc)) e efv end @@ -237,9 +244,9 @@ fun exp ((ks, ts), e, st : state) = val t = squishCon cfv t (*val () = Print.prefaces "squishExp" [("e", ElabPrint.p_exp E.empty e)]*) - val e = squishExp (nr, cfv, efv) e + val e = squishExp (0(*nr*), cfv, efv) e - val (e, t) = foldr (fn (ex, (e, t)) => + val (e, t) = foldl (fn (ex, (e, t)) => let val (name, t') = List.nth (ts, ex) in @@ -252,7 +259,7 @@ fun exp ((ks, ts), e, st : state) = end) (e, t) efv - val (e, t) = foldr (fn (cx, (e, t)) => + val (e, t) = foldl (fn (cx, (e, t)) => let val (name, k) = List.nth (ks, cx) in @@ -272,10 +279,12 @@ fun exp ((ks, ts), e, st : state) = vis val d = (DValRec vis, #2 ed) + + val ts = map (fn (x, _, t, _) => (x, t)) vis @ ts in - ([], (maxName, d :: ds, subs)) + ([], (ts, maxName, d :: ds, subs)) end) - (#maxName st, #decls st, []) eds + (ts, #maxName st, #decls st, []) eds in (ELet (eds, doSubst e subs), {maxName = maxName, diff --git a/tests/blog.ur b/tests/blog.ur new file mode 100644 index 00000000..a3a06cb6 --- /dev/null +++ b/tests/blog.ur @@ -0,0 +1,16 @@ +fun main wrap = + let + fun edit id = + let + val r = 0 + fun save () = + in + wrap (save ()) + end + in + edit 0 + end + +fun wrap (inside : xbody) = return + +val main () = main wrap diff --git a/tests/blog.urp b/tests/blog.urp new file mode 100644 index 00000000..a3f7bfaa --- /dev/null +++ b/tests/blog.urp @@ -0,0 +1,4 @@ +debug +database dbname=blog + +blog \ No newline at end of file diff --git a/tests/blog.urs b/tests/blog.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/blog.urs @@ -0,0 +1 @@ +val main : unit -> transaction page diff --git a/tests/nest.ur b/tests/nest.ur index 8da50712..96bfdff4 100644 --- a/tests/nest.ur +++ b/tests/nest.ur @@ -45,7 +45,26 @@ fun f (x : int) = page3 end -datatype list t = Nil | Cons of t * list t +fun add2 (x : int) (y : int) = + let + fun add3 () = x + y + in + add3 + end + +fun add3 (x : int) = + let + fun add2 (y : int) = + let + fun add1 (z : int) = x + y + z + in + add1 + end + in + add2 + end + +(*datatype list t = Nil | Cons of t * list t fun length (t ::: Type) (ls : list t) = let @@ -57,3 +76,4 @@ fun length (t ::: Type) (ls : list t) = length' ls 0 end +*) diff --git a/tests/nest2.ur b/tests/nest2.ur new file mode 100644 index 00000000..9a1d271a --- /dev/null +++ b/tests/nest2.ur @@ -0,0 +1,15 @@ +fun wooho (wrap : xbody -> transaction page) = + let + fun subPage n = + let + fun subberPage () = wrap {[n]} + in + wrap Go + end + in + subPage 0 + end + +fun wrap x = return {x} + +fun main () = wooho wrap diff --git a/tests/nest2.urp b/tests/nest2.urp new file mode 100644 index 00000000..2668c65e --- /dev/null +++ b/tests/nest2.urp @@ -0,0 +1,3 @@ +debug + +nest2 -- cgit v1.2.3 From 0a10b5b7d2bbdcbfec723176b2a31d6b4c6d34d1 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 15:37:38 -0500 Subject: Inserted a NULL value --- CHANGELOG | 9 +++++ include/urweb.h | 6 +++ lib/basis.urs | 5 +++ src/c/urweb.c | 35 ++++++++++++++++++ src/cjr_print.sml | 101 +++++++++++++++++++++++++++++++++++++++++---------- src/elab_env.sml | 31 ++++++++++++++-- src/elaborate.sml | 47 ++++++++++++++++-------- src/mono_opt.sml | 5 +++ src/monoize.sml | 24 ++++++++++-- src/urweb.grm | 5 ++- src/urweb.lex | 1 + tests/sql_option.ur | 22 +++++++++++ tests/sql_option.urp | 5 +++ 13 files changed, 252 insertions(+), 44 deletions(-) create mode 100644 tests/sql_option.ur create mode 100644 tests/sql_option.urp (limited to 'src/mono_opt.sml') diff --git a/CHANGELOG b/CHANGELOG index aca01ea7..0f8d0f09 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,12 @@ +======== +NEXT +======== + +- Nested function definitions +- Primitive "time" type +- Nullable SQL columns (via "option") +- Cookies + ======== 20081028 ======== diff --git a/include/urweb.h b/include/urweb.h index 7db66ed4..7e16fd40 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -80,6 +80,12 @@ uw_Basis_string uw_Basis_sqlifyString(uw_context, uw_Basis_string); uw_Basis_string uw_Basis_sqlifyBool(uw_context, uw_Basis_bool); uw_Basis_string uw_Basis_sqlifyTime(uw_context, uw_Basis_time); +uw_Basis_string uw_Basis_sqlifyIntN(uw_context, uw_Basis_int*); +uw_Basis_string uw_Basis_sqlifyFloatN(uw_context, uw_Basis_float*); +uw_Basis_string uw_Basis_sqlifyStringN(uw_context, uw_Basis_string); +uw_Basis_string uw_Basis_sqlifyBoolN(uw_context, uw_Basis_bool*); +uw_Basis_string uw_Basis_sqlifyTimeN(uw_context, uw_Basis_time*); + char *uw_Basis_ensqlBool(uw_Basis_bool); uw_Basis_string uw_Basis_intToString(uw_context, uw_Basis_int); diff --git a/lib/basis.urs b/lib/basis.urs index 84fb4e4c..f68bedee 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -188,6 +188,11 @@ val sql_int : sql_injectable int val sql_float : sql_injectable float val sql_string : sql_injectable string val sql_time : sql_injectable time +val sql_option_bool : sql_injectable (option bool) +val sql_option_int : sql_injectable (option int) +val sql_option_float : sql_injectable (option float) +val sql_option_string : sql_injectable (option string) +val sql_option_time : sql_injectable (option time) val sql_inject : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type -> sql_injectable t -> t -> sql_exp tables agg exps t diff --git a/src/c/urweb.c b/src/c/urweb.c index 638fbb16..1530c138 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -872,6 +872,13 @@ char *uw_Basis_sqlifyInt(uw_context ctx, uw_Basis_int n) { return r; } +char *uw_Basis_sqlifyIntN(uw_context ctx, uw_Basis_int *n) { + if (n == NULL) + return "NULL"; + else + return uw_Basis_sqlifyInt(ctx, *n); +} + char *uw_Basis_sqlifyFloat(uw_context ctx, uw_Basis_float n) { int len; char *r; @@ -883,6 +890,13 @@ char *uw_Basis_sqlifyFloat(uw_context ctx, uw_Basis_float n) { return r; } +char *uw_Basis_sqlifyFloatN(uw_context ctx, uw_Basis_float *n) { + if (n == NULL) + return "NULL"; + else + return uw_Basis_sqlifyFloat(ctx, *n); +} + uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) { char *r, *s2; @@ -920,6 +934,13 @@ uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) { return r; } +uw_Basis_string uw_Basis_sqlifyStringN(uw_context ctx, uw_Basis_string s) { + if (s == NULL) + return "NULL"; + else + return uw_Basis_sqlifyString(ctx, s); +} + char *uw_Basis_sqlifyBool(uw_context ctx, uw_Basis_bool b) { if (b == uw_Basis_False) return "FALSE"; @@ -927,6 +948,13 @@ char *uw_Basis_sqlifyBool(uw_context ctx, uw_Basis_bool b) { return "TRUE"; } +char *uw_Basis_sqlifyBoolN(uw_context ctx, uw_Basis_bool *b) { + if (b == NULL) + return "NULL"; + else + return uw_Basis_sqlifyBool(ctx, *b); +} + char *uw_Basis_sqlifyTime(uw_context ctx, uw_Basis_time t) { size_t len; char *r; @@ -942,6 +970,13 @@ char *uw_Basis_sqlifyTime(uw_context ctx, uw_Basis_time t) { return ""; } +char *uw_Basis_sqlifyTimeN(uw_context ctx, uw_Basis_time *t) { + if (t == NULL) + return "NULL"; + else + return uw_Basis_sqlifyTime(ctx, *t); +} + char *uw_Basis_ensqlBool(uw_Basis_bool b) { static uw_Basis_int true = 1; static uw_Basis_int false = 0; diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 06154b91..d7e426c3 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -408,24 +408,61 @@ fun p_unsql wontLeakStrings env (tAll as (t, loc)) e = box [string "uw_Basis_strdup(ctx, ", e, string ")"] | TFfi ("Basis", "bool") => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"] | TFfi ("Basis", "time") => box [string "uw_Basis_stringToTime_error(ctx, ", e, string ")"] + | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL"; Print.eprefaces' [("Type", p_typ env tAll)]; string "ERROR") +fun p_getcol wontLeakStrings env (tAll as (t, loc)) i = + case t of + TOption t => + box [string "(PQgetisnull (res, i, ", + string (Int.toString i), + string ") ? NULL : ", + case t of + (TFfi ("Basis", "string"), _) => p_getcol wontLeakStrings env t i + | _ => box [string "({", + newline, + p_typ env t, + space, + string "*tmp = uw_malloc(ctx, sizeof(", + p_typ env t, + string "));", + newline, + string "*tmp = ", + p_getcol wontLeakStrings env t i, + string ";", + newline, + string "tmp;", + newline, + string "})"], + string ")"] + + | _ => + p_unsql wontLeakStrings env tAll + (box [string "PQgetvalue(res, i, ", + string (Int.toString i), + string ")"]) + datatype sql_type = Int | Float | String | Bool | Time + | Nullable of sql_type + +fun p_sql_type' t = + case t of + Int => "uw_Basis_int" + | Float => "uw_Basis_float" + | String => "uw_Basis_string" + | Bool => "uw_Basis_bool" + | Time => "uw_Basis_time" + | Nullable String => "uw_Basis_string" + | Nullable t => p_sql_type' t ^ "*" -fun p_sql_type t = - string (case t of - Int => "uw_Basis_int" - | Float => "uw_Basis_float" - | String => "uw_Basis_string" - | Bool => "uw_Basis_bool" - | Time => "uw_Basis_time") +fun p_sql_type t = string (p_sql_type' t) fun getPargs (e, _) = case e of @@ -448,6 +485,12 @@ fun p_ensql t e = | String => e | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"] | Time => box [string "uw_Basis_sqlifyTime(ctx, ", e, string ")"] + | Nullable String => e + | Nullable t => box [string "(", + e, + string " == NULL ? NULL : ", + p_ensql t (box [string "*", e]), + string ")"] fun notLeaky env allowHeapAllocated = let @@ -1169,10 +1212,7 @@ fun p_exp' par env (e, loc) = space, string "=", space, - p_unsql wontLeakStrings env t - (box [string "PQgetvalue(res, i, ", - string (Int.toString i), - string ")"]), + p_getcol wontLeakStrings env t i, string ";", newline]) outputs, @@ -1660,7 +1700,10 @@ fun p_decl env (dAll as (d, _) : decl) = string "}", newline] - | DPreparedStatements [] => box [] + | DPreparedStatements [] => + box [string "static void uw_db_prepare(uw_context ctx) {", + newline, + string "}"] | DPreparedStatements ss => box [string "static void uw_db_prepare(uw_context ctx) {", newline, @@ -1708,7 +1751,7 @@ datatype 'a search = | NotFound | Error -fun p_sqltype' env (tAll as (t, loc)) = +fun p_sqltype'' env (tAll as (t, loc)) = case t of TFfi ("Basis", "int") => "int8" | TFfi ("Basis", "float") => "float8" @@ -1719,8 +1762,25 @@ fun p_sqltype' env (tAll as (t, loc)) = Print.eprefaces' [("Type", p_typ env tAll)]; "ERROR") +fun p_sqltype' env (tAll as (t, loc)) = + case t of + (TOption t, _) => p_sqltype'' env t + | _ => p_sqltype'' env t ^ " NOT NULL" + fun p_sqltype env t = string (p_sqltype' env t) +fun p_sqltype_base' env t = + case t of + (TOption t, _) => p_sqltype'' env t + | _ => p_sqltype'' env t + +fun p_sqltype_base env t = string (p_sqltype_base' env t) + +fun is_not_null t = + case t of + (TOption _, _) => false + | _ => true + fun p_file env (ds, ps) = let val (pds, env) = ListUtil.foldlMap (fn (d, env) => @@ -1997,8 +2057,13 @@ fun p_file env (ds, ps) = Char.toLower (ident x), "' AND atttypid = (SELECT oid FROM pg_type", " WHERE typname = '", - p_sqltype' env t, - "'))"]) xts), + p_sqltype_base' env t, + "') AND attnotnull = ", + if is_not_null t then + "TRUE" + else + "FALSE", + ")"]) xts), ")"] val q'' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '", @@ -2295,11 +2360,7 @@ fun p_sql env (ds, _) = box [string "uw_", string (CharVector.map Char.toLower x), space, - p_sqltype env t, - space, - string "NOT", - space, - string "NULL"]) xts, + p_sqltype env (t, ErrorMsg.dummySpan)]) xts, string ");", newline, newline] diff --git a/src/elab_env.sml b/src/elab_env.sml index b14cd06c..46f62727 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -150,12 +150,14 @@ datatype class_key = CkNamed of int | CkRel of int | CkProj of int * string list * string + | CkApp of class_key * class_key fun ck2s ck = case ck of CkNamed n => "Named(" ^ Int.toString n ^ ")" | CkRel n => "Rel(" ^ Int.toString n ^ ")" | CkProj (m, ms, x) => "Proj(" ^ Int.toString m ^ "," ^ String.concatWith "," ms ^ "," ^ x ^ ")" + | CkApp (ck1, ck2) => "App(" ^ ck2s ck1 ^ ", " ^ ck2s ck2 ^ ")" fun cp2s (cn, ck) = "(" ^ cn2s cn ^ "," ^ ck2s ck ^ ")" @@ -176,6 +178,12 @@ fun compare x = join (Int.compare (m1, m2), fn () => join (joinL String.compare (ms1, ms2), fn () => String.compare (x1, x2))) + | (CkProj _, _) => LESS + | (_, CkProj _) => GREATER + + | (CkApp (f1, x1), CkApp (f2, x2)) => + join (compare (f1, f2), + fn () => compare (x1, x2)) end structure KM = BinaryMapFn(KK) @@ -251,6 +259,7 @@ fun liftClassKey ck = CkNamed _ => ck | CkRel n => CkRel (n + 1) | CkProj _ => ck + | CkApp (ck1, ck2) => CkApp (liftClassKey ck1, liftClassKey ck2) fun pushCRel (env : env) x k = let @@ -411,6 +420,10 @@ fun class_key_in (c, _) = | CNamed n => SOME (CkNamed n) | CModProj x => SOME (CkProj x) | CUnif (_, _, _, ref (SOME c)) => class_key_in c + | CApp (c1, c2) => + (case (class_key_in c1, class_key_in c2) of + (SOME k1, SOME k2) => SOME (CkApp (k1, k2)) + | _ => NONE) | _ => NONE fun class_pair_in (c, _) = @@ -653,7 +666,7 @@ fun sgnS_con (str, (sgns, strs, cons)) c = end) | _ => c -fun sgnS_con' (m1, ms', (sgns, strs, cons)) c = +fun sgnS_con' (arg as (m1, ms', (sgns, strs, cons))) c = case c of CModProj (m1, ms, x) => (case IM.find (strs, m1) of @@ -663,6 +676,8 @@ fun sgnS_con' (m1, ms', (sgns, strs, cons)) c = (case IM.find (cons, n) of NONE => c | SOME nx => CModProj (m1, ms', nx)) + | CApp (c1, c2) => CApp ((sgnS_con' arg (#1 c1), #2 c1), + (sgnS_con' arg (#1 c2), #2 c2)) | _ => c fun sgnS_sgn (str, (sgns, strs, cons)) sgn = @@ -1033,13 +1048,21 @@ fun projectVal env {sgn, str, field} = ListUtil.search (fn (x, _, to) => if x = field then SOME (let + val base = (CNamed n, #2 sgn) + val nxs = length xs + val base = ListUtil.foldli (fn (i, _, base) => + (CApp (base, + (CRel (nxs - i - 1), #2 sgn)), + #2 sgn)) + base xs + val t = case to of - NONE => (CNamed n, #2 sgn) - | SOME t => (TFun (t, (CNamed n, #2 sgn)), #2 sgn) + NONE => base + | SOME t => (TFun (t, base), #2 sgn) val k = (KType, #2 sgn) in - foldr (fn (x, t) => (TCFun (Explicit, x, k, t), #2 sgn)) + foldr (fn (x, t) => (TCFun (Implicit, x, k, t), #2 sgn)) t xs end) else diff --git a/src/elaborate.sml b/src/elaborate.sml index 3b70c623..a6edc0ed 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1389,17 +1389,32 @@ fun unmodCon env (c, loc) = end | _ => (c, loc) -fun normClassConstraint envs (c, loc) = +fun normClassKey envs c = + let + val c = ElabOps.hnormCon envs c + in + case #1 c of + L'.CApp (c1, c2) => + let + val c1 = normClassKey envs c1 + val c2 = normClassKey envs c2 + in + (L'.CApp (c1, c2), #2 c) + end + | _ => c + end + +fun normClassConstraint env (c, loc) = case c of L'.CApp (f, x) => let - val f = unmodCon (#1 envs) f - val (x, gs) = hnormCon envs x + val f = unmodCon env f + val x = normClassKey env x in - ((L'.CApp (f, x), loc), gs) + (L'.CApp (f, x), loc) end - | L'.CUnif (_, _, _, ref (SOME c)) => normClassConstraint envs c - | _ => ((c, loc), []) + | L'.CUnif (_, _, _, ref (SOME c)) => normClassConstraint env c + | _ => (c, loc) val makeInstantiable = @@ -1491,12 +1506,12 @@ fun elabExp (env, denv) (eAll as (e, loc)) = checkKind env t' tk ktype; (t', gs) end - val (dom, gs2) = normClassConstraint (env, denv) t' - val (e', et, gs3) = elabExp (E.pushERel env x dom, denv) e + val dom = normClassConstraint env t' + val (e', et, gs2) = elabExp (E.pushERel env x dom, denv) e in ((L'.EAbs (x, t', et, e'), loc), (L'.TFun (t', et), loc), - enD gs1 @ enD gs2 @ gs3) + enD gs1 @ gs2) end | L.ECApp (e, c) => let @@ -1708,11 +1723,11 @@ and elabEdecl denv (dAll as (d, loc), (env, gs : constraint list)) = val (e', et, gs2) = elabExp (env, denv) e val gs3 = checkCon (env, denv) e' et c' - val (c', gs4) = normClassConstraint (env, denv) c' + val c' = normClassConstraint env c' val env' = E.pushERel env x c' val c' = makeInstantiable c' in - ((L'.EDVal (x, c', e'), loc), (env', enD gs1 @ gs2 @ enD gs3 @ enD gs4 @ gs)) + ((L'.EDVal (x, c', e'), loc), (env', enD gs1 @ gs2 @ enD gs3 @ gs)) end | L.EDValRec vis => let @@ -1884,12 +1899,12 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = val (c', ck, gs') = elabCon (env, denv) c val (env', n) = E.pushENamed env x c' - val (c', gs'') = normClassConstraint (env, denv) c' + val c' = normClassConstraint env c' in (unifyKinds ck ktype handle KUnify ue => strError env (NotType (ck, ue))); - ([(L'.SgiVal (x, n, c'), loc)], (env', denv, gs' @ gs'' @ gs)) + ([(L'.SgiVal (x, n, c'), loc)], (env', denv, gs' @ gs)) end | L.SgiStr (x, sgn) => @@ -2875,13 +2890,13 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = val (e', et, gs2) = elabExp (env, denv) e val gs3 = checkCon (env, denv) e' et c' - val (c', gs4) = normClassConstraint (env, denv) c' + val c = normClassConstraint env c' val (env', n) = E.pushENamed env x c' val c' = makeInstantiable c' in (*prefaces "DVal" [("x", Print.PD.string x), ("c'", p_con env c')];*) - ([(L'.DVal (x, n, c', e'), loc)], (env', denv, enD gs1 @ gs2 @ enD gs3 @ enD gs4 @ gs)) + ([(L'.DVal (x, n, c', e'), loc)], (env', denv, enD gs1 @ gs2 @ enD gs3 @ gs)) end | L.DValRec vis => let @@ -3404,7 +3419,7 @@ fun elabFile basis topStr topSgn env file = ("Hnormed 2", p_con env (ElabOps.hnormCon env c2))])) | TypeClass (env, c, r, loc) => let - val c = ElabOps.hnormCon env c + val c = normClassKey env c in case E.resolveClass env c of SOME e => r := SOME e diff --git a/src/mono_opt.sml b/src/mono_opt.sml index b22f053b..93cb888b 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -268,6 +268,11 @@ fun exp e = | EFfiApp ("Basis", "sqlifyInt", [(EPrim (Prim.Int n), _)]) => EPrim (Prim.String (sqlifyInt n)) + | EFfiApp ("Basis", "sqlifyIntN", [(ENone _, _)]) => + EPrim (Prim.String "NULL") + | EFfiApp ("Basis", "sqlifyIntN", [(ESome (_, (EPrim (Prim.Int n), _)), _)]) => + EPrim (Prim.String (sqlifyInt n)) + | EFfiApp ("Basis", "sqlifyFloat", [(EPrim (Prim.Float n), _)]) => EPrim (Prim.String (sqlifyFloat n)) | EFfiApp ("Basis", "sqlifyBool", [b as (_, loc)]) => diff --git a/src/monoize.sml b/src/monoize.sml index c4c296bd..83da382b 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -982,10 +982,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EFfiApp ("Basis", "dml", [e]) => let val (e, fm) = monoExp (env, st, fm) e - val un = (L'.TRecord [], loc) in - ((L'.EAbs ("_", un, un, - (L'.EDml (liftExpInExp 0 e), loc)), loc), + ((L'.EDml (liftExpInExp 0 e), loc), fm) end @@ -1274,6 +1272,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "string"), loc), (L'.EFfiApp ("Basis", "sqlifyTime", [(L'.ERel 0, loc)]), loc)), loc), fm) + | L.EFfi ("Basis", "sql_option_int") => + ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "int"), loc), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyIntN", [(L'.ERel 0, loc)]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_option_float") => + ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "float"), loc), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyFloatN", [(L'.ERel 0, loc)]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_option_bool") => + ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "bool"), loc), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyBoolN", [(L'.ERel 0, loc)]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_option_string") => + ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "string"), loc), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyStringN", [(L'.ERel 0, loc)]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_option_time") => + ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "time"), loc), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyTimeN", [(L'.ERel 0, loc)]), loc)), loc), + fm) | L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) => ((L'.ERecord [], loc), fm) diff --git a/src/urweb.grm b/src/urweb.grm index b2f2d486..2482be1b 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -214,7 +214,7 @@ fun tagIn bt = | TRUE | FALSE | CAND | OR | NOT | COUNT | AVG | SUM | MIN | MAX | ASC | DESC - | INSERT | INTO | VALUES | UPDATE | SET | DELETE + | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | CURRENT_TIMESTAMP | NE | LT | LE | GT | GE @@ -1251,6 +1251,9 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In s (LBRACEleft, RBRACEright))) | LPAREN sqlexp RPAREN (sqlexp) + | NULL (sql_inject ((EVar (["Basis"], "None", Infer), + s (NULLleft, NULLright)))) + | COUNT LPAREN STAR RPAREN (let val loc = s (COUNTleft, RPARENright) in diff --git a/src/urweb.lex b/src/urweb.lex index f5ea558a..f4ae3a85 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -357,6 +357,7 @@ notags = [^<{\n]+; "UPDATE" => (Tokens.UPDATE (pos yypos, pos yypos + size yytext)); "SET" => (Tokens.SET (pos yypos, pos yypos + size yytext)); "DELETE" => (Tokens.DELETE (pos yypos, pos yypos + size yytext)); + "NULL" => (Tokens.NULL (pos yypos, pos yypos + size yytext)); "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext)); diff --git a/tests/sql_option.ur b/tests/sql_option.ur new file mode 100644 index 00000000..257f8c55 --- /dev/null +++ b/tests/sql_option.ur @@ -0,0 +1,22 @@ +table t : { O : option int } + +fun addNull () = + dml (INSERT INTO t (O) VALUES (NULL)); + return Done + +(*fun add42 () = + dml (INSERT INTO t (O) VALUES (42)); + return Done*) + +fun main () : transaction page = + xml <- queryX (SELECT * FROM t) + (fn r => case r.T.O of + None => Nada
 + | Some n => Num: {[n]}
); + return + {xml} + + Add a null
+ + +(* Add a 42
*) diff --git a/tests/sql_option.urp b/tests/sql_option.urp new file mode 100644 index 00000000..543c32a8 --- /dev/null +++ b/tests/sql_option.urp @@ -0,0 +1,5 @@ +debug +database dbname=option +sql option.sql + +sql_option -- cgit v1.2.3 From a676c53ffcf88833514d12968ee5b6b28aa8cc8a Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 9 Nov 2008 18:19:47 -0500 Subject: Remove some allocation --- src/cjr_print.sml | 15 +++++++++------ src/mono_opt.sml | 30 +++++++++++++++++++++++++++++- src/mono_reduce.sig | 2 ++ src/prepare.sml | 33 ++++++++++++++++++++++++--------- 4 files changed, 64 insertions(+), 16 deletions(-) (limited to 'src/mono_opt.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 7c13fcb5..b1eb04b3 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1186,10 +1186,6 @@ fun p_exp' par env (e, loc) = p_exp env initial, string ";", newline, - case prepared of - NONE => box [string "printf(\"Executing: %s\\n\", query);", - newline] - | _ => box [], string "PGresult *res = ", case prepared of NONE => string "PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);" @@ -1371,8 +1367,15 @@ fun p_exp' par env (e, loc) = | ENextval {seq, prepared} => let - val query = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) - val query = (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), query]), loc) + val query = case seq of + (EPrim (Prim.String s), loc) => + (EPrim (Prim.String ("SELECT NEXTVAL('" ^ s ^ "')")), loc) + | _ => + let + val query = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) + in + (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), query]), loc) + end in box [string "(uw_begin_region(ctx), ", string "({", diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 93cb888b..e350db1d 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -319,12 +319,40 @@ fun exp e = e | EWrite (EQuery {exps, tables, state, query, + initial = (EPrim (Prim.String ""), _), + body}, loc) => + let + fun passLets (depth, (e', _), lets) = + case e' of + EStrcat ((ERel x, _), e'') => + if x = depth then + let + val body = (optExp (EWrite e'', loc), loc) + val body = foldl (fn ((x, t, e'), e) => + (ELet (x, t, e', e), loc)) + body lets + in + EQuery {exps = exps, tables = tables, query = query, + state = (TRecord [], loc), + initial = (ERecord [], loc), + body = body} + end + else + e + | ELet (x, t, e', e'') => + passLets (depth + 1, e'', (x, t, e') :: lets) + | _ => e + in + passLets (0, body, []) + end + + (*| EWrite (EQuery {exps, tables, state, query, initial = (EPrim (Prim.String ""), _), body = (EStrcat ((ERel 0, _), e'), _)}, loc) => EQuery {exps = exps, tables = tables, query = query, state = (TRecord [], loc), initial = (ERecord [], loc), - body = (optExp (EWrite e', loc), loc)} + body = (optExp (EWrite e', loc), loc)}*) | EWrite (ELet (x, t, e1, e2), loc) => optExp (ELet (x, t, e1, (EWrite e2, loc)), loc) diff --git a/src/mono_reduce.sig b/src/mono_reduce.sig index 2495c7f9..a6b6cc81 100644 --- a/src/mono_reduce.sig +++ b/src/mono_reduce.sig @@ -33,4 +33,6 @@ signature MONO_REDUCE = sig val subExpInExp : int * Mono.exp -> Mono.exp -> Mono.exp + val impure : Mono.exp -> bool + end diff --git a/src/prepare.sml b/src/prepare.sml index b20c7fec..28c14639 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -176,13 +176,21 @@ fun prepExp (e as (_, loc), sns) = end | EQuery {exps, tables, rnum, state, query, body, initial, ...} => - (case prepString (query, [], 0) of - NONE => (e, sns) - | SOME (ss, n) => - ((EQuery {exps = exps, tables = tables, rnum = rnum, - state = state, query = query, body = body, - initial = initial, prepared = SOME (#2 sns)}, loc), - ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1))) + let + val (body, sns) = prepExp (body, sns) + in + case prepString (query, [], 0) of + NONE => + ((EQuery {exps = exps, tables = tables, rnum = rnum, + state = state, query = query, body = body, + initial = initial, prepared = SOME (#2 sns)}, loc), + sns) + | SOME (ss, n) => + ((EQuery {exps = exps, tables = tables, rnum = rnum, + state = state, query = query, body = body, + initial = initial, prepared = SOME (#2 sns)}, loc), + ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1)) + end | EDml {dml, ...} => (case prepString (dml, [], 0) of @@ -193,8 +201,15 @@ fun prepExp (e as (_, loc), sns) = | ENextval {seq, ...} => let - val s = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) - val s = (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), s]), loc) + val s = case seq of + (EPrim (Prim.String s), loc) => + (EPrim (Prim.String ("SELECT NEXTVAL('" ^ s ^ "')")), loc) + | _ => + let + val s' = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) + in + (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), s']), loc) + end in case prepString (s, [], 0) of NONE => (e, sns) -- cgit v1.2.3 From 0510db82b18aae60ca4e9f5935ad0f18e0b1a1ea Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 11 Nov 2008 20:24:55 -0500 Subject: Fix type calculation for applying-a-case optimization --- src/mono_opt.sml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src/mono_opt.sml') diff --git a/src/mono_opt.sml b/src/mono_opt.sml index e350db1d..b56372c7 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -292,7 +292,7 @@ fun exp e = {disc = disc, result = (TRecord [], loc)}), loc) - | EApp ((ECase (discE, pes, {disc, ...}), loc), arg as (ERecord [], _)) => + | EApp ((ECase (discE, pes, {disc, result = (TFun (_, ran), _)}), loc), arg as (ERecord [], _)) => let fun doBody e = case #1 e of @@ -302,7 +302,7 @@ fun exp e = optExp (ECase (discE, map (fn (p, e) => (p, doBody e)) pes, {disc = disc, - result = (TRecord [], loc)}), loc) + result = ran}), loc) end | EWrite (EQuery {exps, tables, state, query, -- cgit v1.2.3 From 940865b04fa534983982b261386a3b1926bd5531 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 25 Nov 2008 10:05:44 -0500 Subject: Fusing writes with recursive function calls --- CHANGELOG | 5 +++ src/compiler.sig | 4 ++ src/compiler.sml | 13 +++++- src/fuse.sig | 32 ++++++++++++++ src/fuse.sml | 130 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/mono_opt.sig | 1 + src/mono_opt.sml | 2 + src/mono_util.sig | 7 +++ src/mono_util.sml | 21 ++++++++- src/sources | 3 ++ 10 files changed, 216 insertions(+), 2 deletions(-) create mode 100644 src/fuse.sig create mode 100644 src/fuse.sml (limited to 'src/mono_opt.sml') diff --git a/CHANGELOG b/CHANGELOG index a9cc96db..cbd67118 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,8 @@ +======== +======== + +- Optimization: Fusing page writes with calls to recursive functions + ======== 20081120 ======== diff --git a/src/compiler.sig b/src/compiler.sig index af086675..8c52ea32 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -76,6 +76,7 @@ signature COMPILER = sig val untangle : (Mono.file, Mono.file) phase val mono_reduce : (Mono.file, Mono.file) phase val mono_shake : (Mono.file, Mono.file) phase + val fuse : (Mono.file, Mono.file) phase val pathcheck : (Mono.file, Mono.file) phase val cjrize : (Mono.file, Cjr.file) phase val prepare : (Cjr.file, Cjr.file) phase @@ -104,6 +105,9 @@ signature COMPILER = sig val toMono_reduce : (string, Mono.file) transform val toMono_shake : (string, Mono.file) transform val toMono_opt2 : (string, Mono.file) transform + val toFuse : (string, Mono.file) transform + val toUntangle2 : (string, Mono.file) transform + val toMono_shake2 : (string, Mono.file) transform val toPathcheck : (string, Mono.file) transform val toCjrize : (string, Cjr.file) transform val toPrepare : (string, Cjr.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 6a6c4391..aac4a924 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -523,12 +523,23 @@ val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake +val fuse = { + func = Fuse.fuse, + print = MonoPrint.p_file MonoEnv.empty +} + +val toFuse = transform fuse "fuse" o toMono_opt2 + +val toUntangle2 = transform untangle "untangle2" o toFuse + +val toMono_shake2 = transform mono_shake "mono_shake2" o toUntangle2 + val pathcheck = { func = (fn file => (PathCheck.check file; file)), print = MonoPrint.p_file MonoEnv.empty } -val toPathcheck = transform pathcheck "pathcheck" o toMono_opt2 +val toPathcheck = transform pathcheck "pathcheck" o toMono_shake2 val cjrize = { func = Cjrize.cjrize, diff --git a/src/fuse.sig b/src/fuse.sig new file mode 100644 index 00000000..3ad45ac9 --- /dev/null +++ b/src/fuse.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * 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 + * 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 + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +signature FUSE = sig + + val fuse : Mono.file -> Mono.file + +end diff --git a/src/fuse.sml b/src/fuse.sml new file mode 100644 index 00000000..b6bd6b47 --- /dev/null +++ b/src/fuse.sml @@ -0,0 +1,130 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * 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 + * 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 + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure Fuse :> FUSE = struct + +open Mono +structure U = MonoUtil + +structure IM = IntBinaryMap + +fun returnsString (t, loc) = + let + fun rs (t, loc) = + case t of + TFfi ("Basis", "string") => SOME ([], (TRecord [], loc)) + | TFun (dom, ran) => + (case rs ran of + NONE => NONE + | SOME (args, ran') => SOME (dom :: args, (TFun (dom, ran'), loc))) + | _ => NONE + in + case t of + TFun (dom, ran) => + (case rs ran of + NONE => NONE + | SOME (args, ran') => SOME (dom :: args, (TFun (dom, ran'), loc))) + | _ => NONE + end + +fun fuse file = + let + fun doDecl (d as (_, loc), (funcs, maxName)) = + let + val (d, funcs, maxName) = + case #1 d of + DValRec vis => + let + val (vis', funcs, maxName) = + foldl (fn ((x, n, t, e, s), (vis', funcs, maxName)) => + case returnsString t of + NONE => (vis', funcs, maxName) + | SOME (args, t') => + let + fun getBody (e, args) = + case (#1 e, args) of + (_, []) => (e, []) + | (EAbs (x, t, _, e), _ :: args) => + let + val (body, args') = getBody (e, args) + in + (body, (x, t) :: args') + end + | _ => raise Fail "Fuse: getBody" + + val (body, args) = getBody (e, args) + val body = MonoOpt.optExp (EWrite body, loc) + val (body, _) = foldl (fn ((x, dom), (body, ran)) => + ((EAbs (x, dom, ran, body), loc), + (TFun (dom, ran), loc))) + (body, (TRecord [], loc)) args + in + ((x, maxName, t', body, s) :: vis', + IM.insert (funcs, n, maxName), + maxName + 1) + end) + ([], funcs, maxName) vis + in + ((DValRec (vis @ vis'), loc), funcs, maxName) + end + | _ => (d, funcs, maxName) + + fun exp e = + case e of + EWrite e' => + let + fun unravel (e, loc) = + case e of + ENamed n => + (case IM.find (funcs, n) of + NONE => NONE + | SOME n' => SOME (ENamed n', loc)) + | EApp (e1, e2) => + (case unravel e1 of + NONE => NONE + | SOME e1 => SOME (EApp (e1, e2), loc)) + | _ => NONE + in + case unravel e' of + NONE => e + | SOME (e', _) => e' + end + | _ => e + in + (U.Decl.map {typ = fn x => x, + exp = exp, + decl = fn x => x} + d, + (funcs, maxName)) + end + + val (file, _) = ListUtil.foldlMap doDecl (IM.empty, U.File.maxName file + 1) file + in + file + end + +end diff --git a/src/mono_opt.sig b/src/mono_opt.sig index d147e7bc..d0268087 100644 --- a/src/mono_opt.sig +++ b/src/mono_opt.sig @@ -28,5 +28,6 @@ signature MONO_OPT = sig val optimize : Mono.file -> Mono.file + val optExp : Mono.exp -> Mono.exp end diff --git a/src/mono_opt.sml b/src/mono_opt.sml index b56372c7..6c0e6e21 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -366,4 +366,6 @@ and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) val optimize = U.File.map {typ = typ, exp = exp, decl = decl} +val optExp = U.Exp.map {typ = typ, exp = exp} + end diff --git a/src/mono_util.sig b/src/mono_util.sig index 4e9d5d91..32a83855 100644 --- a/src/mono_util.sig +++ b/src/mono_util.sig @@ -90,6 +90,11 @@ structure Decl : sig exp : Mono.exp' * 'state -> 'state, decl : Mono.decl' * 'state -> 'state} -> 'state -> Mono.decl -> 'state + + val map : {typ : Mono.typ' -> Mono.typ', + exp : Mono.exp' -> Mono.exp', + decl : Mono.decl' -> Mono.decl'} + -> Mono.decl -> Mono.decl end structure File : sig @@ -121,6 +126,8 @@ structure File : sig exp : Mono.exp' * 'state -> 'state, decl : Mono.decl' * 'state -> 'state} -> 'state -> Mono.file -> 'state + + val maxName : Mono.file -> int end end diff --git a/src/mono_util.sml b/src/mono_util.sml index 14ab1674..2b2476e7 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -422,6 +422,13 @@ fun fold {typ, exp, decl} s d = S.Continue (_, s) => s | S.Return _ => raise Fail "MonoUtil.Decl.fold: Impossible" +fun map {typ, exp, decl} e = + case mapfold {typ = fn c => fn () => S.Continue (typ c, ()), + exp = fn e => fn () => S.Continue (exp e, ()), + decl = fn d => fn () => S.Continue (decl d, ())} e () of + S.Return () => raise Fail "MonoUtil.Decl.map: Impossible" + | S.Continue (e, ()) => e + end structure File = struct @@ -490,7 +497,7 @@ fun map {typ, exp, decl} e = case mapfold {typ = fn c => fn () => S.Continue (typ c, ()), exp = fn e => fn () => S.Continue (exp e, ()), decl = fn d => fn () => S.Continue (decl d, ())} e () of - S.Return () => raise Fail "Mono_util.File.map" + S.Return () => raise Fail "MonoUtil.File.map: Impossible" | S.Continue (e, ()) => e fun fold {typ, exp, decl} s d = @@ -500,6 +507,18 @@ fun fold {typ, exp, decl} s d = S.Continue (_, s) => s | S.Return _ => raise Fail "MonoUtil.File.fold: Impossible" +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 + | DVal (_, n, _, _, _) => Int.max (n, count) + | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis + | DExport _ => count + | DTable _ => count + | DSequence _ => count + | DDatabase _ => count) 0 + end end diff --git a/src/sources b/src/sources index bddcac67..13f505d0 100644 --- a/src/sources +++ b/src/sources @@ -140,6 +140,9 @@ mono_shake.sml pathcheck.sig pathcheck.sml +fuse.sig +fuse.sml + cjr.sml cjr_env.sig -- cgit v1.2.3 From e478b4d432d65b33613a601f71204fc0c656c3db Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 19 Dec 2008 12:38:11 -0500 Subject: Displayed an alert dialog --- include/urweb.h | 2 ++ lib/basis.urs | 7 ++++++- src/c/urweb.c | 35 +++++++++++++++++++++++++++++++++++ src/cjrize.sml | 2 ++ src/mono.sml | 2 ++ src/mono_opt.sml | 5 +++++ src/mono_print.sml | 3 +++ src/mono_reduce.sml | 2 ++ src/mono_util.sml | 4 ++++ src/monoize.sml | 13 +++++++++++++ tests/alert.ur | 3 +++ tests/alert.urp | 3 +++ 12 files changed, 80 insertions(+), 1 deletion(-) create mode 100644 tests/alert.ur create mode 100644 tests/alert.urp (limited to 'src/mono_opt.sml') diff --git a/include/urweb.h b/include/urweb.h index 3d7b967c..647f153a 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -94,6 +94,8 @@ uw_Basis_string uw_Basis_sqlifyTimeN(uw_context, uw_Basis_time*); char *uw_Basis_ensqlBool(uw_Basis_bool); +char *uw_Basis_jsifyString(uw_context, uw_Basis_string); + uw_Basis_string uw_Basis_intToString(uw_context, uw_Basis_int); uw_Basis_string uw_Basis_floatToString(uw_context, uw_Basis_float); uw_Basis_string uw_Basis_boolToString(uw_context, uw_Basis_bool); diff --git a/lib/basis.urs b/lib/basis.urs index ffba2b37..ac4c4832 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -100,6 +100,11 @@ val getCookie : t ::: Type -> http_cookie t -> transaction (option t) val setCookie : t ::: Type -> http_cookie t -> t -> transaction unit +(** JavaScript-y gadgets *) + +val alert : string -> transaction unit + + (** SQL *) con sql_table :: {Type} -> Type @@ -403,7 +408,7 @@ val ul : bodyTag [] val hr : bodyTag [] -val a : bodyTag [Link = transaction page] +val a : bodyTag [Link = transaction page, Onclick = transaction unit] val form : ctx ::: {Unit} -> bind ::: {Type} -> fn [[Body] ~ ctx] => diff --git a/src/c/urweb.c b/src/c/urweb.c index 7a9b3e79..64cdb81e 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -1056,6 +1056,41 @@ char *uw_Basis_ensqlBool(uw_Basis_bool b) { return (char *)&true; } +uw_Basis_string uw_Basis_jsifyString(uw_context ctx, uw_Basis_string s) { + char *r, *s2; + + uw_check_heap(ctx, strlen(s) * 4 + 2); + + r = s2 = ctx->heap_front; + *s2++ = '"'; + + for (; *s; s++) { + char c = *s; + + switch (c) { + case '"': + strcpy(s2, "\\\""); + s2 += 2; + break; + case '\\': + strcpy(s2, "\\\\"); + s2 += 2; + break; + default: + if (isprint(c)) + *s2++ = c; + else { + sprintf(s2, "\\%3o", c); + s2 += 4; + } + } + } + + strcpy(s2, "\""); + ctx->heap_front = s2 + 1; + return r; +} + uw_Basis_string uw_Basis_intToString(uw_context ctx, uw_Basis_int n) { int len; char *r; diff --git a/src/cjrize.sml b/src/cjrize.sml index 6c34923b..1152b0ef 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -420,6 +420,8 @@ fun cifyExp (eAll as (e, loc), sm) = ((L'.EUnurlify (e, t), loc), sm) end + | L.EJavaScript _ => raise Fail "EJavaScript remains" + fun cifyDecl ((d, loc), sm) = case d of L.DDatatype (x, n, xncs) => diff --git a/src/mono.sml b/src/mono.sml index f465d2bd..187b1853 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -96,6 +96,8 @@ datatype exp' = | EUnurlify of exp * typ + | EJavaScript of exp + withtype exp = exp' located diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 6c0e6e21..7f83c003 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -360,6 +360,11 @@ fun exp e = | EWrite (EPrim (Prim.String ""), loc) => ERecord [] + | EJavaScript (EAbs (_, (TRecord [], _), _, (EFfiApp ("Basis", "alert", [s]), _)), loc) => + EStrcat ((EPrim (Prim.String "alert("), loc), + (EStrcat ((EFfiApp ("Basis", "jsifyString", [s]), loc), + (EPrim (Prim.String ")"), loc)), loc)) + | _ => 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 8d91d048..7b675438 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -275,6 +275,9 @@ fun p_exp' par env (e, _) = | EUnurlify (e, _) => box [string "unurlify(", p_exp env e, string ")"] + | EJavaScript e => box [string "JavaScript(", + p_exp env e, + string ")"] and p_exp env = p_exp' false env diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 9cf6d8e8..040414f3 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -75,6 +75,7 @@ fun impure (e, _) = | ELet (_, _, e1, e2) => impure e1 orelse impure e2 | EClosure (_, es) => List.exists impure es + | EJavaScript e => impure e val liftExpInExp = Monoize.liftExpInExp @@ -329,6 +330,7 @@ fun reduce file = | EDml e => summarize d e @ [WriteDb] | ENextval e => summarize d e @ [WriteDb] | EUnurlify (e, _) => summarize d e + | EJavaScript e => summarize d e fun exp env e = diff --git a/src/mono_util.sml b/src/mono_util.sml index 2b2476e7..18b5c948 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -311,6 +311,10 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mft t, fn t' => (EUnurlify (e', t'), loc))) + | EJavaScript e => + S.map2 (mfe ctx e, + fn e' => + (EJavaScript e', loc)) in mfe end diff --git a/src/monoize.sml b/src/monoize.sml index e23d4f80..e92a1c8a 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1744,6 +1744,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) = result = (L'.TFfi ("Basis", "string"), loc)}), loc), fm) end + | (L'.TFun _, _) => + let + val s' = " " ^ lowercaseFirst x ^ "='" + in + ((L'.EStrcat (s, + (L'.EStrcat ( + (L'.EPrim (Prim.String s'), loc), + (L'.EStrcat ( + (L'.EJavaScript e, loc), + (L'.EPrim (Prim.String "'"), loc)), loc)), + loc)), loc), + fm) + end | _ => let val fooify = diff --git a/tests/alert.ur b/tests/alert.ur new file mode 100644 index 00000000..7b2eaacf --- /dev/null +++ b/tests/alert.ur @@ -0,0 +1,3 @@ +fun main () : transaction page = return + Click Me! + diff --git a/tests/alert.urp b/tests/alert.urp new file mode 100644 index 00000000..3976e9b0 --- /dev/null +++ b/tests/alert.urp @@ -0,0 +1,3 @@ +debug + +alert -- cgit v1.2.3 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/compiler.sig | 2 + src/compiler.sml | 9 +- src/jscomp.sig | 32 +++++ src/jscomp.sml | 344 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/mono_env.sig | 1 + src/mono_env.sml | 11 ++ src/mono_opt.sml | 5 - src/mono_util.sig | 11 ++ src/mono_util.sml | 15 +++ src/prim.sig | 2 + src/prim.sml | 6 + src/sources | 3 + tests/alert.ur | 2 +- 13 files changed, 436 insertions(+), 7 deletions(-) create mode 100644 src/jscomp.sig create mode 100644 src/jscomp.sml (limited to 'src/mono_opt.sml') diff --git a/src/compiler.sig b/src/compiler.sig index 59ad32be..1f1f4973 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -75,6 +75,7 @@ signature COMPILER = sig val untangle : (Mono.file, Mono.file) phase val mono_reduce : (Mono.file, Mono.file) phase val mono_shake : (Mono.file, Mono.file) phase + val jscomp : (Mono.file, Mono.file) phase val fuse : (Mono.file, Mono.file) phase val pathcheck : (Mono.file, Mono.file) phase val cjrize : (Mono.file, Cjr.file) phase @@ -101,6 +102,7 @@ signature COMPILER = sig val toUntangle : (string, Mono.file) transform val toMono_reduce : (string, Mono.file) transform val toMono_shake : (string, Mono.file) transform + val toJscomp : (string, Mono.file) transform val toMono_opt2 : (string, Mono.file) transform val toFuse : (string, Mono.file) transform val toUntangle2 : (string, Mono.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 0ff4ee6a..ecee1065 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -511,7 +511,14 @@ val mono_shake = { val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce -val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake +val jscomp = { + func = JsComp.process, + print = MonoPrint.p_file MonoEnv.empty +} + +val toJscomp = transform jscomp "jscomp" o toMono_reduce + +val toMono_opt2 = transform mono_opt "mono_opt2" o toJscomp val fuse = { func = Fuse.fuse, diff --git a/src/jscomp.sig b/src/jscomp.sig new file mode 100644 index 00000000..929c507d --- /dev/null +++ b/src/jscomp.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * 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 + * 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 + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +signature JSCOMP = sig + + val process : Mono.file -> Mono.file + +end diff --git a/src/jscomp.sml b/src/jscomp.sml new file mode 100644 index 00000000..0dd7882a --- /dev/null +++ b/src/jscomp.sml @@ -0,0 +1,344 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * 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 + * 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 + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure JsComp :> JSCOMP = struct + +open Mono + +structure EM = ErrorMsg +structure E = MonoEnv +structure U = MonoUtil + +type state = { + decls : decl list, + script : string +} + +fun varDepth (e, _) = + case e of + EPrim _ => 0 + | ERel _ => 0 + | ENamed _ => 0 + | ECon (_, _, NONE) => 0 + | ECon (_, _, SOME e) => varDepth e + | ENone _ => 0 + | ESome (_, e) => varDepth e + | EFfi _ => 0 + | EFfiApp (_, _, es) => foldl Int.max 0 (map varDepth es) + | EApp (e1, e2) => Int.max (varDepth e1, varDepth e2) + | EAbs _ => 0 + | EUnop (_, e) => varDepth e + | EBinop (_, e1, e2) => Int.max (varDepth e1, varDepth e2) + | ERecord xes => foldl Int.max 0 (map (fn (_, e, _) => varDepth e) xes) + | EField (e, _) => varDepth e + | ECase (e, pes, _) => + foldl Int.max (varDepth e) + (map (fn (p, e) => E.patBindsN p + varDepth e) pes) + | EStrcat (e1, e2) => Int.max (varDepth e1, varDepth e2) + | EError (e, _) => varDepth e + | EWrite e => varDepth e + | ESeq (e1, e2) => Int.max (varDepth e1, varDepth e2) + | ELet (_, _, e1, e2) => Int.max (varDepth e1, 1 + varDepth e2) + | EClosure _ => 0 + | EQuery _ => 0 + | EDml _ => 0 + | ENextval _ => 0 + | EUnurlify _ => 0 + | EJavaScript _ => 0 + +fun jsExp inAttr outer = + let + val len = length outer + + fun jsE inner (e as (_, loc), st) = + let + fun str s = (EPrim (Prim.String s), loc) + + fun var n = Int.toString (len + inner - n - 1) + + fun patCon pc = + case pc of + PConVar n => str (Int.toString n) + | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"") + + fun strcat es = + case es of + [] => (EPrim (Prim.String ""), loc) + | [x] => x + | x :: es' => (EStrcat (x, strcat es'), loc) + + fun isNullable (t, _) = + case t of + TOption _ => true + | _ => false + + fun unsupported s = + (EM.errorAt loc (s ^ " in code to be compiled to JavaScript"); + (str "ERROR", st)) + in + case #1 e of + EPrim (Prim.String s) => + (str ("\"" + ^ String.translate (fn #"'" => + if inAttr then + "\\047" + else + "'" + | #"<" => + if inAttr then + "<" + else + "\\074" + | #"\\" => "\\\\" + | ch => String.str ch) s + ^ "\""), st) + | EPrim p => (str (Prim.toString p), st) + | ERel n => + if n < inner then + (str ("uwr" ^ var n), st) + else + (str ("uwo" ^ var n), st) + | ENamed _ => raise Fail "Named" + | ECon (_, pc, NONE) => (patCon pc, st) + | ECon (_, pc, SOME e) => + let + val (s, st) = jsE inner (e, st) + in + (strcat [str "{n:", + patCon pc, + str ",v:", + s, + str "}"], st) + end + | ENone _ => (str "null", st) + | ESome (t, e) => + let + val (e, st) = jsE inner (e, st) + in + (if isNullable t then + strcat [str "{v:", e, str "}"] + else + e, st) + end + + | EFfi (_, s) => (str s, st) + | EFfiApp (_, s, []) => (str (s ^ "()"), st) + | EFfiApp (_, s, [e]) => + let + val (e, st) = jsE inner (e, st) + + in + (strcat [str (s ^ "("), + e, + str ")"], st) + end + | EFfiApp (_, s, e :: es) => + let + val (e, st) = jsE inner (e, st) + val (es, st) = ListUtil.foldlMapConcat + (fn (e, st) => + let + val (e, st) = jsE inner (e, st) + in + ([str ",", e], st) + end) + st es + in + (strcat (str (s ^ "(") + :: e + :: es + @ [str ")"]), st) + end + + | EApp (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [e1, str "(", e2, str ")"], st) + end + | EAbs (_, _, _, e) => + let + val locals = List.tabulate + (varDepth e, + fn i => str ("var uwr" ^ Int.toString (len + inner + i) ^ ";")) + val (e, st) = jsE (inner + 1) (e, st) + in + (strcat (str ("function(uwr" + ^ Int.toString (len + inner) + ^ "){") + :: locals + @ [str "return ", + e, + str "}"]), + st) + end + + | EUnop (s, e) => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str ("(" ^ s), + e, + str ")"], + st) + end + | EBinop (s, e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "(", + e1, + str s, + e2, + str ")"], + st) + end + + | ERecord [] => (str "null", st) + | ERecord [(x, e, _)] => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "{uw_x:", e, str "}"], st) + end + | ERecord ((x, e, _) :: xes) => + let + val (e, st) = jsE inner (e, st) + + val (es, st) = + foldr (fn ((x, e, _), (es, st)) => + let + val (e, st) = jsE inner (e, st) + in + (str (",uw_" ^ x ^ ":") + :: e + :: es, + st) + end) + ([str "}"], st) xes + in + (strcat (str ("{uw_" ^ x ^ ":") + :: e + :: es), + st) + end + | EField (e, x) => + let + val (e, st) = jsE inner (e, st) + in + (strcat [e, + str ("." ^ x)], st) + end + + | ECase _ => raise Fail "Jscomp: ECase" + + | EStrcat (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "(", e1, str "+", e2, str ")"], st) + end + + | EError (e, _) => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "alert(\"ERROR: \"+", e, str ")"], + st) + end + + | EWrite _ => unsupported "EWrite" + + | ESeq (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "(", e1, str ",", e2, str ")"], st) + end + | ELet (_, _, e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE (inner + 1) (e2, st) + in + (strcat [str ("(uwr" ^ Int.toString (len + inner) ^ "="), + e1, + str ",", + e2, + str ")"], st) + end + + | EClosure _ => unsupported "EClosure" + | EQuery _ => unsupported "Query" + | EDml _ => unsupported "DML" + | ENextval _ => unsupported "Nextval" + | EUnurlify _ => unsupported "EUnurlify" + | EJavaScript _ => unsupported "Nested JavaScript" + end + in + jsE + end + +val decl : state -> decl -> decl * state = + U.Decl.foldMapB {typ = fn x => x, + exp = fn (env, e, st) => + case e of + EJavaScript (EAbs (_, t, _, e), _) => + let + val (e, st) = jsExp true (t :: env) 0 (e, st) + in + (#1 e, st) + end + | _ => (e, st), + decl = fn (_, e, st) => (e, st), + bind = fn (env, U.Decl.RelE (_, t)) => t :: env + | (env, _) => env} + [] + +fun process file = + let + fun doDecl (d, st) = + let + val (d, st) = decl st d + in + (List.revAppend (#decls st, [d]), + {decls = [], + script = #script st}) + end + + val (ds, st) = ListUtil.foldlMapConcat doDecl + {decls = [], + script = ""} + file + in + ds + end + +end diff --git a/src/mono_env.sig b/src/mono_env.sig index cb6f2352..c59596ae 100644 --- a/src/mono_env.sig +++ b/src/mono_env.sig @@ -47,5 +47,6 @@ signature MONO_ENV = sig val declBinds : env -> Mono.decl -> env val patBinds : env -> Mono.pat -> env + val patBindsN : Mono.pat -> int end 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 diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 7f83c003..6c0e6e21 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -360,11 +360,6 @@ fun exp e = | EWrite (EPrim (Prim.String ""), loc) => ERecord [] - | EJavaScript (EAbs (_, (TRecord [], _), _, (EFfiApp ("Basis", "alert", [s]), _)), loc) => - EStrcat ((EPrim (Prim.String "alert("), loc), - (EStrcat ((EFfiApp ("Basis", "jsifyString", [s]), loc), - (EPrim (Prim.String ")"), loc)), loc)) - | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) diff --git a/src/mono_util.sig b/src/mono_util.sig index 32a83855..2a96211a 100644 --- a/src/mono_util.sig +++ b/src/mono_util.sig @@ -71,6 +71,11 @@ structure Exp : sig val exists : {typ : Mono.typ' -> bool, exp : Mono.exp' -> bool} -> Mono.exp -> bool + + val foldB : {typ : Mono.typ' * 'state -> 'state, + exp : 'context * Mono.exp' * 'state -> 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Mono.exp -> 'state end structure Decl : sig @@ -95,6 +100,12 @@ structure Decl : sig exp : Mono.exp' -> Mono.exp', decl : Mono.decl' -> Mono.decl'} -> Mono.decl -> Mono.decl + + val foldMapB : {typ : Mono.typ' * 'state -> Mono.typ' * 'state, + exp : 'context * Mono.exp' * 'state -> Mono.exp' * 'state, + decl : 'context * Mono.decl' * 'state -> Mono.decl' * 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Mono.decl -> Mono.decl * 'state end structure File : sig diff --git a/src/mono_util.sml b/src/mono_util.sml index 18b5c948..ebc30984 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -357,6 +357,13 @@ fun exists {typ, exp} k = S.Return _ => true | S.Continue _ => false +fun foldB {typ, exp, bind} ctx s e = + case mapfoldB {typ = fn t => fn s => S.Continue (t, typ (t, s)), + exp = fn ctx => fn e => fn s => S.Continue (e, exp (ctx, e, s)), + bind = bind} ctx e s of + S.Continue (_, s) => s + | S.Return _ => raise Fail "MonoUtil.Exp.foldB: Impossible" + end structure Decl = struct @@ -433,6 +440,14 @@ fun map {typ, exp, decl} e = S.Return () => raise Fail "MonoUtil.Decl.map: Impossible" | S.Continue (e, ()) => e +fun foldMapB {typ, exp, decl, bind} ctx s d = + case mapfoldB {typ = fn c => fn s => S.Continue (typ (c, s)), + exp = fn ctx => fn e => fn s => S.Continue (exp (ctx, e, s)), + decl = fn ctx => fn d => fn s => S.Continue (decl (ctx, d, s)), + bind = bind} ctx d s of + S.Continue v => v + | S.Return _ => raise Fail "MonoUtil.Decl.foldMapB: Impossible" + end structure File = struct diff --git a/src/prim.sig b/src/prim.sig index 3083a26e..54625379 100644 --- a/src/prim.sig +++ b/src/prim.sig @@ -38,4 +38,6 @@ signature PRIM = sig val equal : t * t -> bool val compare : t * t -> order + val toString : t -> string + end diff --git a/src/prim.sml b/src/prim.sml index daf666e8..468b28d5 100644 --- a/src/prim.sml +++ b/src/prim.sml @@ -53,6 +53,12 @@ fun float2s n = else Real64.toString n +fun toString t = + case t of + Int n => int2s n + | Float n => float2s n + | String s => s + fun p_t_GCC t = case t of Int n => string (int2s n) diff --git a/src/sources b/src/sources index 6972dc36..05b1cc54 100644 --- a/src/sources +++ b/src/sources @@ -137,6 +137,9 @@ untangle.sml mono_shake.sig mono_shake.sml +jscomp.sig +jscomp.sml + pathcheck.sig pathcheck.sml diff --git a/tests/alert.ur b/tests/alert.ur index 7b2eaacf..3fe68d75 100644 --- a/tests/alert.ur +++ b/tests/alert.ur @@ -1,3 +1,3 @@ fun main () : transaction page = return - Click Me! + Click Me! -- cgit v1.2.3 From d5c3faacb1c3114fe6802973a62528cda8be8ac7 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 21 Dec 2008 12:30:57 -0500 Subject: Handling singnal bind --- jslib/urweb.js | 3 +- src/cjrize.sml | 1 + src/compiler.sig | 3 +- src/compiler.sml | 8 +++-- src/jscomp.sml | 90 +++++++++++++++++++++++++++++++++++++++-------------- src/mono.sml | 1 + src/mono_opt.sml | 3 ++ src/mono_print.sml | 6 ++++ src/mono_reduce.sml | 5 +++ src/mono_util.sml | 6 ++++ src/monoize.sml | 18 +++++++++-- tests/sbind.ur | 5 +++ tests/sbind.urp | 3 ++ 13 files changed, 122 insertions(+), 30 deletions(-) create mode 100644 tests/sbind.ur create mode 100644 tests/sbind.urp (limited to 'src/mono_opt.sml') diff --git a/jslib/urweb.js b/jslib/urweb.js index b7a1af91..f552b26b 100644 --- a/jslib/urweb.js +++ b/jslib/urweb.js @@ -1,4 +1,5 @@ -function sreturn(v) { return {v : v} } +function sr(v) { return {v : v} } +function sb(x,y) { return {v : y(x.v).v} } function dyn(s) { var x = document.createElement("span"); diff --git a/src/cjrize.sml b/src/cjrize.sml index 78513ef7..a46c725e 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -423,6 +423,7 @@ fun cifyExp (eAll as (e, loc), sm) = | L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains" | L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains" + | L.ESignalBind _ => raise Fail "Cjrize: ESignalBind remains" fun cifyDecl ((d, loc), sm) = case d of diff --git a/src/compiler.sig b/src/compiler.sig index 1f1f4973..c156b268 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -102,8 +102,9 @@ signature COMPILER = sig val toUntangle : (string, Mono.file) transform val toMono_reduce : (string, Mono.file) transform val toMono_shake : (string, Mono.file) transform - val toJscomp : (string, Mono.file) transform val toMono_opt2 : (string, Mono.file) transform + val toJscomp : (string, Mono.file) transform + val toMono_opt3 : (string, Mono.file) transform val toFuse : (string, Mono.file) transform val toUntangle2 : (string, Mono.file) transform val toMono_shake2 : (string, Mono.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index ecee1065..6d499283 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -511,21 +511,23 @@ val mono_shake = { val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce +val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake + val jscomp = { func = JsComp.process, print = MonoPrint.p_file MonoEnv.empty } -val toJscomp = transform jscomp "jscomp" o toMono_reduce +val toJscomp = transform jscomp "jscomp" o toMono_opt2 -val toMono_opt2 = transform mono_opt "mono_opt2" o toJscomp +val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp val fuse = { func = Fuse.fuse, print = MonoPrint.p_file MonoEnv.empty } -val toFuse = transform fuse "fuse" o toMono_opt2 +val toFuse = transform fuse "fuse" o toMono_opt3 val toUntangle2 = transform untangle "untangle2" o toFuse diff --git a/src/jscomp.sml b/src/jscomp.sml index 95c18016..c38056e8 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -33,6 +33,20 @@ structure EM = ErrorMsg structure E = MonoEnv structure U = MonoUtil +val funcs = [(("Basis", "alert"), "alert"), + (("Basis", "htmlifyString"), "escape")] + +structure FM = BinaryMapFn(struct + type ord_key = string * string + fun compare ((m1, x1), (m2, x2)) = + Order.join (String.compare (m1, m2), + fn () => String.compare (x1, x2)) + end) + +val funcs = foldl (fn ((k, v), m) => FM.insert (m, k, v)) FM.empty funcs + +fun ffi k = FM.find (funcs, k) + type state = { decls : decl list, script : string @@ -70,6 +84,7 @@ fun varDepth (e, _) = | EUnurlify _ => 0 | EJavaScript _ => 0 | ESignalReturn e => varDepth e + | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2) fun strcat loc es = case es of @@ -150,33 +165,50 @@ fun jsExp mode outer = e, st) end - | EFfi (_, s) => (str s, st) - | EFfiApp (_, s, []) => (str (s ^ "()"), st) - | EFfiApp (_, s, [e]) => + | EFfi k => let - val (e, st) = jsE inner (e, st) - + val name = case ffi k of + NONE => (EM.errorAt loc "Unsupported FFI identifier in JavaScript"; + "ERROR") + | SOME s => s in - (strcat [str (s ^ "("), - e, - str ")"], st) + (str name, st) end - | EFfiApp (_, s, e :: es) => + | EFfiApp (m, x, args) => let - val (e, st) = jsE inner (e, st) - val (es, st) = ListUtil.foldlMapConcat - (fn (e, st) => - let - val (e, st) = jsE inner (e, st) - in - ([str ",", e], st) - end) - st es + val name = case ffi (m, x) of + NONE => (EM.errorAt loc "Unsupported FFI function in JavaScript"; + "ERROR") + | SOME s => s in - (strcat (str (s ^ "(") - :: e - :: es - @ [str ")"]), st) + case args of + [] => (str (name ^ "()"), st) + | [e] => + let + val (e, st) = jsE inner (e, st) + + in + (strcat [str (name ^ "("), + e, + str ")"], st) + end + | e :: es => + let + val (e, st) = jsE inner (e, st) + val (es, st) = ListUtil.foldlMapConcat + (fn (e, st) => + let + val (e, st) = jsE inner (e, st) + in + ([str ",", e], st) + end) + st es + in + (strcat (str (name ^ "(") + :: e + :: es + @ [str ")"]), st) + end end | EApp (e1, e2) => @@ -317,11 +349,23 @@ fun jsExp mode outer = let val (e, st) = jsE inner (e, st) in - (strcat [str "sreturn(", + (strcat [str "sr(", e, str ")"], st) end + | ESignalBind (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "sb(", + e1, + str ",", + e2, + str ")"], + st) + end end in jsE diff --git a/src/mono.sml b/src/mono.sml index 1a7fde00..54b77550 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -105,6 +105,7 @@ datatype exp' = | EJavaScript of javascript_mode * exp | ESignalReturn of exp + | ESignalBind of exp * exp withtype exp = exp' located diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 6c0e6e21..550a055c 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -360,6 +360,9 @@ fun exp e = | EWrite (EPrim (Prim.String ""), loc) => ERecord [] + | ESignalBind ((ESignalReturn e1, loc), e2) => + optExp (EApp (e2, e1), loc) + | _ => 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 e44bb74c..608fe269 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -285,6 +285,12 @@ fun p_exp' par env (e, _) = | ESignalReturn e => box [string "Return(", p_exp env e, string ")"] + | ESignalBind (e1, e2) => box [string "Return(", + p_exp env e1, + string ",", + space, + p_exp env e2, + string ")"] and p_exp env = p_exp' false env diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index e1da02c9..841e034e 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -77,6 +77,7 @@ fun impure (e, _) = | EClosure (_, es) => List.exists impure es | EJavaScript (_, e) => impure e | ESignalReturn e => impure e + | ESignalBind (e1, e2) => impure e1 orelse impure e2 val liftExpInExp = Monoize.liftExpInExp @@ -333,6 +334,7 @@ fun reduce file = | EUnurlify (e, _) => summarize d e | EJavaScript (_, e) => summarize d e | ESignalReturn e => summarize d e + | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 fun exp env e = @@ -478,6 +480,9 @@ fun reduce file = | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) => EPrim (Prim.String (s1 ^ s2)) + | ESignalBind ((ESignalReturn e1, loc), e2) => + #1 (reduceExp env (EApp (e2, e1), loc)) + | _ => e in (*Print.prefaces "exp'" [("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*) diff --git a/src/mono_util.sml b/src/mono_util.sml index 9788a551..a85443d7 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -328,6 +328,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mfe ctx e, fn e' => (ESignalReturn e', loc)) + | ESignalBind (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (ESignalBind (e1', e2'), loc))) in mfe end diff --git a/src/monoize.sml b/src/monoize.sml index 63d84d8c..30bd5daa 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -957,8 +957,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val mt1 = (L'.TFun (un, t1), loc) val mt2 = (L'.TFun (un, t2), loc) in - ((L'.EAbs ("m1", mt1, (L'.TFun (mt1, (L'.TFun (mt2, (L'.TFun (un, un), loc)), loc)), loc), - (L'.EAbs ("m2", mt2, (L'.TFun (un, un), loc), + ((L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc)), loc), + (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc), (L'.EAbs ("_", un, un, (L'.ELet ("r", t1, (L'.EApp ((L'.ERel 2, loc), (L'.ERecord [], loc)), loc), @@ -989,6 +989,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ESignalReturn (L'.ERel 0, loc), loc)), loc), fm) end + | L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _), + (L.EFfi ("Basis", "signal_monad"), _)) => + let + val t1 = monoType env t1 + val t2 = monoType env t2 + val un = (L'.TRecord [], loc) + val mt1 = (L'.TSignal t1, loc) + val mt2 = (L'.TSignal t2, loc) + in + ((L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), mt2), loc), + (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), mt2, + (L'.ESignalBind ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + fm) + end | L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) => let diff --git a/tests/sbind.ur b/tests/sbind.ur new file mode 100644 index 00000000..6e3ca782 --- /dev/null +++ b/tests/sbind.ur @@ -0,0 +1,5 @@ +fun main () : transaction page = return +

Before

+

{[s]}}/>

+

After

+ diff --git a/tests/sbind.urp b/tests/sbind.urp new file mode 100644 index 00000000..d8735c70 --- /dev/null +++ b/tests/sbind.urp @@ -0,0 +1,3 @@ +debug + +sbind -- cgit v1.2.3 From 8d3edc5aaa4617dd06623447cf9357067eadc072 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 30 Dec 2008 11:33:31 -0500 Subject: Harmonized source-setting between server and client --- src/cjrize.sml | 2 ++ src/jscomp.sml | 15 ++++++++++----- src/mono.sml | 2 +- src/mono_opt.sml | 2 ++ src/mono_print.sml | 13 ++++++++----- src/mono_reduce.sml | 4 ++-- src/mono_util.sml | 10 ++++++++-- src/monoize.sml | 16 ++++++++-------- 8 files changed, 41 insertions(+), 23 deletions(-) (limited to 'src/mono_opt.sml') diff --git a/src/cjrize.sml b/src/cjrize.sml index 6d0ece61..1a5d10c0 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -422,7 +422,9 @@ fun cifyExp (eAll as (e, loc), sm) = ((L'.EUnurlify (e, t), loc), sm) end + | L.EJavaScript (_, _, SOME e) => cifyExp (e, sm) | L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains" + | L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains" | L.ESignalBind _ => raise Fail "Cjrize: ESignalBind remains" | L.ESignalSource _ => raise Fail "Cjrize: ESignalSource remains" diff --git a/src/jscomp.sml b/src/jscomp.sml index 8b874289..a4e3dd35 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -190,6 +190,12 @@ fun jsExp mode outer = end | EFfiApp (m, x, args) => let + val args = + case (m, x, args) of + ("Basis", "new_client_source", [(EJavaScript (_, e, _), _)]) => [e] + | ("Basis", "set_client_source", [e1, (EJavaScript (_, e2, _), _)]) => [e1, e2] + | _ => args + val name = case ffi (m, x) of NONE => (EM.errorAt loc ("Unsupported FFI function " ^ x ^ " in JavaScript"); "ERROR") @@ -200,7 +206,6 @@ fun jsExp mode outer = | [e] => let val (e, st) = jsE inner (e, st) - in (strcat [str (name ^ "("), e, @@ -398,7 +403,7 @@ val decl : state -> decl -> decl * state = U.Decl.foldMapB {typ = fn x => x, exp = fn (env, e, st) => let - fun doCode m env e = + fun doCode m env orig e = let val len = length env fun str s = (EPrim (Prim.String s), #2 e) @@ -408,12 +413,12 @@ val decl : state -> decl -> decl * state = fn i => str ("var uwr" ^ Int.toString (len + i) ^ ";")) val (e, st) = jsExp m env 0 (e, st) in - (#1 (strcat (#2 e) (locals @ [e])), st) + (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st) end in case e of - EJavaScript (m, (EAbs (_, t, _, e), _)) => doCode m (t :: env) e - | EJavaScript (m, e) => doCode m env e + EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => doCode m (t :: env) orig e + | EJavaScript (m, e, _) => doCode m env e e | _ => (e, st) end, decl = fn (_, e, st) => (e, st), diff --git a/src/mono.sml b/src/mono.sml index 41457071..b58396fa 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -103,7 +103,7 @@ datatype exp' = | EUnurlify of exp * typ - | EJavaScript of javascript_mode * exp + | EJavaScript of javascript_mode * exp * exp option | ESignalReturn of exp | ESignalBind of exp * exp diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 550a055c..7f23d8b1 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -363,6 +363,8 @@ fun exp e = | ESignalBind ((ESignalReturn e1, loc), e2) => optExp (EApp (e2, e1), loc) + | EJavaScript (_, _, SOME (e, _)) => e + | _ => 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 a876cfac..f8a23d1d 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -216,10 +216,12 @@ fun p_exp' par env (e, _) = p_exp env e, string ")"] - | ESeq (e1, e2) => box [p_exp env e1, + | ESeq (e1, e2) => box [string "(", + p_exp env e1, string ";", space, - p_exp env e2] + p_exp env e2, + string ")"] | ELet (x, t, e1, e2) => box [string "(let", space, string x, @@ -279,9 +281,10 @@ fun p_exp' par env (e, _) = | EUnurlify (e, _) => box [string "unurlify(", p_exp env e, string ")"] - | EJavaScript (_, e) => box [string "JavaScript(", - p_exp env e, - string ")"] + | EJavaScript (_, e, NONE) => box [string "JavaScript(", + p_exp env e, + string ")"] + | EJavaScript (_, _, SOME e) => p_exp env e | ESignalReturn e => box [string "Return(", p_exp env e, diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 072c548e..c96f97cf 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -76,7 +76,7 @@ fun impure (e, _) = | ELet (_, _, e1, e2) => impure e1 orelse impure e2 | EClosure (_, es) => List.exists impure es - | EJavaScript (_, e) => impure e + | EJavaScript (_, e, _) => impure e | ESignalReturn e => impure e | ESignalBind (e1, e2) => impure e1 orelse impure e2 | ESignalSource e => impure e @@ -335,7 +335,7 @@ fun reduce file = | EDml e => summarize d e @ [WriteDb] | ENextval e => summarize d e @ [WriteDb] | EUnurlify (e, _) => summarize d e - | EJavaScript (_, e) => summarize d e + | EJavaScript (_, e, _) => summarize d e | ESignalReturn e => summarize d e | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 | ESignalSource e => summarize d e diff --git a/src/mono_util.sml b/src/mono_util.sml index 3f9183d0..9ce3293b 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -324,10 +324,16 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mft t, fn t' => (EUnurlify (e', t'), loc))) - | EJavaScript (m, e) => + | EJavaScript (m, e, NONE) => S.map2 (mfe ctx e, fn e' => - (EJavaScript (m, e'), loc)) + (EJavaScript (m, e', NONE), loc)) + | EJavaScript (m, e, SOME e2) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfe ctx e2, + fn e2' => + (EJavaScript (m, e', SOME e2'), loc))) | ESignalReturn e => S.map2 (mfe ctx e, diff --git a/src/monoize.sml b/src/monoize.sml index f40d49d0..f62848c5 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -976,7 +976,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TSource, loc)), loc), (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TSource, loc), (L'.EFfiApp ("Basis", "new_client_source", - [(L'.EJavaScript (L'.File, (L'.ERel 1, loc)), loc)]), loc)), loc)), + [(L'.EJavaScript (L'.File, (L'.ERel 1, loc), NONE), loc)]), + loc)), loc)), loc), fm) end @@ -990,7 +991,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), (L'.EFfiApp ("Basis", "set_client_source", [(L'.ERel 2, loc), - (L'.EJavaScript (L'.File, (L'.ERel 1, loc)), loc)]), + (L'.EJavaScript (L'.File, (L'.ERel 1, loc), NONE), loc)]), loc)), loc)), loc)), loc), fm) end @@ -1801,7 +1802,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EStrcat ( (L'.EPrim (Prim.String s'), loc), (L'.EStrcat ( - (L'.EJavaScript (L'.Attribute, e), loc), + (L'.EJavaScript (L'.Attribute, e, NONE), loc), (L'.EPrim (Prim.String "'"), loc)), loc)), loc)), loc), fm) @@ -1887,13 +1888,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | "dyn" => (case #1 attrs of - (*L'.ERecord [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _), - e), _), _)] => (e, fm) *) - - L'.ERecord [("Signal", e, _)] => + L'.ERecord [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _), + e), _), _)] => (e, fm) + | L'.ERecord [("Signal", e, _)] => ((L'.EStrcat ((L'.EPrim (Prim.String ""), loc)), loc)), loc), fm) | _ => raise Fail "Monoize: Bad dyn attributes") -- cgit v1.2.3 From b8e7b835e7cde4cf374138467da8b16e93a65eb9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 10 Mar 2009 15:17:23 -0400 Subject: Batch example --- demo/batch.ur | 80 +++++++++ demo/batch.urp | 3 + demo/batch.urs | 1 + demo/increment.urp | 1 - demo/prose | 4 + lib/js/urweb.js | 25 ++- src/jscomp.sml | 6 +- src/mono_opt.sml | 2 + src/rpcify.sml | 506 +++++++++++++++++++++++++++++------------------------ 9 files changed, 395 insertions(+), 233 deletions(-) create mode 100644 demo/batch.ur create mode 100644 demo/batch.urp create mode 100644 demo/batch.urs (limited to 'src/mono_opt.sml') diff --git a/demo/batch.ur b/demo/batch.ur new file mode 100644 index 00000000..454ff691 --- /dev/null +++ b/demo/batch.ur @@ -0,0 +1,80 @@ +datatype list t = Nil | Cons of t * list t + +table t : {Id : int, A : string} + +fun allRows () = + query (SELECT * FROM t) + (fn r acc => return (Cons ((r.T.Id, r.T.A), acc))) + Nil + +fun doBatch ls = + case ls of + Nil => return () + | Cons ((id, a), ls') => + dml (INSERT INTO t (Id, A) VALUES ({[id]}, {[a]})); + doBatch ls' + +fun del id = + dml (DELETE FROM t WHERE t.Id = {[id]}) + +fun show withDel lss = + let + fun show' ls = + case ls of + Nil => + | Cons ((id, a), ls) => + {[id]} {[a]} {if withDel then +