summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/cjr.sml2
-rw-r--r--src/cjr_print.sml77
-rw-r--r--src/cjrize.sml7
-rw-r--r--src/mono.sml1
-rw-r--r--src/mono_print.sml3
-rw-r--r--src/mono_reduce.sml1
-rw-r--r--src/mono_util.sml5
-rw-r--r--src/monoize.sml33
-rw-r--r--src/prepare.sml7
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)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-02 22:15:48 +0000