(* Copyright (c) 2008-2014, 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 SK = struct type ord_key = string val compare = String.compare end structure SS = BinarySetFn(SK) structure SM = BinaryMapFn(SK) structure RM = BinaryMapFn(struct type ord_key = (string * L'.typ) list fun compare (r1, r2) = MonoUtil.Typ.compare ((L'.TRecord r1, E.dummySpan), (L'.TRecord r2, E.dummySpan)) end) val nextPvar = MonoFooify.nextPvar val pvars = ref (RM.empty : (int * (string * int * L'.typ) list) RM.map) val pvarDefs = MonoFooify.pvarDefs val pvarOldDefs = ref ([] : (int * (string * int * L.con option) list) list) fun choosePvar () = let val n = !nextPvar in nextPvar := n + 1; n end fun pvar (r, r', loc) = case RM.find (!pvars, r') of NONE => let val n = choosePvar () val fs = map (fn (x, t) => (x, choosePvar (), t)) r' val r = ListMergeSort.sort (fn (((L.CName x, _), _), ((L.CName y, _), _)) => String.compare (x, y) = GREATER | _ => raise Fail "Monoize: pvar, not CName") r val (r, fs') = ListPair.foldr (fn ((_, t), (x, n, _), (r, fs')) => ((x, n, SOME t) :: r, SM.insert (fs', x, n))) ([], SM.empty) (r, fs) in pvars := RM.insert (!pvars, r', (n, fs)); pvarDefs := ("$poly" ^ Int.toString n, n, map (fn (x, n, t) => (x, n, SOME t)) fs) :: !pvarDefs; pvarOldDefs := (n, r) :: !pvarOldDefs; (n, fs) end | SOME v => v val singletons = SS.addList (SS.empty, ["link", "br", "p", "hr", "input", "img", "base", "meta", "param", "area", "col"]) 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", "variant"), _), (L.CRecord ((L.KType, _), xts), _)) => let val xts' = map (fn (x, t) => (monoName env x, mt env dtmap t)) xts val xts' = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) xts' val (n, cs) = pvar (xts, xts', loc) val cs = map (fn (x, n, t) => (x, n, SOME t)) cs in (L'.TDatatype (n, ref (ElabUtil.classifyDatatype cs, cs)), loc) end | 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)), ("Pow", (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", "xhead") => (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "xbody") => (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "xtable") => (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.CFfi ("Basis", "css_value") => (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "css_property") => (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "css_style") => (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "id") => (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "requestHeader") => (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "responseHeader") => (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "envVar") => (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "meta") => (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "data_attr_kind") => (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "data_attr") => (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.CApp ((L.CFfi ("Basis", "sql_query"), _), _), _), _), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((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.CApp ((L.CApp ((L.CFfi ("Basis", "sql_expw"), _), _), _), _), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CFfi ("Basis", "sql_window"), _), _) => (L'.TRecord [], loc) | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_window_function"), _), _), _), _), _), _), _), _) => (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.CFfi ("Basis", "dml") => (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.CApp ((L.CApp ((L.CFfi ("Basis", "sql_partition"), _), _), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_window"), _), _), _), _), _), _), _), _) => (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 Fm = MonoFooify.Fm fun fooifyExp fk env = MonoFooify.fooifyExp fk (fn n => let val (_, t, _, s) = Env.lookupENamed env n in (monoType env t, s) end) (fn n => let val (x, _, xncs) = Env.lookupDatatype env n in (x, map (fn (x, n, c) => (x, n, Option.map (monoType env) c)) xncs) end) val attrifyExp = fooifyExp MonoFooify.Attr val urlifyExp = fooifyExp MonoFooify.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.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 (Prim.Normal, "")), 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 (Prim.Normal, "")), 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 (Prim.Normal, ", ")), 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 (Prim.Normal, s)), loc) fun strH s = (L'.EPrim (Prim.String (Prim.Html, 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)), ("Pow", (L'.TFun (t, (L'.TFun (t, t), loc)), loc))], loc) fun numEx (t, zero, neg, plus, minus, times, dv, md, ex) = ((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)), ("Pow", ex, (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.ECApp ( (L.ECApp ((L.EFfi ("Basis", "make"), _), nmC as (L.CName nm, _)), _), t), _), (L.CRecord (_, xts), _)) => let val t' = monoType env t val xts' = map (fn (x, t) => (monoName env x, monoType env t)) xts val xts' = (nm, t') :: xts' val xts' = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) xts' val (n, cs) = pvar ((nmC, t) :: xts, xts', loc) val cs' = map (fn (x, n, t) => (x, n, SOME t)) cs val cl = ElabUtil.classifyDatatype cs' in case List.find (fn (nm', _, _) => nm' = nm) cs of NONE => raise Fail "Monoize: Polymorphic variant tag mismatch for 'make'" | SOME (_, n', _) => ((L'.EAbs ("x", t', (L'.TDatatype (n, ref (cl, cs')), loc), (L'.ECon (cl, L'.PConVar n', SOME (L'.ERel 0, loc)), loc)), loc), fm) end | L.ECApp ( (L.ECApp ((L.EFfi ("Basis", "match"), _), (L.CRecord (_, xts), _)), _), t) => let val t = monoType env t val xts' = map (fn (x, t) => (monoName env x, monoType env t)) xts val xts' = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) xts' val (n, cs) = pvar (xts, xts', loc) val cs' = map (fn (x, n, t) => (x, n, SOME t)) cs val cl = ElabUtil.classifyDatatype cs' val fs = (L'.TRecord (map (fn (x, t') => (x, (L'.TFun (t', t), loc))) xts'), loc) val dt = (L'.TDatatype (n, ref (cl, cs')), loc) in ((L'.EAbs ("v", dt, (L'.TFun (fs, t), loc), (L'.EAbs ("fs", fs, t, (L'.ECase ((L'.ERel 1, loc), map (fn (x, n', t') => ((L'.PCon (cl, L'.PConVar n', SOME (L'.PVar ("x", t'), loc)), loc), (L'.EApp ((L'.EField ((L'.ERel 1, loc), x), loc), (L'.ERel 0, loc)), loc))) cs, {disc = dt, result = t}), loc)), loc)), loc), fm) end | 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'.Int, "==", (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'.NotInt, "==", (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'.NotInt, "==", (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 (L'.NotInt, "!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'.NotInt, "==", (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'.EFfiApp ("Basis", "eq_time", [((L'.ERel 1, loc), (L'.TFfi ("Basis", "time"), loc)), ((L'.ERel 0, loc), (L'.TFfi ("Basis", "time"), 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.ECApp ((L.EFfi ("Basis", "pow"), _), 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), "Pow"), 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 (L'.Int, 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 "%", intBin "powl" ) 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 (L'.NotInt, 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 "fdiv", floatBin "fmod", floatBin "powf" ) 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 (L'.Int, 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 (L'.NotInt, 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 (L'.NotInt, 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 (L'.NotInt, s, (L'.EBinop (L'.NotInt, "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 (L'.NotInt, 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'.EFfiApp ("Basis", s, [((L'.ERel 1, loc), (L'.TFfi ("Basis", "time"), loc)), ((L'.ERel 0, loc), (L'.TFfi ("Basis", "time"), loc))]), loc)), loc)), loc) in ordEx ((L'.TFfi ("Basis", "time"), loc), boolBin "lt_time", boolBin "le_time") 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_queryString") => 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_css_class") => 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_id") => 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.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "show_sql_query"), _), _), _), _), _), _), _), _) => 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.ECApp ((L.EFfi ("Basis", "transaction_return"), _), t) => let val t = monoType env t in ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), t), loc), (L'.EAbs ("_", (L'.TRecord [], loc), t, (L'.ERel 1, loc)), loc)), loc), fm) end | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "transaction_bind"), _), 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 ("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), 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", "float", [(e, t)]) => let val (e, fm) = monoExp (env, st, fm) e in ((L'.EFfiApp ("Basis", "floatFromInt", [(e, monoType env t)]), loc), fm) end | 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), (L'.TSource, 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'.TSource, loc)), ((L'.EJavaScript (L'.Source t, (L'.ERel 1, loc)), loc), (L'.TFfi ("Basis", "string"), 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), (L'.TSource, 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), (L'.TSource, 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.ECApp ((L.EFfi ("Basis", "signal_return"), _), t) => let val t = monoType env t in ((L'.EAbs ("x", t, (L'.TSignal t, loc), (L'.ESignalReturn (L'.ERel 0, loc), loc)), loc), fm) end | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "signal_bind"), _), 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 ("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), 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), s)]), 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", [(str (Settings.getUrlPrefix ()), s), ((L'.ERel 2, loc), s), (e, s), (fd "Expires", (L'.TOption (L'.TFfi ("Basis", "time"), loc), loc)), (fd "Secure", (L'.TFfi ("Basis", "bool"), loc))]) , 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", [(str (Settings.getUrlPrefix ()), s), ((L'.ERel 1, loc), s)]), 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), (L'.TRecord [], 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), (L'.TFfi ("Basis", "channel"), loc)), (e, (L'.TFfi ("Basis", "string"), loc))]), loc)), loc)), loc)), loc), fm) end | L.ECApp ((L.EFfi ("Basis", "no_primary_key"), _), _) => (str "", 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), (str (String.concatWith ", " (map (fn (x, _) => Settings.mangleSql (monoNameLc env x) ^ (if #textKeysNeedLengths (Settings.currentDbms ()) andalso isBlobby t then "(767)" else "")) unique)))), 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 (str ("UNIQUE (" ^ String.concatWith ", " (map (fn (x, t) => Settings.mangleSql (monoNameLc env x) ^ (if #textKeysNeedLengths (Settings.currentDbms ()) andalso isBlobby t then "(767)" else "")) unique) ^ ")"), 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 = str "" 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 (Prim.Normal, "")), loc), (L'.ERecord [("1", str (Settings.mangleSql (lowercaseFirst nm1)), string), ("2", str (Settings.mangleSql (lowercaseFirst nm2)), string)], loc)), ((L'.PVar ("_", string), loc), (L'.ERecord [("1", (L'.EStrcat ( str (Settings.mangleSql (lowercaseFirst nm1) ^ ", "), (L'.EField ((L'.ERel 1, loc), "1"), loc)), loc), string), ("2", (L'.EStrcat ( str (Settings.mangleSql (lowercaseFirst nm2) ^ ", "), (L'.EField ((L'.ERel 1, loc), "2"), loc)), loc), string)], loc))], {disc = string, result = mat}), loc)), loc)), loc), fm) end | L.ECApp ((L.EFfi ("Basis", "restrict"), _), _) => (str "RESTRICT", fm) | L.ECApp ((L.EFfi ("Basis", "cascade"), _), _) => (str "CASCADE", fm) | L.ECApp ((L.EFfi ("Basis", "no_action"), _), _) => (str "NO ACTION", fm) | L.ECApp ((L.EFfi ("Basis", "set_null"), _), _) => (str "SET NULL", 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 (Prim.Normal, "NO ACTION")), loc), str ""), ((L'.PVar ("_", string), loc), strcat [str (" ON " ^ kw ^ " "), (L'.EField ((L'.ERel 1, 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 [str "FOREIGN KEY (", (L'.EField ((L'.ERel 2, loc), "1"), loc), str ") REFERENCES ", (L'.ERel 1, loc), str " (", (L'.EField ((L'.ERel 2, loc), "2"), loc), str ")", 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 (str "CHECK ", (L'.EFfiApp ("Basis", "checkString", [((L'.ERel 0, loc), string)]), loc)), loc)), loc), fm) end | L.EFfiApp ("Basis", "dml", [(e, _)]) => let val (e, fm) = monoExp (env, st, fm) e in ((L'.EDml (e, L'.Error), loc), fm) end | L.EFfiApp ("Basis", "tryDml", [(e, _)]) => let val (e, fm) = monoExp (env, st, fm) e in ((L'.EDml (e, L'.None), 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) in ((L'.EAbs ("tab", s, (L'.TFun (rt, s), loc), (L'.EAbs ("fs", rt, s, strcat [str "INSERT INTO ", (L'.ERel 1, loc), str " (", strcatComma (map (fn (x, _) => str (Settings.mangleSql x)) fields), str ") VALUES (", strcatComma (map (fn (x, _) => (L'.EField ((L'.ERel 0, loc), x), loc)) fields), str ")"]), 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) 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 [str "UPDATE ", (L'.ERel 1, loc), str " AS T_T SET ", strcatComma (map (fn (x, _) => strcat [str (Settings.mangleSql x ^ " = "), (L'.EField ((L'.ERel 2, loc), x), loc)]) changed), str " WHERE ", (L'.ERel 0, loc)] else strcat [str "UPDATE ", (L'.ERel 1, loc), str " SET ", strcatComma (map (fn (x, _) => strcat [str (Settings.mangleSql x ^ " = "), (L'.EFfiApp ("Basis", "unAs", [((L'.EField ((L'.ERel 2, loc), x), loc), s)]), loc)]) changed), str " WHERE ", (L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), loc)]), loc)), loc)), loc), fm) end | _ => poly ()) | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "delete"), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) in ((L'.EAbs ("tab", s, (L'.TFun (s, s), loc), (L'.EAbs ("e", s, s, if #supportsDeleteAs (Settings.currentDbms ()) then strcat [str "DELETE FROM ", (L'.ERel 1, loc), str " AS T_T WHERE ", (L'.ERel 0, loc)] else strcat [str "DELETE FROM ", (L'.ERel 1, loc), str " WHERE ", (L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), 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.ECApp ((L.EFfi ("Basis", "sql_query"), _), _), _), _), _), _), _), _), _), _) => let 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 (Prim.Normal, "")), loc), str ""), ((L'.PVar ("orderby", s), loc), strcat [str " ORDER BY ", (L'.ERel 0, loc)])], {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.ECApp ( (L.EFfi ("Basis", "sql_query1"), _), _), _), _), _), (L.CRecord (_, tables), _)), _), (L.CRecord (_, grouped), _)), _), (L.CRecord (_, stables), _)), _), sexps), _), _) => let 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 [str "SELECT ", (L'.ECase (gf "Distinct", [((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis", datatyp = "bool", con = "True", arg = NONE}, NONE), loc), str "DISTINCT "), ((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis", datatyp = "bool", con = "False", arg = NONE}, NONE), loc), str "")], {disc = b, result = s}), loc), if List.null sexps andalso List.all (List.null o #2) stables then str "0" else strcatComma (map (fn (x, t) => strcat [ (L'.EField (gf "SelectExps", x), loc), str (" AS " ^ Settings.mangleSql x) ]) sexps @ map (fn (x, xts) => strcatComma (map (fn (x', _) => str ("T_" ^ x ^ "." ^ Settings.mangleSql x')) xts)) stables), (L'.ECase (gf "From", [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), str ""), ((L'.PVar ("x", s), loc), strcat [str " FROM ", (L'.ERel 0, loc)])], {disc = s, result = s}), loc), (L'.ECase (gf "Where", [((L'.PPrim (Prim.String (Prim.Normal, #trueString (Settings.currentDbms ()))), loc), str ""), ((L'.PVar ("where", s), loc), strcat [str " WHERE ", (L'.ERel 0, loc)])], {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 str "" else strcat [ str " GROUP BY ", strcatComma (map (fn (x, xts) => strcatComma (map (fn (x', _) => str ("T_" ^ x ^ "." ^ Settings.mangleSql x')) xts)) grouped) ], (L'.ECase (gf "Having", [((L'.PPrim (Prim.String (Prim.Normal, #trueString (Settings.currentDbms ()))), loc), str ""), ((L'.PVar ("having", s), loc), strcat [str " HAVING ", (L'.ERel 0, loc)])], {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), (L'.TFfi ("Basis", "int"), 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), (L'.TFfi ("Basis", "float"), 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), (L'.TFfi ("Basis", "bool"), 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), (L'.TFfi ("Basis", "string"), 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), (L'.TFfi ("Basis", "char"), 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), (L'.TFfi ("Basis", "time"), 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), (L'.TFfi ("Basis", "blob"), 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), (L'.TFfi ("Basis", "channel"), 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), (L'.TFfi ("Basis", "client"), 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), (L'.TFfi ("Basis", "string"), loc))]), loc)), loc), fm) | L.EFfi ("Basis", "sql_url") => ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc), (L'.EFfiApp ("Basis", "sqlifyString", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), 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) fun toSqlType (t : L'.typ) = case #1 t of L'.TFfi ("Basis", "int") => Settings.Int | L'.TFfi ("Basis", "float") => Settings.Float | L'.TFfi ("Basis", "string") => Settings.String | L'.TFfi ("Basis", "char") => Settings.Char | L'.TFfi ("Basis", "bool") => Settings.Bool | L'.TFfi ("Basis", "time") => Settings.Time | L'.TFfi ("Basis", "blob") => Settings.Blob | L'.TFfi ("Basis", "channel") => Settings.Channel | L'.TFfi ("Basis", "client") => Settings.Client | _ => raise Fail "Monoize/sql_option_prim: invalid SQL type" 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), str (#p_cast (Settings.currentDbms ()) ("NULL", toSqlType t))), ((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.EFfi ("Basis", "sql_from_nil"), _), _) => (str "", 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), str (" AS T_" ^ name)]), loc), fm) end | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_query"), _), _), _), _), _), (L.CName name, _)) => let val s = (L'.TFfi ("Basis", "string"), loc) in ((L'.EAbs ("q", s, s, strcat [str "(", (L'.ERel 0, loc), str (") AS T_" ^ name)]), loc), fm) end | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_comma"), _), _), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) val disc = (L'.TRecord [("1", s), ("2", s)], loc) in ((L'.EAbs ("tab1", s, (L'.TFun (s, s), loc), (L'.EAbs ("tab2", s, s, (L'.ECase ((L'.ERecord [("1", (L'.ERel 1, loc), s), ("2", (L'.ERel 0, loc), s)], loc), [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 0, loc)), ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 1, loc)), ((L'.PVar ("_", disc), loc), strcat [(L'.ERel 2, loc), str ", ", (L'.ERel 1, loc)])], {disc = disc, result = s}), 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) val disc = (L'.TRecord [("1", s), ("2", s)], 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, (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s), ("2", (L'.ERel 1, loc), s)], loc), [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 1, loc)), ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), ((L'.PVar ("_", disc), loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then [str "("] else []) @ [(L'.ERel 3, loc), str " JOIN ", (L'.ERel 2, loc), str " ON ", (L'.ERel 1, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then [str ")"] else [])))], {disc = disc, result = s}), 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) val disc = (L'.TRecord [("1", s), ("2", s)], 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, (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s), ("2", (L'.ERel 1, loc), s)], loc), [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 1, loc)), ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), ((L'.PVar ("_", disc), loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then [str "("] else []) @ [(L'.ERel 3, loc), str " LEFT JOIN ", (L'.ERel 2, loc), str " ON ", (L'.ERel 1, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then [str ")"] else [])))], {disc = disc, result = s}), 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) val disc = (L'.TRecord [("1", s), ("2", s)], 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, (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s), ("2", (L'.ERel 1, loc), s)], loc), [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 1, loc)), ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), ((L'.PVar ("_", disc), loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then [str "("] else []) @ [(L'.ERel 3, loc), str " RIGHT JOIN ", (L'.ERel 2, loc), str " ON ", (L'.ERel 1, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then [str ")"] else [])))], {disc = disc, result = s}), 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) val disc = (L'.TRecord [("1", s), ("2", s)], 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, (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s), ("2", (L'.ERel 1, loc), s)], loc), [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 1, loc)), ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), ((L'.PVar ("_", disc), loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then [str "("] else []) @ [(L'.ERel 3, loc), str " FULL JOIN ", (L'.ERel 2, loc), str " ON ", (L'.ERel 1, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then [str ")"] else [])))], {disc = disc, result = s}), loc)), loc)), loc)), loc)), loc), fm) end | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) => (str "", fm) | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_random"), _), _), _), _) => (str (#randomFunction (Settings.currentDbms ()) ^ "()"), fm) | L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "sql_order_by_Cons"), _), _), _), _), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) in ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), (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 (Prim.Normal, "")), loc), strcat [(L'.ERel 2, loc), (L'.ERel 1, loc)]), ((L'.PVar ("_", s), loc), strcat [(L'.ERel 3, loc), (L'.ERel 2, loc), str ", ", (L'.ERel 1, loc)])], {disc = s, result = s}), loc)), loc)), loc)), loc)), loc), fm) end | L.EFfi ("Basis", "sql_no_limit") => (str "", fm) | L.EFfiApp ("Basis", "sql_limit", [(e, t)]) => let val (e, fm) = monoExp (env, st, fm) e in (strcat [ str " LIMIT ", (L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc) ], fm) end | L.EFfi ("Basis", "sql_no_offset") => (str "", fm) | L.EFfiApp ("Basis", "sql_offset", [(e, t)]) => let val (e, fm) = monoExp (env, st, fm) e in (strcat [ str " OFFSET ", (L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc) ], fm) end | L.ECApp ((L.EFfi ("Basis", "sql_eq"), _), _) => (str "=", fm) | L.ECApp ((L.EFfi ("Basis", "sql_ne"), _), _) => (str "<>", fm) | L.ECApp ((L.EFfi ("Basis", "sql_lt"), _), _) => (str "<", fm) | L.ECApp ((L.EFfi ("Basis", "sql_le"), _), _) => (str "<=", fm) | L.ECApp ((L.EFfi ("Basis", "sql_gt"), _), _) => (str ">", fm) | L.ECApp ((L.EFfi ("Basis", "sql_ge"), _), _) => (str ">=", fm) | L.ECApp ((L.EFfi ("Basis", "sql_plus"), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), str "+"), loc), fm) | L.ECApp ((L.EFfi ("Basis", "sql_minus"), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), str "-"), loc), fm) | L.ECApp ((L.EFfi ("Basis", "sql_times"), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), str "*"), loc), fm) | L.ECApp ((L.EFfi ("Basis", "sql_div"), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), str "/"), loc), fm) | L.EFfi ("Basis", "sql_mod") => (str "%", fm) | L.EFfi ("Basis", "sql_like") => (str "LIKE", fm) | L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "sql_unary"), _), _), _), _), _), _), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), 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 [str "(", (L'.ERel 1, loc), str " ", (L'.ERel 0, loc), str ")"]), loc)), loc), fm) end | L.EFfi ("Basis", "sql_not") => (str "NOT", fm) | L.ECApp ((L.EFfi ("Basis", "sql_neg"), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), str "-"), loc), fm) | L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "sql_binary"), _), _), _), _), _), _), _), arg1), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) fun default n = strcat [str "(", (L'.ERel (n + 1), loc), str " ", (L'.ERel (n + 2), loc), str " ", (L'.ERel n, loc), str ")"] val body = case #1 arg1 of L.CApp ((L.CFfi ("Basis", "option"), _), _) => (L'.ECase ((L'.ERel 2, loc), [((L'.PPrim (Prim.String (Prim.Normal, "=")), loc), if #supportsIsDistinctFrom (Settings.currentDbms ()) then strcat [str "((", (L'.ERel 1, loc), str " IS NOT DISTINCT FROM ", (L'.ERel 0, loc), str "))"] else strcat [str "((", (L'.ERel 1, loc), str " ", (L'.ERel 2, loc), str " ", (L'.ERel 0, loc), str ") OR ((", (L'.ERel 1, loc), str ") IS NULL AND (", (L'.ERel 0, loc), str ") IS NULL))"]), ((L'.PVar ("_", s), loc), default 1)], {disc = s, result = s}), loc) | _ => default 0 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, body), loc)), loc)), loc), fm) end | L.EFfi ("Basis", "sql_and") => (str "AND", fm) | L.EFfi ("Basis", "sql_or") => (str "OR", 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, _)) => (str ("T_" ^ tab ^ "." ^ Settings.mangleSql (lowercaseFirst field)), fm) | L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _), _), (L.CName nm, _)) => (str (Settings.mangleSql (lowercaseFirst nm)), fm) | L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "sql_relop"), _), _), _), _), _), _), _), _), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) val disc = (L'.TFfi ("Basis", "bool"), loc) in (if #nestedRelops (Settings.currentDbms ()) then (L'.EAbs ("c", s, (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), (L'.EAbs ("all", (L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), (L'.EAbs ("e2", s, s, strcat [str "((", (L'.ERel 1, loc), str ") ", (L'.ERel 3, loc), (L'.ECase ((L'.ERel 2, loc), [((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis", datatyp = "bool", con = "True", arg = NONE}, NONE), loc), str " ALL"), ((L'.PVar ("_", disc), loc), str "")], {disc = disc, result = s}), loc), str " (", (L'.ERel 0, loc), str "))"]), loc)), loc)), loc)), loc) else (L'.EAbs ("c", s, (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), (L'.EAbs ("all", (L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), (L'.EAbs ("e2", s, s, strcat [(L'.ERel 1, loc), str " ", (L'.ERel 3, loc), (L'.ECase ((L'.ERel 2, loc), [((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis", datatyp = "bool", con = "True", arg = NONE}, NONE), loc), str " ALL"), ((L'.PVar ("_", disc), loc), str "")], {disc = disc, result = s}), loc), str " ", (L'.ERel 0, loc)]), loc)), loc)), loc)), loc), fm) end | L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "sql_forget_tables"), _), _), _), _), _), _), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) in ((L'.EAbs ("x", s, s, (L'.ERel 0, loc)), loc), fm) end | L.EFfi ("Basis", "sql_union") => (str "UNION", fm) | L.EFfi ("Basis", "sql_intersect") => (if #onlyUnion (Settings.currentDbms ()) then ErrorMsg.errorAt loc "The DBMS you've selected doesn't support INTERSECT." else (); (str "INTERSECT", fm)) | L.EFfi ("Basis", "sql_except") => (if #onlyUnion (Settings.currentDbms ()) then ErrorMsg.errorAt loc "The DBMS you've selected doesn't support EXCEPT." else (); (str "EXCEPT", fm)) | L.ECApp ( (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "sql_count"), _), _), _), _), _), _) => (str "COUNT(*)", fm) | L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "sql_aggregate"), _), _), _), _), _), _), _), _), _), t) => let val s = (L'.TFfi ("Basis", "string"), loc) val main = strcat [(L'.ERel 1, loc), str "(", (L'.ERel 0, loc), str ")"] in ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), main), loc)), loc), fm) end | L.ECApp ((L.EFfi ("Basis", "sql_count_col"), _), _) => (str "COUNT", 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_summable_option"), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), (L'.ERecord [], loc)), loc), fm) | L.ECApp ((L.EFfi ("Basis", "sql_avg"), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), str "AVG"), loc), fm) | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_sum"), _), _), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), str "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.ECApp ((L.EFfi ("Basis", "sql_arith_option"), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), (L'.ERecord [], loc)), 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_maxable_option"), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), (L'.ERecord [], loc)), loc), fm) | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_max"), _), _), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), str "MAX"), loc)), loc), fm) | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_min"), _), _), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), str "MIN"), loc)), loc), fm) | L.EFfi ("Basis", "sql_asc") => (str "", fm) | L.EFfi ("Basis", "sql_desc") => (str " DESC", fm) | L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "sql_nfunc"), _), _), _), _), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) in ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm) end | L.EFfi ("Basis", "sql_window_normal") => ((L'.ERecord [], loc), fm) | L.EFfi ("Basis", "sql_window_fancy") => ((L'.ERecord [], loc), fm) | L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "sql_window"), _), _), _), _), _), _), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) in ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, s), loc), (L'.EAbs ("e", s, s, (L'.ERel 0, loc)), loc)), loc), fm) end | L.EFfi ("Basis", "sql_current_timestamp") => (str "CURRENT_TIMESTAMP", fm) | L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "sql_ufunc"), _), _), _), _), _), _), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) in ((L'.EAbs ("f", s, (L'.TFun (s, s), loc), (L'.EAbs ("x", s, s, strcat [(L'.ERel 1, loc), str "(", (L'.ERel 0, loc), str ")"]), loc)), loc), fm) end | L.EFfi ("Basis", "sql_octet_length") => (str (if #supportsOctetLength (Settings.currentDbms ()) then "octet_length" else "length"), fm) | L.EFfi ("Basis", "sql_lower") => (str "lower", fm) | L.EFfi ("Basis", "sql_upper") => (str "upper", fm) | L.ECApp ((L.EFfi ("Basis", "sql_known"), _), _) => ((L'.EFfi ("Basis", "sql_known"), loc), fm) | (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "sql_is_null"), _), _), _), _), _), _), _), _)) => let val s = (L'.TFfi ("Basis", "string"), loc) in ((L'.EAbs ("s", s, s, strcat [str "(", (L'.ERel 0, loc), str " IS NULL)"]), loc), fm) end | (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "sql_coalesce"), _), _), _), _), _), _), _), _)) => let val s = (L'.TFfi ("Basis", "string"), loc) in ((L'.EAbs ("x1", s, (L'.TFun (s, s), loc), (L'.EAbs ("x1", s, s, strcat [str "COALESCE(", (L'.ERel 1, loc), str ",", (L'.ERel 0, loc), str ")"]), loc)), loc), fm) end | (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "sql_if_then_else"), _), _), _), _), _), _), _), _)) => let val s = (L'.TFfi ("Basis", "string"), loc) in ((L'.EAbs ("if", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("then", s, (L'.TFun (s, s), loc), (L'.EAbs ("else", s, s, strcat [str "(CASE WHEN (", (L'.ERel 2, loc), str ") THEN (", (L'.ERel 1, loc), str ") ELSE (", (L'.ERel 0, loc), str ") END)"]), loc)), loc)), loc), fm) end | L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "sql_nullable"), _), _), _), _), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), 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.ECApp ( (L.EFfi ("Basis", "sql_subquery"), _), _), _), _), _), _), _), _), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) in ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, s), loc), (L'.EAbs ("x", s, s, strcat [str "(", (L'.ERel 0, loc), str ")"]), loc)), loc), fm) end | L.ECApp ( (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "sql_no_partition"), _), _), _), _), _), _) => (str "", fm) | L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "sql_partition"), _), _), _), _), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) in ((L'.EAbs ("e", s, s, strcat [str "PARTITION BY ", (L'.ERel 0, loc)]), loc), fm) end | L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "sql_window_function"), _), _), _), _), _), _), _), _) => let val () = if #windowFunctions (Settings.currentDbms ()) then () else ErrorMsg.errorAt loc "The DBMS you've selected doesn't support window functions." val s = (L'.TFfi ("Basis", "string"), loc) val main = strcat [(L'.ERel 2, loc), str " OVER (", (L'.ERel 1, loc), (L'.ECase ((L'.ERel 0, loc), [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), str ""), ((L'.PVar ("_", s), loc), strcat [str " ORDER BY ", (L'.ERel 1, loc)])], {disc = s, result = s}), loc), str ")"] in ((L'.EAbs ("w", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("p", s, (L'.TFun (s, s), loc), (L'.EAbs ("o", s, s, main), loc)), loc)), loc), fm) end | L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "sql_window_aggregate"), _), _), _), _), _), _), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) val main = strcat [(L'.ERel 1, loc), str "(", (L'.ERel 0, loc), str ")"] in ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, s, main), loc)), loc), fm) end | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_window_count"), _), _), _), _), _), _) => (str "COUNT(*)", fm) | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_rank"), _), _), _), _), _), _) => (str "RANK()", fm) | 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.EFfi ("Basis", "null") => (str "", fm) | L.EFfiApp ("Basis", "classes", [(s1, _), (s2, _)]) => let val (s1, fm) = monoExp (env, st, fm) s1 val (s2, fm) = monoExp (env, st, fm) s2 in ((L'.EStrcat (s1, (L'.EStrcat (str " ", s2), loc)), loc), fm) end | L.EFfi ("Basis", "data_kind") => (str "data-", fm) | L.EFfi ("Basis", "aria_kind") => (str "aria-", fm) | L.EFfiApp ("Basis", "data_attr", [(sk, _), (s1, _), (s2, _)]) => let val (sk, fm) = monoExp (env, st, fm) sk val (s1, fm) = monoExp (env, st, fm) s1 val (s2, fm) = monoExp (env, st, fm) s2 in ((L'.EStrcat (sk, (L'.EStrcat ((L'.EFfiApp ("Basis", "blessData", [(s1, (L'.TFfi ("Basis", "string"), loc))]), loc), (L'.EStrcat (str "=\"", (L'.EStrcat ((L'.EFfiApp ("Basis", "attrifyString", [(s2, (L'.TFfi ("Basis", "string"), loc))]), loc), str "\""), loc)), loc)), loc)), loc), fm) end | L.EFfiApp ("Basis", "data_attrs", [(s1, _), (s2, _)]) => let val (s1, fm) = monoExp (env, st, fm) s1 val (s2, fm) = monoExp (env, st, fm) s2 in ((L'.EStrcat (s1, (L'.EStrcat (str " ", s2), loc)), loc), fm) end | L.EFfiApp ("Basis", "css_url", [(s, _)]) => let val (s, fm) = monoExp (env, st, fm) s in ((L'.EStrcat (str "url(", (L'.EStrcat ((L'.EFfiApp ("Basis", "css_url", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc), str ")"), loc)), loc), fm) end | L.EFfiApp ("Basis", "property", [(s, _)]) => let val (s, fm) = monoExp (env, st, fm) s in ((L'.EStrcat ((L'.EFfiApp ("Basis", "property", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc), str ":"), loc), fm) end | L.EFfiApp ("Basis", "value", [(s1, _), (s2, _)]) => let val (s1, fm) = monoExp (env, st, fm) s1 val (s2, fm) = monoExp (env, st, fm) s2 in ((L'.EStrcat (s1, (L'.EStrcat (str " ", s2), loc)), loc), fm) end | L.EFfi ("Basis", "noStyle") => (str "", fm) | L.EFfiApp ("Basis", "oneProperty", [(s1, _), (s2, _)]) => let val (s1, fm) = monoExp (env, st, fm) s1 val (s2, fm) = monoExp (env, st, fm) s2 in ((L'.EStrcat (s1, (L'.EStrcat (s2, str ";"), loc)), 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, (L'.TFfi ("Basis", "string"), loc))]), loc), fm) end | L.ECApp ( (L.ECApp ((L.EFfi ("Basis", "cdataChar"), _), _), _), _) => ((L'.EAbs ("ch", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "string"), loc), (L'.EFfiApp ("Basis", "htmlifySpecialChar", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "char"), loc))]), loc)), loc), fm) | 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.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"), _), (L.CRecord (_, attrsGiven), _)), _), _), _), ctxOuter), _), _), _), _), _), _), _), _), _), _), _), class), _), dynClass), _), style), _), dynStyle), _), attrs), _), tag), _), xml) => let fun getTag' (e, _) = case e of L.EFfi (_, 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 (_, 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 | _ => map (fn ((L.CName x, _), t) => (x, (L'.EField (attrs, x), loc), monoType env t) | (c, t) => (E.errorAt loc "Non-constant field name for HTML tag attribute"; Print.eprefaces' [("Name", CorePrint.p_con env c)]; ("", (L'.EField (attrs, ""), loc), monoType env t))) attrsGiven 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) = if tag = "body" then findOnload (attrs, NONE, NONE, []) else (NONE, NONE, attrs) val (class, fm) = monoExp (env, st, fm) class val (dynClass, fm) = monoExp (env, st, fm) dynClass val (style, fm) = monoExp (env, st, fm) style val (dynStyle, fm) = monoExp (env, st, fm) dynStyle (* Special case for