Mercurial > urweb
diff src/cjr_print.sml @ 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 | 15e0c935c91b |
children | 438561303d02 |
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