Moved dml code into Settings

5 files changed, 110 insertions, 80 deletions

diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 92e15b51..ee9011b7 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1696,16 +1696,16 @@ fun p_exp' par env (e, loc) =
       | EDml {dml, prepared} =>
         box [string "(uw_begin_region(ctx), ({",
              newline,
-             string "PGconn *conn = uw_get_db(ctx);",
-             newline,
              case prepared of
                  NONE => box [string "char *dml = ",
                               p_exp env dml,
                               string ";",
-                              newline]
-               | SOME _ =>
+                              newline,
+                              newline,
+                              #dml (Settings.currentDbms ()) loc]
+               | SOME (id, dml') =>
                  let
-                     val ets = getPargs dml
+                     val inputs = getPargs dml
                  in
                      box [p_list_sepi newline
                                       (fn i => fn (e, t) =>
@@ -1718,83 +1718,18 @@ fun p_exp' par env (e, loc) =
                                                        space,
                                                        p_exp env e,
                                                        string ";"])
-                                      ets,
+                                      inputs,
                           newline,
                           newline,
 
-                          string "const int paramFormats[] = { ",
-                          p_list_sep (box [string ",", space])
-                                     (fn (_, t) => if isBlob t then string "1" else string "0") ets,
-                          string " };",
-                          newline,
-                          string "const int paramLengths[] = { ",
-                          p_list_sepi (box [string ",", space])
-                                      (fn i => fn (_, Blob) => string ("arg" ^ Int.toString (i + 1) ^ ".size")
-                                                | (_, Nullable Blob) => string ("arg" ^ Int.toString (i + 1)
-                                                                                ^ "?arg" ^ Int.toString (i + 1) ^ "->size:0")
-                                                | _ => string "0") ets,
-                          string " };",
-                          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]
+                          #dmlPrepared (Settings.currentDbms ()) {loc = loc,
+                                                                  id = id,
+                                                                  dml = dml',
+                                                                  inputs = map #2 inputs}]
                  end,
              newline,
              newline,
-             string "PGresult *res = ",
-             case prepared of
-                 NONE => string "PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);"
-               | SOME (n, s) =>
-                 if #persistent (Settings.currentProtocol ()) then
-                     box [string "PQexecPrepared(conn, \"uw",
-                          string (Int.toString n),
-                          string "\", ",
-                          string (Int.toString (length (getPargs dml))),
-                          string ", paramValues, paramLengths, paramFormats, 0);"]
-                 else
-                     box [string "PQexecParams(conn, \"",
-                          string (String.toString s),
-                          string "\", ",
-                          string (Int.toString (length (getPargs dml))),
-                          string ", NULL, paramValues, paramLengths, paramFormats, 0);"],
-             newline,
-             newline,
-
-             string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");",
-             newline,
-             newline,
 
-             string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
-             newline,
-             box [string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40001\")) {",
-                  box [newline,
-                       string "PQclear(res);",
-                       newline,
-                       string "uw_error(ctx, UNLIMITED_RETRY, \"Serialization failure\");",
-                       newline],
-                  string "}",
-                  newline,
-                  string "PQclear(res);",
-                  newline,
-                  string "uw_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 "uw_end_region(ctx);",
              newline,
              string "uw_unit_v;",
diff --git a/src/mysql.sml b/src/mysql.sml
index 976fefef..27b4ca77 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -255,6 +255,8 @@ fun init (dbstring, ss) =
 
 fun query _ = raise Fail "MySQL query"
 fun queryPrepared _ = raise Fail "MySQL queryPrepared"
+fun dml _ = raise Fail "MySQL dml"
+fun dmlPrepared _ = raise Fail "MySQL dmlPrepared"
 
 val () = addDbms {name = "mysql",
                   header = "mysql/mysql.h",
@@ -273,6 +275,8 @@ val () = addDbms {name = "mysql",
                                      newline],
                   init = init,
                   query = query,
-                  queryPrepared = queryPrepared}
+                  queryPrepared = queryPrepared,
+                  dml = dml,
+                  dmlPrepared = dmlPrepared}
 
 end
diff --git a/src/postgres.sml b/src/postgres.sml
index 8239ec93..01777843 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -391,6 +391,87 @@ fun queryPrepared {loc, id, query, inputs, numCols, doCols} =
                                                                                   string (String.toString query),
                                                                                   string "\""]}]
 
+fun dmlCommon {loc, dml} =
+    box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");",
+         newline,
+         newline,
+
+         string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
+         newline,
+         box [string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40001\")) {",
+              box [newline,
+                   string "PQclear(res);",
+                   newline,
+                   string "uw_error(ctx, UNLIMITED_RETRY, \"Serialization failure\");",
+                   newline],
+              string "}",
+              newline,
+              string "PQclear(res);",
+              newline,
+              string "uw_error(ctx, FATAL, \"",
+              string (ErrorMsg.spanToString loc),
+              string ": DML failed:\\n%s\\n%s\", ",
+              dml,
+              string ", PQerrorMessage(conn));",
+              newline],
+         string "}",
+         newline,
+         newline,
+
+         string "PQclear(res);",
+         newline]
+
+fun dml loc =
+    box [string "PGconn *conn = uw_get_db(ctx);",
+         newline,
+         string "PGresult *res = PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);",
+         newline,
+         newline,
+         dmlCommon {loc = loc, dml = string "dml"}]
+
+fun dmlPrepared {loc, id, dml, inputs} =
+    box [string "PGconn *conn = uw_get_db(ctx);",
+         newline,
+         string "const int paramFormats[] = { ",
+         p_list_sep (box [string ",", space])
+                    (fn t => if isBlob t then string "1" else string "0") inputs,
+         string " };",
+         newline,
+         string "const int paramLengths[] = { ",
+         p_list_sepi (box [string ",", space])
+                     (fn i => fn Blob => string ("arg" ^ Int.toString (i + 1) ^ ".size")
+                               | Nullable Blob => string ("arg" ^ Int.toString (i + 1)
+                                                          ^ "?arg" ^ Int.toString (i + 1) ^ "->size:0")
+                               | _ => string "0") inputs,
+         string " };",
+         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))]))
+                     inputs,
+         string " };",
+         newline,
+         newline,
+         string "PGresult *res = ",
+         if #persistent (Settings.currentProtocol ()) then
+             box [string "PQexecPrepared(conn, \"uw",
+                  string (Int.toString id),
+                  string "\", ",
+                  string (Int.toString (length inputs)),
+                  string ", paramValues, paramLengths, paramFormats, 0);"]
+         else
+             box [string "PQexecParams(conn, \"",
+                  string (String.toString dml),
+                  string "\", ",
+                  string (Int.toString (length inputs)),
+                  string ", NULL, paramValues, paramLengths, paramFormats, 0);"],
+         newline,
+         newline,
+         dmlCommon {loc = loc, dml = box [string "\"",
+                                          string (String.toString dml),
+                                          string "\""]}]
+
 val () = addDbms {name = "postgres",
                   header = "postgresql/libpq-fe.h",
                   link = "-lpq",
@@ -398,7 +479,9 @@ val () = addDbms {name = "postgres",
                                      newline],
                   init = init,
                   query = query,
-                  queryPrepared = queryPrepared}
+                  queryPrepared = queryPrepared,
+                  dml = dml,
+                  dmlPrepared = dmlPrepared}
 val () = setDbms "postgres"
 
 end
diff --git a/src/settings.sig b/src/settings.sig
index 536f6a1f..9912b0e1 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -135,7 +135,10 @@ signature SETTINGS = sig
                           inputs : sql_type list, numCols : int,
                           doCols : ({wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc)
                                    -> Print.PD.pp_desc}
-                         -> Print.PD.pp_desc
+                         -> Print.PD.pp_desc,
+         dml : ErrorMsg.span -> Print.PD.pp_desc,
+         dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string,
+                        inputs : sql_type list} -> Print.PD.pp_desc
     }
 
     val addDbms : dbms -> unit
diff --git a/src/settings.sml b/src/settings.sml
index 2e0a5ac8..86d8afa9 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -321,7 +321,10 @@ type dbms = {
                       inputs : sql_type list, numCols : int,
                       doCols : ({wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc)
                                -> Print.PD.pp_desc}
-                     -> Print.PD.pp_desc
+                     -> Print.PD.pp_desc,
+     dml : ErrorMsg.span -> Print.PD.pp_desc,
+     dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string,
+                    inputs : sql_type list} -> Print.PD.pp_desc
 }
 
 val dbmses = ref ([] : dbms list)
@@ -331,7 +334,9 @@ val curDb = ref ({name = "",
                   global_init = Print.box [],
                   init = fn _ => Print.box [],
                   query = fn _ => Print.box [],
-                  queryPrepared = fn _ => Print.box []} : dbms)
+                  queryPrepared = fn _ => Print.box [],
+                  dml = fn _ => Print.box [],
+                  dmlPrepared = fn _ => Print.box []} : dbms)
 
 fun addDbms v = dbmses := v :: !dbmses
 fun setDbms s =