Mercurial > urweb
changeset 280:fdd7a698be01
Compiling a parametrized query the inefficient way
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 02 Sep 2008 17:31:45 -0400 |
| parents | 8bb46d87b074 |
| children | 7d5860add50f |
| files | include/urweb.h lib/basis.urs src/c/urweb.c src/cjr_env.sml src/cjr_print.sml src/cjrize.sml src/compiler.sml src/elaborate.sml src/mono_reduce.sml src/tag.sml tests/pquery.ur tests/pquery.urp tests/pquery.urs |
| diffstat | 13 files changed, 111 insertions(+), 29 deletions(-) [+] |
line wrap: on
line diff
--- a/include/urweb.h Tue Sep 02 16:18:05 2008 -0400 +++ b/include/urweb.h Tue Sep 02 17:31:45 2008 -0400 @@ -59,3 +59,5 @@ lw_Basis_string lw_Basis_strcat(lw_context, lw_Basis_string, lw_Basis_string); lw_Basis_string lw_Basis_strdup(lw_context, lw_Basis_string); + +lw_Basis_string lw_Basis_sqlifyString(lw_context, lw_Basis_string);
--- a/lib/basis.urs Tue Sep 02 16:18:05 2008 -0400 +++ b/lib/basis.urs Tue Sep 02 17:31:45 2008 -0400 @@ -230,7 +230,7 @@ val h1 : bodyTag [] val li : bodyTag [] -val a : bodyTag [Link = page] +val a : bodyTag [Link = transaction page] val lform : ctx ::: {Unit} -> [Body] ~ ctx -> bind ::: {Type} -> xml lform [] bind @@ -255,4 +255,4 @@ val submit : ctx ::: {Unit} -> [LForm] ~ ctx -> use ::: {Type} -> unit - -> tag [Action = $use -> page] ([LForm] ++ ctx) ([LForm] ++ ctx) use [] + -> tag [Action = $use -> transaction page] ([LForm] ++ ctx) ([LForm] ++ ctx) use []
--- a/src/c/urweb.c Tue Sep 02 16:18:05 2008 -0400 +++ b/src/c/urweb.c Tue Sep 02 17:31:45 2008 -0400 @@ -589,3 +589,41 @@ return s; } + + +lw_Basis_string lw_Basis_sqlifyString(lw_context ctx, lw_Basis_string s) { + char *r, *s2; + + lw_check_heap(ctx, strlen(s) * 2 + 4); + + r = s2 = ctx->heap_front; + *s2++ = 'E'; + *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; + } + } + } + + *s2++ = '\''; + *s2++ = 0; + ctx->heap_front = s2; + return r; +}
--- a/src/cjr_env.sml Tue Sep 02 16:18:05 2008 -0400 +++ b/src/cjr_env.sml Tue Sep 02 17:31:45 2008 -0400 @@ -48,7 +48,7 @@ structs : (string * typ) list IM.map } -val empty = { +val empty : env = { datatypes = IM.empty, constructors = IM.empty, @@ -56,7 +56,7 @@ relE = [], namedE = IM.empty, - structs = IM.empty + structs = IM.insert (IM.empty, 0, []) } fun pushDatatype (env : env) x n xncs =
--- a/src/cjr_print.sml Tue Sep 02 16:18:05 2008 -0400 +++ b/src/cjr_print.sml Tue Sep 02 17:31:45 2008 -0400 @@ -881,7 +881,7 @@ case ek of Core.Link => fields | Core.Action => - case List.last ts of + case List.nth (ts, length ts - 2) of (TRecord i, _) => let val xts = E.lookupStruct env i @@ -1222,12 +1222,12 @@ case ek of Core.Link => (ts, string "", string "") | Core.Action => - case List.last ts of + case List.nth (ts, length ts - 2) of (TRecord i, _) => let val xts = E.lookupStruct env i in - (List.drop (ts, 1), + (List.take (ts, length ts - 2), box [box (map (fn (x, t) => box [p_typ env t, space, string "lw_input_", @@ -1324,10 +1324,9 @@ p_list_sep (box [string ",", space]) (fn x => x) (string "ctx" - :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts - @ [string "lw_unit_v"]), + :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts), inputsVar, - string ");", + string ", lw_unit_v);", newline, string "return;", newline,
--- a/src/cjrize.sml Tue Sep 02 16:18:05 2008 -0400 +++ b/src/cjrize.sml Tue Sep 02 17:31:45 2008 -0400 @@ -171,7 +171,7 @@ ((L'.PRecord xps, loc), sm) end -fun cifyExp ((e, loc), sm) = +fun cifyExp (eAll as (e, loc), sm) = case e of L.EPrim p => ((L'.EPrim p, loc), sm) | L.ERel n => ((L'.ERel n, loc), sm) @@ -206,6 +206,7 @@ ((L'.EApp (e1, e2), loc), sm) end | L.EAbs _ => (ErrorMsg.errorAt loc "Anonymous function remains at code generation"; + Print.prefaces' [("Function", MonoPrint.p_exp MonoEnv.empty eAll)]; (dummye, sm)) | L.ERecord xes =>
--- a/src/compiler.sml Tue Sep 02 16:18:05 2008 -0400 +++ b/src/compiler.sml Tue Sep 02 17:31:45 2008 -0400 @@ -93,15 +93,17 @@ end } -fun run (tr : ('src, 'dst) transform) = #func tr +fun run (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors (); + #func tr x) fun runPrint (tr : ('src, 'dst) transform) input = - case #func tr input of - NONE => print "Failure\n" - | SOME v => - (print "Success\n"; - Print.print (#print tr v); - print "\n") + (ErrorMsg.resetErrors (); + case #func tr input of + NONE => print "Failure\n" + | SOME v => + (print "Success\n"; + Print.print (#print tr v); + print "\n")) fun time (tr : ('src, 'dst) transform) input = let
--- a/src/elaborate.sml Tue Sep 02 16:18:05 2008 -0400 +++ b/src/elaborate.sml Tue Sep 02 17:31:45 2008 -0400 @@ -1482,11 +1482,9 @@ fun elabExp (env, denv) (eAll as (e, loc)) = let - - in - (*eprefaces "elabExp" [("eAll", SourcePrint.p_exp eAll)];*) - - case e of + (*val () = eprefaces "elabExp" [("eAll", SourcePrint.p_exp eAll)];*) + + val r = case e of L.EAnnot (e, t) => let val (e', et, gs1) = elabExp (env, denv) e @@ -1756,6 +1754,12 @@ ((L'.ECase (e', pes', {disc = et, result = result}), loc), result, enD gs' @ gs) end + + (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 r)*) + in + (*prefaces "elabExp" [("e", SourcePrint.p_exp eAll), + ("|tcs|", PD.string (Int.toString (length tcs)))];*) + r end @@ -2731,7 +2735,7 @@ | _ => sgnError env (SgnWrongForm (sgn1, sgn2)) -fun elabDecl ((d, loc), (env, denv, gs : constraint list)) = +fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = let (*val () = preface ("elabDecl", SourcePrint.p_decl (d, loc))*) @@ -2873,7 +2877,7 @@ | SOME c => elabCon (env, denv) c in ((x, c', e), enD gs1 @ gs) - end) [] vis + end) gs vis val (vis, env) = ListUtil.foldlMap (fn ((x, c', e), env) => let @@ -3103,16 +3107,21 @@ | L.DClass (x, c) => let val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) - val (c', ck, gs) = elabCon (env, denv) c + val (c', ck, gs') = elabCon (env, denv) c val (env, n) = E.pushCNamed env x k (SOME c') val env = E.pushClass env n in checkKind env c' ck k; - ([(L'.DClass (x, n, c'), loc)], (env, denv, [])) + ([(L'.DClass (x, n, c'), loc)], (env, denv, enD gs' @ gs)) end - | L.DDatabase s => ([(L'.DDatabase s, loc)], (env, denv, [])) + | L.DDatabase s => ([(L'.DDatabase s, loc)], (env, denv, gs)) + + (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) in + (*prefaces "elabDecl" [("e", SourcePrint.p_decl dAll), + ("|tcs|", PD.string (Int.toString (length tcs)))];*) + r end
--- a/src/mono_reduce.sml Tue Sep 02 16:18:05 2008 -0400 +++ b/src/mono_reduce.sml Tue Sep 02 17:31:45 2008 -0400 @@ -97,6 +97,12 @@ (PWild, _) => Yes env | (PVar (x, t), _) => Yes (E.pushERel env x t (SOME e)) + | (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) => + if String.isPrefix s' s then + Maybe + else + No + | (PPrim p, EPrim p') => if Prim.equal (p, p') then Yes env
--- a/src/tag.sml Tue Sep 02 16:18:05 2008 -0400 +++ b/src/tag.sml Tue Sep 02 17:31:45 2008 -0400 @@ -216,7 +216,9 @@ ((EApp (app, (ERel n, loc)), loc), n - 1)) ((ENamed f, loc), length args - 1) args + val app = (EApp (app, (ERecord [], loc)), loc) val body = (EWrite app, loc) + val t = (TFun (unit, unit), loc) val (abs, _, t) = foldr (fn (t, (abs, n, rest)) => ((EAbs ("x" ^ Int.toString n, t, @@ -224,7 +226,7 @@ abs), loc), n + 1, (TFun (t, rest), loc))) - (body, 0, unit) args + (body, 0, t) args in (abs, t) end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/pquery.ur Tue Sep 02 17:31:45 2008 -0400 @@ -0,0 +1,16 @@ +table t1 : {A : int, B : string, C : float} + +fun lookup (inp : {B : string}) = + s <- query (SELECT t1.B FROM t1 WHERE t1.B = {inp.B}) + (fn fs _ => return fs.T1.B) + "Couldn't find it!"; + return <html><body> + Result: {cdata s} + </body></html> + +fun main () : transaction page = return <html><body> + <lform> + B: <textbox{#B}/> + <submit action={lookup}/> + </lform> +</body></html>