Preliminary work supporting channels in databases

4 files changed, 89 insertions, 15 deletions

diff --git a/src/c/urweb.c b/src/c/urweb.c
index 5fa2af42..75f7675f 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -999,6 +999,16 @@ char *uw_Basis_attrifyInt(uw_context ctx, uw_Basis_int n) {
   return result;
 }
 
+char *uw_Basis_attrifyChannel(uw_context ctx, uw_Basis_channel n) {
+  char *result;
+  int len;
+  uw_check_heap(ctx, INTS_MAX);
+  result = ctx->heap.front;
+  sprintf(result, "%lld%n", (long long)n, &len);
+  ctx->heap.front += len+1;
+  return result;
+}
+
 char *uw_Basis_attrifyFloat(uw_context ctx, uw_Basis_float n) {
   char *result;
   int len;
@@ -1502,6 +1512,17 @@ char *uw_Basis_sqlifyInt(uw_context ctx, uw_Basis_int n) {
   return r;
 }
 
+char *uw_Basis_sqlifyChannel(uw_context ctx, uw_Basis_channel n) {
+  int len;
+  char *r;
+
+  uw_check_heap(ctx, INTS_MAX + 6);
+  r = ctx->heap.front;
+  sprintf(r, "%lld::int4%n", (long long)n, &len);
+  ctx->heap.front += len+1;
+  return r;
+}
+
 char *uw_Basis_sqlifyIntN(uw_context ctx, uw_Basis_int *n) {
   if (n == NULL)
     return "NULL";
@@ -1673,6 +1694,18 @@ uw_Basis_int *uw_Basis_stringToInt(uw_context ctx, uw_Basis_string s) {
     return NULL;
 }
 
+uw_Basis_channel *uw_Basis_stringToChannel(uw_context ctx, uw_Basis_string s) {
+  char *endptr;
+  uw_Basis_channel n = strtoll(s, &endptr, 10);
+
+  if (*s != '\0' && *endptr == '\0') {
+    uw_Basis_channel *r = uw_malloc(ctx, sizeof(uw_Basis_channel));
+    *r = n;
+    return r;
+  } else
+    return NULL;
+}
+
 uw_Basis_float *uw_Basis_stringToFloat(uw_context ctx, uw_Basis_string s) {
   char *endptr;
   uw_Basis_float n = strtod(s, &endptr);
@@ -1740,6 +1773,16 @@ uw_Basis_int uw_Basis_stringToInt_error(uw_context ctx, uw_Basis_string s) {
     uw_error(ctx, FATAL, "Can't parse int: %s", s);
 }
 
+uw_Basis_channel uw_Basis_stringToChannel_error(uw_context ctx, uw_Basis_string s) {
+  char *endptr;
+  uw_Basis_channel n = strtoll(s, &endptr, 10);
+
+  if (*s != '\0' && *endptr == '\0')
+    return n;
+  else
+    uw_error(ctx, FATAL, "Can't parse channel int: %s", s);
+}
+
 uw_Basis_float uw_Basis_stringToFloat_error(uw_context ctx, uw_Basis_string s) {
   char *endptr;
   uw_Basis_float n = strtod(s, &endptr);
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 79a43d19..a17a0416 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -403,6 +403,7 @@ fun p_unsql wontLeakStrings env (tAll as (t, loc)) e =
             box [string "uw_Basis_strdup(ctx, ", e, string ")"]
       | TFfi ("Basis", "bool") => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"]
       | TFfi ("Basis", "time") => box [string "uw_Basis_stringToTime_error(ctx, ", e, string ")"]
+      | TFfi ("Basis", "channel") => box [string "uw_Basis_stringToChannel_error(ctx, ", e, string ")"]
 
       | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL";
               Print.eprefaces' [("Type", p_typ env tAll)];
@@ -445,6 +446,7 @@ datatype sql_type =
        | String
        | Bool
        | Time
+       | Channel
        | Nullable of sql_type
 
 fun p_sql_type' t =
@@ -454,6 +456,7 @@ fun p_sql_type' t =
       | String => "uw_Basis_string"
       | Bool => "uw_Basis_bool"
       | Time => "uw_Basis_time"
+      | Channel => "uw_Basis_channel"
       | Nullable String => "uw_Basis_string"
       | Nullable t => p_sql_type' t ^ "*"
 
@@ -469,12 +472,14 @@ fun getPargs (e, _) =
       | EFfiApp ("Basis", "sqlifyString", [e]) => [(e, String)]
       | EFfiApp ("Basis", "sqlifyBool", [e]) => [(e, Bool)]
       | EFfiApp ("Basis", "sqlifyTime", [e]) => [(e, Time)]
+      | EFfiApp ("Basis", "sqlifyChannel", [e]) => [(e, Channel)]
 
-      | EFfiApp ("Basis", "sqlifyIntN", [e]) => [(e, Nullable Int)]
-      | EFfiApp ("Basis", "sqlifyFloatN", [e]) => [(e, Nullable Float)]
-      | EFfiApp ("Basis", "sqlifyStringN", [e]) => [(e, Nullable String)]
-      | EFfiApp ("Basis", "sqlifyBoolN", [e]) => [(e, Nullable Bool)]
-      | EFfiApp ("Basis", "sqlifyTimeN", [e]) => [(e, Nullable Time)]
+      | ECase (e,
+               [((PNone _, _),
+                 (EPrim (Prim.String "NULL"), _)),
+                ((PSome (_, (PVar _, _)), _),
+                 (EFfiApp (m, x, [(ERel 0, _)]), _))],
+               _) => map (fn (x, y) => (x, Nullable y)) (getPargs (EFfiApp (m, x, [e]), #2 e))
 
       | ECase (e,
                [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _),
@@ -492,6 +497,7 @@ fun p_ensql t e =
       | String => e
       | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"]
       | Time => box [string "uw_Basis_sqlifyTime(ctx, ", e, string ")"]
+      | Channel => box [string "uw_Basis_attrifyChannel(ctx, ", e, string ")"]
       | Nullable String => e
       | Nullable t => box [string "(",
                            e,
@@ -2102,6 +2108,7 @@ fun p_sqltype'' env (tAll as (t, loc)) =
       | TFfi ("Basis", "string") => "text"
       | TFfi ("Basis", "bool") => "bool"
       | TFfi ("Basis", "time") => "timestamp"
+      | TFfi ("Basis", "channel") => "int4"
       | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
               Print.eprefaces' [("Type", p_typ env tAll)];
               "ERROR")
diff --git a/src/monoize.sml b/src/monoize.sml
index 1860fd19..eb3f81b3 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -165,6 +165,8 @@ fun monoType env =
 
                   | L.CApp ((L.CFfi ("Basis", "sql_injectable_prim"), _), t) =>
                     (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
+                  | L.CApp ((L.CFfi ("Basis", "sql_injectable_nullable"), _), t) =>
+                    (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
                   | L.CApp ((L.CFfi ("Basis", "sql_injectable"), _), t) =>
                     (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
                   | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_unary"), _), _), _), _) =>
@@ -1425,6 +1427,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "string"), loc),
                        (L'.EFfiApp ("Basis", "sqlifyTime", [(L'.ERel 0, loc)]), loc)), loc),
              fm)
+          | L.ECApp ((L.EFfi ("Basis", "sql_channel"), _), _) =>
+            ((L'.EAbs ("x", (L'.TFfi ("Basis", "channel"), loc), (L'.TFfi ("Basis", "string"), loc),
+                       (L'.EFfiApp ("Basis", "sqlifyChannel", [(L'.ERel 0, loc)]), loc)), loc),
+             fm)
           | L.ECApp ((L.EFfi ("Basis", "sql_prim"), _), t) =>
             let
                 val t = monoType env t
@@ -1453,6 +1459,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                  result = s}), loc)), loc)), loc),
                  fm)
             end
+          | L.ECApp ((L.EFfi ("Basis", "sql_nullable"), _), t) =>
+            let
+                val t = monoType env t
+                val s = (L'.TFfi ("Basis", "string"), loc)
+            in
+                ((L'.EAbs ("f",
+                           (L'.TFun (t, s), loc),
+                           (L'.TFun ((L'.TOption t, loc), s), loc),
+                           (L'.EAbs ("x",
+                                     (L'.TOption t, loc),
+                                     s,
+                                     (L'.ECase ((L'.ERel 0, loc),
+                                                [((L'.PNone t, loc),
+                                                  (L'.EPrim (Prim.String "NULL"), loc)),
+                                                 ((L'.PSome (t, (L'.PVar ("y", t), loc)), loc),
+                                                  (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc))],
+                                                {disc = (L'.TOption t, loc),
+                                                 result = s}), loc)), loc)), loc),
+                 fm)
+            end
 
           | L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) =>
             ((L'.ERecord [], loc), fm)
diff --git a/src/prepare.sml b/src/prepare.sml
index 110f6f9a..1f3f323a 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -47,17 +47,15 @@ fun prepString (e, ss, n) =
         SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1)
       | EFfiApp ("Basis", "sqlifyTime", [e]) =>
         SOME ("$" ^ Int.toString (n + 1) ^ "::timestamp" :: ss, n + 1)
+      | EFfiApp ("Basis", "sqlifyChannel", [e]) =>
+        SOME ("$" ^ Int.toString (n + 1) ^ "::int4" :: ss, n + 1)
 
-      | EFfiApp ("Basis", "sqlifyIntN", [e]) =>
-        SOME ("$" ^ Int.toString (n + 1) ^ "::int8" :: ss, n + 1)
-      | EFfiApp ("Basis", "sqlifyFloatN", [e]) =>
-        SOME ("$" ^ Int.toString (n + 1) ^ "::float8" :: ss, n + 1)
-      | EFfiApp ("Basis", "sqlifyStringN", [e]) =>
-        SOME ("$" ^ Int.toString (n + 1) ^ "::text" :: ss, n + 1)
-      | EFfiApp ("Basis", "sqlifyBoolN", [e]) =>
-        SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1)
-      | EFfiApp ("Basis", "sqlifyTimeN", [e]) =>
-        SOME ("$" ^ Int.toString (n + 1) ^ "::timestamp" :: ss, n + 1)
+      | ECase (e,
+               [((PNone _, _),
+                 (EPrim (Prim.String "NULL"), _)),
+                ((PSome (_, (PVar _, _)), _),
+                 (EFfiApp (m, x, [(ERel 0, _)]), _))],
+               _) => prepString ((EFfiApp (m, x, [e]), #2 e), ss, n)
 
       | ECase (e,
                [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _),