Mercurial > urweb

comparison src/cjr_print.sml @ 1623:218e2a9a53d0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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
comparison
equal deleted inserted replaced
1622:a20daedfd1d0 1623:218e2a9a53d0
110 string (Int.toString i), 110 string (Int.toString i),
111 string "*"] 111 string "*"]
112 112
113 and p_typ env = p_typ' false env 113 and p_typ env = p_typ' false env
114 114
115 fun p_htyp' par env (t, loc) =
116 case t of
117 TFun (t1, t2) => parenIf par (box [p_htyp' true env t1,
118 space,
119 string "->",
120 space,
121 p_htyp' true env t2])
122 | TRecord i =>
123 let
124 val xts = E.lookupStruct env i
125 in
126 box [string "{",
127 p_list (fn (x, t) =>
128 box [string x,
129 space,
130 string ":",
131 space,
132 p_htyp env t]) xts,
133 string "}"]
134 end
135 | TDatatype (_, n, _) =>
136 let
137 val (name, _) = E.lookupDatatype env n
138 in
139 string name
140 end
141 | TFfi (m, x) => string (m ^ "." ^ x)
142 | TOption t => parenIf par (box [string "option",
143 space,
144 p_htyp' true env t])
145 | TList (t, _) => parenIf par (box [string "list",
146 space,
147 p_htyp' true env t])
148
149 and p_htyp env = p_htyp' false env
150
115 fun p_rel env n = string ("__uwr_" ^ ident (#1 (E.lookupERel env n)) ^ "_" ^ Int.toString (E.countERels env - n - 1)) 151 fun p_rel env n = string ("__uwr_" ^ ident (#1 (E.lookupERel env n)) ^ "_" ^ Int.toString (E.countERels env - n - 1))
116 handle CjrEnv.UnboundRel _ => string ("__uwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1)) 152 handle CjrEnv.UnboundRel _ => string ("__uwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1))
117 153
118 fun p_enamed' env n = 154 fun p_enamed' env n =
119 "__uwn_" ^ ident (#1 (E.lookupENamed env n)) ^ "_" ^ Int.toString n 155 "__uwn_" ^ ident (#1 (E.lookupENamed env n)) ^ "_" ^ Int.toString n
386 string ")"] 422 string ")"]
387 | TFfi ("Basis", "channel") => box [string "uw_Basis_stringToChannel_error(ctx, ", e, string ")"] 423 | TFfi ("Basis", "channel") => box [string "uw_Basis_stringToChannel_error(ctx, ", e, string ")"]
388 | TFfi ("Basis", "client") => box [string "uw_Basis_stringToClient_error(ctx, ", e, string ")"] 424 | TFfi ("Basis", "client") => box [string "uw_Basis_stringToClient_error(ctx, ", e, string ")"]
389 425
390 | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL"; 426 | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL";
391 Print.eprefaces' [("Type", p_typ env tAll)]; 427 Print.eprefaces' [("Type", p_htyp env tAll)];
392 string "ERROR") 428 string "ERROR")
393 429
394 fun p_getcol wontLeakStrings env (tAll as (t, loc)) i = 430 fun p_getcol wontLeakStrings env (tAll as (t, loc)) i =
395 case t of 431 case t of
396 TOption t => 432 TOption t =>
1360 | TFfi ("Basis", "blob") => Blob 1396 | TFfi ("Basis", "blob") => Blob
1361 | TFfi ("Basis", "channel") => Channel 1397 | TFfi ("Basis", "channel") => Channel
1362 | TFfi ("Basis", "client") => Client 1398 | TFfi ("Basis", "client") => Client
1363 | TOption t' => Nullable (sql_type_in env t') 1399 | TOption t' => Nullable (sql_type_in env t')
1364 | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type"; 1400 | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
1365 Print.eprefaces' [("Type", p_typ env tAll)]; 1401 Print.eprefaces' [("Type", p_htyp env tAll)];
1366 Int) 1402 Int)
1367 1403
1368 fun potentiallyFancy (e, _) = 1404 fun potentiallyFancy (e, _) =
1369 case e of 1405 case e of
1370 EPrim _ => false 1406 EPrim _ => false
2376 | TFfi ("Basis", "time") => "timestamp" 2412 | TFfi ("Basis", "time") => "timestamp"
2377 | TFfi ("Basis", "blob") => "bytea" 2413 | TFfi ("Basis", "blob") => "bytea"
2378 | TFfi ("Basis", "channel") => "int8" 2414 | TFfi ("Basis", "channel") => "int8"
2379 | TFfi ("Basis", "client") => "int4" 2415 | TFfi ("Basis", "client") => "int4"
2380 | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type"; 2416 | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
2381 Print.eprefaces' [("Type", p_typ env tAll)]; 2417 Print.eprefaces' [("Type", p_htyp env tAll)];
2382 "ERROR") 2418 "ERROR")
2383 2419
2384 fun p_sqltype' env (tAll as (t, loc)) = 2420 fun p_sqltype' env (tAll as (t, loc)) =
2385 case t of 2421 case t of
2386 (TOption t, _) => p_sqltype'' env t 2422 (TOption t, _) => p_sqltype'' env t
2967 val dbstring = ref "" 3003 val dbstring = ref ""
2968 val expunge = ref 0 3004 val expunge = ref 0
2969 val initialize = ref 0 3005 val initialize = ref 0
2970 val prepped = ref [] 3006 val prepped = ref []
2971 3007
2972 val () = app (fn d => 3008 val _ = foldl (fn (d, env) =>
2973 case #1 d of 3009 ((case #1 d of
2974 DDatabase {name = x, expunge = y, initialize = z} => (hasDb := true; 3010 DDatabase {name = x, expunge = y, initialize = z} => (hasDb := true;
2975 dbstring := x; 3011 dbstring := x;
2976 expunge := y; 3012 expunge := y;
2977 initialize := z) 3013 initialize := z)
2978 | DTable (s, xts, _, _) => tables := (s, map (fn (x, t) => 3014 | DTable (s, xts, _, _) => tables := (s, map (fn (x, t) =>
2979 (x, sql_type_in env t)) xts) :: !tables 3015 (x, sql_type_in env t)) xts) :: !tables
2980 | DView (s, xts, _) => views := (s, map (fn (x, t) => 3016 | DView (s, xts, _) => views := (s, map (fn (x, t) =>
2981 (x, sql_type_in env t)) xts) :: !views 3017 (x, sql_type_in env t)) xts) :: !views
2982 | DSequence s => sequences := s :: !sequences 3018 | DSequence s => sequences := s :: !sequences
2983 | DPreparedStatements ss => prepped := ss 3019 | DPreparedStatements ss => prepped := ss
2984 | _ => ()) ds 3020 | _ => ());
3021 E.declBinds env d)) E.empty ds
2985 3022
2986 val hasDb = !hasDb 3023 val hasDb = !hasDb
2987 3024
2988 fun expDb (e, _) = 3025 fun expDb (e, _) =
2989 case e of 3026 case e of