Compiling a parametrized query the inefficient way

8 files changed, 83 insertions, 26 deletions

diff --git a/src/c/urweb.c b/src/c/urweb.c
index f0e93e46..57caa03d 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -589,3 +589,41 @@ lw_Basis_string lw_Basis_strdup(lw_context ctx, lw_Basis_string s1) {
 
   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;
+}
diff --git a/src/cjr_env.sml b/src/cjr_env.sml
index 482b93f6..0859abe5 100644
--- a/src/cjr_env.sml
+++ b/src/cjr_env.sml
@@ -48,7 +48,7 @@ type env = {
      structs : (string * typ) list IM.map
 }
 
-val empty = {
+val empty : env = {
     datatypes = IM.empty,
     constructors = IM.empty,
 
@@ -56,7 +56,7 @@ val empty = {
     relE = [],
     namedE = IM.empty,
 
-    structs = IM.empty
+    structs = IM.insert (IM.empty, 0, [])
 }
 
 fun pushDatatype (env : env) x n xncs =
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 938821be..50098a99 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -881,7 +881,7 @@ fun p_file env (ds, ps) =
                                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 @@ fun p_file env (ds, ps) =
                     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 @@ fun p_file env (ds, ps) =
                           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,
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 88fae6f0..ed8182c2 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -171,7 +171,7 @@ fun cifyPat ((p, loc), sm) =
             ((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 @@ fun cifyExp ((e, loc), sm) =
             ((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 =>
diff --git a/src/compiler.sml b/src/compiler.sml
index f9fe0da8..263aaf9a 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -93,15 +93,17 @@ fun op o (tr2 : ('b, 'c) transform, tr1 : ('a, 'b) transform) = {
               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
diff --git a/src/elaborate.sml b/src/elaborate.sml
index d4b71b80..5770fe5b 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1482,11 +1482,9 @@ fun normClassConstraint envs (c, loc) =
 
 fun elabExp (env, denv) (eAll as (e, loc)) =
     let
-        
-    in
-        (*eprefaces "elabExp" [("eAll", SourcePrint.p_exp eAll)];*)
+        (*val () = eprefaces "elabExp" [("eAll", SourcePrint.p_exp eAll)];*)
 
-        case e of
+        val r = case e of
             L.EAnnot (e, t) =>
             let
                 val (e', et, gs1) = elabExp (env, denv) e
@@ -1756,6 +1754,12 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
 
                 ((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 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
       | _ => 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 @@ fun elabDecl ((d, loc), (env, denv, gs : constraint list)) =
                                                                      | 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 @@ fun elabDecl ((d, loc), (env, denv, gs : constraint list)) =
               | 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
 
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 5367be60..cc44869a 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -97,6 +97,12 @@ fun match (env, p : pat, e : exp) =
         (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
diff --git a/src/tag.sml b/src/tag.sml
index a8b59c5a..34595732 100644
--- a/src/tag.sml
+++ b/src/tag.sml
@@ -216,7 +216,9 @@ fun tag file =
                                                                                  ((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 @@ fun tag file =
                                                                                             abs), loc),
                                                                                      n + 1,
                                                                                      (TFun (t, rest), loc)))
-                                                                                (body, 0, unit) args
+                                                                                (body, 0, t) args
                                                     in
                                                         (abs, t)
                                                     end