First INSERT works

9 files changed, 136 insertions, 0 deletions

diff --git a/src/cjr.sml b/src/cjr.sml
index ac30bd9f..f9155980 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -85,6 +85,8 @@ datatype exp' =
                      body : exp,
                      initial : exp,
                      prepared : int option }
+       | EDml of { dml : exp,
+                   prepared : int option }
 
 withtype exp = exp' located
 
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 022b9a68..342f7683 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -857,6 +857,83 @@ fun p_exp' par env (e, loc) =
                  string "})"]
         end
 
+      | EDml {dml, prepared} =>
+        box [string "({",
+             newline,
+             string "PGconn *conn = lw_get_db(ctx);",
+             newline,
+             case prepared of
+                 NONE => box [string "char *dml = ",
+                              p_exp env dml,
+                              string ";",
+                              newline]
+               | SOME _ =>
+                 let
+                     val ets = getPargs dml
+                 in
+                     box [p_list_sepi newline
+                                      (fn i => fn (e, t) =>
+                                                  box [p_sql_type t,
+                                                       space,
+                                                       string "arg",
+                                                       string (Int.toString (i + 1)),
+                                                       space,
+                                                       string "=",
+                                                       space,
+                                                       p_exp env e,
+                                                       string ";"])
+                                      ets,
+                          newline,
+                          newline,
+
+                          string "const char *paramValues[] = { ",
+                          p_list_sepi (box [string ",", space])
+                                      (fn i => fn (_, t) => p_ensql t (box [string "arg",
+                                                                            string (Int.toString (i + 1))]))
+                                      ets,
+                          string " };",
+                          newline,
+                          newline]
+                 end,
+             newline,
+             newline,
+             string "PGresult *res = ",
+             case prepared of
+                 NONE => string "PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);"
+               | SOME n => box [string "PQexecPrepared(conn, \"lw",
+                                string (Int.toString n),
+                                string "\", ",
+                                string (Int.toString (length (getPargs dml))),
+                                string ", paramValues, NULL, NULL, 0);"],
+             newline,
+             newline,
+
+             string "if (res == NULL) lw_error(ctx, FATAL, \"Out of memory allocating DML result.\");",
+             newline,
+             newline,
+
+             string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
+             newline,
+             box [string "PQclear(res);",
+                  newline,
+                  string "lw_error(ctx, FATAL, \"",
+                  string (ErrorMsg.spanToString loc),
+                  string ": DML failed:\\n%s\\n%s\", ",
+                  case prepared of
+                      NONE => string "dml"
+                    | SOME _ => p_exp env dml,
+                  string ", PQerrorMessage(conn));",
+                  newline],
+             string "}",
+             newline,
+             newline,
+
+             string "PQclear(res);",
+             newline,
+             string "lw_unit_v;",
+             newline,
+             string "})"]
+
 and p_exp env = p_exp' false env
 
 fun p_fun env (fx, n, args, ran, e) =
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 1f515552..d6d7ba5e 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -374,6 +374,13 @@ fun cifyExp (eAll as (e, loc), sm) =
                          query = query, body = body, initial = initial, prepared = NONE}, loc), sm)
         end
 
+      | L.EDml e =>
+        let
+            val (e, sm) = cifyExp (e, sm)
+        in
+            ((L'.EDml {dml = e, prepared = NONE}, loc), sm)
+        end
+
 
 fun cifyDecl ((d, loc), sm) =
     case d of
diff --git a/src/mono.sml b/src/mono.sml
index ce34c585..b10f651c 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -88,6 +88,7 @@ datatype exp' =
                      query : exp,
                      body : exp,
                      initial : exp }
+       | EDml of exp
 
 
 withtype exp = exp' located
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 643cb657..0b85e1c4 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -257,6 +257,9 @@ fun p_exp' par env (e, _) =
              string "in",
              space,
              p_exp (E.pushERel (E.pushERel env "r" dummyt NONE) "acc" dummyt NONE) body]
+      | EDml e => box [string "dml(",
+                       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 9ae44e47..11a52a4c 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -39,6 +39,7 @@ fun impure (e, _) =
     case e of
         EWrite _ => true
       | EQuery _ => true
+      | EDml _ => true
       | EAbs _ => false
 
       | EPrim _ => false
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 3e6a9f0f..e9f8e033 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -285,6 +285,11 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
                                                                                        body = body',
                                                                                        initial = initial'},
                                                                                loc)))))))
+
+              | EDml e =>
+                S.map2 (mfe ctx e,
+                     fn e' =>
+                        (EDml e', loc))
     in
         mfe
     end
diff --git a/src/monoize.sml b/src/monoize.sml
index 09735568..449306ca 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -591,6 +591,39 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                  fm)
             end
 
+          | 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),
+                 fm)
+            end
+          | L.ECApp ((L.EFfi ("Basis", "insert"), _), fields) =>
+            (case monoType env (L.TRecord fields, loc) of
+                 (L'.TRecord fields, _) =>
+                 let
+                     val s = (L'.TFfi ("Basis", "string"), loc)
+                     val fields = map (fn (x, _) => (x, s)) fields
+                     val rt = (L'.TRecord fields, loc)
+                     fun sc s = (L'.EPrim (Prim.String s), loc)
+                 in
+                     ((L'.EAbs ("tab", s, (L'.TFun (rt, s), loc),
+                                (L'.EAbs ("fs", rt, s,
+                                          strcat loc [sc "INSERT INTO ",
+                                                      (L'.ERel 1, loc),
+                                                      sc " (",
+                                                      strcatComma loc (map (fn (x, _) => sc ("lw_" ^ x)) fields),
+                                                      sc ") VALUES (",
+                                                      strcatComma loc (map (fn (x, _) =>
+                                                                               (L'.EField ((L'.ERel 0, loc),
+                                                                                           x), loc)) fields),
+                                                      sc ")"]), loc)), loc),
+                      fm)
+                 end
+               | _ => poly ())
+
           | L.ECApp (
             (L.ECApp (
              (L.ECApp ((L.EFfi ("Basis", "query"), _), (L.CRecord (_, tables), _)), _),
diff --git a/src/prepare.sml b/src/prepare.sml
index a1dd0e79..bb1af6cc 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -150,6 +150,13 @@ fun prepExp (e as (_, loc), sns) =
                        initial = initial, prepared = SOME (#2 sns)}, loc),
               ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1)))
 
+      | EDml {dml, ...} =>
+        (case prepString (dml, [], 0) of
+             NONE => (e, sns)
+           | SOME (ss, n) =>
+             ((EDml {dml = dml, prepared = SOME (#2 sns)}, loc),
+              ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1)))
+
 fun prepDecl (d as (_, loc), sns) =
     case #1 d of
         DStruct _ => (d, sns)