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>
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/pquery.urp	Tue Sep 02 17:31:45 2008 -0400
@@ -0,0 +1,6 @@
+debug
+database dbname=test
+exe /tmp/webapp
+sql /tmp/urweb.sql
+
+pquery
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/pquery.urs	Tue Sep 02 17:31:45 2008 -0400
@@ -0,0 +1,1 @@
+val main : unit -> transaction page