# HG changeset patch
# User Adam Chlipala <adam@chlipala.net>
# Date 1322945961 18000
# Node ID 218e2a9a53d05a7a34212be9048861d735ada363
# Parent  a20daedfd1d0fa9c9ba43aeeeafdd3250b7a81eb
Better error messages about non-SQL-izability of types

diff -r a20daedfd1d0 -r 218e2a9a53d0 src/cjr_print.sml
--- a/src/cjr_print.sml	Sat Dec 03 10:13:36 2011 -0500
+++ b/src/cjr_print.sml	Sat Dec 03 15:59:21 2011 -0500
@@ -112,6 +112,42 @@
 
 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 @@
       | 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 @@
       | 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 @@
       | 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 @@
         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
 
diff -r a20daedfd1d0 -r 218e2a9a53d0 src/mono_shake.sml
--- a/src/mono_shake.sml	Sat Dec 03 10:13:36 2011 -0500
+++ b/src/mono_shake.sml	Sat Dec 03 15:59:21 2011 -0500
@@ -115,6 +115,8 @@
                   | ((DDatabase {expunge = n1, initialize = n2, ...}, _), (page_cs, page_es)) =>
                     (page_cs, IS.addList (page_es, [n1, n2]))
                   | ((DTask (e1, e2), _), st) => usedVars (usedVars st e2) e1
+                  | ((DTable (_, xts, e1, e2), _), st) => usedVars (usedVars (usedVars st e1) e2)
+                                                                   (ERecord (map (fn (x, t) => (x, (ERecord [], #2 e1), t)) xts), #2 e1)
                   | ((DView (_, _, e), _), st) => usedVars st e
                   | ((DPolicy pol, _), st) =>
                     let
diff -r a20daedfd1d0 -r 218e2a9a53d0 tests/cantSql.ur
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/cantSql.ur	Sat Dec 03 15:59:21 2011 -0500
@@ -0,0 +1,3 @@
+datatype foo = Bar of int
+
+table bad : { A : foo, B : { X : float } }
diff -r a20daedfd1d0 -r 218e2a9a53d0 tests/cantSql.urp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/cantSql.urp	Sat Dec 03 15:59:21 2011 -0500
@@ -0,0 +1,3 @@
+database dbname=test
+
+cantSql