Mercurial > urweb
changeset 1623:218e2a9a53d0
Better error messages about non-SQL-izability of types
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Sat, 03 Dec 2011 15:59:21 -0500 |
| parents | a20daedfd1d0 |
| children | f96e708b4b93 |
| files | src/cjr_print.sml src/mono_shake.sml tests/cantSql.ur tests/cantSql.urp |
| diffstat | 4 files changed, 61 insertions(+), 16 deletions(-) [+] |
line wrap: on
line diff
--- 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
--- 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