summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2011-12-03 15:59:21 -0500
committerGravatar Adam Chlipala <adam@chlipala.net>2011-12-03 15:59:21 -0500
commit5a6ced2cb8eb45b392c72988a834323a61a147a1 (patch)
treef6aeb73b5d2ae01ccd7b732ed8c991fc269665e9 /src
parent10dea359cb906fc9f87c64eb11e0d74c7fe99702 (diff)
Better error messages about non-SQL-izability of types
Diffstat (limited to 'src')
-rw-r--r--src/cjr_print.sml69
-rw-r--r--src/mono_shake.sml2
2 files changed, 55 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
diff --git a/src/mono_shake.sml b/src/mono_shake.sml
index f601e712..b6de9410 100644
--- a/src/mono_shake.sml
+++ b/src/mono_shake.sml
@@ -115,6 +115,8 @@ fun shake file =
| ((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