(* Copyright (c) 2008-2010, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* - Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
* - Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
* - The names of contributors may not be used to endorse or promote products
* derived from this software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*)
structure Monoize :> MONOIZE = struct
structure E = ErrorMsg
structure Env = CoreEnv
structure L = Core
structure L' = Mono
structure IM = IntBinaryMap
structure IS = IntBinarySet
structure SS = BinarySetFn(struct
type ord_key = string
val compare = String.compare
end)
val singletons = SS.addList (SS.empty,
["link",
"br",
"p",
"hr",
"input",
"button",
"img"])
val dummyTyp = (L'.TDatatype (0, ref (L'.Enum, [])), E.dummySpan)
structure U = MonoUtil
val liftExpInExp =
U.Exp.mapB {typ = fn t => t,
exp = fn bound => fn e =>
case e of
L'.ERel xn =>
if xn < bound then
e
else
L'.ERel (xn + 1)
| _ => e,
bind = fn (bound, U.Exp.RelE _) => bound + 1
| (bound, _) => bound}
fun monoName env (all as (c, loc)) =
let
fun poly () =
(E.errorAt loc "Unsupported name constructor";
Print.eprefaces' [("Constructor", CorePrint.p_con env all)];
"")
in
case c of
L.CName s => s
| _ => poly ()
end
fun lowercaseFirst "" = ""
| lowercaseFirst s = String.str (Char.toLower (String.sub (s, 0)))
^ String.extract (s, 1, NONE)
fun monoNameLc env c = lowercaseFirst (monoName env c)
fun readType' (t, loc) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc),
(L'.TOption t, loc)), loc)
fun readErrType (t, loc) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc),
t), loc)
fun readType (t, loc) =
(L'.TRecord [("Read", readType' (t, loc)),
("ReadError", readErrType (t, loc))],
loc)
fun monoType env =
let
fun mt env dtmap (all as (c, loc)) =
let
fun poly () =
(E.errorAt loc "Unsupported type constructor";
Print.eprefaces' [("Constructor", CorePrint.p_con env all)];
dummyTyp)
in
case c of
L.TFun (c1, c2) => (L'.TFun (mt env dtmap c1, mt env dtmap c2), loc)
| L.TCFun _ => poly ()
| L.TRecord (L.CRecord ((L.KType, _), xcs), _) =>
let
val xcs = map (fn (x, t) => (monoName env x, mt env dtmap t)) xcs
val xcs = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) xcs
in
(L'.TRecord xcs, loc)
end
| L.TRecord _ => poly ()
| L.CApp ((L.CFfi ("Basis", "option"), _), t) =>
(L'.TOption (mt env dtmap t), loc)
| L.CApp ((L.CFfi ("Basis", "list"), _), t) =>
(L'.TList (mt env dtmap t), loc)
| L.CApp ((L.CFfi ("Basis", "monad"), _), _) =>
(L'.TRecord [], loc)
| L.CApp ((L.CFfi ("Basis", "eq"), _), t) =>
let
val t = mt env dtmap t
in
(L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)
end
| L.CApp ((L.CFfi ("Basis", "num"), _), t) =>
let
val t = mt env dtmap t
in
(L'.TRecord [("Zero", t),
("Neg", (L'.TFun (t, t), loc)),
("Plus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
("Minus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
("Times", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
("Div", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
("Mod", (L'.TFun (t, (L'.TFun (t, t), loc)), loc))],
loc)
end
| L.CApp ((L.CFfi ("Basis", "ord"), _), t) =>
let
val t = mt env dtmap t
in
(L'.TRecord [("Lt", (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)),
("Le", (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc))],
loc)
end
| L.CApp ((L.CFfi ("Basis", "show"), _), t) =>
(L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
| L.CApp ((L.CFfi ("Basis", "read"), _), t) =>
readType (mt env dtmap t, loc)
| L.CFfi ("Basis", "unit") => (L'.TRecord [], loc)
| L.CFfi ("Basis", "page") => (L'.TFfi ("Basis", "string"), loc)
| L.CFfi ("Basis", "xbody") => (L'.TFfi ("Basis", "string"), loc)
| L.CFfi ("Basis", "xtr") => (L'.TFfi ("Basis", "string"), loc)
| L.CFfi ("Basis", "xform") => (L'.TFfi ("Basis", "string"), loc)
| L.CFfi ("Basis", "url") => (L'.TFfi ("Basis", "string"), loc)
| L.CFfi ("Basis", "mimeType") => (L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CFfi ("Basis", "css_class") => (L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CFfi ("Basis", "serialized"), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
(L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc)
| L.CApp ((L.CFfi ("Basis", "source"), _), t) =>
(L'.TSource, loc)
| L.CApp ((L.CFfi ("Basis", "signal"), _), t) =>
(L'.TSignal (mt env dtmap t), loc)
| L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_table"), _), _), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CFfi ("Basis", "sql_view"), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CFfi ("Basis", "sql_sequence") =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query"), _), _), _), _), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query1"), _), _), _), _), _), _), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_from_items"), _), _), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CFfi ("Basis", "primary_key"), _), _), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraints"), _), _), _), _) =>
(L'.TFfi ("Basis", "sql_constraints"), loc)
| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraint"), _), _), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CFfi ("Basis", "linkable"), _), _), _), _) =>
(L'.TRecord [], loc)
| L.CApp ((L.CApp ((L.CFfi ("Basis", "matching"), _), _), _), _) =>
let
val string = (L'.TFfi ("Basis", "string"), loc)
in
(L'.TRecord [("1", string), ("2", string)], loc)
end
| L.CApp ((L.CFfi ("Basis", "propagation_mode"), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_subset"), _), _), _), _) =>
(L'.TRecord [], loc)
| L.CFfi ("Basis", "sql_relop") =>
(L'.TFfi ("Basis", "string"), loc)
| L.CFfi ("Basis", "sql_direction") =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_order_by"), _), _), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CFfi ("Basis", "sql_limit") =>
(L'.TFfi ("Basis", "string"), loc)
| L.CFfi ("Basis", "sql_offset") =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CFfi ("Basis", "fieldsOf"), _), _), _), _) =>
(L'.TRecord [], loc)
| L.CApp ((L.CFfi ("Basis", "sql_injectable_prim"), _), t) =>
(L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
| L.CApp ((L.CFfi ("Basis", "sql_injectable"), _), t) =>
(L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
| L.CApp ((L.CApp ((L.CFfi ("Basis", "nullify"), _), _), _), _) =>
(L'.TRecord [], loc)
| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_unary"), _), _), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_binary"), _), _), _), _), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_aggregate"), _), _), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CFfi ("Basis", "sql_summable"), _), _) =>
(L'.TRecord [], loc)
| L.CApp ((L.CFfi ("Basis", "sql_maxable"), _), _) =>
(L'.TRecord [], loc)
| L.CApp ((L.CFfi ("Basis", "sql_arith"), _), _) =>
(L'.TRecord [], loc)
| L.CApp ((L.CFfi ("Basis", "sql_nfunc"), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_ufunc"), _), _), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CFfi ("Basis", "channel"), _), _) =>
(L'.TFfi ("Basis", "channel"), loc)
| L.CRel _ => poly ()
| L.CNamed n =>
(case IM.find (dtmap, n) of
SOME r => (L'.TDatatype (n, r), loc)
| NONE =>
let
val r = ref (L'.Default, [])
val (_, xs, xncs) = Env.lookupDatatype env n
val dtmap' = IM.insert (dtmap, n, r)
val xncs = map (fn (x, n, to) => (x, n, Option.map (mt env dtmap') to)) xncs
in
case xs of
[] =>(r := (ElabUtil.classifyDatatype xncs, xncs);
(L'.TDatatype (n, r), loc))
| _ => poly ()
end)
| L.CFfi mx => (L'.TFfi mx, loc)
| L.CApp _ => poly ()
| L.CAbs _ => poly ()
| L.CName _ => poly ()
| L.CRecord _ => poly ()
| L.CConcat _ => poly ()
| L.CMap _ => poly ()
| L.CUnit => poly ()
| L.CTuple _ => poly ()
| L.CProj _ => poly ()
| L.CKAbs _ => poly ()
| L.CKApp _ => poly ()
| L.TKFun _ => poly ()
end
in
mt env IM.empty
end
val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan)
structure IM = IntBinaryMap
datatype foo_kind =
Attr
| Url
fun fk2s fk =
case fk of
Attr => "attr"
| Url => "url"
structure Fm :> sig
type t
val empty : int -> t
val lookup : t -> foo_kind -> int -> (int -> t -> L'.decl * t) -> t * int
val lookupList : t -> foo_kind -> L'.typ -> (int -> t -> L'.decl * t) -> t * int
val enter : t -> t
val decls : t -> L'.decl list
val freshName : t -> int * t
end = struct
structure M = BinaryMapFn(struct
type ord_key = foo_kind
fun compare x =
case x of
(Attr, Attr) => EQUAL
| (Attr, _) => LESS
| (_, Attr) => GREATER
| (Url, Url) => EQUAL
end)
structure TM = BinaryMapFn(struct
type ord_key = L'.typ
val compare = MonoUtil.Typ.compare
end)
type t = {
count : int,
map : int IM.map M.map,
listMap : int TM.map M.map,
decls : L'.decl list
}
fun empty count = {
count = count,
map = M.empty,
listMap = M.empty,
decls = []
}
fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []}
fun freshName {count, map, listMap, decls} = (count, {count = count + 1, map = map, listMap = listMap, decls = decls})
fun decls ({decls, ...} : t) = decls
fun lookup (t as {count, map, listMap, decls}) k n thunk =
let
val im = Option.getOpt (M.find (map, k), IM.empty)
in
case IM.find (im, n) of
NONE =>
let
val n' = count
val (d, {count, map, listMap, decls}) =
thunk count {count = count + 1,
map = M.insert (map, k, IM.insert (im, n, n')),
listMap = listMap,
decls = decls}
in
({count = count,
map = map,
listMap = listMap,
decls = d :: decls}, n')
end
| SOME n' => (t, n')
end
fun lookupList (t as {count, map, listMap, decls}) k tp thunk =
let
val tm = Option.getOpt (M.find (listMap, k), TM.empty)
in
case TM.find (tm, tp) of
NONE =>
let
val n' = count
val (d, {count, map, listMap, decls}) =
thunk count {count = count + 1,
map = map,
listMap = M.insert (listMap, k, TM.insert (tm, tp, n')),
decls = decls}
in
({count = count,
map = map,
listMap = listMap,
decls = d :: decls}, n')
end
| SOME n' => (t, n')
end
end
fun capitalize s =
if s = "" then
s
else
str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
fun fooifyExp fk env =
let
fun fooify fm (e, tAll as (t, loc)) =
case #1 e of
L'.EClosure (fnam, [(L'.ERecord [], _)]) =>
let
val (_, _, _, s) = Env.lookupENamed env fnam
in
((L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm)
end
| L'.EClosure (fnam, args) =>
let
val (_, ft, _, s) = Env.lookupENamed env fnam
val ft = monoType env ft
fun attrify (args, ft, e, fm) =
case (args, ft) of
([], _) => (e, fm)
| (arg :: args, (L'.TFun (t, ft), _)) =>
let
val (arg', fm) = fooify fm (arg, t)
in
attrify (args, ft,
(L'.EStrcat (e,
(L'.EStrcat ((L'.EPrim (Prim.String "/"), loc),
arg'), loc)), loc),
fm)
end
| _ => (E.errorAt loc "Type mismatch encoding attribute";
(e, fm))
in
attrify (args, ft, (L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm)
end
| _ =>
case t of
L'.TFfi ("Basis", "unit") => ((L'.EPrim (Prim.String ""), loc), fm)
| L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [e]), loc), fm)
| L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm)
| L'.TRecord ((x, t) :: xts) =>
let
val (se, fm) = fooify fm ((L'.EField (e, x), loc), t)
in
foldl (fn ((x, t), (se, fm)) =>
let
val (se', fm) = fooify fm ((L'.EField (e, x), loc), t)
in
((L'.EStrcat (se,
(L'.EStrcat ((L'.EPrim (Prim.String "/"), loc),
se'), loc)), loc),
fm)
end) (se, fm) xts
end
| L'.TDatatype (i, ref (dk, _)) =>
let
fun makeDecl n fm =
let
val (x, _, xncs) = Env.lookupDatatype env i
val (branches, fm) =
ListUtil.foldlMap
(fn ((x, n, to), fm) =>
case to of
NONE =>
(((L'.PCon (dk, L'.PConVar n, NONE), loc),
(L'.EPrim (Prim.String x), loc)),
fm)
| SOME t =>
let
val t = monoType env t
val (arg, fm) = fooify fm ((L'.ERel 0, loc), t)
in
(((L'.PCon (dk, L'.PConVar n, SOME (L'.PVar ("a", t), loc)), loc),
(L'.EStrcat ((L'.EPrim (Prim.String (x ^ "/")), loc),
arg), loc)),
fm)
end)
fm xncs
val dom = tAll
val ran = (L'.TFfi ("Basis", "string"), loc)
in
((L'.DValRec [(fk2s fk ^ "ify_" ^ x,
n,
(L'.TFun (dom, ran), loc),
(L'.EAbs ("x",
dom,
ran,
(L'.ECase ((L'.ERel 0, loc),
branches,
{disc = dom,
result = ran}), loc)), loc),
"")], loc),
fm)
end
val (fm, n) = Fm.lookup fm fk i makeDecl
in
((L'.EApp ((L'.ENamed n, loc), e), loc), fm)
end
| L'.TOption t =>
let
val (body, fm) = fooify fm ((L'.ERel 0, loc), t)
in
((L'.ECase (e,
[((L'.PNone t, loc),
(L'.EPrim (Prim.String "None"), loc)),
((L'.PSome (t, (L'.PVar ("x", t), loc)), loc),
(L'.EStrcat ((L'.EPrim (Prim.String "Some/"), loc),
body), loc))],
{disc = tAll,
result = (L'.TFfi ("Basis", "string"), loc)}), loc),
fm)
end
| L'.TList t =>
let
fun makeDecl n fm =
let
val rt = (L'.TRecord [("1", t), ("2", (L'.TList t, loc))], loc)
val (arg, fm) = fooify fm ((L'.ERel 0, loc), rt)
val branches = [((L'.PNone rt, loc),
(L'.EPrim (Prim.String "Nil"), loc)),
((L'.PSome (rt, (L'.PVar ("a", rt), loc)), loc),
(L'.EStrcat ((L'.EPrim (Prim.String "Cons/"), loc),
arg), loc))]
val dom = tAll
val ran = (L'.TFfi ("Basis", "string"), loc)
in
((L'.DValRec [(fk2s fk ^ "ify_list",
n,
(L'.TFun (dom, ran), loc),
(L'.EAbs ("x",
dom,
ran,
(L'.ECase ((L'.ERel 0, loc),
branches,
{disc = dom,
result = ran}), loc)), loc),
"")], loc),
fm)
end
val (fm, n) = Fm.lookupList fm fk t makeDecl
in
((L'.EApp ((L'.ENamed n, loc), e), loc), fm)
end
| _ => (E.errorAt loc "Don't know how to encode attribute/URL type";
Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
(dummyExp, fm))
in
fooify
end
val attrifyExp = fooifyExp Attr
val urlifyExp = fooifyExp Url
datatype 'a failable_search =
Found of 'a
| NotFound
| Error
structure St :> sig
type t
val empty : t
val radioGroup : t -> string option
val setRadioGroup : t * string -> t
end = struct
type t = {
radioGroup : string option
}
val empty = {radioGroup = NONE}
fun radioGroup (t : t) = #radioGroup t
fun setRadioGroup (t : t, x) = {radioGroup = SOME x}
end
fun monoPatCon env pc =
case pc of
L.PConVar n => L'.PConVar n
| L.PConFfi {mod = m, datatyp, con, arg, ...} => L'.PConFfi {mod = m, datatyp = datatyp, con = con,
arg = Option.map (monoType env) arg}
val dummyPat = (L'.PPrim (Prim.Int 0), ErrorMsg.dummySpan)
fun listify t = (L'.TRecord [("1", t), ("2", (L'.TList t, #2 t))], #2 t)
fun monoPat env (all as (p, loc)) =
let
fun poly () =
(E.errorAt loc "Unsupported pattern";
Print.eprefaces' [("Pattern", CorePrint.p_pat env all)];
dummyPat)
in
case p of
L.PWild => (L'.PWild, loc)
| L.PVar (x, t) => (L'.PVar (x, monoType env t), loc)
| L.PPrim p => (L'.PPrim p, loc)
| L.PCon (dk, pc, [], po) => (L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc)
| L.PCon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], NONE) =>
(L'.PNone (listify (monoType env t)), loc)
| L.PCon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], SOME p) =>
(L'.PSome (listify (monoType env t), monoPat env p), loc)
| L.PCon (L.Option, _, [t], NONE) => (L'.PNone (monoType env t), loc)
| L.PCon (L.Option, pc, [t], SOME p) => (L'.PSome (monoType env t, monoPat env p), loc)
| L.PCon _ => poly ()
| L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc)
end
fun strcat loc es =
case es of
[] => (L'.EPrim (Prim.String ""), loc)
| [e] => e
| _ =>
let
val e2 = List.last es
val es = List.take (es, length es - 1)
val e1 = List.last es
val es = List.take (es, length es - 1)
in
foldr (fn (e, e') => (L'.EStrcat (e, e'), loc))
(L'.EStrcat (e1, e2), loc) es
end
fun strcatComma loc es =
case es of
[] => (L'.EPrim (Prim.String ""), loc)
| [e] => e
| _ =>
let
val e1 = List.last es
val es = List.take (es, length es - 1)
in
foldr (fn (e, e') =>
case (e, e') of
((L'.EPrim (Prim.String ""), _), _) => e'
| (_, (L'.EPrim (Prim.String ""), _)) => e
| _ =>
(L'.EStrcat (e,
(L'.EStrcat ((L'.EPrim (Prim.String ", "), loc), e'), loc)), loc))
e1 es
end
fun strcatR loc e xs = strcatComma loc (map (fn (x, _) => (L'.EField (e, x), loc)) xs)
val readCookie = ref IS.empty
fun isBlobby (t : L.con) =
case #1 t of
L.CFfi ("Basis", "string") => true
| L.CFfi ("Basis", "blob") => true
| _ => false
fun monoExp (env, st, fm) (all as (e, loc)) =
let
val strcat = strcat loc
val strcatComma = strcatComma loc
fun str s = (L'.EPrim (Prim.String s), loc)
fun poly () =
(E.errorAt loc "Unsupported expression";
Print.eprefaces' [("Expression", CorePrint.p_exp env all)];
(dummyExp, fm))
fun numTy t =
(L'.TRecord [("Zero", t),
("Neg", (L'.TFun (t, t), loc)),
("Plus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
("Minus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
("Times", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
("Div", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
("Mod", (L'.TFun (t, (L'.TFun (t, t), loc)), loc))], loc)
fun numEx (t, zero, neg, plus, minus, times, dv, md) =
((L'.ERecord [("Zero", (L'.EPrim zero, loc), t),
("Neg", neg, (L'.TFun (t, t), loc)),
("Plus", plus, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
("Minus", minus, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
("Times", times, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
("Div", dv, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
("Mod", md, (L'.TFun (t, (L'.TFun (t, t), loc)), loc))], loc), fm)
fun ordTy t =
(L'.TRecord [("Lt", (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)),
("Le", (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc))], loc)
fun ordEx (t, lt, le) =
((L'.ERecord [("Lt", lt, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)),
("Le", le, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc))],
loc), fm)
fun outerRec xts =
(L'.TRecord (map (fn ((L.CName x, _), (L.CRecord (_, xts), _)) =>
(x, (L'.TRecord (map (fn (x', _) => (x, (L'.TRecord [], loc))) xts), loc))
| (x, all as (_, loc)) =>
(E.errorAt loc "Unsupported record field constructor";
Print.eprefaces' [("Name", CorePrint.p_con env x),
("Constructor", CorePrint.p_con env all)];
("", dummyTyp))) xts), loc)
in
case e of
L.EPrim p => ((L'.EPrim p, loc), fm)
| L.ERel n => ((L'.ERel n, loc), fm)
| L.ENamed n => ((L'.ENamed n, loc), fm)
| L.ECon (dk, pc, [], eo) =>
let
val (eo, fm) =
case eo of
NONE => (NONE, fm)
| SOME e =>
let
val (e, fm) = monoExp (env, st, fm) e
in
(SOME e, fm)
end
in
((L'.ECon (dk, monoPatCon env pc, eo), loc), fm)
end
| L.ECon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], NONE) =>
((L'.ENone (listify (monoType env t)), loc), fm)
| L.ECon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], SOME e) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
((L'.ESome (listify (monoType env t), e), loc), fm)
end
| L.ECon (L.Option, _, [t], NONE) =>
((L'.ENone (monoType env t), loc), fm)
| L.ECon (L.Option, _, [t], SOME e) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
((L'.ESome (monoType env t, e), loc), fm)
end
| L.ECon _ => poly ()
| L.ECApp ((L.EFfi ("Basis", "eq"), _), t) =>
let
val t = monoType env t
val b = (L'.TFfi ("Basis", "bool"), loc)
val dom = (L'.TFun (t, (L'.TFun (t, b), loc)), loc)
in
((L'.EAbs ("f", dom, dom,
(L'.ERel 0, loc)), loc), fm)
end
| L.ECApp ((L.EFfi ("Basis", "ne"), _), t) =>
let
val t = monoType env t
val b = (L'.TFfi ("Basis", "bool"), loc)
val dom = (L'.TFun (t, (L'.TFun (t, b), loc)), loc)
in
((L'.EAbs ("f", dom, dom,
(L'.EAbs ("x", t, (L'.TFun (t, b), loc),
(L'.EAbs ("y", t, b,
(L'.EUnop ("!", (L'.EApp ((L'.EApp ((L'.ERel 2, loc),
(L'.ERel 1, loc)), loc),
(L'.ERel 0, loc)), loc)), loc)),
loc)),
loc)),
loc), fm)
end
| L.EFfi ("Basis", "eq_int") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc),
(L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
(L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc),
(L'.TFfi ("Basis", "bool"), loc),
(L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
fm)
| L.EFfi ("Basis", "eq_float") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc),
(L'.TFun ((L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
(L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc),
(L'.TFfi ("Basis", "bool"), loc),
(L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
fm)
| L.EFfi ("Basis", "eq_bool") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc),
(L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
(L'.EAbs ("y", (L'.TFfi ("Basis", "bool"), loc),
(L'.TFfi ("Basis", "bool"), loc),
(L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
fm)
| L.EFfi ("Basis", "eq_string") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc),
(L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
(L'.EAbs ("y", (L'.TFfi ("Basis", "string"), loc),
(L'.TFfi ("Basis", "bool"), loc),
(L'.EBinop ("!strcmp", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
fm)
| L.EFfi ("Basis", "eq_char") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc),
(L'.TFun ((L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
(L'.EAbs ("y", (L'.TFfi ("Basis", "char"), loc),
(L'.TFfi ("Basis", "bool"), loc),
(L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
fm)
| L.EFfi ("Basis", "eq_time") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc),
(L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
(L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc),
(L'.TFfi ("Basis", "bool"), loc),
(L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
fm)
| L.ECApp ((L.EFfi ("Basis", "mkEq"), _), t) =>
let
val t = monoType env t
val b = (L'.TFfi ("Basis", "bool"), loc)
val dom = (L'.TFun (t, (L'.TFun (t, b), loc)), loc)
in
((L'.EAbs ("f", dom, dom,
(L'.ERel 0, loc)), loc), fm)
end
| L.ECApp ((L.EFfi ("Basis", "zero"), _), t) =>
let
val t = monoType env t
in
((L'.EAbs ("r", numTy t, t,
(L'.EField ((L'.ERel 0, loc), "Zero"), loc)), loc), fm)
end
| L.ECApp ((L.EFfi ("Basis", "neg"), _), t) =>
let
val t = monoType env t
in
((L'.EAbs ("r", numTy t, (L'.TFun (t, t), loc),
(L'.EField ((L'.ERel 0, loc), "Neg"), loc)), loc), fm)
end
| L.ECApp ((L.EFfi ("Basis", "plus"), _), t) =>
let
val t = monoType env t
in
((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
(L'.EField ((L'.ERel 0, loc), "Plus"), loc)), loc), fm)
end
| L.ECApp ((L.EFfi ("Basis", "minus"), _), t) =>
let
val t = monoType env t
in
((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
(L'.EField ((L'.ERel 0, loc), "Minus"), loc)), loc), fm)
end
| L.ECApp ((L.EFfi ("Basis", "times"), _), t) =>
let
val t = monoType env t
in
((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
(L'.EField ((L'.ERel 0, loc), "Times"), loc)), loc), fm)
end
| L.ECApp ((L.EFfi ("Basis", "divide"), _), t) =>
let
val t = monoType env t
in
((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
(L'.EField ((L'.ERel 0, loc), "Div"), loc)), loc), fm)
end
| L.ECApp ((L.EFfi ("Basis", "mod"), _), t) =>
let
val t = monoType env t
in
((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
(L'.EField ((L'.ERel 0, loc), "Mod"), loc)), loc), fm)
end
| L.EFfi ("Basis", "num_int") =>
let
fun intBin s =
(L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc),
(L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "int"), loc)), loc),
(L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc),
(L'.TFfi ("Basis", "int"), loc),
(L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
in
numEx ((L'.TFfi ("Basis", "int"), loc),
Prim.Int (Int64.fromInt 0),
(L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc),
(L'.TFfi ("Basis", "int"), loc),
(L'.EUnop ("-", (L'.ERel 0, loc)), loc)), loc),
intBin "+",
intBin "-",
intBin "*",
intBin "/",
intBin "%")
end
| L.EFfi ("Basis", "num_float") =>
let
fun floatBin s =
(L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc),
(L'.TFun ((L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "float"), loc)), loc),
(L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc),
(L'.TFfi ("Basis", "float"), loc),
(L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
in
numEx ((L'.TFfi ("Basis", "float"), loc),
Prim.Float 0.0,
(L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc),
(L'.TFfi ("Basis", "float"), loc),
(L'.EUnop ("-", (L'.ERel 0, loc)), loc)), loc),
floatBin "+",
floatBin "-",
floatBin "*",
floatBin "/",
floatBin "fmod")
end
| L.ECApp ((L.EFfi ("Basis", "lt"), _), t) =>
let
val t = monoType env t
in
((L'.EAbs ("r", ordTy t, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc),
(L'.EField ((L'.ERel 0, loc), "Lt"), loc)), loc), fm)
end
| L.ECApp ((L.EFfi ("Basis", "le"), _), t) =>
let
val t = monoType env t
in
((L'.EAbs ("r", ordTy t, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc),
(L'.EField ((L'.ERel 0, loc), "Le"), loc)), loc), fm)
end
| L.ECApp ((L.EFfi ("Basis", "gt"), _), t) =>
let
val t = monoType env t
val b = (L'.TFfi ("Basis", "bool"), loc)
in
((L'.EAbs ("f", ordTy t, (L'.TFun (t, (L'.TFun (t, b), loc)), loc),
(L'.EAbs ("x", t, (L'.TFun (t, b), loc),
(L'.EAbs ("y", t, b,
(L'.EUnop ("!",
(L'.EApp ((L'.EApp ((L'.EField ((L'.ERel 2, loc),
"Le"), loc),
(L'.ERel 1, loc)), loc),
(L'.ERel 0, loc)), loc)), loc)), loc)),
loc)),
loc), fm)
end
| L.ECApp ((L.EFfi ("Basis", "ge"), _), t) =>
let
val t = monoType env t
val b = (L'.TFfi ("Basis", "bool"), loc)
in
((L'.EAbs ("f", ordTy t, (L'.TFun (t, (L'.TFun (t, b), loc)), loc),
(L'.EAbs ("x", t, (L'.TFun (t, b), loc),
(L'.EAbs ("y", t, b,
(L'.EUnop ("!",
(L'.EApp ((L'.EApp ((L'.EField ((L'.ERel 2, loc),
"Lt"), loc),
(L'.ERel 1, loc)), loc),
(L'.ERel 0, loc)), loc)), loc)), loc)),
loc)),
loc), fm)
end
| L.EFfi ("Basis", "ord_int") =>
let
fun intBin s =
(L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc),
(L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
(L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc),
(L'.TFfi ("Basis", "bool"), loc),
(L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
in
ordEx ((L'.TFfi ("Basis", "int"), loc),
intBin "<",
intBin "<=")
end
| L.EFfi ("Basis", "ord_float") =>
let
fun floatBin s =
(L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc),
(L'.TFun ((L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
(L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc),
(L'.TFfi ("Basis", "bool"), loc),
(L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
in
ordEx ((L'.TFfi ("Basis", "float"), loc),
floatBin "<",
floatBin "<=")
end
| L.EFfi ("Basis", "ord_bool") =>
let
fun boolBin s =
(L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc),
(L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
(L'.EAbs ("y", (L'.TFfi ("Basis", "bool"), loc),
(L'.TFfi ("Basis", "bool"), loc),
(L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
in
ordEx ((L'.TFfi ("Basis", "bool"), loc),
boolBin "<",
boolBin "<=")
end
| L.EFfi ("Basis", "ord_string") =>
let
fun boolBin s =
(L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc),
(L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
(L'.EAbs ("y", (L'.TFfi ("Basis", "string"), loc),
(L'.TFfi ("Basis", "bool"), loc),
(L'.EBinop (s,
(L'.EBinop ("strcmp",
(L'.ERel 1, loc),
(L'.ERel 0, loc)), loc),
(L'.EPrim (Prim.Int (Int64.fromInt 0)), loc)), loc)), loc)), loc)
in
ordEx ((L'.TFfi ("Basis", "string"), loc),
boolBin "<",
boolBin "<=")
end
| L.EFfi ("Basis", "ord_char") =>
let
fun charBin s =
(L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc),
(L'.TFun ((L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
(L'.EAbs ("y", (L'.TFfi ("Basis", "char"), loc),
(L'.TFfi ("Basis", "bool"), loc),
(L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
in
ordEx ((L'.TFfi ("Basis", "char"), loc),
charBin "<",
charBin "<=")
end
| L.EFfi ("Basis", "ord_time") =>
let
fun boolBin s =
(L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc),
(L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
(L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc),
(L'.TFfi ("Basis", "bool"), loc),
(L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
in
ordEx ((L'.TFfi ("Basis", "time"), loc),
boolBin "<",
boolBin "<=")
end
| L.ECApp ((L.EFfi ("Basis", "mkOrd"), _), t) =>
let
val t = monoType env t
val b = (L'.TFfi ("Basis", "bool"), loc)
val dom = ordTy t
in
((L'.EAbs ("f", dom, dom,
(L'.ERel 0, loc)), loc), fm)
end
| L.ECApp ((L.EFfi ("Basis", "show"), _), t) =>
let
val t = monoType env t
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("f", (L'.TFun (t, s), loc), (L'.TFun (t, s), loc),
(L'.ERel 0, loc)), loc), fm)
end
| L.EFfi ("Basis", "show_int") =>
((L'.EFfi ("Basis", "intToString"), loc), fm)
| L.EFfi ("Basis", "show_float") =>
((L'.EFfi ("Basis", "floatToString"), loc), fm)
| L.EFfi ("Basis", "show_string") =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm)
end
| L.EFfi ("Basis", "show_url") =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm)
end
| L.EFfi ("Basis", "show_char") =>
((L'.EFfi ("Basis", "charToString"), loc), fm)
| L.EFfi ("Basis", "show_bool") =>
((L'.EFfi ("Basis", "boolToString"), loc), fm)
| L.EFfi ("Basis", "show_time") =>
((L'.EFfi ("Basis", "timeToString"), loc), fm)
| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "show_xml"), _), _),_), _), _), _) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm)
end
| L.ECApp ((L.EFfi ("Basis", "mkShow"), _), t) =>
let
val t = monoType env t
val b = (L'.TFfi ("Basis", "string"), loc)
val dom = (L'.TFun (t, b), loc)
in
((L'.EAbs ("f", dom, dom,
(L'.ERel 0, loc)), loc), fm)
end
| L.ECApp ((L.EFfi ("Basis", "read"), _), t) =>
let
val t = monoType env t
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("f", readType (t, loc), readType' (t, loc),
(L'.EField ((L'.ERel 0, loc), "Read"), loc)), loc), fm)
end
| L.ECApp ((L.EFfi ("Basis", "readError"), _), t) =>
let
val t = monoType env t
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("f", readType (t, loc), readErrType (t, loc),
(L'.EField ((L'.ERel 0, loc), "ReadError"), loc)), loc), fm)
end
| L.ECApp ((L.EFfi ("Basis", "mkRead"), _), t) =>
let
val t = monoType env t
val b = (L'.TFfi ("Basis", "string"), loc)
val b' = (L'.TOption b, loc)
val dom = (L'.TFun (t, b), loc)
val dom' = (L'.TFun (t, b'), loc)
in
((L'.EAbs ("f", dom, (L'.TFun (dom', readType (t, loc)), loc),
(L'.EAbs ("f'", dom', readType (t, loc),
(L'.ERecord [("Read", (L'.ERel 0, loc), dom),
("ReadError", (L'.ERel 1, loc), dom')], loc)), loc)), loc),
fm)
end
| L.EFfi ("Basis", "read_int") =>
let
val t = (L'.TFfi ("Basis", "int"), loc)
in
((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToInt"), loc), readType' (t, loc)),
("ReadError", (L'.EFfi ("Basis", "stringToInt_error"), loc), readErrType (t, loc))],
loc),
fm)
end
| L.EFfi ("Basis", "read_float") =>
let
val t = (L'.TFfi ("Basis", "float"), loc)
in
((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToFloat"), loc), readType' (t, loc)),
("ReadError", (L'.EFfi ("Basis", "stringToFloat_error"), loc), readErrType (t, loc))],
loc),
fm)
end
| L.EFfi ("Basis", "read_string") =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.ERecord [("Read", (L'.EAbs ("s", s, (L'.TOption s, loc),
(L'.ESome (s, (L'.ERel 0, loc)), loc)), loc), readType' (s, loc)),
("ReadError", (L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), readErrType (s, loc))], loc),
fm)
end
| L.EFfi ("Basis", "read_char") =>
let
val t = (L'.TFfi ("Basis", "char"), loc)
in
((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToChar"), loc), readType' (t, loc)),
("ReadError", (L'.EFfi ("Basis", "stringToChar_error"), loc), readErrType (t, loc))],
loc),
fm)
end
| L.EFfi ("Basis", "read_bool") =>
let
val t = (L'.TFfi ("Basis", "bool"), loc)
in
((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToBool"), loc), readType' (t, loc)),
("ReadError", (L'.EFfi ("Basis", "stringToBool_error"), loc), readErrType (t, loc))],
loc),
fm)
end
| L.EFfi ("Basis", "read_time") =>
let
val t = (L'.TFfi ("Basis", "time"), loc)
in
((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToTime"), loc), readType' (t, loc)),
("ReadError", (L'.EFfi ("Basis", "stringToTime_error"), loc), readErrType (t, loc))],
loc),
fm)
end
| L.EFfi ("Basis", "transaction_monad") => ((L'.ERecord [], loc), fm)
| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), (L.CFfi ("Basis", "transaction"), _)), _), t) =>
let
val t = monoType env t
in
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), t), loc)), loc),
(L'.EAbs ("x", t,
(L'.TFun ((L'.TRecord [], loc), t), loc),
(L'.EAbs ("_", (L'.TRecord [], loc), t,
(L'.ERel 1, loc)), loc)), loc)), loc),
fm)
end
| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), (L.CFfi ("Basis", "transaction"), _)), _),
t1), _), t2) =>
let
val t1 = monoType env t1
val t2 = monoType env t2
val un = (L'.TRecord [], loc)
val mt1 = (L'.TFun (un, t1), loc)
val mt2 = (L'.TFun (un, t2), loc)
in
((L'.EAbs ("_", un,
(L'.TFun (mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc)), loc)), loc),
(L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc)), loc),
(L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc),
(L'.EAbs ("_", un, un,
(L'.ELet ("r", t1, (L'.EApp ((L'.ERel 2, loc),
(L'.ERecord [], loc)), loc),
(L'.EApp (
(L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc),
(L'.ERecord [], loc)),
loc)), loc)), loc)), loc)), loc)), loc),
fm)
end
| L.EApp ((L.ECApp ((L.EFfi ("Basis", "recv"), _), t1), _), ch) =>
let
val un = (L'.TRecord [], loc)
val t1 = monoType env t1
val (ch, fm) = monoExp (env, st, fm) ch
in
((L'.EAbs ("_", un, un, (L'.ERecv (liftExpInExp 0 ch, t1), loc)), loc), fm)
end
| L.EFfiApp ("Basis", "recv", _) => poly ()
| L.EFfiApp ("Basis", "sleep", [n]) =>
let
val (n, fm) = monoExp (env, st, fm) n
in
((L'.ESleep n, loc), fm)
end
| L.EFfiApp ("Basis", "sleep", _) => poly ()
| L.ECApp ((L.EFfi ("Basis", "source"), _), t) =>
let
val t = monoType env t
in
((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TSource, loc)), loc),
(L'.EAbs ("_", (L'.TRecord [], loc), (L'.TSource, loc),
(L'.EFfiApp ("Basis", "new_client_source",
[(L'.EJavaScript (L'.Source t, (L'.ERel 1, loc)), loc)]),
loc)), loc)),
loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "set"), _), t) =>
let
val t = monoType env t
in
((L'.EAbs ("src", (L'.TSource, loc),
(L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc)), loc),
(L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc),
(L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
(L'.EFfiApp ("Basis", "set_client_source",
[(L'.ERel 2, loc),
(L'.EJavaScript (L'.Source t,
(L'.ERel 1, loc)), loc)]),
loc)), loc)), loc)), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "get"), _), t) =>
let
val t = monoType env t
in
((L'.EAbs ("src", (L'.TSource, loc),
(L'.TFun ((L'.TRecord [], loc), t), loc),
(L'.EAbs ("_", (L'.TRecord [], loc), t,
(L'.EFfiApp ("Basis", "get_client_source",
[(L'.ERel 1, loc)]),
loc)), loc)), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "current"), _), t) =>
let
val t = monoType env t
in
((L'.EAbs ("src", (L'.TSource, loc),
(L'.TFun ((L'.TRecord [], loc), t), loc),
(L'.EAbs ("_", (L'.TRecord [], loc), t,
(L'.EFfiApp ("Basis", "current",
[(L'.ERel 1, loc)]),
loc)), loc)), loc),
fm)
end
| L.EFfiApp ("Basis", "spawn", [e]) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
((L'.ESpawn e, loc), fm)
end
| L.EFfi ("Basis", "signal_monad") => ((L'.ERecord [], loc), fm)
| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), (L.CFfi ("Basis", "signal"), _)), _), t) =>
let
val t = monoType env t
in
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (t, (L'.TSignal t, loc)), loc),
(L'.EAbs ("x", t, (L'.TSignal t, loc),
(L'.ESignalReturn (L'.ERel 0, loc), loc)), loc)), loc),
fm)
end
| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), (L.CFfi ("Basis", "signal"), _)), _),
t1), _), t2) =>
let
val t1 = monoType env t1
val t2 = monoType env t2
val un = (L'.TRecord [], loc)
val mt1 = (L'.TSignal t1, loc)
val mt2 = (L'.TSignal t2, loc)
in
((L'.EAbs ("_", un, (L'.TFun (mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), mt2), loc)), loc),
(L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), mt2), loc),
(L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), mt2,
(L'.ESignalBind ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)),
loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "signal"), _), t) =>
let
val t = monoType env t
in
((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), (L'.TSignal t, loc),
(L'.ESignalSource (L'.ERel 0, loc), loc)), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
val un = (L'.TRecord [], loc)
val t = monoType env t
in
((L'.EAbs ("c", s, (L'.TFun (un, s), loc),
(L'.EAbs ("_", un, s,
(L'.EUnurlify ((L'.EFfiApp ("Basis", "get_cookie", [(L'.ERel 1, loc)]), loc),
t, true),
loc)), loc)), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "setCookie"), _), t) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
val un = (L'.TRecord [], loc)
val t = monoType env t
val rt = (L'.TRecord [("Value", t),
("Expires", (L'.TOption (L'.TFfi ("Basis", "time"),
loc), loc)),
("Secure", (L'.TFfi ("Basis", "bool"), loc))], loc)
fun fd x = (L'.EField ((L'.ERel 1, loc), x), loc)
val (e, fm) = urlifyExp env fm (fd "Value", t)
in
((L'.EAbs ("c", s, (L'.TFun (rt, (L'.TFun (un, un), loc)), loc),
(L'.EAbs ("r", rt, (L'.TFun (un, un), loc),
(L'.EAbs ("_", un, un,
(L'.EFfiApp ("Basis", "set_cookie", [(L'.EPrim (Prim.String
(Settings.getUrlPrefix ())),
loc),
(L'.ERel 2, loc),
e,
fd "Expires",
fd "Secure"])
, loc)), loc)), loc)), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "clearCookie"), _), t) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
val un = (L'.TRecord [], loc)
in
((L'.EAbs ("c", s, (L'.TFun (un, un), loc),
(L'.EAbs ("_", un, un,
(L'.EFfiApp ("Basis", "clear_cookie",
[(L'.EPrim (Prim.String
(Settings.getUrlPrefix ())),
loc),
(L'.ERel 1, loc)]),
loc)), loc)), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "channel"), _), t) =>
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "channel"), loc),
(L'.EFfiApp ("Basis", "new_channel", [(L'.ERecord [], loc)]), loc)), loc),
fm)
| L.ECApp ((L.EFfi ("Basis", "send"), _), t) =>
let
val t = monoType env t
val (e, fm) = urlifyExp env fm ((L'.ERel 1, loc), t)
in
((L'.EAbs ("ch", (L'.TFfi ("Basis", "channel"), loc),
(L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc)), loc),
(L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc),
(L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
(L'.EFfiApp ("Basis", "send",
[(L'.ERel 2, loc),
e]),
loc)), loc)), loc)), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "no_primary_key"), _), _) =>
((L'.EPrim (Prim.String ""), loc),
fm)
| L.ECApp (
(L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "primary_key"), _), _), _), t), _),
nm), _),
(L.CRecord (_, unique), _)) =>
let
val unique = (nm, t) :: unique
val witnesses = (L'.TRecord (map (fn (nm, _) => (monoName env nm, (L'.TRecord [], loc))) unique), loc)
in
((L'.EAbs ("_", witnesses, (L'.TFfi ("Basis", "string"), loc),
(L'.EPrim (Prim.String
(String.concatWith ", "
(map (fn (x, _) =>
"uw_" ^ monoNameLc env x
^ (if #textKeysNeedLengths (Settings.currentDbms ())
andalso isBlobby t then
"(767)"
else
"")) unique))),
loc)), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "no_constraint"), _), _) =>
((L'.ERecord [], loc),
fm)
| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "one_constraint"), _), _), _), _), _), (L.CName name, _)) =>
((L'.EAbs ("c",
(L'.TFfi ("Basis", "string"), loc),
(L'.TFfi ("Basis", "sql_constraints"), loc),
(L'.ERecord [(name, (L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))], loc)), loc),
fm)
| L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "join_constraints"), _),
_), _),
_), _),
_) =>
let
val constraints = (L'.TFfi ("Basis", "sql_constraints"), loc)
in
((L'.EAbs ("cs1", constraints, (L'.TFun (constraints, constraints), loc),
(L'.EAbs ("cs2", constraints, constraints,
(L'.EStrcat ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
fm)
end
| L.ECApp (
(L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "unique"), _), _), _), t), _),
nm), _),
(L.CRecord (_, unique), _)) =>
let
val unique = (nm, t) :: unique
in
((L'.EPrim (Prim.String ("UNIQUE ("
^ String.concatWith ", "
(map (fn (x, t) => "uw_" ^ monoNameLc env x
^ (if #textKeysNeedLengths (Settings.currentDbms ())
andalso isBlobby t then
"(767)"
else
"")) unique)
^ ")")), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "linkable_same"), loc), _) =>
((L'.ERecord [], loc), fm)
| L.ECApp ((L.EFfi ("Basis", "linkable_from_nullable"), loc), _) =>
((L'.ERecord [], loc), fm)
| L.ECApp ((L.EFfi ("Basis", "linkable_to_nullable"), loc), _) =>
((L'.ERecord [], loc), fm)
| L.EFfi ("Basis", "mat_nil") =>
let
val string = (L'.TFfi ("Basis", "string"), loc)
val stringE = (L'.EPrim (Prim.String ""), loc)
in
((L'.ERecord [("1", stringE, string),
("2", stringE, string)], loc), fm)
end
| L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "mat_cons"), _),
_), _),
_), _),
_), _),
_), _),
(L.CName nm1, _)), _),
(L.CName nm2, _)) =>
let
val string = (L'.TFfi ("Basis", "string"), loc)
val mat = (L'.TRecord [("1", string), ("2", string)], loc)
in
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (mat, mat), loc),
(L'.EAbs ("m", mat, mat,
(L'.ECase ((L'.EField ((L'.ERel 0, loc), "1"), loc),
[((L'.PPrim (Prim.String ""), loc),
(L'.ERecord [("1", (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm1)),
loc), string),
("2", (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm2)),
loc), string)], loc)),
((L'.PWild, loc),
(L'.ERecord [("1", (L'.EStrcat (
(L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm1
^ ", ")),
loc),
(L'.EField ((L'.ERel 0, loc), "1"), loc)),
loc), string),
("2", (L'.EStrcat (
(L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm2
^ ", ")), loc),
(L'.EField ((L'.ERel 0, loc), "2"), loc)),
loc), string)],
loc))],
{disc = string,
result = mat}), loc)), loc)), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "restrict"), _), _) => ((L'.EPrim (Prim.String "RESTRICT"), loc), fm)
| L.ECApp ((L.EFfi ("Basis", "cascade"), _), _) => ((L'.EPrim (Prim.String "CASCADE"), loc), fm)
| L.ECApp ((L.EFfi ("Basis", "no_action"), _), _) => ((L'.EPrim (Prim.String "NO ACTION"), loc), fm)
| L.ECApp ((L.EFfi ("Basis", "set_null"), _), _) => ((L'.EPrim (Prim.String "SET NULL"), loc), fm)
| L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "foreign_key"), _),
_), _),
_), _),
_), _),
_), _),
_), _),
_), _),
_), _),
_) =>
let
val unit = (L'.TRecord [], loc)
val string = (L'.TFfi ("Basis", "string"), loc)
val mat = (L'.TRecord [("1", string), ("2", string)], loc)
val recd = (L'.TRecord [("OnDelete", string),
("OnUpdate", string)], loc)
fun strcat [] = raise Fail "Monoize.strcat"
| strcat [e] = e
| strcat (e1 :: es) = (L'.EStrcat (e1, strcat es), loc)
fun prop (fd, kw) =
(L'.ECase ((L'.EField ((L'.ERel 0, loc), fd), loc),
[((L'.PPrim (Prim.String "NO ACTION"), loc),
(L'.EPrim (Prim.String ""), loc)),
((L'.PWild, loc),
strcat [(L'.EPrim (Prim.String (" ON " ^ kw ^ " ")), loc),
(L'.EField ((L'.ERel 0, loc), fd), loc)])],
{disc = string,
result = string}), loc)
in
((L'.EAbs ("m", mat, (L'.TFun (string, (L'.TFun (recd, string), loc)), loc),
(L'.EAbs ("tab", string, (L'.TFun (recd, string), loc),
(L'.EAbs ("pr", recd, string,
strcat [(L'.EPrim (Prim.String "FOREIGN KEY ("), loc),
(L'.EField ((L'.ERel 2, loc), "1"), loc),
(L'.EPrim (Prim.String ") REFERENCES "), loc),
(L'.ERel 1, loc),
(L'.EPrim (Prim.String " ("), loc),
(L'.EField ((L'.ERel 2, loc), "2"), loc),
(L'.EPrim (Prim.String ")"), loc),
prop ("OnDelete", "DELETE"),
prop ("OnUpdate", "UPDATE")]), loc)), loc)), loc),
fm)
end
| L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "sql_exp_weaken"), _),
_), _),
_), _),
_), _),
_), _),
_), _),
_), _),
_) =>
let
val string = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("e", string, string, (L'.ERel 0, loc)), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "check"), _), _) =>
let
val string = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("e", string, string,
(L'.EStrcat ((L'.EPrim (Prim.String "CHECK "), loc),
(L'.EFfiApp ("Basis", "checkString",
[(L'.ERel 0, loc)]), loc)), loc)), loc),
fm)
end
| L.EFfiApp ("Basis", "dml", [e]) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
((L'.EDml e, loc),
fm)
end
| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "insert"), _), fields), _), _) =>
(case monoType env (L.TRecord fields, loc) of
(L'.TRecord fields, _) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
val fields = map (fn (x, _) => (x, s)) fields
val rt = (L'.TRecord fields, loc)
fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("tab", s, (L'.TFun (rt, s), loc),
(L'.EAbs ("fs", rt, s,
strcat [sc "INSERT INTO ",
(L'.ERel 1, loc),
sc " (",
strcatComma (map (fn (x, _) => sc ("uw_" ^ x)) fields),
sc ") VALUES (",
strcatComma (map (fn (x, _) =>
(L'.EField ((L'.ERel 0, loc),
x), loc)) fields),
sc ")"]), loc)), loc),
fm)
end
| _ => poly ())
| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "update"), _), _), _), _), _), changed) =>
(case monoType env (L.TRecord changed, loc) of
(L'.TRecord changed, _) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
val changed = map (fn (x, _) => (x, s)) changed
val rt = (L'.TRecord changed, loc)
fun sc s = (L'.EPrim (Prim.String s), 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,
if #supportsUpdateAs (Settings.currentDbms ()) then
strcat [sc "UPDATE ",
(L'.ERel 1, loc),
sc " AS T_T SET ",
strcatComma (map (fn (x, _) =>
strcat [sc ("uw_" ^ x
^ " = "),
(L'.EField
((L'.ERel 2,
loc),
x), loc)])
changed),
sc " WHERE ",
(L'.ERel 0, loc)]
else
strcat [sc "UPDATE ",
(L'.ERel 1, loc),
sc " SET ",
strcatComma (map (fn (x, _) =>
strcat [sc ("uw_" ^ x
^ " = "),
(L'.EField
((L'.ERel 2,
loc),
x), loc)])
changed),
sc " WHERE ",
(L'.EFfiApp ("Basis", "unAs", [(L'.ERel 0, loc)]), loc)]),
loc)), loc)), loc),
fm)
end
| _ => poly ())
| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "delete"), _), _), _), _) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("tab", s, (L'.TFun (s, s), loc),
(L'.EAbs ("e", s, s,
if #supportsDeleteAs (Settings.currentDbms ()) then
strcat [sc "DELETE FROM ",
(L'.ERel 1, loc),
sc " AS T_T WHERE ",
(L'.ERel 0, loc)]
else
strcat [sc "DELETE FROM ",
(L'.ERel 1, loc),
sc " WHERE ",
(L'.EFfiApp ("Basis", "unAs", [(L'.ERel 0, loc)]), loc)]), loc)), loc),
fm)
end
| L.ECApp (
(L.ECApp (
(L.ECApp ((L.EFfi ("Basis", "query"), _), (L.CRecord (_, tables), _)), _),
exps), _),
state) =>
(case monoType env (L.TRecord exps, loc) of
(L'.TRecord exps, _) =>
let
val tables = map (fn ((L.CName x, _), xts) =>
(case monoType env (L.TRecord xts, loc) of
(L'.TRecord xts, _) => SOME (x, xts)
| _ => NONE)
| _ => NONE) tables
in
if List.exists (fn x => x = NONE) tables then
poly ()
else
let
val tables = List.mapPartial (fn x => x) tables
val state = monoType env state
val s = (L'.TFfi ("Basis", "string"), loc)
val un = (L'.TRecord [], loc)
val rt = exps @ map (fn (x, xts) => (x, (L'.TRecord xts, loc))) tables
val ft = (L'.TFun ((L'.TRecord rt, loc),
(L'.TFun (state,
(L'.TFun (un, state), loc)),
loc)), loc)
val body' = (L'.EApp (
(L'.EApp (
(L'.EApp ((L'.ERel 4, loc),
(L'.ERel 1, loc)), loc),
(L'.ERel 0, loc)), loc),
(L'.ERecord [], loc)), loc)
val body = (L'.EQuery {exps = exps,
tables = tables,
state = state,
query = (L'.ERel 3, loc),
body = body',
initial = (L'.ERel 1, loc)},
loc)
in
((L'.EAbs ("q", s, (L'.TFun (ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc)), loc),
(L'.EAbs ("f", ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc),
(L'.EAbs ("i", state, (L'.TFun (un, state), loc),
(L'.EAbs ("_", un, state,
body), loc)), loc)), loc)), loc), fm)
end
end
| _ => poly ())
| L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_query"), _), _), _), _), _), _), _), _) =>
let
fun sc s = (L'.EPrim (Prim.String s), loc)
val s = (L'.TFfi ("Basis", "string"), loc)
fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc)
in
((L'.EAbs ("r",
(L'.TRecord [("Rows", s), ("OrderBy", s), ("Limit", s), ("Offset", s)], loc),
s,
strcat [gf "Rows",
(L'.ECase (gf "OrderBy",
[((L'.PPrim (Prim.String ""), loc), sc ""),
((L'.PWild, loc),
strcat [sc " ORDER BY ",
gf "OrderBy"])],
{disc = s, result = s}), loc),
gf "Limit",
gf "Offset"]), loc), fm)
end
| L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "sql_query1"), _),
_), _),
(L.CRecord (_, tables), _)), _),
(L.CRecord (_, grouped), _)), _),
(L.CRecord (_, stables), _)), _),
sexps), _),
_) =>
let
fun sc s = (L'.EPrim (Prim.String s), loc)
val s = (L'.TFfi ("Basis", "string"), loc)
val b = (L'.TFfi ("Basis", "bool"), loc)
val un = (L'.TRecord [], loc)
fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc)
fun doTables tables =
let
val tables = map (fn ((L.CName x, _), xts) =>
(case monoType env (L.TRecord xts, loc) of
(L'.TRecord xts, _) => SOME (x, xts)
| _ => NONE)
| _ => NONE) tables
in
if List.exists (fn x => x = NONE) tables then
NONE
else
let
val tables = List.mapPartial (fn x => x) tables
val tables = ListMergeSort.sort
(fn ((x, _), (y, _)) => String.compare (x, y) = GREATER)
tables
val tables = map (fn (x, xts) =>
(x, ListMergeSort.sort
(fn ((x, _), (y, _)) => String.compare (x, y) = GREATER)
xts)) tables
in
SOME tables
end
end
in
case (doTables tables, doTables grouped, doTables stables, monoType env (L.TRecord sexps, loc)) of
(SOME tables, SOME grouped, SOME stables, (L'.TRecord sexps, _)) =>
let
val sexps = ListMergeSort.sort
(fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) sexps
in
((L'.EAbs ("r",
(L'.TRecord [("Distinct", b),
("From", s),
("Where", s),
("GroupBy", un),
("Having", s),
("SelectFields", un),
("SelectExps", (L'.TRecord (map (fn (x, _) => (x, s)) sexps), loc))],
loc),
s,
strcat [sc "SELECT ",
(L'.ECase (gf "Distinct",
[((L'.PCon (L'.Enum,
L'.PConFfi {mod = "Basis",
datatyp = "bool",
con = "True",
arg = NONE},
NONE), loc),
(L'.EPrim (Prim.String "DISTINCT "), loc)),
((L'.PCon (L'.Enum,
L'.PConFfi {mod = "Basis",
datatyp = "bool",
con = "False",
arg = NONE},
NONE), loc),
(L'.EPrim (Prim.String ""), loc))],
{disc = b, result = s}), loc),
strcatComma (map (fn (x, t) =>
strcat [
(L'.EField (gf "SelectExps", x), loc),
sc (" AS _" ^ x)
]) sexps
@ map (fn (x, xts) =>
strcatComma
(map (fn (x', _) =>
sc ("T_" ^ x
^ ".uw_"
^ x'))
xts)) stables),
sc " FROM ",
gf "From",
(L'.ECase (gf "Where",
[((L'.PPrim (Prim.String "TRUE"), loc),
sc ""),
((L'.PWild, loc),
strcat [sc " WHERE ", gf "Where"])],
{disc = s,
result = s}), loc),
if List.all (fn (x, xts) =>
case List.find (fn (x', _) => x' = x) grouped of
NONE => List.null xts
| SOME (_, xts') =>
List.all (fn (x, _) =>
List.exists (fn (x', _) => x' = x)
xts') xts) tables then
sc ""
else
strcat [
sc " GROUP BY ",
strcatComma (map (fn (x, xts) =>
strcatComma
(map (fn (x', _) =>
sc ("T_" ^ x
^ ".uw_"
^ x'))
xts)) grouped)
],
(L'.ECase (gf "Having",
[((L'.PPrim (Prim.String
(#trueString (Settings.currentDbms ()))), loc),
sc ""),
((L'.PWild, loc),
strcat [sc " HAVING ", gf "Having"])],
{disc = s,
result = s}), loc)
]), loc),
fm)
end
| _ => poly ()
end
| L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "sql_inject"), _),
_), _),
_), _),
_), _),
t) =>
let
val t = monoType env t
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("f", (L'.TFun (t, s), loc), (L'.TFun (t, s), loc),
(L'.ERel 0, loc)), loc), fm)
end
| L.EFfi ("Basis", "sql_int") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EFfiApp ("Basis", "sqlifyInt", [(L'.ERel 0, loc)]), loc)), loc),
fm)
| L.EFfi ("Basis", "sql_float") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EFfiApp ("Basis", "sqlifyFloat", [(L'.ERel 0, loc)]), loc)), loc),
fm)
| L.EFfi ("Basis", "sql_bool") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EFfiApp ("Basis", "sqlifyBool", [(L'.ERel 0, loc)]), loc)), loc),
fm)
| L.EFfi ("Basis", "sql_string") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EFfiApp ("Basis", "sqlifyString", [(L'.ERel 0, loc)]), loc)), loc),
fm)
| L.EFfi ("Basis", "sql_char") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EFfiApp ("Basis", "sqlifyChar", [(L'.ERel 0, loc)]), loc)), loc),
fm)
| L.EFfi ("Basis", "sql_time") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EFfiApp ("Basis", "sqlifyTime", [(L'.ERel 0, loc)]), loc)), loc),
fm)
| L.EFfi ("Basis", "sql_blob") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "blob"), loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EFfiApp ("Basis", "sqlifyBlob", [(L'.ERel 0, loc)]), loc)), loc),
fm)
| L.ECApp ((L.EFfi ("Basis", "sql_channel"), _), _) =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "channel"), loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EFfiApp ("Basis", "sqlifyChannel", [(L'.ERel 0, loc)]), loc)), loc),
fm)
| L.EFfi ("Basis", "sql_client") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "client"), loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EFfiApp ("Basis", "sqlifyClient", [(L'.ERel 0, loc)]), loc)), loc),
fm)
| L.ECApp ((L.EFfi ("Basis", "sql_serialized"), _), _) =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EFfiApp ("Basis", "sqlifyString", [(L'.ERel 0, loc)]), loc)), loc),
fm)
| L.ECApp ((L.EFfi ("Basis", "sql_prim"), _), t) =>
let
val t = monoType env t
val tf = (L'.TFun (t, (L'.TFfi ("Basis", "string"), loc)), loc)
in
((L'.EAbs ("f", tf, tf, (L'.ERel 0, loc)), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "sql_option_prim"), _), t) =>
let
val t = monoType env t
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("f",
(L'.TFun (t, s), loc),
(L'.TFun ((L'.TOption t, loc), s), loc),
(L'.EAbs ("x",
(L'.TOption t, loc),
s,
(L'.ECase ((L'.ERel 0, loc),
[((L'.PNone t, loc),
(L'.EPrim (Prim.String "NULL"), loc)),
((L'.PSome (t, (L'.PVar ("y", t), loc)), loc),
(L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc))],
{disc = (L'.TOption t, loc),
result = s}), loc)), loc)), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "nullify_option"), _), _) =>
((L'.ERecord [], loc), fm)
| L.ECApp ((L.EFfi ("Basis", "nullify_prim"), _), _) =>
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
(L'.ERecord [], loc)), loc),
fm)
| L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) =>
((L'.ERecord [], loc), fm)
| L.ECApp ((L.EFfi ("Basis", "sql_subset_all"), _), _) =>
((L'.ERecord [], loc), fm)
| L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_subset_concat"),
_), _), _), _), _), _), _), _) =>
let
val un = (L'.TRecord [], loc)
in
((L'.EAbs ("_", un, (L'.TFun (un, un), loc),
(L'.EAbs ("_", un, un,
(L'.ERecord [], loc)), loc)), loc),
fm)
end
| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "fieldsOf_table"), _), _), _), _) =>
((L'.ERecord [], loc), fm)
| L.ECApp ((L.EFfi ("Basis", "fieldsOf_view"), _), _) =>
((L'.ERecord [], loc), fm)
| L.ECApp ((L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_table"), _), _),
_), _), _), _), _), _), _),
(L.CName name, _)) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("tab", s, s,
strcat [(L'.ERel 0, loc),
(L'.EPrim (Prim.String (" AS T_" ^ name)), loc)]), loc),
fm)
end
| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_comma"), _), _), _), _), _), _) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("tab1", s, (L'.TFun (s, s), loc),
(L'.EAbs ("tab2", s, s,
strcat [(L'.ERel 1, loc),
(L'.EPrim (Prim.String ", "), loc),
(L'.ERel 0, loc)]), loc)), loc),
fm)
end
| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_inner_join"), _), _), _), _), _), _) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
(L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
(L'.EAbs ("on", s, s,
strcat [(L'.EPrim (Prim.String "("), loc),
(L'.ERel 2, loc),
(L'.EPrim (Prim.String " JOIN "), loc),
(L'.ERel 1, loc),
(L'.EPrim (Prim.String " ON "), loc),
(L'.ERel 0, loc),
(L'.EPrim (Prim.String ")"), loc)]), loc)), loc)), loc),
fm)
end
| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_left_join"), _), _), _), _), _),
(L.CRecord (_, right), _)) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("_", outerRec right,
(L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
(L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
(L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
(L'.EAbs ("on", s, s,
strcat [(L'.EPrim (Prim.String "("), loc),
(L'.ERel 2, loc),
(L'.EPrim (Prim.String " LEFT JOIN "), loc),
(L'.ERel 1, loc),
(L'.EPrim (Prim.String " ON "), loc),
(L'.ERel 0, loc),
(L'.EPrim (Prim.String ")"), loc)]),
loc)), loc)), loc)), loc),
fm)
end
| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_right_join"), _), (L.CRecord (_, left), _)),
_), _), _), _) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("_", outerRec left,
(L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
(L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
(L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
(L'.EAbs ("on", s, s,
strcat [(L'.EPrim (Prim.String "("), loc),
(L'.ERel 2, loc),
(L'.EPrim (Prim.String " RIGHT JOIN "), loc),
(L'.ERel 1, loc),
(L'.EPrim (Prim.String " ON "), loc),
(L'.ERel 0, loc),
(L'.EPrim (Prim.String ")"), loc)]),
loc)), loc)), loc)), loc),
fm)
end
| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_full_join"), _), (L.CRecord (_, left), _)), _),
(L.CRecord (_, right), _)), _), _) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("_", outerRec (left @ right),
(L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
(L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
(L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
(L'.EAbs ("on", s, s,
strcat [(L'.EPrim (Prim.String "("), loc),
(L'.ERel 2, loc),
(L'.EPrim (Prim.String " FULL JOIN "), loc),
(L'.ERel 1, loc),
(L'.EPrim (Prim.String " ON "), loc),
(L'.ERel 0, loc),
(L'.EPrim (Prim.String ")"), loc)]),
loc)), loc)), loc)), loc),
fm)
end
| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) =>
((L'.EPrim (Prim.String ""), loc), fm)
| L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "sql_order_by_Cons"), _),
_), _),
_), _),
_) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("e1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
(L'.EAbs ("d", s, (L'.TFun (s, s), loc),
(L'.EAbs ("e2", s, s,
(L'.ECase ((L'.ERel 0, loc),
[((L'.PPrim (Prim.String ""), loc),
strcat [(L'.ERel 2, loc),
(L'.ERel 1, loc)]),
((L'.PWild, loc),
strcat [(L'.ERel 2, loc),
(L'.ERel 1, loc),
sc ", ",
(L'.ERel 0, loc)])],
{disc = s, result = s}), loc)), loc)), loc)), loc),
fm)
end
| L.EFfi ("Basis", "sql_no_limit") =>
((L'.EPrim (Prim.String ""), loc), fm)
| L.EFfiApp ("Basis", "sql_limit", [e]) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
(strcat [
(L'.EPrim (Prim.String " LIMIT "), loc),
(L'.EFfiApp ("Basis", "sqlifyInt", [e]), loc)
],
fm)
end
| L.EFfi ("Basis", "sql_no_offset") =>
((L'.EPrim (Prim.String ""), loc), fm)
| L.EFfiApp ("Basis", "sql_offset", [e]) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
(strcat [
(L'.EPrim (Prim.String " OFFSET "), loc),
(L'.EFfiApp ("Basis", "sqlifyInt", [e]), loc)
],
fm)
end
| L.ECApp ((L.EFfi ("Basis", "sql_eq"), _), _) =>
((L'.EPrim (Prim.String "="), loc), fm)
| L.ECApp ((L.EFfi ("Basis", "sql_ne"), _), _) =>
((L'.EPrim (Prim.String "<>"), loc), fm)
| L.ECApp ((L.EFfi ("Basis", "sql_lt"), _), _) =>
((L'.EPrim (Prim.String "<"), loc), fm)
| L.ECApp ((L.EFfi ("Basis", "sql_le"), _), _) =>
((L'.EPrim (Prim.String "<="), loc), fm)
| L.ECApp ((L.EFfi ("Basis", "sql_gt"), _), _) =>
((L'.EPrim (Prim.String ">"), loc), fm)
| L.ECApp ((L.EFfi ("Basis", "sql_ge"), _), _) =>
((L'.EPrim (Prim.String ">="), loc), fm)
| L.ECApp ((L.EFfi ("Basis", "sql_plus"), _), _) =>
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EPrim (Prim.String "+"), loc)), loc), fm)
| L.ECApp ((L.EFfi ("Basis", "sql_minus"), _), _) =>
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EPrim (Prim.String "-"), loc)), loc), fm)
| L.ECApp ((L.EFfi ("Basis", "sql_times"), _), _) =>
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EPrim (Prim.String "*"), loc)), loc), fm)
| L.ECApp ((L.EFfi ("Basis", "sql_div"), _), _) =>
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EPrim (Prim.String "/"), loc)), loc), fm)
| L.EFfi ("Basis", "sql_mod") =>
((L'.EPrim (Prim.String "%"), loc), fm)
| L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "sql_unary"), _),
_), _),
_), _),
_), _),
_), _),
_) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
(L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
strcat [sc "(",
(L'.ERel 1, loc),
sc " ",
(L'.ERel 0, loc),
sc ")"]), loc)), loc),
fm)
end
| L.EFfi ("Basis", "sql_not") => ((L'.EPrim (Prim.String "NOT"), loc), fm)
| L.ECApp ((L.EFfi ("Basis", "sql_neg"), _), _) =>
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EPrim (Prim.String "-"), loc)), loc), fm)
| L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "sql_binary"), _),
_), _),
_), _),
_), _),
_), _),
_), _),
_) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
(L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
(L'.EAbs ("e2", s, s,
strcat [sc "(",
(L'.ERel 1, loc),
sc " ",
(L'.ERel 2, loc),
sc " ",
(L'.ERel 0, loc),
sc ")"]), loc)), loc)), loc),
fm)
end
| L.EFfi ("Basis", "sql_and") => ((L'.EPrim (Prim.String "AND"), loc), fm)
| L.EFfi ("Basis", "sql_or") => ((L'.EPrim (Prim.String "OR"), loc), fm)
| L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "sql_field"), _),
_), _),
_), _),
_), _),
_), _),
_), _),
(L.CName tab, _)), _),
(L.CName field, _)) => ((L'.EPrim (Prim.String ("T_" ^ tab ^ ".uw_" ^ lowercaseFirst field)), loc), fm)
| L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "sql_exp"), _),
_), _),
_), _),
_), _),
_), _),
(L.CName nm, _)) => ((L'.EPrim (Prim.String ("_" ^ lowercaseFirst nm)), loc), fm)
| L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "sql_relop"), _),
_), _),
_), _),
_), _),
_), _),
_) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
(L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
(L'.EAbs ("e2", s, s,
strcat [sc "((",
(L'.ERel 1, loc),
sc ") ",
(L'.ERel 2, loc),
sc " (",
(L'.ERel 0, loc),
sc "))"]), loc)), loc)), loc),
fm)
end
| L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "sql_forget_tables"), _),
_), _),
_), _),
_), _),
_) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("x", s, s, (L'.ERel 0, loc)), loc),
fm)
end
| L.EFfi ("Basis", "sql_union") => ((L'.EPrim (Prim.String "UNION"), loc), fm)
| L.EFfi ("Basis", "sql_intersect") => ((L'.EPrim (Prim.String "INTERSECT"), loc), fm)
| L.EFfi ("Basis", "sql_except") => ((L'.EPrim (Prim.String "EXCEPT"), loc), fm)
| L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "sql_count"), _),
_), _),
_), _),
_) => ((L'.EPrim (Prim.String "COALESCE(COUNT(*),0)"), loc),
fm)
| L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "sql_aggregate"), _),
_), _),
_), _),
_), _),
_), _),
t) =>
let
val default =
case #1 t of
L.CFfi ("Basis", s) =>
(case s of
"int" => "0"
| "float" => "0.0"
| "string" => "''"
| "time" => "0"
| _ => raise Fail "Illegal type of sql_aggregate [1]")
| _ => raise Fail "Illegal type of sql_aggregate [2]"
val s = (L'.TFfi ("Basis", "string"), loc)
fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
(L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
strcat [sc "COALESCE(",
(L'.ERel 1, loc),
sc "(",
(L'.ERel 0, loc),
sc (")," ^ default ^ ")")]), loc)), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "sql_count_col"), _), _) =>
((L'.EPrim (Prim.String "COUNT"), loc),
fm)
| L.EFfi ("Basis", "sql_summable_int") => ((L'.ERecord [], loc), fm)
| L.EFfi ("Basis", "sql_summable_float") => ((L'.ERecord [], loc), fm)
| L.ECApp ((L.EFfi ("Basis", "sql_avg"), _), _) =>
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EPrim (Prim.String "AVG"), loc)), loc),
fm)
| L.ECApp ((L.EFfi ("Basis", "sql_sum"), _), _) =>
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EPrim (Prim.String "SUM"), loc)), loc),
fm)
| L.EFfi ("Basis", "sql_arith_int") => ((L'.ERecord [], loc), fm)
| L.EFfi ("Basis", "sql_arith_float") => ((L'.ERecord [], loc), fm)
| L.EFfi ("Basis", "sql_maxable_int") => ((L'.ERecord [], loc), fm)
| L.EFfi ("Basis", "sql_maxable_float") => ((L'.ERecord [], loc), fm)
| L.EFfi ("Basis", "sql_maxable_string") => ((L'.ERecord [], loc), fm)
| L.ECApp ((L.EFfi ("Basis", "sql_max"), _), _) =>
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EPrim (Prim.String "MAX"), loc)), loc),
fm)
| L.ECApp ((L.EFfi ("Basis", "sql_min"), _), _) =>
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EPrim (Prim.String "MIN"), loc)), loc),
fm)
| L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm)
| L.EFfi ("Basis", "sql_desc") => ((L'.EPrim (Prim.String " DESC"), loc), fm)
| L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "sql_nfunc"), _),
_), _),
_), _),
_), _),
_) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc),
fm)
end
| L.EFfi ("Basis", "sql_current_timestamp") => ((L'.EPrim (Prim.String "CURRENT_TIMESTAMP"), loc), fm)
| L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "sql_ufunc"), _),
_), _),
_), _),
_), _),
_), _),
_) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("f", s, (L'.TFun (s, s), loc),
(L'.EAbs ("x", s, s,
strcat [(L'.ERel 1, loc),
sc "(",
(L'.ERel 0, loc),
sc ")"]), loc)), loc),
fm)
end
| L.EFfi ("Basis", "sql_octet_length") =>
((L'.EPrim (Prim.String (if #supportsOctetLength (Settings.currentDbms ()) then
"octet_length"
else
"length")), loc), fm)
| (L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "sql_is_null"), _), _),
_), _),
_), _),
_), _)) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("s", s, s,
strcat [sc "(",
(L'.ERel 0, loc),
sc " IS NULL)"]), loc),
fm)
end
| L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "sql_nullable"), _),
_), _),
_), _),
_), _),
_) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("u", (L'.TRecord [], loc), (L'.TFun (s, s), loc),
(L'.EAbs ("x", s, s,
(L'.ERel 0, loc)), loc)), loc),
fm)
end
| L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "sql_subquery"), _),
_), _),
_), _),
_), _),
_), _),
_) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("x", s, s,
strcat [sc "(",
(L'.ERel 0, loc),
sc ")"]), loc),
fm)
end
| L.EFfiApp ("Basis", "nextval", [e]) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
((L'.ENextval e, loc), fm)
end
| L.EFfiApp ("Basis", "setval", [e1, e2]) =>
let
val (e1, fm) = monoExp (env, st, fm) e1
val (e2, fm) = monoExp (env, st, fm) e2
in
((L'.ESetval (e1, e2), loc), fm)
end
| L.EApp (
(L.ECApp (
(L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _),
_), _),
se) =>
let
val (se, fm) = monoExp (env, st, fm) se
in
((L'.EFfiApp ("Basis", "htmlifyString", [se]), loc), fm)
end
| L.EApp (
(L.EApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "join"),
_), _), _),
_), _),
_), _),
_), _),
xml1), _),
xml2) =>
let
val (xml1, fm) = monoExp (env, st, fm) xml1
val (xml2, fm) = monoExp (env, st, fm) xml2
in
((L'.EStrcat (xml1, xml2), loc), fm)
end
| L.EApp (
(L.EApp (
(L.EApp (
(L.EApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "tag"),
_), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
class), _),
attrs), _),
tag), _),
xml) =>
let
fun getTag' (e, _) =
case e of
L.EFfi ("Basis", tag) => (tag, [])
| L.ECApp (e, t) => let
val (tag, ts) = getTag' e
in
(tag, ts @ [t])
end
| _ => (E.errorAt loc "Non-constant XML tag";
Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
("", []))
fun getTag (e, _) =
case e of
L.EFfiApp ("Basis", tag, [(L.ERecord [], _)]) => (tag, [])
| L.EApp (e, (L.ERecord [], _)) => getTag' e
| _ => (E.errorAt loc "Non-constant XML tag";
Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
("", []))
val (tag, targs) = getTag tag
val (attrs, fm) = monoExp (env, st, fm) attrs
val attrs = case #1 attrs of
L'.ERecord xes => xes
| _ => raise Fail "Non-record attributes!"
val attrs =
if List.exists (fn ("Link", _, _) => true
| _ => false) attrs then
List.filter (fn ("Href", _, _) => false
| _ => true) attrs
else
attrs
fun findOnload (attrs, onload, onunload, acc) =
case attrs of
[] => (onload, onunload, acc)
| ("Onload", e, _) :: rest => findOnload (rest, SOME e, onunload, acc)
| ("Onunload", e, _) :: rest => findOnload (rest, onload, SOME e, acc)
| x :: rest => findOnload (rest, onload, onunload, x :: acc)
val (onload, onunload, attrs) = findOnload (attrs, NONE, NONE, [])
val (class, fm) = monoExp (env, st, fm) class
fun tagStart tag =
let
val t = (L'.TFfi ("Basis", "string"), loc)
val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc)
val s = (L'.ECase (class,
[((L'.PNone t, loc),
s),
((L'.PSome (t, (L'.PVar ("x", t), loc)), loc),
(L'.EStrcat (s,
(L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc),
(L'.EStrcat ((L'.ERel 0, loc),
(L'.EPrim (Prim.String "\""), loc)),
loc)), loc)), loc))],
{disc = (L'.TOption t, loc),
result = t}), loc)
in
foldl (fn (("Action", _, _), acc) => acc
| (("Source", _, _), acc) => acc
| ((x, e, t), (s, fm)) =>
case t of
(L'.TFfi ("Basis", "bool"), _) =>
let
val s' = " " ^ lowercaseFirst x
in
((L'.ECase (e,
[((L'.PCon (L'.Enum,
L'.PConFfi {mod = "Basis",
datatyp = "bool",
con = "True",
arg = NONE},
NONE), loc),
(L'.EStrcat (s,
(L'.EPrim (Prim.String s'), loc)), loc)),
((L'.PCon (L'.Enum,
L'.PConFfi {mod = "Basis",
datatyp = "bool",
con = "False",
arg = NONE},
NONE), loc),
s)],
{disc = (L'.TFfi ("Basis", "bool"), loc),
result = (L'.TFfi ("Basis", "string"), loc)}), loc),
fm)
end
| (L'.TFun (dom, _), _) =>
let
val s' = " " ^ lowercaseFirst x ^ "='"
val (e, s') =
case #1 dom of
L'.TRecord [] => ((L'.EApp (e, (L'.ERecord [], loc)), loc), s')
| _ => ((L'.EApp ((L'.EApp (e, (L'.EFfiApp ("Basis", "kc", []), loc)),
loc), (L'.ERecord [], loc)), loc),
s' ^ "uwe=event;")
val s' = s' ^ "exec("
in
((L'.EStrcat (s,
(L'.EStrcat (
(L'.EPrim (Prim.String s'), loc),
(L'.EStrcat (
(L'.EJavaScript (L'.Attribute, e), loc),
(L'.EPrim (Prim.String ");return false'"), loc)), loc)),
loc)), loc),
fm)
end
| _ =>
let
val fooify =
case x of
"Link" => urlifyExp
| "Action" => urlifyExp
| _ => attrifyExp
val x =
case x of
"Typ" => "Type"
| "Link" => "Href"
| _ => x
val xp = " " ^ lowercaseFirst x ^ "=\""
val (e, fm) = fooify env fm (e, t)
in
((L'.EStrcat (s,
(L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
(L'.EStrcat (e,
(L'.EPrim (Prim.String "\""),
loc)),
loc)),
loc)), loc),
fm)
end)
(s, fm) attrs
end
fun input typ =
case targs of
[_, (L.CName name, _)] =>
let
val (ts, fm) = tagStart "input"
in
((L'.EStrcat (ts,
(L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\" />")),
loc)), loc), fm)
end
| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
raise Fail "No name passed to input tag")
fun normal (tag, extra, extraInner) =
let
val (tagStart, fm) = tagStart tag
val tagStart = case extra of
NONE => tagStart
| SOME extra => (L'.EStrcat (tagStart, extra), loc)
fun normal () =
let
val (xml, fm) = monoExp (env, st, fm) xml
val xml = case extraInner of
NONE => xml
| SOME ei => (L'.EStrcat (ei, xml), loc)
in
((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
(L'.EStrcat (xml,
(L'.EPrim (Prim.String (String.concat [""])),
loc)), loc)),
loc),
fm)
end
fun isSingleton () =
let
val (bef, aft) = Substring.splitl (not o Char.isSpace) (Substring.full tag)
in
SS.member (singletons, if Substring.isEmpty aft then
tag
else
Substring.string bef)
end
in
case xml of
(L.EApp ((L.ECApp (
(L.ECApp ((L.EFfi ("Basis", "cdata"), _),
_), _),
_), _),
(L.EPrim (Prim.String s), _)), _) =>
if CharVector.all Char.isSpace s andalso isSingleton () then
((L'.EStrcat (tagStart, (L'.EPrim (Prim.String " />"), loc)), loc), fm)
else
normal ()
| _ => normal ()
end
fun setAttrs jexp =
let
val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc)
val assgns = List.mapPartial
(fn ("Source", _, _) => NONE
| ("Onchange", e, _) =>
SOME (strcat [str "addOnChange(d,exec(",
(L'.EJavaScript (L'.Script, e), loc),
str "))"])
| (x, e, _) =>
SOME (strcat [str ("d." ^ lowercaseFirst x ^ "=exec("),
(L'.EJavaScript (L'.Script, e), loc),
str ");"]))
attrs
val t = (L'.TFfi ("Basis", "string"), loc)
val setClass = (L'.ECase (class,
[((L'.PNone t, loc),
str ""),
((L'.PSome (t, (L'.PVar ("x", t), loc)), loc),
(L'.EStrcat ((L'.EPrim (Prim.String "d.className=\""), loc),
(L'.EStrcat ((L'.ERel 0, loc),
(L'.EPrim (Prim.String "\";"), loc)), loc)),
loc))],
{disc = (L'.TOption t, loc),
result = t}), loc)
in
case assgns of
[] => strcat [str "var d=",
jexp,
str ";",
setClass]
| _ => strcat (str "var d="
:: jexp
:: str ";"
:: setClass
:: assgns)
end
fun execify e =
case e of
NONE => (L'.EPrim (Prim.String ""), loc)
| SOME e =>
let
val e = (L'.EApp (e, (L'.ERecord [], loc)), loc)
in
(L'.EStrcat ((L'.EPrim (Prim.String "exec("), loc),
(L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc),
(L'.EPrim (Prim.String ")"), loc)), loc)), loc)
end
in
(case tag of
"body" => let
val onload = execify onload
val onunload = execify onunload
in
normal ("body",
SOME (L'.EStrcat ((L'.EFfiApp ("Basis", "maybe_onload",
[(L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings",
[(L'.ERecord [], loc)]), loc),
onload), loc)]),
loc),
(L'.EFfiApp ("Basis", "maybe_onunload",
[onunload]),
loc)), loc),
SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc))
end
| "dyn" =>
let
fun inTag tag = case targs of
(L.CRecord (_, ctx), _) :: _ =>
List.exists (fn ((L.CName tag', _), _) => tag' = tag
| _ => false) ctx
| _ => false
val tag = if inTag "Tr" then
"tr"
else if inTag "Table" then
"table"
else
"span"
in
case attrs of
[("Signal", e, _)] =>
((L'.EStrcat
((L'.EPrim (Prim.String ("")), loc)), loc)), loc),
fm)
| _ => raise Fail "Monoize: Bad dyn attributes"
end
| "submit" => normal ("input type=\"submit\"", NONE, NONE)
| "button" => normal ("input type=\"submit\"", NONE, NONE)
| "hidden" => input "hidden"
| "textbox" =>
(case targs of
[_, (L.CName name, _)] =>
(case List.find (fn ("Source", _, _) => true | _ => false) attrs of
NONE =>
let
val (ts, fm) = tagStart "input"
in
((L'.EStrcat (ts,
(L'.EPrim (Prim.String (" name=\"" ^ name ^ "\" />")),
loc)), loc), fm)
end
| SOME (_, src, _) =>
(strcat [str ""],
fm))
| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
raise Fail "No name passed to textbox tag"))
| "password" => input "password"
| "textarea" =>
(case targs of
[_, (L.CName name, _)] =>
let
val (ts, fm) = tagStart "textarea"
val (xml, fm) = monoExp (env, st, fm) xml
in
((L'.EStrcat ((L'.EStrcat (ts,
(L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc),
(L'.EStrcat (xml,
(L'.EPrim (Prim.String ""),
loc)), loc)),
loc), fm)
end
| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
raise Fail "No name passed to ltextarea tag"))
| "checkbox" => input "checkbox"
| "upload" => input "file"
| "radio" =>
(case targs of
[_, (L.CName name, _)] =>
monoExp (env, St.setRadioGroup (st, name), fm) xml
| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
raise Fail "No name passed to radio tag"))
| "radioOption" =>
(case St.radioGroup st of
NONE => raise Fail "No name for radioGroup"
| SOME name =>
normal ("input",
SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc),
NONE))
| "select" =>
(case targs of
[_, (L.CName name, _)] =>
let
val (ts, fm) = tagStart "select"
val (xml, fm) = monoExp (env, st, fm) xml
in
((L'.EStrcat ((L'.EStrcat (ts,
(L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")),
loc)), loc),
(L'.EStrcat (xml,
(L'.EPrim (Prim.String ""),
loc)), loc)),
loc),
fm)
end
| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
raise Fail "No name passed to lselect tag"))
| "ctextbox" =>
(case List.find (fn ("Source", _, _) => true | _ => false) attrs of
NONE =>
let
val (ts, fm) = tagStart "input"
in
((L'.EStrcat (ts,
(L'.EPrim (Prim.String " />"), loc)),
loc), fm)
end
| SOME (_, src, _) =>
let
val sc = strcat [str "inp(exec(",
(L'.EJavaScript (L'.Script, src), loc),
str "))"]
val sc = setAttrs sc
in
(strcat [str ""],
fm)
end)
| "ccheckbox" =>
(case List.find (fn ("Source", _, _) => true | _ => false) attrs of
NONE =>
let
val (ts, fm) = tagStart "input type=\"checkbox\""
in
((L'.EStrcat (ts,
(L'.EPrim (Prim.String " />"), loc)),
loc), fm)
end
| SOME (_, src, _) =>
let
val sc = strcat [str "chk(exec(",
(L'.EJavaScript (L'.Script, src), loc),
str "))"]
val sc = setAttrs sc
in
(strcat [str ""],
fm)
end)
| "cselect" =>
(case List.find (fn ("Source", _, _) => true | _ => false) attrs of
NONE =>
let
val (xml, fm) = monoExp (env, st, fm) xml
val (ts, fm) = tagStart "select"
in
(strcat [ts,
str ">",
xml,
str ""],
fm)
end
| SOME (_, src, _) =>
let
val (xml, fm) = monoExp (env, st, fm) xml
val sc = strcat [str "sel(exec(",
(L'.EJavaScript (L'.Script, src), loc),
str "),exec(",
(L'.EJavaScript (L'.Script, xml), loc),
str "))"]
val sc = setAttrs sc
in
(strcat [str ""],
fm)
end)
| "coption" => normal ("option", NONE, NONE)
| "ctextarea" =>
(case List.find (fn ("Source", _, _) => true | _ => false) attrs of
NONE =>
let
val (ts, fm) = tagStart "textarea"
in
((L'.EStrcat (ts,
(L'.EPrim (Prim.String " />"), loc)),
loc), fm)
end
| SOME (_, src, _) =>
let
val sc = strcat [str "tbx(exec(",
(L'.EJavaScript (L'.Script, src), loc),
str "))"]
val sc = setAttrs sc
in
(strcat [str ""],
fm)
end)
| "tabl" => normal ("table", NONE, NONE)
| _ => normal (tag, NONE, NONE))
end
| L.EApp ((L.ECApp (
(L.ECApp ((L.EFfi ("Basis", "form"), _), _), _),
(L.CRecord (_, fields), _)), _),
xml) =>
let
fun findSubmit (e, _) =
case e of
L.EApp (
(L.EApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "join"),
_), _), _),
_), _),
_), _),
_), _),
xml1), _),
xml2) => (case findSubmit xml1 of
Error => Error
| NotFound => findSubmit xml2
| Found e =>
case findSubmit xml2 of
NotFound => Found e
| _ => Error)
| L.EApp (
(L.EApp (
(L.EApp (
(L.EApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "tag"),
_), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
_), _),
attrs), _),
_), _),
xml) =>
(case #1 attrs of
L.ERecord xes =>
(case ListUtil.search (fn ((L.CName "Action", _), e, t) => SOME (e, t)
| _ => NONE) xes of
NONE => findSubmit xml
| SOME et =>
case findSubmit xml of
NotFound => Found et
| _ => Error)
| _ => findSubmit xml)
| _ => NotFound
val (func, action, fm) = case findSubmit xml of
NotFound => (0, (L'.EPrim (Prim.String ""), loc), fm)
| Error => raise Fail "Not ready for multi-submit lforms yet"
| Found (action, actionT) =>
let
val func = case #1 action of
L.EClosure (n, _) => n
| _ => raise Fail "Monoize: Action is not a closure"
val actionT = monoType env actionT
val (action, fm) = monoExp (env, st, fm) action
val (action, fm) = urlifyExp env fm (action, actionT)
in
(func,
(L'.EStrcat ((L'.EPrim (Prim.String " action=\""), loc),
(L'.EStrcat (action,
(L'.EPrim (Prim.String "\""), loc)), loc)), loc),
fm)
end
val hasUpload = CoreUtil.Exp.exists {kind = fn _ => false,
con = fn _ => false,
exp = fn e =>
case e of
L.EFfi ("Basis", "upload") => true
| _ => false} xml
val (xml, fm) = monoExp (env, st, fm) xml
val xml =
if IS.member (!readCookie, func) then
let
fun inFields s = List.exists (fn ((L.CName s', _), _) => s' = s
| _ => true) fields
fun getSigName () =
let
fun getSigName' n =
let
val s = "Sig" ^ Int.toString n
in
if inFields s then
getSigName' (n + 1)
else
s
end
in
if inFields "Sig" then
getSigName' 0
else
"Sig"
end
val sigName = getSigName ()
val sigSet = (L'.EFfiApp ("Basis", "sigString", [(L'.ERecord [], loc)]), loc)
val sigSet = (L'.EStrcat ((L'.EPrim (Prim.String (""), loc)), loc)
in
(L'.EStrcat (sigSet, xml), loc)
end
else
xml
val action = if hasUpload then
(L'.EStrcat (action,
(L'.EPrim (Prim.String " enctype=\"multipart/form-data\""), loc)), loc)
else
action
in
((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String ""), loc)), loc)), loc),
fm)
end
| L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp (
(L.EFfi ("Basis", "subform"), _), _), _), _),
_), _), _), (L.CName nm, loc)) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("xml", s, s,
strcat [(L'.EPrim (Prim.String ("")), loc),
(L'.ERel 0, loc),
(L'.EPrim (Prim.String ("")), loc)]),
loc),
fm)
end
| L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp (
(L.EFfi ("Basis", "subforms"), _), _), _), _),
_), _), _), (L.CName nm, loc)) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("xml", s, s,
strcat [(L'.EPrim (Prim.String ("")), loc),
(L'.ERel 0, loc),
(L'.EPrim (Prim.String ("")), loc)]),
loc),
fm)
end
| L.ECApp ((L.ECApp (
(L.EFfi ("Basis", "entry"), _), _), _), _) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("xml", s, s,
strcat [(L'.EPrim (Prim.String ("")), loc),
(L'.ERel 0, loc),
(L'.EPrim (Prim.String ("")), loc)]),
loc),
fm)
end
| L.EApp ((L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "useMore"), _), _), _),
_), _),
_), _),
_), _),
xml) => monoExp (env, st, fm) xml
| L.ECApp ((L.EFfi ("Basis", "error"), _), t) =>
let
val t = monoType env t
in
((L'.EAbs ("s", (L'.TFfi ("Basis", "string"), loc), t,
(L'.EError ((L'.ERel 0, loc), t), loc)), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t) =>
let
val t = monoType env t
val un = (L'.TRecord [], loc)
in
((L'.EAbs ("b", (L'.TFfi ("Basis", "blob"), loc),
(L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc)), loc),
(L'.EAbs ("mt", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
(L'.EAbs ("_", un, t,
(L'.EReturnBlob {blob = (L'.ERel 2, loc),
mimeType = (L'.ERel 1, loc),
t = t}, loc)), loc)), loc)), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "redirect"), _), t) =>
let
val t = monoType env t
val un = (L'.TRecord [], loc)
in
((L'.EAbs ("url", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
(L'.EAbs ("_", un, t,
(L'.ERedirect ((L'.ERel 1, loc), t), loc)), loc)), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "serialize"), _), t) =>
let
val t = monoType env t
val (e, fm) = urlifyExp env fm ((L'.ERel 0, loc), t)
in
((L'.EAbs ("v", t, (L'.TFfi ("Basis", "string"), loc), e), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "deserialize"), _), t) =>
let
val t = monoType env t
in
((L'.EAbs ("v", (L'.TFfi ("Basis", "string"), loc), t, (L'.EUnurlify ((L'.ERel 0, loc), t, false),
loc)), loc),
fm)
end
| L.EFfiApp ("Basis", "url", [e]) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
urlifyExp env fm (e, dummyTyp)
end
| L.EApp (e1, e2) =>
let
val (e1, fm) = monoExp (env, st, fm) e1
val (e2, fm) = monoExp (env, st, fm) e2
in
((L'.EApp (e1, e2), loc), fm)
end
| L.EAbs (x, dom, ran, e) =>
let
val (e, fm) = monoExp (Env.pushERel env x dom, st, fm) e
in
((L'.EAbs (x, monoType env dom, monoType env ran, e), loc), fm)
end
| L.ECApp _ => poly ()
| L.ECAbs _ => poly ()
| L.EFfi mx => ((L'.EFfi mx, loc), fm)
| L.EFfiApp (m, x, es) =>
let
val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
in
((L'.EFfiApp (m, x, es), loc), fm)
end
| L.ERecord xes =>
let
val (xes, fm) = ListUtil.foldlMap
(fn ((x, e, t), fm) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
((monoName env x,
e,
monoType env t), fm)
end) fm xes
val xes = ListMergeSort.sort (fn ((x, _, _), (y, _, _)) => String.compare (x, y) = GREATER) xes
in
((L'.ERecord xes, loc), fm)
end
| L.EField (e, x, _) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
((L'.EField (e, monoName env x), loc), fm)
end
| L.EConcat _ => poly ()
| L.ECut _ => poly ()
| L.ECutMulti _ => poly ()
| L.ECase (e, pes, {disc, result}) =>
let
val (e, fm) = monoExp (env, st, fm) e
val (pes, fm) = ListUtil.foldlMap
(fn ((p, e), fm) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
((monoPat env p, e), fm)
end) fm pes
in
((L'.ECase (e, pes, {disc = monoType env disc, result = monoType env result}), loc), fm)
end
| L.EWrite e =>
let
val (e, fm) = monoExp (env, st, fm) e
in
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
(L'.EWrite (liftExpInExp 0 e), loc)), loc), fm)
end
| L.EClosure (n, es) =>
let
val (es, fm) = ListUtil.foldlMap (fn (e, fm) =>
monoExp (env, st, fm) e)
fm es
val e = (L'.EClosure (n, es), loc)
in
(e, fm)
end
| L.ELet (x, t, e1, e2) =>
let
val t' = monoType env t
val (e1, fm) = monoExp (env, st, fm) e1
val (e2, fm) = monoExp (Env.pushERel env x t, st, fm) e2
in
((L'.ELet (x, t', e1, e2), loc), fm)
end
| L.EServerCall (n, es, t) =>
let
val t = monoType env t
val (_, ft, _, name) = Env.lookupENamed env n
val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
fun encodeArgs (es, ft, acc, fm) =
case (es, ft) of
([], _) => (rev acc, fm)
| (e :: es, (L.TFun (dom, ran), _)) =>
let
val (e, fm) = urlifyExp env fm (e, monoType env dom)
in
encodeArgs (es, ran, e
:: (L'.EPrim (Prim.String "/"), loc)
:: acc, fm)
end
| _ => raise Fail "Monoize: Not enough arguments visible in RPC function type"
val (call, fm) = encodeArgs (es, ft, [], fm)
val call = foldl (fn (e, call) => (L'.EStrcat (call, e), loc))
(L'.EPrim (Prim.String name), loc) call
val unit = (L'.TRecord [], loc)
val eff = if IS.member (!readCookie, n) then
L'.ReadCookieWrite
else
L'.ReadOnly
val e = (L'.EServerCall (call, t, eff), loc)
val e = liftExpInExp 0 e
val e = (L'.EAbs ("_", unit, unit, e), loc)
in
(e, fm)
end
| L.EKAbs _ => poly ()
| L.EKApp _ => poly ()
end
fun monoDecl (env, fm) (all as (d, loc)) =
let
fun poly () =
(E.errorAt loc "Unsupported declaration";
Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
NONE)
in
case d of
L.DCon _ => NONE
| L.DDatatype [("list", n, [_], [("Nil", _, NONE),
("Cons", _, SOME (L.TRecord (L.CRecord (_,
[((L.CName "1", _),
(L.CRel 0, _)),
((L.CName "2", _),
(L.CApp ((L.CNamed n', _),
(L.CRel 0, _)),
_))]), _), _))])] =>
if n = n' then
NONE
else
poly ()
| L.DDatatype dts =>
let
val env' = Env.declBinds env all
val dts = map (fn (x, n, [], xncs) =>
(x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env') to)) xncs)
| _ => (E.errorAt loc "Polymorphic datatype needed too late";
Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
("", 0, []))) dts
val d = (L'.DDatatype dts, loc)
in
SOME (env', fm, [d])
end
| L.DVal (x, n, t, e, s) =>
let
val (e, fm) = monoExp (env, St.empty, fm) e
in
SOME (Env.pushENamed env x n t NONE s,
fm,
[(L'.DVal (x, n, monoType env t, e, s), loc)])
end
| L.DValRec vis =>
let
val vis = map (fn (x, n, t, e, s) =>
let
fun maybeTransaction (t, e) =
case (#1 t, #1 e) of
(L.CApp ((L.CFfi ("Basis", "transaction"), _), _), _) =>
SOME (L.EAbs ("_",
(L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc),
t,
(L.EApp (CoreEnv.liftExpInExp 0 e,
(L.ERecord [], loc)), loc)), loc)
| (L.TFun (dom, ran), L.EAbs (x, _, _, e)) =>
(case maybeTransaction (ran, e) of
NONE => NONE
| SOME e => SOME (L.EAbs (x, dom, ran, e), loc))
| _ => NONE
in
(x, n, t,
case maybeTransaction (t, e) of
NONE => e
| SOME e => e,
s)
end) vis
val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis
val (vis, fm) = ListUtil.foldlMap
(fn ((x, n, t, e, s), fm) =>
let
val (e, fm) = monoExp (env, St.empty, fm) e
in
((x, n, monoType env t, e, s), fm)
end)
fm vis
in
SOME (env,
fm,
[(L'.DValRec vis, loc)])
end
| L.DExport (ek, n, b) =>
let
val (_, t, _, s) = Env.lookupENamed env n
fun unwind (t, args) =
case #1 t of
L.TFun (dom, ran) => unwind (ran, dom :: args)
| L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
unwind (t, (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) :: args)
| _ => (rev args, t)
val (ts, ran) = unwind (t, [])
val ts = map (monoType env) ts
val ran = monoType env ran
in
SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran, b), loc)])
end
| L.DTable (x, n, (L.CRecord (_, xts), _), s, pe, _, ce, _) =>
let
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
val s = "uw_" ^ s
val e_name = (L'.EPrim (Prim.String s), loc)
val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
val (pe, fm) = monoExp (env, St.empty, fm) pe
val (ce, fm) = monoExp (env, St.empty, fm) ce
in
SOME (Env.pushENamed env x n t NONE s,
fm,
[(L'.DTable (s, xts, pe, ce), loc),
(L'.DVal (x, n, t', e_name, s), loc)])
end
| L.DTable _ => poly ()
| L.DView (x, n, s, e, (L.CRecord (_, xts), _)) =>
let
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
val s = "uw_" ^ s
val e_name = (L'.EPrim (Prim.String s), loc)
val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
val (e, fm) = monoExp (env, St.empty, fm) e
val e = (L'.EFfiApp ("Basis", "viewify", [e]), loc)
in
SOME (Env.pushENamed env x n t NONE s,
fm,
[(L'.DView (s, xts, e), loc),
(L'.DVal (x, n, t', e_name, s), loc)])
end
| L.DView _ => poly ()
| L.DSequence (x, n, s) =>
let
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
val s = "uw_" ^ s
val e = (L'.EPrim (Prim.String s), loc)
in
SOME (Env.pushENamed env x n t NONE s,
fm,
[(L'.DSequence s, loc),
(L'.DVal (x, n, t', e, s), loc)])
end
| L.DDatabase _ => NONE
| L.DCookie (x, n, t, s) =>
let
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
val e = (L'.EPrim (Prim.String s), loc)
in
SOME (Env.pushENamed env x n t NONE s,
fm,
[(L'.DCookie s, loc),
(L'.DVal (x, n, t', e, s), loc)])
end
| L.DStyle (x, n, s) =>
let
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
val e = (L'.EPrim (Prim.String s), loc)
in
SOME (Env.pushENamed env x n t NONE s,
fm,
[(L'.DStyle s, loc),
(L'.DVal (x, n, t', e, s), loc)])
end
| L.DTask (e1, e2) =>
let
val (e1, fm) = monoExp (env, St.empty, fm) e1
val (e2, fm) = monoExp (env, St.empty, fm) e2
in
SOME (env,
fm,
[(L'.DTask (e1, e2), loc)])
end
end
datatype expungable = Client | Channel
fun monoize env file =
let
(* Calculate which exported functions need cookie signature protection *)
val rcook = foldl (fn ((d, _), rcook) =>
case d of
L.DExport (L.Action L.ReadCookieWrite, n, _) => IS.add (rcook, n)
| L.DExport (L.Rpc L.ReadCookieWrite, n, _) => IS.add (rcook, n)
| _ => rcook)
IS.empty file
val () = readCookie := rcook
val loc = E.dummySpan
val client = (L'.TFfi ("Basis", "client"), loc)
val unit = (L'.TRecord [], loc)
fun calcClientish xts =
foldl (fn ((x : L.con, t : L.con), st as (nullable, notNullable)) =>
case #1 x of
L.CName x =>
(case #1 t of
L.CFfi ("Basis", "client") =>
(nullable, (x, Client) :: notNullable)
| L.CApp ((L.CFfi ("Basis", "option"), _),
(L.CFfi ("Basis", "client"), _)) =>
((x, Client) :: nullable, notNullable)
| L.CApp ((L.CFfi ("Basis", "channel"), _), _) =>
(nullable, (x, Channel) :: notNullable)
| L.CApp ((L.CFfi ("Basis", "option"), _),
(L.CApp ((L.CFfi ("Basis", "channel"), _), _), _)) =>
((x, Channel) :: nullable, notNullable)
| _ => st)
| _ => st) ([], []) xts
fun expunger () =
let
val target = (L'.EFfiApp ("Basis", "sqlifyClient", [(L'.ERel 0, loc)]), loc)
fun doTable (tab, xts, e) =
case xts of
L.CRecord (_, xts) =>
let
val (nullable, notNullable) = calcClientish xts
fun cond (x, v) =
(L'.EStrcat ((L'.EPrim (Prim.String ("uw_" ^ x
^ (case v of
Client => ""
| Channel => " >> 32")
^ " = ")), loc),
target), loc)
val e =
foldl (fn ((x, v), e) =>
(L'.ESeq (
(L'.EDml (L'.EStrcat (
(L'.EPrim (Prim.String ("UPDATE uw_"
^ tab
^ " SET uw_"
^ x
^ " = NULL WHERE ")), loc),
cond (x, v)), loc), loc),
e), loc))
e nullable
val e =
case notNullable of
[] => e
| eb :: ebs =>
(L'.ESeq (
(L'.EDml (foldl
(fn (eb, s) =>
(L'.EStrcat (s,
(L'.EStrcat ((L'.EPrim (Prim.String " OR "),
loc),
cond eb), loc)), loc))
(L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM uw_"
^ tab
^ " WHERE ")), loc),
cond eb), loc)
ebs), loc),
e), loc)
in
e
end
| _ => e
val e = (L'.ERecord [], loc)
in
foldl (fn ((d, _), e) =>
case d of
L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e)
| _ => e) e file
end
fun initializer () =
let
fun doTable (tab, xts, e) =
case xts of
L.CRecord (_, xts) =>
let
val (nullable, notNullable) = calcClientish xts
val e =
case nullable of
[] => e
| (x, _) :: ebs =>
(L'.ESeq (
(L'.EDml (L'.EPrim (Prim.String
(foldl (fn ((x, _), s) =>
s ^ ", uw_" ^ x ^ " = NULL")
("UPDATE uw_"
^ tab
^ " SET uw_"
^ x
^ " = NULL")
ebs)), loc), loc),
e), loc)
val e =
case notNullable of
[] => e
| eb :: ebs =>
(L'.ESeq (
(L'.EDml (L'.EPrim (Prim.String ("DELETE FROM uw_"
^ tab)), loc), loc),
e), loc)
in
e
end
| _ => e
val e = (L'.ERecord [], loc)
in
foldl (fn ((d, _), e) =>
case d of
L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e)
| _ => e) e file
end
val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
case #1 d of
L.DDatabase s =>
let
val (nExp, fm) = Fm.freshName fm
val (nIni, fm) = Fm.freshName fm
val dExp = L'.DVal ("expunger",
nExp,
(L'.TFun (client, unit), loc),
(L'.EAbs ("cli", client, unit, expunger ()), loc),
"expunger")
val dIni = L'.DVal ("initializer",
nIni,
(L'.TFun (unit, unit), loc),
(L'.EAbs ("_", unit, unit, initializer ()), loc),
"initializer")
in
(env, Fm.enter fm, (L'.DDatabase {name = s,
expunge = nExp,
initialize = nIni}, loc)
:: (dExp, loc)
:: (dIni, loc)
:: ds)
end
| _ =>
case monoDecl (env, fm) d of
NONE => (env, fm, ds)
| SOME (env, fm, ds') =>
(env,
Fm.enter fm,
ds' @ Fm.decls fm @ ds))
(env, Fm.empty (CoreUtil.File.maxName file + 1), []) file
in
rev ds
end
end