Mercurial > urweb
changeset 307:52d4c60518d4
First INSERT works
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 07 Sep 2008 15:05:52 -0400 |
| parents | 99e4f39e820d |
| children | 72480e249130 |
| files | src/cjr.sml src/cjr_print.sml src/cjrize.sml src/mono.sml src/mono_print.sml src/mono_reduce.sml src/mono_util.sml src/monoize.sml src/prepare.sml |
| diffstat | 9 files changed, 136 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjr.sml Sun Sep 07 14:38:14 2008 -0400 +++ b/src/cjr.sml Sun Sep 07 15:05:52 2008 -0400 @@ -85,6 +85,8 @@ body : exp, initial : exp, prepared : int option } + | EDml of { dml : exp, + prepared : int option } withtype exp = exp' located
--- a/src/cjr_print.sml Sun Sep 07 14:38:14 2008 -0400 +++ b/src/cjr_print.sml Sun Sep 07 15:05:52 2008 -0400 @@ -857,6 +857,83 @@ 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) =
--- a/src/cjrize.sml Sun Sep 07 14:38:14 2008 -0400 +++ b/src/cjrize.sml Sun Sep 07 15:05:52 2008 -0400 @@ -374,6 +374,13 @@ 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
--- a/src/mono.sml Sun Sep 07 14:38:14 2008 -0400 +++ b/src/mono.sml Sun Sep 07 15:05:52 2008 -0400 @@ -88,6 +88,7 @@ query : exp, body : exp, initial : exp } + | EDml of exp withtype exp = exp' located
--- a/src/mono_print.sml Sun Sep 07 14:38:14 2008 -0400 +++ b/src/mono_print.sml Sun Sep 07 15:05:52 2008 -0400 @@ -257,6 +257,9 @@ 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
--- a/src/mono_reduce.sml Sun Sep 07 14:38:14 2008 -0400 +++ b/src/mono_reduce.sml Sun Sep 07 15:05:52 2008 -0400 @@ -39,6 +39,7 @@ case e of EWrite _ => true | EQuery _ => true + | EDml _ => true | EAbs _ => false | EPrim _ => false
--- a/src/mono_util.sml Sun Sep 07 14:38:14 2008 -0400 +++ b/src/mono_util.sml Sun Sep 07 15:05:52 2008 -0400 @@ -285,6 +285,11 @@ body = body', initial = initial'}, loc))))))) + + | EDml e => + S.map2 (mfe ctx e, + fn e' => + (EDml e', loc)) in mfe end
--- a/src/monoize.sml Sun Sep 07 14:38:14 2008 -0400 +++ b/src/monoize.sml Sun Sep 07 15:05:52 2008 -0400 @@ -591,6 +591,39 @@ 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), _)), _),
--- a/src/prepare.sml Sun Sep 07 14:38:14 2008 -0400 +++ b/src/prepare.sml Sun Sep 07 15:05:52 2008 -0400 @@ -150,6 +150,13 @@ 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)