diff options
author | Benjamin Barenblat <bbaren@mit.edu> | 2020-05-30 19:49:56 -0400 |
---|---|---|
committer | Benjamin Barenblat <bbaren@mit.edu> | 2020-05-30 19:49:56 -0400 |
commit | c2f1e1096f602b1cbd4531352f3e1ea6d656a186 (patch) | |
tree | ae102982878bb0c31bdfe07209e60bfc14030490 /src/monoize.sml | |
parent | 095c2640aa2070ed4e2765875238d5e6e6673856 (diff) | |
parent | 5a0b639dfbd7db9d16c6995f72ba17152a1f362d (diff) |
Merge branch 'upstream' into dfsg_clean20200209+dfsgdfsg_clean
Diffstat (limited to 'src/monoize.sml')
-rw-r--r-- | src/monoize.sml | 128 |
1 files changed, 122 insertions, 6 deletions
diff --git a/src/monoize.sml b/src/monoize.sml index 11c6ea31..22b4e0e7 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -50,6 +50,38 @@ structure RM = BinaryMapFn(struct (L'.TRecord r2, E.dummySpan)) end) +val uses_similar = ref false + +local + val url_prefixes = ref [] +in + +fun reset () = (url_prefixes := []; uses_similar := false) + +fun addPrefix prefix = + let + fun isPrefix s1 s2 = + String.isPrefix s1 s2 + andalso (size s1 = size s2 + orelse String.sub (s2, size s1) = #"/") + in + if List.exists (fn prefix' => + let + fun tryOne prefix' prefix = + isPrefix prefix' prefix + andalso (ErrorMsg.error ("Conflicting URL prefixes for page handlers: \"" ^ prefix' ^ "\" is a prefix of \"" ^ prefix ^ "\"."); + true) + in + tryOne prefix' prefix + orelse tryOne prefix prefix' + end) (!url_prefixes) then + () + else + url_prefixes := prefix :: !url_prefixes + end + +end + val nextPvar = MonoFooify.nextPvar val pvars = ref (RM.empty : (int * (string * int * L'.typ) list) RM.map) val pvarDefs = MonoFooify.pvarDefs @@ -325,6 +357,8 @@ fun monoType env = (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_ufunc"), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_bfunc"), _), _), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_partition"), _), _), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_window"), _), _), _), _), _), _), _), _) => @@ -1339,7 +1373,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = Settings.mangleSql (monoNameLc env x) ^ (if #textKeysNeedLengths (Settings.currentDbms ()) andalso isBlobby t then - "(767)" + "(255)" else "")) unique)))), loc), @@ -1383,7 +1417,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (map (fn (x, t) => Settings.mangleSql (monoNameLc env x) ^ (if #textKeysNeedLengths (Settings.currentDbms ()) andalso isBlobby t then - "(767)" + "(255)" else "")) unique) ^ ")"), @@ -1540,17 +1574,31 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EFfiApp ("Basis", "dml", [(e, _)]) => let + val string = (L'.TFfi ("Basis", "string"), loc) val (e, fm) = monoExp (env, st, fm) e in - ((L'.EDml (e, L'.Error), loc), + ((L'.ECase (e, + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + (L'.ERecord [], loc)), + ((L'.PVar ("cmd", string), loc), + (L'.EDml ((L'.ERel 0, loc), L'.Error), loc))], + {disc = string, + result = (L'.TRecord [], loc)}), loc), fm) end | L.EFfiApp ("Basis", "tryDml", [(e, _)]) => let + val string = (L'.TFfi ("Basis", "string"), loc) val (e, fm) = monoExp (env, st, fm) e in - ((L'.EDml (e, L'.None), loc), + ((L'.ECase (e, + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + (L'.ERecord [], loc)), + ((L'.PVar ("cmd", string), loc), + (L'.EDml ((L'.ERel 0, loc), L'.None), loc))], + {disc = string, + result = (L'.TRecord [], loc)}), loc), fm) end @@ -1579,7 +1627,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "update"), _), _), _), _), _), changed) => (case monoType env (L.TRecord changed, loc) of - (L'.TRecord changed, _) => + (L'.TRecord [], _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + val rt = (L'.TRecord [], loc) + in + ((L'.EAbs ("fs", rt, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), + (L'.EAbs ("tab", s, (L'.TFun (s, s), loc), + (L'.EAbs ("e", s, s, + str ""), loc)), loc)), loc), + fm) + end + | (L'.TRecord changed, _) => let val s = (L'.TFfi ("Basis", "string"), loc) val changed = map (fn (x, _) => (x, s)) changed @@ -2638,6 +2697,40 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.ECApp ((L.EFfi ("Basis", "sql_known"), _), _) => ((L'.EFfi ("Basis", "sql_known"), loc), fm) + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_bfunc"), _), + _), _), + _), _), + _), _), + _), _), + _), _), + _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("f", s, (L'.TFun (s, s), loc), + (L'.EAbs ("x1", s, s, + (L'.EAbs ("x2", s, s, + strcat [(L'.ERel 2, loc), + str "(", + (L'.ERel 1, loc), + str ",", + (L'.ERel 0, loc), + str ")"]), loc)), loc)), loc), + fm) + end + | L.EFfi ("Basis", "sql_similarity") => + ((case #supportsSimilar (Settings.currentDbms ()) of + NONE => ErrorMsg.errorAt loc "The DBMS you've selected doesn't support SIMILAR." + | _ => ()); + uses_similar := true; + (str "similarity", fm)) + | (L.ECApp ( (L.ECApp ( (L.ECApp ( @@ -3953,6 +4046,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) = loc)), loc), fm) end + | L.ECApp ((L.EFfi ("Basis", "unsafeSerializedToString"), _), _) => + let + val t = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("v", t, t, (L'.ERel 0, loc)), loc), + fm) + end + | L.ECApp ((L.EFfi ("Basis", "unsafeSerializedFromString"), _), _) => + let + val t = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("v", t, t, (L'.ERel 0, loc)), loc), + fm) + end | L.EFfiApp ("Basis", "url", [(e, _)]) => let @@ -4194,6 +4301,7 @@ fun monoDecl (env, fm) (all as (d, loc)) = | L.DExport (ek, n, b) => let val (_, t, _, s) = Env.lookupENamed env n + val () = addPrefix s fun unwind (t, args) = case #1 t of @@ -4353,6 +4461,7 @@ datatype expungable = Client | Channel fun monoize env file = let + val () = reset () val () = pvars := RM.empty (* Calculate which exported functions need cookie signature protection *) @@ -4522,7 +4631,8 @@ fun monoize env file = in (env, Fm.enter fm, (L'.DDatabase {name = s, expunge = nExp, - initialize = nIni}, loc) + initialize = nIni, + usesSimilar = false}, loc) :: (dExp, loc) :: (dIni, loc) :: ds) @@ -4546,6 +4656,12 @@ fun monoize env file = | _ => ds' @ Fm.decls fm @ (L'.DDatatype (!pvarDefs), loc) :: ds))) (env, Fm.empty mname, []) file + val ds = map (fn (L'.DDatabase r, loc) => + (L'.DDatabase {name = #name r, + expunge = #expunge r, + initialize = #initialize r, + usesSimilar = !uses_similar}, loc) + | x => x) ds val monoFile = (rev ds, []) in pvars := RM.empty; |