diff options
| -rw-r--r-- | src/cjr_print.sml | 69 | ||||
| -rw-r--r-- | src/mono_shake.sml | 2 | ||||
| -rw-r--r-- | tests/cantSql.ur | 3 | ||||
| -rw-r--r-- | tests/cantSql.urp | 3 |
4 files changed, 61 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 diff --git a/tests/cantSql.ur b/tests/cantSql.ur new file mode 100644 index 00000000..026fcaa4 --- /dev/null +++ b/tests/cantSql.ur @@ -0,0 +1,3 @@ +datatype foo = Bar of int + +table bad : { A : foo, B : { X : float } } diff --git a/tests/cantSql.urp b/tests/cantSql.urp new file mode 100644 index 00000000..b1809f0f --- /dev/null +++ b/tests/cantSql.urp @@ -0,0 +1,3 @@ +database dbname=test + +cantSql |