Better error messages about non-SQL-izability of types

1 files changed, 53 insertions, 16 deletions

diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 2c4f7b36..d51cc4ee 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -112,6 +112,42 @@ fun p_typ' par env (t, loc) =
 
 and p_typ env = p_typ' false env
 
+fun p_htyp' par env (t, loc) =
+    case t of
+        TFun (t1, t2) => parenIf par (box [p_htyp' true env t1,
+                                           space,
+                                           string "->",
+                                           space,
+                                           p_htyp' true env t2])
+      | TRecord i =>
+        let
+            val xts = E.lookupStruct env i
+        in
+            box [string "{",
+                 p_list (fn (x, t) =>
+                            box [string x,
+                                 space,
+                                 string ":",
+                                 space,
+                                 p_htyp env t]) xts,
+                 string "}"]
+        end
+      | TDatatype (_, n, _) =>
+        let
+            val (name, _) = E.lookupDatatype env n
+        in
+            string name
+        end
+      | TFfi (m, x) => string (m ^ "." ^ x)
+      | TOption t => parenIf par (box [string "option",
+                                       space,
+                                       p_htyp' true env t])
+      | TList (t, _) => parenIf par (box [string "list",
+                                          space,
+                                          p_htyp' true env t])
+
+and p_htyp env = p_htyp' false env
+
 fun p_rel env n = string ("__uwr_" ^ ident (#1 (E.lookupERel env n)) ^ "_" ^ Int.toString (E.countERels env - n - 1))
     handle CjrEnv.UnboundRel _ => string ("__uwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1))
 
@@ -388,7 +424,7 @@ fun p_unsql wontLeakStrings env (tAll as (t, loc)) e eLen =
       | TFfi ("Basis", "client") => box [string "uw_Basis_stringToClient_error(ctx, ", e, string ")"]
 
       | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL";
-              Print.eprefaces' [("Type", p_typ env tAll)];
+              Print.eprefaces' [("Type", p_htyp env tAll)];
               string "ERROR")
 
 fun p_getcol wontLeakStrings env (tAll as (t, loc)) i =
@@ -1362,7 +1398,7 @@ fun sql_type_in env (tAll as (t, loc)) =
       | TFfi ("Basis", "client") => Client
       | TOption t' => Nullable (sql_type_in env t')
       | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
-              Print.eprefaces' [("Type", p_typ env tAll)];
+              Print.eprefaces' [("Type", p_htyp env tAll)];
               Int)
 
 fun potentiallyFancy (e, _) =
@@ -2378,7 +2414,7 @@ fun p_sqltype'' env (tAll as (t, loc)) =
       | TFfi ("Basis", "channel") => "int8"
       | TFfi ("Basis", "client") => "int4"
       | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
-              Print.eprefaces' [("Type", p_typ env tAll)];
+              Print.eprefaces' [("Type", p_htyp env tAll)];
               "ERROR")
 
 fun p_sqltype' env (tAll as (t, loc)) =
@@ -2969,19 +3005,20 @@ fun p_file env (ds, ps) =
         val initialize = ref 0
         val prepped = ref []
 
-        val () = app (fn d =>
-                         case #1 d of
-                             DDatabase {name = x, expunge = y, initialize = z} => (hasDb := true;
-                                                                                   dbstring := x;
-                                                                                   expunge := y;
-                                                                                   initialize := z)
-                           | DTable (s, xts, _, _) => tables := (s, map (fn (x, t) =>
-                                                                            (x, sql_type_in env t)) xts) :: !tables
-                           | DView (s, xts, _) => views := (s, map (fn (x, t) =>
-                                                                       (x, sql_type_in env t)) xts) :: !views
-                           | DSequence s => sequences := s :: !sequences
-                           | DPreparedStatements ss => prepped := ss
-                           | _ => ()) ds
+        val _ = foldl (fn (d, env) =>
+                          ((case #1 d of
+                                DDatabase {name = x, expunge = y, initialize = z} => (hasDb := true;
+                                                                                      dbstring := x;
+                                                                                      expunge := y;
+                                                                                      initialize := z)
+                              | DTable (s, xts, _, _) => tables := (s, map (fn (x, t) =>
+                                                                               (x, sql_type_in env t)) xts) :: !tables
+                              | DView (s, xts, _) => views := (s, map (fn (x, t) =>
+                                                                          (x, sql_type_in env t)) xts) :: !views
+                              | DSequence s => sequences := s :: !sequences
+                              | DPreparedStatements ss => prepped := ss
+                              | _ => ());
+                           E.declBinds env d)) E.empty ds
 
         val hasDb = !hasDb