Ur/Web: src/monoize.sml annotate

annotate src/monoize.sml @ 706:1fb318c17546

Enhance table sig item support and get demo compiling again

author	Adam Chlipala <adamc@hcoop.net>
date	Tue, 07 Apr 2009 15:04:07 -0400
parents	e6706a1df013
children	d8217b4cb617

rev	line source
adamc@25	1 (* Copyright (c) 2008, Adam Chlipala
adamc@25	2 * All rights reserved.
adamc@25	3 *
adamc@25	4 * Redistribution and use in source and binary forms, with or without
adamc@25	5 * modification, are permitted provided that the following conditions are met:
adamc@25	6 *
adamc@25	7 * - Redistributions of source code must retain the above copyright notice,
adamc@25	8 * this list of conditions and the following disclaimer.
adamc@25	9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@25	10 * this list of conditions and the following disclaimer in the documentation
adamc@25	11 * and/or other materials provided with the distribution.
adamc@25	12 * - The names of contributors may not be used to endorse or promote products
adamc@25	13 * derived from this software without specific prior written permission.
adamc@25	14 *
adamc@25	15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@25	16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@25	17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@25	18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@25	19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@25	20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@25	21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@25	22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@25	23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@25	24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@25	25 * POSSIBILITY OF SUCH DAMAGE.
adamc@25	26 *)
adamc@25	27
adamc@25	28 structure Monoize :> MONOIZE = struct
adamc@25	29
adamc@25	30 structure E = ErrorMsg
adamc@25	31 structure Env = CoreEnv
adamc@25	32
adamc@25	33 structure L = Core
adamc@25	34 structure L' = Mono
adamc@25	35
adamc@196	36 structure IM = IntBinaryMap
adamc@196	37
adamc@385	38 val urlPrefix = ref "/"
adamc@385	39
adamc@196	40 val dummyTyp = (L'.TDatatype (0, ref (L'.Enum, [])), E.dummySpan)
adamc@25	41
adamc@252	42 structure U = MonoUtil
adamc@252	43
adamc@252	44 val liftExpInExp =
adamc@252	45 U.Exp.mapB {typ = fn t => t,
adamc@252	46 exp = fn bound => fn e =>
adamc@252	47 case e of
adamc@252	48 L'.ERel xn =>
adamc@252	49 if xn < bound then
adamc@252	50 e
adamc@252	51 else
adamc@252	52 L'.ERel (xn + 1)
adamc@252	53 \| _ => e,
adamc@252	54 bind = fn (bound, U.Exp.RelE _) => bound + 1
adamc@252	55 \| (bound, _) => bound}
adamc@252	56
adamc@25	57 fun monoName env (all as (c, loc)) =
adamc@25	58 let
adamc@25	59 fun poly () =
adamc@25	60 (E.errorAt loc "Unsupported name constructor";
adamc@25	61 Print.eprefaces' [("Constructor", CorePrint.p_con env all)];
adamc@25	62 "")
adamc@25	63 in
adamc@25	64 case c of
adamc@25	65 L.CName s => s
adamc@25	66 \| _ => poly ()
adamc@25	67 end
adamc@25	68
adamc@292	69 fun readType' (t, loc) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc),
adamc@292	70 (L'.TOption t, loc)), loc)
adamc@292	71 fun readErrType (t, loc) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc),
adamc@292	72 t), loc)
adamc@292	73 fun readType (t, loc) =
adamc@292	74 (L'.TRecord [("Read", readType' (t, loc)),
adamc@292	75 ("ReadError", readErrType (t, loc))],
adamc@292	76 loc)
adamc@292	77
adamc@196	78 fun monoType env =
adamc@25	79 let
adamc@196	80 fun mt env dtmap (all as (c, loc)) =
adamc@196	81 let
adamc@196	82 fun poly () =
adamc@196	83 (E.errorAt loc "Unsupported type constructor";
adamc@196	84 Print.eprefaces' [("Constructor", CorePrint.p_con env all)];
adamc@196	85 dummyTyp)
adamc@196	86 in
adamc@196	87 case c of
adamc@196	88 L.TFun (c1, c2) => (L'.TFun (mt env dtmap c1, mt env dtmap c2), loc)
adamc@196	89 \| L.TCFun _ => poly ()
adamc@196	90 \| L.TRecord (L.CRecord ((L.KType, _), xcs), _) =>
adamc@196	91 (L'.TRecord (map (fn (x, t) => (monoName env x, mt env dtmap t)) xcs), loc)
adamc@196	92 \| L.TRecord _ => poly ()
adamc@196	93
adamc@288	94 \| L.CApp ((L.CFfi ("Basis", "option"), _), t) =>
adamc@288	95 (L'.TOption (mt env dtmap t), loc)
adamc@288	96
adamc@387	97 \| L.CApp ((L.CFfi ("Basis", "eq"), _), t) =>
adamc@387	98 let
adamc@387	99 val t = mt env dtmap t
adamc@387	100 in
adamc@387	101 (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)
adamc@387	102 end
adamc@389	103 \| L.CApp ((L.CFfi ("Basis", "num"), _), t) =>
adamc@389	104 let
adamc@389	105 val t = mt env dtmap t
adamc@389	106 in
adamc@417	107 (L'.TRecord [("Zero", t),
adamc@417	108 ("Neg", (L'.TFun (t, t), loc)),
adamc@389	109 ("Plus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	110 ("Minus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	111 ("Times", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	112 ("Div", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	113 ("Mod", (L'.TFun (t, (L'.TFun (t, t), loc)), loc))],
adamc@389	114 loc)
adamc@389	115 end
adamc@391	116 \| L.CApp ((L.CFfi ("Basis", "ord"), _), t) =>
adamc@391	117 let
adamc@391	118 val t = mt env dtmap t
adamc@391	119 in
adamc@391	120 (L'.TRecord [("Lt", (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)),
adamc@391	121 ("Le", (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc))],
adamc@391	122 loc)
adamc@391	123 end
adamc@286	124 \| L.CApp ((L.CFfi ("Basis", "show"), _), t) =>
adamc@286	125 (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
adamc@290	126 \| L.CApp ((L.CFfi ("Basis", "read"), _), t) =>
adamc@292	127 readType (mt env dtmap t, loc)
adamc@286	128
adamc@196	129 \| L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) =>
adamc@196	130 (L'.TFfi ("Basis", "string"), loc)
adamc@196	131 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) =>
adamc@196	132 (L'.TFfi ("Basis", "string"), loc)
adamc@196	133
adamc@251	134 \| L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
adamc@252	135 (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc)
adamc@565	136 \| L.CApp ((L.CFfi ("Basis", "source"), _), t) =>
adamc@577	137 (L'.TSource, loc)
adamc@568	138 \| L.CApp ((L.CFfi ("Basis", "signal"), _), t) =>
adamc@568	139 (L'.TSignal (mt env dtmap t), loc)
adamc@462	140 \| L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) =>
adamc@462	141 (L'.TFfi ("Basis", "string"), loc)
adamc@705	142 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_table"), _), _), _), _) =>
adamc@252	143 (L'.TFfi ("Basis", "string"), loc)
adamc@338	144 \| L.CFfi ("Basis", "sql_sequence") =>
adamc@338	145 (L'.TFfi ("Basis", "string"), loc)
adamc@252	146 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query"), _), _), _), _) =>
adamc@252	147 (L'.TFfi ("Basis", "string"), loc)
adamc@252	148 \| L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query1"), _), _), _), _), _), _) =>
adamc@252	149 (L'.TFfi ("Basis", "string"), loc)
adamc@252	150 \| L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _) =>
adamc@252	151 (L'.TFfi ("Basis", "string"), loc)
adamc@704	152 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraints"), _), _), _), _) =>
adamc@704	153 (L'.TFfi ("Basis", "sql_constraints"), loc)
adamc@705	154 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraint"), _), _), _), _) =>
adamc@704	155 (L'.TFfi ("Basis", "string"), loc)
adamc@252	156
adamc@252	157 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_subset"), _), _), _), _) =>
adamc@252	158 (L'.TRecord [], loc)
adamc@252	159 \| L.CFfi ("Basis", "sql_relop") =>
adamc@252	160 (L'.TFfi ("Basis", "string"), loc)
adamc@252	161 \| L.CFfi ("Basis", "sql_direction") =>
adamc@252	162 (L'.TFfi ("Basis", "string"), loc)
adamc@252	163 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_order_by"), _), _), _), _) =>
adamc@252	164 (L'.TFfi ("Basis", "string"), loc)
adamc@252	165 \| L.CFfi ("Basis", "sql_limit") =>
adamc@252	166 (L'.TFfi ("Basis", "string"), loc)
adamc@252	167 \| L.CFfi ("Basis", "sql_offset") =>
adamc@252	168 (L'.TFfi ("Basis", "string"), loc)
adamc@252	169
adamc@676	170 \| L.CApp ((L.CFfi ("Basis", "sql_injectable_prim"), _), t) =>
adamc@676	171 (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
adamc@252	172 \| L.CApp ((L.CFfi ("Basis", "sql_injectable"), _), t) =>
adamc@252	173 (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
adamc@252	174 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_unary"), _), _), _), _) =>
adamc@252	175 (L'.TFfi ("Basis", "string"), loc)
adamc@252	176 \| L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_binary"), _), _), _), _), _), _) =>
adamc@252	177 (L'.TFfi ("Basis", "string"), loc)
adamc@252	178 \| L.CApp ((L.CFfi ("Basis", "sql_aggregate"), _), t) =>
adamc@252	179 (L'.TFfi ("Basis", "string"), loc)
adamc@252	180 \| L.CApp ((L.CFfi ("Basis", "sql_summable"), _), _) =>
adamc@252	181 (L'.TRecord [], loc)
adamc@252	182 \| L.CApp ((L.CFfi ("Basis", "sql_maxable"), _), _) =>
adamc@252	183 (L'.TRecord [], loc)
adamc@559	184 \| L.CApp ((L.CFfi ("Basis", "sql_arith"), _), _) =>
adamc@559	185 (L'.TRecord [], loc)
adamc@441	186 \| L.CApp ((L.CFfi ("Basis", "sql_nfunc"), _), _) =>
adamc@441	187 (L'.TFfi ("Basis", "string"), loc)
adamc@251	188
adamc@668	189 \| L.CApp ((L.CFfi ("Basis", "channel"), _), _) =>
adamc@668	190 (L'.TFfi ("Basis", "channel"), loc)
adamc@668	191
adamc@196	192 \| L.CRel _ => poly ()
adamc@196	193 \| L.CNamed n =>
adamc@196	194 (case IM.find (dtmap, n) of
adamc@196	195 SOME r => (L'.TDatatype (n, r), loc)
adamc@196	196 \| NONE =>
adamc@196	197 let
adamc@196	198 val r = ref (L'.Default, [])
adamc@196	199 val (_, xs, xncs) = Env.lookupDatatype env n
adamc@196	200
adamc@196	201 val dtmap' = IM.insert (dtmap, n, r)
adamc@196	202
adamc@196	203 val xncs = map (fn (x, n, to) => (x, n, Option.map (mt env dtmap') to)) xncs
adamc@196	204 in
adamc@196	205 case xs of
adamc@198	206 [] =>(r := (ElabUtil.classifyDatatype xncs, xncs);
adamc@196	207 (L'.TDatatype (n, r), loc))
adamc@196	208 \| _ => poly ()
adamc@196	209 end)
adamc@196	210 \| L.CFfi mx => (L'.TFfi mx, loc)
adamc@196	211 \| L.CApp _ => poly ()
adamc@196	212 \| L.CAbs _ => poly ()
adamc@196	213
adamc@196	214 \| L.CName _ => poly ()
adamc@196	215
adamc@196	216 \| L.CRecord _ => poly ()
adamc@196	217 \| L.CConcat _ => poly ()
adamc@621	218 \| L.CMap _ => poly ()
adamc@196	219 \| L.CUnit => poly ()
adamc@214	220
adamc@214	221 \| L.CTuple _ => poly ()
adamc@214	222 \| L.CProj _ => poly ()
adamc@626	223
adamc@626	224 \| L.CKAbs _ => poly ()
adamc@626	225 \| L.CKApp _ => poly ()
adamc@626	226 \| L.TKFun _ => poly ()
adamc@196	227 end
adamc@25	228 in
adamc@196	229 mt env IM.empty
adamc@25	230 end
adamc@25	231
adamc@25	232 val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan)
adamc@25	233
adamc@179	234 structure IM = IntBinaryMap
adamc@179	235
adamc@179	236 datatype foo_kind =
adamc@179	237 Attr
adamc@179	238 \| Url
adamc@179	239
adamc@179	240 fun fk2s fk =
adamc@179	241 case fk of
adamc@179	242 Attr => "attr"
adamc@179	243 \| Url => "url"
adamc@179	244
adamc@179	245 structure Fm :> sig
adamc@179	246 type t
adamc@179	247
adamc@179	248 val empty : int -> t
adamc@179	249
adamc@179	250 val lookup : t -> foo_kind -> int -> (int -> t -> L'.decl * t) -> t * int
adamc@179	251 val enter : t -> t
adamc@179	252 val decls : t -> L'.decl list
adamc@683	253
adamc@683	254 val freshName : t -> int * t
adamc@179	255 end = struct
adamc@179	256
adamc@179	257 structure M = BinaryMapFn(struct
adamc@179	258 type ord_key = foo_kind
adamc@179	259 fun compare x =
adamc@179	260 case x of
adamc@179	261 (Attr, Attr) => EQUAL
adamc@179	262 \| (Attr, _) => LESS
adamc@179	263 \| (_, Attr) => GREATER
adamc@179	264
adamc@179	265 \| (Url, Url) => EQUAL
adamc@179	266 end)
adamc@179	267
adamc@179	268 type t = {
adamc@179	269 count : int,
adamc@179	270 map : int IM.map M.map,
adamc@179	271 decls : L'.decl list
adamc@179	272 }
adamc@179	273
adamc@179	274 fun empty count = {
adamc@179	275 count = count,
adamc@179	276 map = M.empty,
adamc@179	277 decls = []
adamc@179	278 }
adamc@179	279
adamc@179	280 fun enter ({count, map, ...} : t) = {count = count, map = map, decls = []}
adamc@683	281 fun freshName {count, map, decls} = (count, {count = count + 1, map = map, decls = decls})
adamc@179	282 fun decls ({decls, ...} : t) = decls
adamc@179	283
adamc@179	284 fun lookup (t as {count, map, decls}) k n thunk =
adamc@120	285 let
adamc@179	286 val im = Option.getOpt (M.find (map, k), IM.empty)
adamc@179	287 in
adamc@179	288 case IM.find (im, n) of
adamc@179	289 NONE =>
adamc@179	290 let
adamc@179	291 val n' = count
adamc@179	292 val (d, {count, map, decls}) = thunk count {count = count + 1,
adamc@179	293 map = M.insert (map, k, IM.insert (im, n, n')),
adamc@179	294 decls = decls}
adamc@179	295 in
adamc@179	296 ({count = count,
adamc@179	297 map = map,
adamc@179	298 decls = d :: decls}, n')
adamc@179	299 end
adamc@179	300 \| SOME n' => (t, n')
adamc@179	301 end
adamc@179	302
adamc@179	303 end
adamc@185	304
adamc@185	305
adamc@185	306 fun capitalize s =
adamc@185	307 if s = "" then
adamc@185	308 s
adamc@185	309 else
adamc@185	310 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
adamc@179	311
adamc@179	312 fun fooifyExp fk env =
adamc@179	313 let
adamc@179	314 fun fooify fm (e, tAll as (t, loc)) =
adamc@120	315 case #1 e of
adamc@120	316 L'.EClosure (fnam, [(L'.ERecord [], _)]) =>
adamc@120	317 let
adamc@120	318 val (_, _, _, s) = Env.lookupENamed env fnam
adamc@120	319 in
adamc@385	320 ((L'.EPrim (Prim.String (!urlPrefix ^ s)), loc), fm)
adamc@120	321 end
adamc@120	322 \| L'.EClosure (fnam, args) =>
adamc@120	323 let
adamc@120	324 val (_, ft, _, s) = Env.lookupENamed env fnam
adamc@120	325 val ft = monoType env ft
adamc@111	326
adamc@179	327 fun attrify (args, ft, e, fm) =
adamc@120	328 case (args, ft) of
adamc@179	329 ([], _) => (e, fm)
adamc@120	330 \| (arg :: args, (L'.TFun (t, ft), _)) =>
adamc@179	331 let
adamc@179	332 val (arg', fm) = fooify fm (arg, t)
adamc@179	333 in
adamc@179	334 attrify (args, ft,
adamc@179	335 (L'.EStrcat (e,
adamc@179	336 (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc),
adamc@179	337 arg'), loc)), loc),
adamc@179	338 fm)
adamc@179	339 end
adamc@120	340 \| _ => (E.errorAt loc "Type mismatch encoding attribute";
adamc@179	341 (e, fm))
adamc@120	342 in
adamc@385	343 attrify (args, ft, (L'.EPrim (Prim.String (!urlPrefix ^ s)), loc), fm)
adamc@120	344 end
adamc@120	345 \| _ =>
adamc@120	346 case t of
adamc@185	347 L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [e]), loc), fm)
adamc@200	348
adamc@179	349 \| L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm)
adamc@200	350 \| L'.TRecord ((x, t) :: xts) =>
adamc@200	351 let
adamc@200	352 val (se, fm) = fooify fm ((L'.EField (e, x), loc), t)
adamc@200	353 in
adamc@200	354 foldl (fn ((x, t), (se, fm)) =>
adamc@200	355 let
adamc@200	356 val (se', fm) = fooify fm ((L'.EField (e, x), loc), t)
adamc@200	357 in
adamc@200	358 ((L'.EStrcat (se,
adamc@200	359 (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc),
adamc@200	360 se'), loc)), loc),
adamc@200	361 fm)
adamc@200	362 end) (se, fm) xts
adamc@200	363 end
adamc@111	364
adamc@196	365 \| L'.TDatatype (i, ref (dk, _)) =>
adamc@179	366 let
adamc@179	367 fun makeDecl n fm =
adamc@179	368 let
adamc@193	369 val (x, _, xncs) = Env.lookupDatatype env i
adamc@179	370
adamc@179	371 val (branches, fm) =
adamc@179	372 ListUtil.foldlMap
adamc@179	373 (fn ((x, n, to), fm) =>
adamc@179	374 case to of
adamc@179	375 NONE =>
adamc@188	376 (((L'.PCon (dk, L'.PConVar n, NONE), loc),
adamc@179	377 (L'.EPrim (Prim.String x), loc)),
adamc@179	378 fm)
adamc@179	379 \| SOME t =>
adamc@179	380 let
adamc@182	381 val t = monoType env t
adamc@182	382 val (arg, fm) = fooify fm ((L'.ERel 0, loc), t)
adamc@179	383 in
adamc@188	384 (((L'.PCon (dk, L'.PConVar n, SOME (L'.PVar ("a", t), loc)), loc),
adamc@179	385 (L'.EStrcat ((L'.EPrim (Prim.String (x ^ "/")), loc),
adamc@179	386 arg), loc)),
adamc@179	387 fm)
adamc@179	388 end)
adamc@179	389 fm xncs
adamc@179	390
adamc@179	391 val dom = tAll
adamc@179	392 val ran = (L'.TFfi ("Basis", "string"), loc)
adamc@179	393 in
adamc@179	394 ((L'.DValRec [(fk2s fk ^ "ify_" ^ x,
adamc@179	395 n,
adamc@179	396 (L'.TFun (dom, ran), loc),
adamc@179	397 (L'.EAbs ("x",
adamc@179	398 dom,
adamc@179	399 ran,
adamc@179	400 (L'.ECase ((L'.ERel 0, loc),
adamc@179	401 branches,
adamc@182	402 {disc = dom,
adamc@182	403 result = ran}), loc)), loc),
adamc@179	404 "")], loc),
adamc@179	405 fm)
adamc@179	406 end
adamc@179	407
adamc@179	408 val (fm, n) = Fm.lookup fm fk i makeDecl
adamc@179	409 in
adamc@179	410 ((L'.EApp ((L'.ENamed n, loc), e), loc), fm)
adamc@179	411 end
adamc@164	412
adamc@471	413 \| L'.TOption t =>
adamc@471	414 let
adamc@471	415 val (body, fm) = fooify fm ((L'.ERel 0, loc), t)
adamc@471	416 in
adamc@471	417 ((L'.ECase (e,
adamc@471	418 [((L'.PNone t, loc),
adamc@471	419 (L'.EPrim (Prim.String "None"), loc)),
adamc@471	420
adamc@471	421 ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc),
adamc@471	422 (L'.EStrcat ((L'.EPrim (Prim.String "Some/"), loc),
adamc@471	423 body), loc))],
adamc@471	424 {disc = tAll,
adamc@471	425 result = (L'.TFfi ("Basis", "string"), loc)}), loc),
adamc@471	426 fm)
adamc@471	427 end
adamc@471	428
adamc@490	429 \| _ => (E.errorAt loc "Don't know how to encode attribute/URL type";
adamc@120	430 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
adamc@179	431 (dummyExp, fm))
adamc@120	432 in
adamc@120	433 fooify
adamc@120	434 end
adamc@120	435
adamc@179	436 val attrifyExp = fooifyExp Attr
adamc@179	437 val urlifyExp = fooifyExp Url
adamc@105	438
adamc@143	439 datatype 'a failable_search =
adamc@143	440 Found of 'a
adamc@143	441 \| NotFound
adamc@143	442 \| Error
adamc@143	443
adamc@153	444 structure St :> sig
adamc@153	445 type t
adamc@153	446
adamc@153	447 val empty : t
adamc@153	448
adamc@153	449 val radioGroup : t -> string option
adamc@153	450 val setRadioGroup : t * string -> t
adamc@153	451 end = struct
adamc@153	452
adamc@153	453 type t = {
adamc@153	454 radioGroup : string option
adamc@153	455 }
adamc@153	456
adamc@153	457 val empty = {radioGroup = NONE}
adamc@153	458
adamc@153	459 fun radioGroup (t : t) = #radioGroup t
adamc@153	460
adamc@153	461 fun setRadioGroup (t : t, x) = {radioGroup = SOME x}
adamc@153	462
adamc@153	463 end
adamc@153	464
adamc@186	465 fun monoPatCon env pc =
adamc@178	466 case pc of
adamc@178	467 L.PConVar n => L'.PConVar n
adamc@188	468 \| L.PConFfi {mod = m, datatyp, con, arg, ...} => L'.PConFfi {mod = m, datatyp = datatyp, con = con,
adamc@188	469 arg = Option.map (monoType env) arg}
adamc@178	470
adamc@193	471 val dummyPat = (L'.PPrim (Prim.Int 0), ErrorMsg.dummySpan)
adamc@193	472
adamc@193	473 fun monoPat env (all as (p, loc)) =
adamc@193	474 let
adamc@193	475 fun poly () =
adamc@193	476 (E.errorAt loc "Unsupported pattern";
adamc@193	477 Print.eprefaces' [("Pattern", CorePrint.p_pat env all)];
adamc@193	478 dummyPat)
adamc@193	479 in
adamc@193	480 case p of
adamc@193	481 L.PWild => (L'.PWild, loc)
adamc@193	482 \| L.PVar (x, t) => (L'.PVar (x, monoType env t), loc)
adamc@193	483 \| L.PPrim p => (L'.PPrim p, loc)
adamc@193	484 \| L.PCon (dk, pc, [], po) => (L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc)
adamc@288	485 \| L.PCon (L.Option, _, [t], NONE) => (L'.PNone (monoType env t), loc)
adamc@288	486 \| L.PCon (L.Option, _, [t], SOME p) => (L'.PSome (monoType env t, monoPat env p), loc)
adamc@193	487 \| L.PCon _ => poly ()
adamc@193	488 \| L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc)
adamc@193	489 end
adamc@178	490
adamc@252	491 fun strcat loc es =
adamc@252	492 case es of
adamc@252	493 [] => (L'.EPrim (Prim.String ""), loc)
adamc@252	494 \| [e] => e
adamc@252	495 \| _ =>
adamc@252	496 let
adamc@252	497 val e2 = List.last es
adamc@252	498 val es = List.take (es, length es - 1)
adamc@252	499 val e1 = List.last es
adamc@252	500 val es = List.take (es, length es - 1)
adamc@252	501 in
adamc@252	502 foldr (fn (e, e') => (L'.EStrcat (e, e'), loc))
adamc@252	503 (L'.EStrcat (e1, e2), loc) es
adamc@252	504 end
adamc@252	505
adamc@252	506 fun strcatComma loc es =
adamc@252	507 case es of
adamc@252	508 [] => (L'.EPrim (Prim.String ""), loc)
adamc@252	509 \| [e] => e
adamc@252	510 \| _ =>
adamc@252	511 let
adamc@252	512 val e1 = List.last es
adamc@252	513 val es = List.take (es, length es - 1)
adamc@252	514 in
adamc@252	515 foldr (fn (e, e') =>
adamc@265	516 case (e, e') of
adamc@265	517 ((L'.EPrim (Prim.String ""), _), _) => e'
adamc@265	518 \| (_, (L'.EPrim (Prim.String ""), _)) => e
adamc@252	519 \| _ =>
adamc@252	520 (L'.EStrcat (e,
adamc@252	521 (L'.EStrcat ((L'.EPrim (Prim.String ", "), loc), e'), loc)), loc))
adamc@252	522 e1 es
adamc@252	523 end
adamc@252	524
adamc@252	525 fun strcatR loc e xs = strcatComma loc (map (fn (x, _) => (L'.EField (e, x), loc)) xs)
adamc@252	526
adamc@179	527 fun monoExp (env, st, fm) (all as (e, loc)) =
adamc@25	528 let
adamc@598	529 val strcat = strcat loc
adamc@598	530 val strcatComma = strcatComma loc
adamc@598	531 fun str s = (L'.EPrim (Prim.String s), loc)
adamc@598	532
adamc@25	533 fun poly () =
adamc@25	534 (E.errorAt loc "Unsupported expression";
adamc@25	535 Print.eprefaces' [("Expression", CorePrint.p_exp env all)];
adamc@179	536 (dummyExp, fm))
adamc@389	537
adamc@389	538 fun numTy t =
adamc@417	539 (L'.TRecord [("Zero", t),
adamc@417	540 ("Neg", (L'.TFun (t, t), loc)),
adamc@389	541 ("Plus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	542 ("Minus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	543 ("Times", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	544 ("Div", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	545 ("Mod", (L'.TFun (t, (L'.TFun (t, t), loc)), loc))], loc)
adamc@417	546 fun numEx (t, zero, neg, plus, minus, times, dv, md) =
adamc@417	547 ((L'.ERecord [("Zero", (L'.EPrim zero, loc), t),
adamc@417	548 ("Neg", neg, (L'.TFun (t, t), loc)),
adamc@389	549 ("Plus", plus, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	550 ("Minus", minus, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	551 ("Times", times, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	552 ("Div", dv, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	553 ("Mod", md, (L'.TFun (t, (L'.TFun (t, t), loc)), loc))], loc), fm)
adamc@391	554
adamc@391	555 fun ordTy t =
adamc@391	556 (L'.TRecord [("Lt", (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)),
adamc@391	557 ("Le", (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc))], loc)
adamc@391	558 fun ordEx (t, lt, le) =
adamc@391	559 ((L'.ERecord [("Lt", lt, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)),
adamc@391	560 ("Le", le, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc))],
adamc@391	561 loc), fm)
adamc@25	562 in
adamc@25	563 case e of
adamc@179	564 L.EPrim p => ((L'.EPrim p, loc), fm)
adamc@179	565 \| L.ERel n => ((L'.ERel n, loc), fm)
adamc@179	566 \| L.ENamed n => ((L'.ENamed n, loc), fm)
adamc@193	567 \| L.ECon (dk, pc, [], eo) =>
adamc@193	568 let
adamc@179	569 val (eo, fm) =
adamc@179	570 case eo of
adamc@179	571 NONE => (NONE, fm)
adamc@179	572 \| SOME e =>
adamc@179	573 let
adamc@179	574 val (e, fm) = monoExp (env, st, fm) e
adamc@179	575 in
adamc@179	576 (SOME e, fm)
adamc@179	577 end
adamc@179	578 in
adamc@188	579 ((L'.ECon (dk, monoPatCon env pc, eo), loc), fm)
adamc@193	580 end
adamc@297	581 \| L.ECon (L.Option, _, [t], NONE) =>
adamc@297	582 ((L'.ENone (monoType env t), loc), fm)
adamc@297	583 \| L.ECon (L.Option, _, [t], SOME e) =>
adamc@297	584 let
adamc@297	585 val (e, fm) = monoExp (env, st, fm) e
adamc@297	586 in
adamc@297	587 ((L'.ESome (monoType env t, e), loc), fm)
adamc@297	588 end
adamc@193	589 \| L.ECon _ => poly ()
adamc@94	590
adamc@387	591 \| L.ECApp ((L.EFfi ("Basis", "eq"), _), t) =>
adamc@387	592 let
adamc@387	593 val t = monoType env t
adamc@387	594 val b = (L'.TFfi ("Basis", "bool"), loc)
adamc@387	595 val dom = (L'.TFun (t, (L'.TFun (t, b), loc)), loc)
adamc@387	596 in
adamc@387	597 ((L'.EAbs ("f", dom, dom,
adamc@387	598 (L'.ERel 0, loc)), loc), fm)
adamc@387	599 end
adamc@387	600 \| L.ECApp ((L.EFfi ("Basis", "ne"), _), t) =>
adamc@387	601 let
adamc@387	602 val t = monoType env t
adamc@387	603 val b = (L'.TFfi ("Basis", "bool"), loc)
adamc@387	604 val dom = (L'.TFun (t, (L'.TFun (t, b), loc)), loc)
adamc@387	605 in
adamc@387	606 ((L'.EAbs ("f", dom, dom,
adamc@387	607 (L'.EAbs ("x", t, (L'.TFun (t, b), loc),
adamc@387	608 (L'.EAbs ("y", t, b,
adamc@387	609 (L'.EUnop ("!", (L'.EApp ((L'.EApp ((L'.ERel 2, loc),
adamc@387	610 (L'.ERel 1, loc)), loc),
adamc@387	611 (L'.ERel 0, loc)), loc)), loc)),
adamc@387	612 loc)),
adamc@387	613 loc)),
adamc@387	614 loc), fm)
adamc@387	615 end
adamc@387	616 \| L.EFfi ("Basis", "eq_int") =>
adamc@387	617 ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc),
adamc@387	618 (L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@387	619 (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc),
adamc@387	620 (L'.TFfi ("Basis", "bool"), loc),
adamc@387	621 (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
adamc@387	622 fm)
adamc@394	623 \| L.EFfi ("Basis", "eq_float") =>
adamc@394	624 ((L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc),
adamc@394	625 (L'.TFun ((L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@394	626 (L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc),
adamc@394	627 (L'.TFfi ("Basis", "bool"), loc),
adamc@394	628 (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
adamc@394	629 fm)
adamc@388	630 \| L.EFfi ("Basis", "eq_bool") =>
adamc@388	631 ((L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc),
adamc@388	632 (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@388	633 (L'.EAbs ("y", (L'.TFfi ("Basis", "bool"), loc),
adamc@388	634 (L'.TFfi ("Basis", "bool"), loc),
adamc@388	635 (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
adamc@388	636 fm)
adamc@388	637 \| L.EFfi ("Basis", "eq_string") =>
adamc@388	638 ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc),
adamc@388	639 (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@388	640 (L'.EAbs ("y", (L'.TFfi ("Basis", "string"), loc),
adamc@388	641 (L'.TFfi ("Basis", "bool"), loc),
adamc@388	642 (L'.EBinop ("!strcmp", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
adamc@388	643 fm)
adamc@437	644 \| L.EFfi ("Basis", "eq_time") =>
adamc@437	645 ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc),
adamc@437	646 (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@437	647 (L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc),
adamc@437	648 (L'.TFfi ("Basis", "bool"), loc),
adamc@437	649 (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
adamc@437	650 fm)
adamc@422	651 \| L.ECApp ((L.EFfi ("Basis", "mkEq"), _), t) =>
adamc@422	652 let
adamc@422	653 val t = monoType env t
adamc@422	654 val b = (L'.TFfi ("Basis", "bool"), loc)
adamc@422	655 val dom = (L'.TFun (t, (L'.TFun (t, b), loc)), loc)
adamc@422	656 in
adamc@422	657 ((L'.EAbs ("f", dom, dom,
adamc@422	658 (L'.ERel 0, loc)), loc), fm)
adamc@422	659 end
adamc@387	660
adamc@417	661 \| L.ECApp ((L.EFfi ("Basis", "zero"), _), t) =>
adamc@417	662 let
adamc@417	663 val t = monoType env t
adamc@417	664 in
adamc@417	665 ((L'.EAbs ("r", numTy t, t,
adamc@417	666 (L'.EField ((L'.ERel 0, loc), "Zero"), loc)), loc), fm)
adamc@417	667 end
adamc@389	668 \| L.ECApp ((L.EFfi ("Basis", "neg"), _), t) =>
adamc@389	669 let
adamc@389	670 val t = monoType env t
adamc@389	671 in
adamc@389	672 ((L'.EAbs ("r", numTy t, (L'.TFun (t, t), loc),
adamc@389	673 (L'.EField ((L'.ERel 0, loc), "Neg"), loc)), loc), fm)
adamc@389	674 end
adamc@389	675 \| L.ECApp ((L.EFfi ("Basis", "plus"), _), t) =>
adamc@389	676 let
adamc@389	677 val t = monoType env t
adamc@389	678 in
adamc@389	679 ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
adamc@389	680 (L'.EField ((L'.ERel 0, loc), "Plus"), loc)), loc), fm)
adamc@389	681 end
adamc@389	682 \| L.ECApp ((L.EFfi ("Basis", "minus"), _), t) =>
adamc@389	683 let
adamc@389	684 val t = monoType env t
adamc@389	685 in
adamc@389	686 ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
adamc@389	687 (L'.EField ((L'.ERel 0, loc), "Minus"), loc)), loc), fm)
adamc@389	688 end
adamc@389	689 \| L.ECApp ((L.EFfi ("Basis", "times"), _), t) =>
adamc@389	690 let
adamc@389	691 val t = monoType env t
adamc@389	692 in
adamc@389	693 ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
adamc@389	694 (L'.EField ((L'.ERel 0, loc), "Times"), loc)), loc), fm)
adamc@389	695 end
adamc@389	696 \| L.ECApp ((L.EFfi ("Basis", "div"), _), t) =>
adamc@389	697 let
adamc@389	698 val t = monoType env t
adamc@389	699 in
adamc@389	700 ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
adamc@389	701 (L'.EField ((L'.ERel 0, loc), "Div"), loc)), loc), fm)
adamc@389	702 end
adamc@389	703 \| L.ECApp ((L.EFfi ("Basis", "mod"), _), t) =>
adamc@389	704 let
adamc@389	705 val t = monoType env t
adamc@389	706 in
adamc@389	707 ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
adamc@389	708 (L'.EField ((L'.ERel 0, loc), "Mod"), loc)), loc), fm)
adamc@389	709 end
adamc@389	710 \| L.EFfi ("Basis", "num_int") =>
adamc@389	711 let
adamc@389	712 fun intBin s =
adamc@389	713 (L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc),
adamc@389	714 (L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "int"), loc)), loc),
adamc@389	715 (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc),
adamc@389	716 (L'.TFfi ("Basis", "int"), loc),
adamc@389	717 (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
adamc@389	718 in
adamc@389	719 numEx ((L'.TFfi ("Basis", "int"), loc),
adamc@417	720 Prim.Int (Int64.fromInt 0),
adamc@389	721 (L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc),
adamc@389	722 (L'.TFfi ("Basis", "int"), loc),
adamc@389	723 (L'.EUnop ("-", (L'.ERel 0, loc)), loc)), loc),
adamc@389	724 intBin "+",
adamc@389	725 intBin "-",
adamc@389	726 intBin "*",
adamc@389	727 intBin "/",
adamc@389	728 intBin "%")
adamc@389	729 end
adamc@390	730 \| L.EFfi ("Basis", "num_float") =>
adamc@390	731 let
adamc@390	732 fun floatBin s =
adamc@390	733 (L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc),
adamc@390	734 (L'.TFun ((L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "float"), loc)), loc),
adamc@390	735 (L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc),
adamc@390	736 (L'.TFfi ("Basis", "float"), loc),
adamc@390	737 (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
adamc@390	738 in
adamc@390	739 numEx ((L'.TFfi ("Basis", "float"), loc),
adamc@417	740 Prim.Float 0.0,
adamc@390	741 (L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc),
adamc@390	742 (L'.TFfi ("Basis", "float"), loc),
adamc@390	743 (L'.EUnop ("-", (L'.ERel 0, loc)), loc)), loc),
adamc@390	744 floatBin "+",
adamc@390	745 floatBin "-",
adamc@390	746 floatBin "*",
adamc@390	747 floatBin "/",
adamc@390	748 floatBin "fmod")
adamc@390	749 end
adamc@391	750
adamc@391	751 \| L.ECApp ((L.EFfi ("Basis", "lt"), _), t) =>
adamc@391	752 let
adamc@391	753 val t = monoType env t
adamc@391	754 in
adamc@391	755 ((L'.EAbs ("r", ordTy t, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc),
adamc@391	756 (L'.EField ((L'.ERel 0, loc), "Lt"), loc)), loc), fm)
adamc@391	757 end
adamc@391	758 \| L.ECApp ((L.EFfi ("Basis", "le"), _), t) =>
adamc@391	759 let
adamc@391	760 val t = monoType env t
adamc@391	761 in
adamc@391	762 ((L'.EAbs ("r", ordTy t, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc),
adamc@391	763 (L'.EField ((L'.ERel 0, loc), "Le"), loc)), loc), fm)
adamc@391	764 end
adamc@392	765 \| L.ECApp ((L.EFfi ("Basis", "gt"), _), t) =>
adamc@392	766 let
adamc@392	767 val t = monoType env t
adamc@392	768 val b = (L'.TFfi ("Basis", "bool"), loc)
adamc@392	769 in
adamc@392	770 ((L'.EAbs ("f", ordTy t, (L'.TFun (t, (L'.TFun (t, b), loc)), loc),
adamc@392	771 (L'.EAbs ("x", t, (L'.TFun (t, b), loc),
adamc@392	772 (L'.EAbs ("y", t, b,
adamc@392	773 (L'.EUnop ("!",
adamc@392	774 (L'.EApp ((L'.EApp ((L'.EField ((L'.ERel 2, loc),
adamc@392	775 "Le"), loc),
adamc@392	776 (L'.ERel 1, loc)), loc),
adamc@392	777 (L'.ERel 0, loc)), loc)), loc)), loc)),
adamc@392	778 loc)),
adamc@392	779 loc), fm)
adamc@392	780 end
adamc@392	781 \| L.ECApp ((L.EFfi ("Basis", "ge"), _), t) =>
adamc@392	782 let
adamc@392	783 val t = monoType env t
adamc@392	784 val b = (L'.TFfi ("Basis", "bool"), loc)
adamc@392	785 in
adamc@392	786 ((L'.EAbs ("f", ordTy t, (L'.TFun (t, (L'.TFun (t, b), loc)), loc),
adamc@392	787 (L'.EAbs ("x", t, (L'.TFun (t, b), loc),
adamc@392	788 (L'.EAbs ("y", t, b,
adamc@392	789 (L'.EUnop ("!",
adamc@392	790 (L'.EApp ((L'.EApp ((L'.EField ((L'.ERel 2, loc),
adamc@392	791 "Lt"), loc),
adamc@392	792 (L'.ERel 1, loc)), loc),
adamc@392	793 (L'.ERel 0, loc)), loc)), loc)), loc)),
adamc@392	794 loc)),
adamc@392	795 loc), fm)
adamc@392	796 end
adamc@391	797 \| L.EFfi ("Basis", "ord_int") =>
adamc@391	798 let
adamc@391	799 fun intBin s =
adamc@391	800 (L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc),
adamc@391	801 (L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@391	802 (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc),
adamc@391	803 (L'.TFfi ("Basis", "bool"), loc),
adamc@391	804 (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
adamc@391	805 in
adamc@391	806 ordEx ((L'.TFfi ("Basis", "int"), loc),
adamc@391	807 intBin "<",
adamc@391	808 intBin "<=")
adamc@391	809 end
adamc@394	810 \| L.EFfi ("Basis", "ord_float") =>
adamc@394	811 let
adamc@394	812 fun floatBin s =
adamc@394	813 (L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc),
adamc@394	814 (L'.TFun ((L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@394	815 (L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc),
adamc@394	816 (L'.TFfi ("Basis", "bool"), loc),
adamc@394	817 (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
adamc@394	818 in
adamc@394	819 ordEx ((L'.TFfi ("Basis", "float"), loc),
adamc@394	820 floatBin "<",
adamc@394	821 floatBin "<=")
adamc@394	822 end
adamc@394	823 \| L.EFfi ("Basis", "ord_bool") =>
adamc@394	824 let
adamc@394	825 fun boolBin s =
adamc@394	826 (L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc),
adamc@394	827 (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@394	828 (L'.EAbs ("y", (L'.TFfi ("Basis", "bool"), loc),
adamc@394	829 (L'.TFfi ("Basis", "bool"), loc),
adamc@394	830 (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
adamc@394	831 in
adamc@394	832 ordEx ((L'.TFfi ("Basis", "bool"), loc),
adamc@394	833 boolBin "<",
adamc@394	834 boolBin "<=")
adamc@394	835 end
adamc@395	836 \| L.EFfi ("Basis", "ord_string") =>
adamc@395	837 let
adamc@395	838 fun boolBin s =
adamc@395	839 (L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc),
adamc@395	840 (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@395	841 (L'.EAbs ("y", (L'.TFfi ("Basis", "string"), loc),
adamc@395	842 (L'.TFfi ("Basis", "bool"), loc),
adamc@395	843 (L'.EBinop (s,
adamc@395	844 (L'.EBinop ("strcmp",
adamc@395	845 (L'.ERel 1, loc),
adamc@395	846 (L'.ERel 0, loc)), loc),
adamc@395	847 (L'.EPrim (Prim.Int (Int64.fromInt 0)), loc)), loc)), loc)), loc)
adamc@395	848 in
adamc@395	849 ordEx ((L'.TFfi ("Basis", "string"), loc),
adamc@395	850 boolBin "<",
adamc@395	851 boolBin "<=")
adamc@395	852 end
adamc@437	853 \| L.EFfi ("Basis", "ord_time") =>
adamc@437	854 let
adamc@437	855 fun boolBin s =
adamc@437	856 (L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc),
adamc@437	857 (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@437	858 (L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc),
adamc@437	859 (L'.TFfi ("Basis", "bool"), loc),
adamc@437	860 (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
adamc@437	861 in
adamc@437	862 ordEx ((L'.TFfi ("Basis", "time"), loc),
adamc@437	863 boolBin "<",
adamc@437	864 boolBin "<=")
adamc@437	865 end
adamc@389	866
adamc@286	867 \| L.ECApp ((L.EFfi ("Basis", "show"), _), t) =>
adamc@286	868 let
adamc@286	869 val t = monoType env t
adamc@286	870 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@286	871 in
adamc@286	872 ((L'.EAbs ("f", (L'.TFun (t, s), loc), (L'.TFun (t, s), loc),
adamc@286	873 (L'.ERel 0, loc)), loc), fm)
adamc@286	874 end
adamc@286	875 \| L.EFfi ("Basis", "show_int") =>
adamc@286	876 ((L'.EFfi ("Basis", "intToString"), loc), fm)
adamc@286	877 \| L.EFfi ("Basis", "show_float") =>
adamc@286	878 ((L'.EFfi ("Basis", "floatToString"), loc), fm)
adamc@286	879 \| L.EFfi ("Basis", "show_string") =>
adamc@286	880 let
adamc@286	881 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@286	882 in
adamc@286	883 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm)
adamc@286	884 end
adamc@286	885 \| L.EFfi ("Basis", "show_bool") =>
adamc@286	886 ((L'.EFfi ("Basis", "boolToString"), loc), fm)
adamc@436	887 \| L.EFfi ("Basis", "show_time") =>
adamc@436	888 ((L'.EFfi ("Basis", "timeToString"), loc), fm)
adamc@452	889 \| L.ECApp ((L.EFfi ("Basis", "mkShow"), _), t) =>
adamc@452	890 let
adamc@452	891 val t = monoType env t
adamc@452	892 val b = (L'.TFfi ("Basis", "string"), loc)
adamc@452	893 val dom = (L'.TFun (t, b), loc)
adamc@452	894 in
adamc@452	895 ((L'.EAbs ("f", dom, dom,
adamc@452	896 (L'.ERel 0, loc)), loc), fm)
adamc@452	897 end
adamc@286	898
adamc@290	899 \| L.ECApp ((L.EFfi ("Basis", "read"), _), t) =>
adamc@290	900 let
adamc@290	901 val t = monoType env t
adamc@290	902 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@290	903 in
adamc@292	904 ((L'.EAbs ("f", readType (t, loc), readType' (t, loc),
adamc@292	905 (L'.EField ((L'.ERel 0, loc), "Read"), loc)), loc), fm)
adamc@292	906 end
adamc@292	907 \| L.ECApp ((L.EFfi ("Basis", "readError"), _), t) =>
adamc@292	908 let
adamc@292	909 val t = monoType env t
adamc@292	910 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@292	911 in
adamc@292	912 ((L'.EAbs ("f", readType (t, loc), readErrType (t, loc),
adamc@292	913 (L'.EField ((L'.ERel 0, loc), "ReadError"), loc)), loc), fm)
adamc@290	914 end
adamc@290	915 \| L.EFfi ("Basis", "read_int") =>
adamc@292	916 let
adamc@292	917 val t = (L'.TFfi ("Basis", "int"), loc)
adamc@292	918 in
adamc@292	919 ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToInt"), loc), readType' (t, loc)),
adamc@292	920 ("ReadError", (L'.EFfi ("Basis", "stringToInt_error"), loc), readErrType (t, loc))],
adamc@292	921 loc),
adamc@292	922 fm)
adamc@292	923 end
adamc@290	924 \| L.EFfi ("Basis", "read_float") =>
adamc@292	925 let
adamc@292	926 val t = (L'.TFfi ("Basis", "float"), loc)
adamc@292	927 in
adamc@292	928 ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToFloat"), loc), readType' (t, loc)),
adamc@292	929 ("ReadError", (L'.EFfi ("Basis", "stringToFloat_error"), loc), readErrType (t, loc))],
adamc@292	930 loc),
adamc@292	931 fm)
adamc@292	932 end
adamc@290	933 \| L.EFfi ("Basis", "read_string") =>
adamc@290	934 let
adamc@290	935 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@290	936 in
adamc@292	937 ((L'.ERecord [("Read", (L'.EAbs ("s", s, (L'.TOption s, loc),
adamc@292	938 (L'.ESome (s, (L'.ERel 0, loc)), loc)), loc), readType' (s, loc)),
adamc@292	939 ("ReadError", (L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), readErrType (s, loc))], loc),
adamc@292	940 fm)
adamc@290	941 end
adamc@290	942 \| L.EFfi ("Basis", "read_bool") =>
adamc@292	943 let
adamc@292	944 val t = (L'.TFfi ("Basis", "bool"), loc)
adamc@292	945 in
adamc@292	946 ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToBool"), loc), readType' (t, loc)),
adamc@292	947 ("ReadError", (L'.EFfi ("Basis", "stringToBool_error"), loc), readErrType (t, loc))],
adamc@292	948 loc),
adamc@292	949 fm)
adamc@292	950 end
adamc@436	951 \| L.EFfi ("Basis", "read_time") =>
adamc@436	952 let
adamc@436	953 val t = (L'.TFfi ("Basis", "time"), loc)
adamc@436	954 in
adamc@436	955 ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToTime"), loc), readType' (t, loc)),
adamc@436	956 ("ReadError", (L'.EFfi ("Basis", "stringToTime_error"), loc), readErrType (t, loc))],
adamc@436	957 loc),
adamc@436	958 fm)
adamc@436	959 end
adamc@290	960
adamc@564	961 \| L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), _), _), t), _),
adamc@564	962 (L.EFfi ("Basis", "transaction_monad"), _)) =>
adamc@252	963 let
adamc@252	964 val t = monoType env t
adamc@252	965 in
adamc@252	966 ((L'.EAbs ("x", t,
adamc@252	967 (L'.TFun ((L'.TRecord [], loc), t), loc),
adamc@252	968 (L'.EAbs ("_", (L'.TRecord [], loc), t,
adamc@252	969 (L'.ERel 1, loc)), loc)), loc), fm)
adamc@252	970 end
adamc@564	971 \| L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _),
adamc@564	972 (L.EFfi ("Basis", "transaction_monad"), _)) =>
adamc@251	973 let
adamc@251	974 val t1 = monoType env t1
adamc@251	975 val t2 = monoType env t2
adamc@251	976 val un = (L'.TRecord [], loc)
adamc@252	977 val mt1 = (L'.TFun (un, t1), loc)
adamc@252	978 val mt2 = (L'.TFun (un, t2), loc)
adamc@251	979 in
adamc@572	980 ((L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc)), loc),
adamc@572	981 (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc),
adamc@252	982 (L'.EAbs ("_", un, un,
adamc@252	983 (L'.ELet ("r", t1, (L'.EApp ((L'.ERel 2, loc),
adamc@252	984 (L'.ERecord [], loc)), loc),
adamc@252	985 (L'.EApp (
adamc@252	986 (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc),
adamc@252	987 (L'.ERecord [], loc)),
adamc@252	988 loc)), loc)), loc)), loc)), loc),
adamc@251	989 fm)
adamc@251	990 end
adamc@697	991
adamc@670	992 \| L.EApp ((L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), _), _), t2), _),
adamc@670	993 (L.EFfi ("Basis", "transaction_monad"), _)), _),
adamc@670	994 (L.EApp ((L.ECApp ((L.EFfi ("Basis", "recv"), _), t1), _),
adamc@670	995 ch), loc)) =>
adamc@670	996 let
adamc@670	997 val t1 = monoType env t1
adamc@670	998 val t2 = monoType env t2
adamc@670	999 val un = (L'.TRecord [], loc)
adamc@670	1000 val mt2 = (L'.TFun (un, t2), loc)
adamc@670	1001 val (ch, fm) = monoExp (env, st, fm) ch
adamc@670	1002 in
adamc@670	1003 ((L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc),
adamc@670	1004 (L'.EAbs ("_", un, un,
adamc@670	1005 (L'.ERecv (liftExpInExp 0 (liftExpInExp 0 ch),
adamc@670	1006 (L'.ERel 1, loc),
adamc@670	1007 t1), loc)), loc)), loc),
adamc@670	1008 fm)
adamc@670	1009 end
adamc@697	1010 \| L.EFfiApp ("Basis", "recv", _) => poly ()
adamc@697	1011
adamc@695	1012 \| L.EApp ((L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), _), _), t2), _),
adamc@695	1013 (L.EFfi ("Basis", "transaction_monad"), _)), _),
adamc@695	1014 (L.EAbs (_, _, _,
adamc@695	1015 (L.EFfiApp ("Basis", "sleep", [n]), _)), loc)) =>
adamc@695	1016 let
adamc@695	1017 val t2 = monoType env t2
adamc@695	1018 val un = (L'.TRecord [], loc)
adamc@695	1019 val mt2 = (L'.TFun (un, t2), loc)
adamc@695	1020 val (n, fm) = monoExp (env, st, fm) n
adamc@695	1021 in
adamc@695	1022 ((L'.EAbs ("m2", (L'.TFun (un, mt2), loc), (L'.TFun (un, un), loc),
adamc@695	1023 (L'.EAbs ("_", un, un,
adamc@697	1024 (L'.ESleep (liftExpInExp 0 n, (L'.EApp ((L'.ERel 1, loc),
adamc@695	1025 (L'.ERecord [], loc)), loc)),
adamc@695	1026 loc)), loc)), loc),
adamc@695	1027 fm)
adamc@695	1028 end
adamc@697	1029 \| L.EFfiApp ("Basis", "sleep", _) => poly ()
adamc@251	1030
adamc@565	1031 \| L.ECApp ((L.EFfi ("Basis", "source"), _), t) =>
adamc@565	1032 let
adamc@565	1033 val t = monoType env t
adamc@565	1034 in
adamc@577	1035 ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TSource, loc)), loc),
adamc@577	1036 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TSource, loc),
adamc@577	1037 (L'.EFfiApp ("Basis", "new_client_source",
adamc@590	1038 [(L'.EJavaScript (L'.Source t, (L'.ERel 1, loc), NONE), loc)]),
adamc@578	1039 loc)), loc)),
adamc@565	1040 loc),
adamc@565	1041 fm)
adamc@565	1042 end
adamc@575	1043 \| L.ECApp ((L.EFfi ("Basis", "set"), _), t) =>
adamc@575	1044 let
adamc@575	1045 val t = monoType env t
adamc@575	1046 in
adamc@577	1047 ((L'.EAbs ("src", (L'.TSource, loc),
adamc@575	1048 (L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc)), loc),
adamc@575	1049 (L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc),
adamc@575	1050 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
adamc@575	1051 (L'.EFfiApp ("Basis", "set_client_source",
adamc@577	1052 [(L'.ERel 2, loc),
adamc@590	1053 (L'.EJavaScript (L'.Source t,
adamc@590	1054 (L'.ERel 1, loc), NONE), loc)]),
adamc@575	1055 loc)), loc)), loc)), loc),
adamc@575	1056 fm)
adamc@575	1057 end
adamc@601	1058 \| L.ECApp ((L.EFfi ("Basis", "get"), _), t) =>
adamc@601	1059 let
adamc@601	1060 val t = monoType env t
adamc@601	1061 in
adamc@601	1062 ((L'.EAbs ("src", (L'.TSource, loc),
adamc@601	1063 (L'.TFun ((L'.TRecord [], loc), t), loc),
adamc@601	1064 (L'.EAbs ("_", (L'.TRecord [], loc), t,
adamc@601	1065 (L'.EFfiApp ("Basis", "get_client_source",
adamc@601	1066 [(L'.ERel 1, loc)]),
adamc@601	1067 loc)), loc)), loc),
adamc@601	1068 fm)
adamc@601	1069 end
adamc@565	1070
adamc@694	1071 \| L.EFfiApp ("Basis", "spawn", [e]) =>
adamc@694	1072 let
adamc@694	1073 val (e, fm) = monoExp (env, st, fm) e
adamc@694	1074 in
adamc@694	1075 ((L'.EApp (e, (L'.ERecord [], loc)), loc), fm)
adamc@694	1076 end
adamc@694	1077
adamc@568	1078 \| L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), _), _), t), _),
adamc@568	1079 (L.EFfi ("Basis", "signal_monad"), _)) =>
adamc@568	1080 let
adamc@568	1081 val t = monoType env t
adamc@568	1082 in
adamc@568	1083 ((L'.EAbs ("x", t, (L'.TSignal t, loc),
adamc@568	1084 (L'.ESignalReturn (L'.ERel 0, loc), loc)), loc),
adamc@568	1085 fm)
adamc@568	1086 end
adamc@572	1087 \| L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _),
adamc@572	1088 (L.EFfi ("Basis", "signal_monad"), _)) =>
adamc@572	1089 let
adamc@572	1090 val t1 = monoType env t1
adamc@572	1091 val t2 = monoType env t2
adamc@572	1092 val un = (L'.TRecord [], loc)
adamc@572	1093 val mt1 = (L'.TSignal t1, loc)
adamc@572	1094 val mt2 = (L'.TSignal t2, loc)
adamc@572	1095 in
adamc@572	1096 ((L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), mt2), loc),
adamc@572	1097 (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), mt2,
adamc@572	1098 (L'.ESignalBind ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
adamc@572	1099 fm)
adamc@572	1100 end
adamc@574	1101 \| L.ECApp ((L.EFfi ("Basis", "signal"), _), t) =>
adamc@574	1102 let
adamc@574	1103 val t = monoType env t
adamc@574	1104 in
adamc@574	1105 ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), (L'.TSignal t, loc),
adamc@574	1106 (L'.ESignalSource (L'.ERel 0, loc), loc)), loc),
adamc@574	1107 fm)
adamc@574	1108 end
adamc@568	1109
adamc@462	1110 \| L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) =>
adamc@462	1111 let
adamc@462	1112 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@462	1113 val un = (L'.TRecord [], loc)
adamc@462	1114 val t = monoType env t
adamc@462	1115 in
adamc@462	1116 ((L'.EAbs ("c", s, (L'.TFun (un, s), loc),
adamc@462	1117 (L'.EAbs ("_", un, s,
adamc@463	1118 (L'.EUnurlify ((L'.EFfiApp ("Basis", "get_cookie", [(L'.ERel 1, loc)]), loc),
adamc@463	1119 t),
adamc@463	1120 loc)), loc)), loc),
adamc@462	1121 fm)
adamc@462	1122 end
adamc@462	1123
adamc@462	1124 \| L.ECApp ((L.EFfi ("Basis", "setCookie"), _), t) =>
adamc@462	1125 let
adamc@462	1126 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@462	1127 val un = (L'.TRecord [], loc)
adamc@462	1128 val t = monoType env t
adamc@462	1129 val (e, fm) = urlifyExp env fm ((L'.ERel 1, loc), t)
adamc@462	1130 in
adamc@462	1131 ((L'.EAbs ("c", s, (L'.TFun (t, (L'.TFun (un, un), loc)), loc),
adamc@462	1132 (L'.EAbs ("v", t, (L'.TFun (un, un), loc),
adamc@462	1133 (L'.EAbs ("_", un, un,
adamc@466	1134 (L'.EFfiApp ("Basis", "set_cookie", [(L'.EPrim (Prim.String (!urlPrefix)),
adamc@466	1135 loc),
adamc@466	1136 (L'.ERel 2, loc),
adamc@466	1137 e]), loc)),
adamc@462	1138 loc)), loc)), loc),
adamc@462	1139 fm)
adamc@462	1140 end
adamc@462	1141
adamc@668	1142 \| L.ECApp ((L.EFfi ("Basis", "channel"), _), t) =>
adamc@668	1143 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "channel"), loc),
adamc@668	1144 (L'.EFfiApp ("Basis", "new_channel", [(L'.ERecord [], loc)]), loc)), loc),
adamc@668	1145 fm)
adamc@668	1146 \| L.ECApp ((L.EFfi ("Basis", "send"), _), t) =>
adamc@668	1147 let
adamc@668	1148 val t = monoType env t
adamc@668	1149 val (e, fm) = urlifyExp env fm ((L'.ERel 1, loc), t)
adamc@668	1150 in
adamc@668	1151 ((L'.EAbs ("ch", (L'.TFfi ("Basis", "channel"), loc),
adamc@668	1152 (L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc)), loc),
adamc@668	1153 (L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc),
adamc@668	1154 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
adamc@668	1155 (L'.EFfiApp ("Basis", "send",
adamc@668	1156 [(L'.ERel 2, loc),
adamc@668	1157 e]),
adamc@668	1158 loc)), loc)), loc)), loc),
adamc@668	1159 fm)
adamc@668	1160 end
adamc@668	1161
adamc@704	1162 \| L.ECApp ((L.EFfi ("Basis", "no_constraint"), _), _) =>
adamc@704	1163 ((L'.ERecord [], loc),
adamc@704	1164 fm)
adamc@705	1165 \| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "one_constraint"), _), _), _), _), _), (L.CName name, _)) =>
adamc@704	1166 ((L'.EAbs ("c",
adamc@704	1167 (L'.TFfi ("Basis", "string"), loc),
adamc@704	1168 (L'.TFfi ("Basis", "sql_constraints"), loc),
adamc@704	1169 (L'.ERecord [(name, (L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))], loc)), loc),
adamc@704	1170 fm)
adamc@705	1171 \| L.ECApp (
adamc@705	1172 (L.ECApp (
adamc@705	1173 (L.ECApp (
adamc@705	1174 (L.EFfi ("Basis", "join_constraints"), _),
adamc@705	1175 _), _),
adamc@705	1176 _), _),
adamc@705	1177 _) =>
adamc@704	1178 let
adamc@704	1179 val constraints = (L'.TFfi ("Basis", "sql_constraints"), loc)
adamc@704	1180 in
adamc@704	1181 ((L'.EAbs ("cs1", constraints, (L'.TFun (constraints, constraints), loc),
adamc@704	1182 (L'.EAbs ("cs2", constraints, constraints,
adamc@704	1183 (L'.EStrcat ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
adamc@704	1184 fm)
adamc@704	1185 end
adamc@704	1186
adamc@705	1187 \| L.ECApp (
adamc@705	1188 (L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "unique"), _), _), _), t), _),
adamc@705	1189 nm), _),
adamc@705	1190 (L.CRecord (_, unique), _)) =>
adamc@705	1191 let
adamc@705	1192 val unique = (nm, t) :: unique
adamc@705	1193 in
adamc@705	1194 ((L'.EPrim (Prim.String ("UNIQUE ("
adamc@705	1195 ^ String.concatWith ", " (map (fn (x, _) => "uw_" ^ monoName env x) unique)
adamc@705	1196 ^ ")")), loc),
adamc@705	1197 fm)
adamc@705	1198 end
adamc@704	1199
adamc@307	1200 \| L.EFfiApp ("Basis", "dml", [e]) =>
adamc@307	1201 let
adamc@307	1202 val (e, fm) = monoExp (env, st, fm) e
adamc@307	1203 in
adamc@468	1204 ((L'.EDml e, loc),
adamc@307	1205 fm)
adamc@307	1206 end
adamc@308	1207
adamc@705	1208 \| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "insert"), _), fields), _), _) =>
adamc@307	1209 (case monoType env (L.TRecord fields, loc) of
adamc@307	1210 (L'.TRecord fields, _) =>
adamc@307	1211 let
adamc@307	1212 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@307	1213 val fields = map (fn (x, _) => (x, s)) fields
adamc@307	1214 val rt = (L'.TRecord fields, loc)
adamc@307	1215 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@307	1216 in
adamc@307	1217 ((L'.EAbs ("tab", s, (L'.TFun (rt, s), loc),
adamc@307	1218 (L'.EAbs ("fs", rt, s,
adamc@598	1219 strcat [sc "INSERT INTO ",
adamc@598	1220 (L'.ERel 1, loc),
adamc@598	1221 sc " (",
adamc@598	1222 strcatComma (map (fn (x, _) => sc ("uw_" ^ x)) fields),
adamc@598	1223 sc ") VALUES (",
adamc@598	1224 strcatComma (map (fn (x, _) =>
adamc@598	1225 (L'.EField ((L'.ERel 0, loc),
adamc@598	1226 x), loc)) fields),
adamc@598	1227 sc ")"]), loc)), loc),
adamc@307	1228 fm)
adamc@307	1229 end
adamc@307	1230 \| _ => poly ())
adamc@307	1231
adamc@705	1232 \| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "update"), _), _), _), _), _), changed) =>
adamc@308	1233 (case monoType env (L.TRecord changed, loc) of
adamc@308	1234 (L'.TRecord changed, _) =>
adamc@308	1235 let
adamc@308	1236 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@308	1237 val changed = map (fn (x, _) => (x, s)) changed
adamc@308	1238 val rt = (L'.TRecord changed, loc)
adamc@308	1239 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@308	1240 in
adamc@308	1241 ((L'.EAbs ("fs", rt, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adamc@308	1242 (L'.EAbs ("tab", s, (L'.TFun (s, s), loc),
adamc@308	1243 (L'.EAbs ("e", s, s,
adamc@598	1244 strcat [sc "UPDATE ",
adamc@598	1245 (L'.ERel 1, loc),
adamc@598	1246 sc " AS T SET ",
adamc@598	1247 strcatComma (map (fn (x, _) =>
adamc@598	1248 strcat [sc ("uw_" ^ x
adamc@598	1249 ^ " = "),
adamc@598	1250 (L'.EField
adamc@598	1251 ((L'.ERel 2,
adamc@598	1252 loc),
adamc@598	1253 x), loc)])
adamc@598	1254 changed),
adamc@598	1255 sc " WHERE ",
adamc@598	1256 (L'.ERel 0, loc)]), loc)), loc)), loc),
adamc@308	1257 fm)
adamc@308	1258 end
adamc@308	1259 \| _ => poly ())
adamc@308	1260
adamc@705	1261 \| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "delete"), _), _), _), _) =>
adamc@309	1262 let
adamc@309	1263 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@309	1264 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@309	1265 in
adamc@309	1266 ((L'.EAbs ("tab", s, (L'.TFun (s, s), loc),
adamc@309	1267 (L'.EAbs ("e", s, s,
adamc@598	1268 strcat [sc "DELETE FROM ",
adamc@598	1269 (L'.ERel 1, loc),
adamc@598	1270 sc " AS T WHERE ",
adamc@598	1271 (L'.ERel 0, loc)]), loc)), loc),
adamc@309	1272 fm)
adamc@309	1273 end
adamc@309	1274
adamc@252	1275 \| L.ECApp (
adamc@252	1276 (L.ECApp (
adamc@252	1277 (L.ECApp ((L.EFfi ("Basis", "query"), _), (L.CRecord (_, tables), _)), _),
adamc@252	1278 exps), _),
adamc@252	1279 state) =>
adamc@252	1280 (case monoType env (L.TRecord exps, loc) of
adamc@252	1281 (L'.TRecord exps, _) =>
adamc@252	1282 let
adamc@252	1283 val tables = map (fn ((L.CName x, _), xts) =>
adamc@252	1284 (case monoType env (L.TRecord xts, loc) of
adamc@252	1285 (L'.TRecord xts, _) => SOME (x, xts)
adamc@252	1286 \| _ => NONE)
adamc@252	1287 \| _ => NONE) tables
adamc@252	1288 in
adamc@252	1289 if List.exists (fn x => x = NONE) tables then
adamc@252	1290 poly ()
adamc@252	1291 else
adamc@252	1292 let
adamc@252	1293 val tables = List.mapPartial (fn x => x) tables
adamc@252	1294 val state = monoType env state
adamc@252	1295 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@252	1296 val un = (L'.TRecord [], loc)
adamc@252	1297
adamc@252	1298 val rt = exps @ map (fn (x, xts) => (x, (L'.TRecord xts, loc))) tables
adamc@252	1299 val ft = (L'.TFun ((L'.TRecord rt, loc),
adamc@252	1300 (L'.TFun (state,
adamc@252	1301 (L'.TFun (un, state), loc)),
adamc@252	1302 loc)), loc)
adamc@252	1303
adamc@267	1304 val body' = (L'.EApp (
adamc@267	1305 (L'.EApp (
adamc@267	1306 (L'.EApp ((L'.ERel 4, loc),
adamc@267	1307 (L'.ERel 1, loc)), loc),
adamc@267	1308 (L'.ERel 0, loc)), loc),
adamc@267	1309 (L'.ERecord [], loc)), loc)
adamc@252	1310
adamc@252	1311 val body = (L'.EQuery {exps = exps,
adamc@252	1312 tables = tables,
adamc@252	1313 state = state,
adamc@252	1314 query = (L'.ERel 3, loc),
adamc@252	1315 body = body',
adamc@252	1316 initial = (L'.ERel 1, loc)},
adamc@252	1317 loc)
adamc@252	1318 in
adamc@252	1319 ((L'.EAbs ("q", s, (L'.TFun (ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc)), loc),
adamc@252	1320 (L'.EAbs ("f", ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc),
adamc@252	1321 (L'.EAbs ("i", state, (L'.TFun (un, state), loc),
adamc@252	1322 (L'.EAbs ("_", un, state,
adamc@252	1323 body), loc)), loc)), loc)), loc), fm)
adamc@252	1324 end
adamc@252	1325 end
adamc@252	1326 \| _ => poly ())
adamc@252	1327
adamc@252	1328 \| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_query"), _), _), _), _), _), _) =>
adamc@252	1329 let
adamc@252	1330 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@252	1331 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@252	1332 fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc)
adamc@252	1333 in
adamc@252	1334 ((L'.EAbs ("r",
adamc@252	1335 (L'.TRecord [("Rows", s), ("OrderBy", s), ("Limit", s), ("Offset", s)], loc),
adamc@252	1336 s,
adamc@598	1337 strcat [gf "Rows",
adamc@598	1338 (L'.ECase (gf "OrderBy",
adamc@598	1339 [((L'.PPrim (Prim.String ""), loc), sc ""),
adamc@598	1340 ((L'.PWild, loc),
adamc@598	1341 strcat [sc " ORDER BY ",
adamc@598	1342 gf "OrderBy"])],
adamc@598	1343 {disc = s, result = s}), loc),
adamc@598	1344 gf "Limit",
adamc@598	1345 gf "Offset"]), loc), fm)
adamc@252	1346 end
adamc@252	1347
adamc@252	1348 \| L.ECApp (
adamc@252	1349 (L.ECApp (
adamc@252	1350 (L.ECApp (
adamc@252	1351 (L.ECApp (
adamc@252	1352 (L.EFfi ("Basis", "sql_query1"), _),
adamc@252	1353 (L.CRecord (_, tables), _)), _),
adamc@252	1354 (L.CRecord (_, grouped), _)), _),
adamc@252	1355 (L.CRecord (_, stables), _)), _),
adamc@252	1356 sexps) =>
adamc@252	1357 let
adamc@252	1358 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@252	1359 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@252	1360 val un = (L'.TRecord [], loc)
adamc@252	1361 fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc)
adamc@252	1362
adamc@705	1363 val tables = List.mapPartial
adamc@705	1364 (fn (x, (L.CTuple [y, _], _)) => SOME (x, y)
adamc@705	1365 \| _ => (E.errorAt loc "Bad sql_query1 tables pair";
adamc@705	1366 NONE))
adamc@705	1367 tables
adamc@705	1368
adamc@252	1369 fun doTables tables =
adamc@252	1370 let
adamc@252	1371 val tables = map (fn ((L.CName x, _), xts) =>
adamc@252	1372 (case monoType env (L.TRecord xts, loc) of
adamc@252	1373 (L'.TRecord xts, _) => SOME (x, xts)
adamc@252	1374 \| _ => NONE)
adamc@252	1375 \| _ => NONE) tables
adamc@252	1376 in
adamc@252	1377 if List.exists (fn x => x = NONE) tables then
adamc@252	1378 NONE
adamc@252	1379 else
adamc@260	1380 let
adamc@260	1381 val tables = List.mapPartial (fn x => x) tables
adamc@260	1382 val tables = ListMergeSort.sort
adamc@260	1383 (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER)
adamc@260	1384 tables
adamc@260	1385 val tables = map (fn (x, xts) =>
adamc@260	1386 (x, ListMergeSort.sort
adamc@260	1387 (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER)
adamc@260	1388 xts)) tables
adamc@260	1389 in
adamc@260	1390 SOME tables
adamc@260	1391 end
adamc@252	1392 end
adamc@252	1393 in
adamc@252	1394 case (doTables tables, doTables grouped, doTables stables, monoType env (L.TRecord sexps, loc)) of
adamc@252	1395 (SOME tables, SOME grouped, SOME stables, (L'.TRecord sexps, _)) =>
adamc@441	1396 let
adamc@441	1397 val sexps = ListMergeSort.sort
adamc@441	1398 (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) sexps
adamc@441	1399 in
adamc@441	1400 ((L'.EAbs ("r",
adamc@441	1401 (L'.TRecord [("From", (L'.TRecord (map (fn (x, _) => (x, s)) tables), loc)),
adamc@441	1402 ("Where", s),
adamc@441	1403 ("GroupBy", un),
adamc@441	1404 ("Having", s),
adamc@441	1405 ("SelectFields", un),
adamc@441	1406 ("SelectExps", (L'.TRecord (map (fn (x, _) => (x, s)) sexps), loc))],
adamc@441	1407 loc),
adamc@441	1408 s,
adamc@598	1409 strcat [sc "SELECT ",
adamc@598	1410 strcatComma (map (fn (x, t) =>
adamc@598	1411 strcat [
adamc@598	1412 (L'.EField (gf "SelectExps", x), loc),
adamc@598	1413 sc (" AS _" ^ x)
adamc@598	1414 ]) sexps
adamc@598	1415 @ map (fn (x, xts) =>
adamc@598	1416 strcatComma
adamc@598	1417 (map (fn (x', _) =>
adamc@598	1418 sc (x ^ ".uw_" ^ x'))
adamc@598	1419 xts)) stables),
adamc@598	1420 sc " FROM ",
adamc@598	1421 strcatComma (map (fn (x, _) => strcat [(L'.EField (gf "From", x), loc),
adamc@598	1422 sc (" AS " ^ x)]) tables),
adamc@598	1423 (L'.ECase (gf "Where",
adamc@598	1424 [((L'.PPrim (Prim.String "TRUE"), loc),
adamc@598	1425 sc ""),
adamc@598	1426 ((L'.PWild, loc),
adamc@598	1427 strcat [sc " WHERE ", gf "Where"])],
adamc@598	1428 {disc = s,
adamc@598	1429 result = s}), loc),
adamc@598	1430
adamc@598	1431 if List.all (fn (x, xts) =>
adamc@598	1432 case List.find (fn (x', _) => x' = x) grouped of
adamc@598	1433 NONE => List.null xts
adamc@598	1434 \| SOME (_, xts') =>
adamc@598	1435 List.all (fn (x, _) =>
adamc@598	1436 List.exists (fn (x', _) => x' = x)
adamc@598	1437 xts') xts) tables then
adamc@598	1438 sc ""
adamc@598	1439 else
adamc@598	1440 strcat [
adamc@598	1441 sc " GROUP BY ",
adamc@598	1442 strcatComma (map (fn (x, xts) =>
adamc@598	1443 strcatComma
adamc@598	1444 (map (fn (x', _) =>
adamc@598	1445 sc (x ^ ".uw_" ^ x'))
adamc@598	1446 xts)) grouped)
adamc@598	1447 ],
adamc@259	1448
adamc@598	1449 (L'.ECase (gf "Having",
adamc@598	1450 [((L'.PPrim (Prim.String "TRUE"), loc),
adamc@598	1451 sc ""),
adamc@598	1452 ((L'.PWild, loc),
adamc@598	1453 strcat [sc " HAVING ", gf "Having"])],
adamc@598	1454 {disc = s,
adamc@598	1455 result = s}), loc)
adamc@441	1456 ]), loc),
adamc@441	1457 fm)
adamc@441	1458 end
adamc@252	1459 \| _ => poly ()
adamc@252	1460 end
adamc@252	1461
adamc@252	1462 \| L.ECApp (
adamc@252	1463 (L.ECApp (
adamc@252	1464 (L.ECApp (
adamc@252	1465 (L.ECApp (
adamc@252	1466 (L.EFfi ("Basis", "sql_inject"), _),
adamc@252	1467 _), _),
adamc@252	1468 _), _),
adamc@252	1469 _), _),
adamc@252	1470 t) =>
adamc@252	1471 let
adamc@252	1472 val t = monoType env t
adamc@252	1473 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@252	1474 in
adamc@252	1475 ((L'.EAbs ("f", (L'.TFun (t, s), loc), (L'.TFun (t, s), loc),
adamc@252	1476 (L'.ERel 0, loc)), loc), fm)
adamc@252	1477 end
adamc@252	1478
adamc@253	1479 \| L.EFfi ("Basis", "sql_int") =>
adamc@253	1480 ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "string"), loc),
adamc@253	1481 (L'.EFfiApp ("Basis", "sqlifyInt", [(L'.ERel 0, loc)]), loc)), loc),
adamc@253	1482 fm)
adamc@253	1483 \| L.EFfi ("Basis", "sql_float") =>
adamc@253	1484 ((L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "string"), loc),
adamc@253	1485 (L'.EFfiApp ("Basis", "sqlifyFloat", [(L'.ERel 0, loc)]), loc)), loc),
adamc@253	1486 fm)
adamc@253	1487 \| L.EFfi ("Basis", "sql_bool") =>
adamc@253	1488 ((L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "string"), loc),
adamc@253	1489 (L'.EFfiApp ("Basis", "sqlifyBool", [(L'.ERel 0, loc)]), loc)), loc),
adamc@253	1490 fm)
adamc@253	1491 \| L.EFfi ("Basis", "sql_string") =>
adamc@253	1492 ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc),
adamc@253	1493 (L'.EFfiApp ("Basis", "sqlifyString", [(L'.ERel 0, loc)]), loc)), loc),
adamc@253	1494 fm)
adamc@439	1495 \| L.EFfi ("Basis", "sql_time") =>
adamc@439	1496 ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "string"), loc),
adamc@439	1497 (L'.EFfiApp ("Basis", "sqlifyTime", [(L'.ERel 0, loc)]), loc)), loc),
adamc@439	1498 fm)
adamc@678	1499 \| L.ECApp ((L.EFfi ("Basis", "sql_channel"), _), _) =>
adamc@678	1500 ((L'.EAbs ("x", (L'.TFfi ("Basis", "channel"), loc), (L'.TFfi ("Basis", "string"), loc),
adamc@678	1501 (L'.EFfiApp ("Basis", "sqlifyChannel", [(L'.ERel 0, loc)]), loc)), loc),
adamc@678	1502 fm)
adamc@682	1503 \| L.EFfi ("Basis", "sql_client") =>
adamc@682	1504 ((L'.EAbs ("x", (L'.TFfi ("Basis", "client"), loc), (L'.TFfi ("Basis", "string"), loc),
adamc@682	1505 (L'.EFfiApp ("Basis", "sqlifyClient", [(L'.ERel 0, loc)]), loc)), loc),
adamc@682	1506 fm)
adamc@676	1507 \| L.ECApp ((L.EFfi ("Basis", "sql_prim"), _), t) =>
adamc@676	1508 let
adamc@676	1509 val t = monoType env t
adamc@676	1510 val tf = (L'.TFun (t, (L'.TFfi ("Basis", "string"), loc)), loc)
adamc@676	1511 in
adamc@676	1512 ((L'.EAbs ("f", tf, tf, (L'.ERel 0, loc)), loc),
adamc@676	1513 fm)
adamc@676	1514 end
adamc@676	1515 \| L.ECApp ((L.EFfi ("Basis", "sql_option_prim"), _), t) =>
adamc@676	1516 let
adamc@676	1517 val t = monoType env t
adamc@676	1518 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@676	1519 in
adamc@676	1520 ((L'.EAbs ("f",
adamc@676	1521 (L'.TFun (t, s), loc),
adamc@676	1522 (L'.TFun ((L'.TOption t, loc), s), loc),
adamc@676	1523 (L'.EAbs ("x",
adamc@676	1524 (L'.TOption t, loc),
adamc@676	1525 s,
adamc@676	1526 (L'.ECase ((L'.ERel 0, loc),
adamc@676	1527 [((L'.PNone t, loc),
adamc@676	1528 (L'.EPrim (Prim.String "NULL"), loc)),
adamc@676	1529 ((L'.PSome (t, (L'.PVar ("y", t), loc)), loc),
adamc@676	1530 (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc))],
adamc@676	1531 {disc = (L'.TOption t, loc),
adamc@676	1532 result = s}), loc)), loc)), loc),
adamc@676	1533 fm)
adamc@676	1534 end
adamc@253	1535
adamc@252	1536 \| L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) =>
adamc@252	1537 ((L'.ERecord [], loc), fm)
adamc@252	1538 \| L.ECApp ((L.EFfi ("Basis", "sql_subset_all"), _), _) =>
adamc@252	1539 ((L'.ERecord [], loc), fm)
adamc@252	1540
adamc@252	1541 \| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) =>
adamc@252	1542 ((L'.EPrim (Prim.String ""), loc), fm)
adamc@261	1543 \| L.ECApp (
adamc@261	1544 (L.ECApp (
adamc@261	1545 (L.ECApp (
adamc@261	1546 (L.EFfi ("Basis", "sql_order_by_Cons"), _),
adamc@261	1547 _), _),
adamc@261	1548 _), _),
adamc@261	1549 _) =>
adamc@261	1550 let
adamc@261	1551 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@261	1552 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@261	1553 in
adamc@268	1554 ((L'.EAbs ("e1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adamc@268	1555 (L'.EAbs ("d", s, (L'.TFun (s, s), loc),
adamc@268	1556 (L'.EAbs ("e2", s, s,
adamc@268	1557 (L'.ECase ((L'.ERel 0, loc),
adamc@268	1558 [((L'.PPrim (Prim.String ""), loc),
adamc@598	1559 strcat [(L'.ERel 2, loc),
adamc@598	1560 (L'.ERel 1, loc)]),
adamc@268	1561 ((L'.PWild, loc),
adamc@598	1562 strcat [(L'.ERel 2, loc),
adamc@598	1563 (L'.ERel 1, loc),
adamc@598	1564 sc ", ",
adamc@598	1565 (L'.ERel 0, loc)])],
adamc@268	1566 {disc = s, result = s}), loc)), loc)), loc)), loc),
adamc@261	1567 fm)
adamc@261	1568 end
adamc@252	1569
adamc@252	1570 \| L.EFfi ("Basis", "sql_no_limit") =>
adamc@252	1571 ((L'.EPrim (Prim.String ""), loc), fm)
adamc@262	1572 \| L.EFfiApp ("Basis", "sql_limit", [e]) =>
adamc@262	1573 let
adamc@262	1574 val (e, fm) = monoExp (env, st, fm) e
adamc@262	1575 in
adamc@598	1576 (strcat [
adamc@262	1577 (L'.EPrim (Prim.String " LIMIT "), loc),
adamc@262	1578 (L'.EFfiApp ("Basis", "sqlifyInt", [e]), loc)
adamc@262	1579 ],
adamc@262	1580 fm)
adamc@262	1581 end
adamc@262	1582
adamc@252	1583 \| L.EFfi ("Basis", "sql_no_offset") =>
adamc@252	1584 ((L'.EPrim (Prim.String ""), loc), fm)
adamc@263	1585 \| L.EFfiApp ("Basis", "sql_offset", [e]) =>
adamc@263	1586 let
adamc@263	1587 val (e, fm) = monoExp (env, st, fm) e
adamc@263	1588 in
adamc@598	1589 (strcat [
adamc@263	1590 (L'.EPrim (Prim.String " OFFSET "), loc),
adamc@263	1591 (L'.EFfiApp ("Basis", "sqlifyInt", [e]), loc)
adamc@263	1592 ],
adamc@263	1593 fm)
adamc@263	1594 end
adamc@253	1595
adamc@559	1596 \| L.ECApp ((L.EFfi ("Basis", "sql_eq"), _), _) =>
adamc@253	1597 ((L'.EPrim (Prim.String "="), loc), fm)
adamc@559	1598 \| L.ECApp ((L.EFfi ("Basis", "sql_ne"), _), _) =>
adamc@253	1599 ((L'.EPrim (Prim.String "<>"), loc), fm)
adamc@559	1600 \| L.ECApp ((L.EFfi ("Basis", "sql_lt"), _), _) =>
adamc@253	1601 ((L'.EPrim (Prim.String "<"), loc), fm)
adamc@559	1602 \| L.ECApp ((L.EFfi ("Basis", "sql_le"), _), _) =>
adamc@253	1603 ((L'.EPrim (Prim.String "<="), loc), fm)
adamc@559	1604 \| L.ECApp ((L.EFfi ("Basis", "sql_gt"), _), _) =>
adamc@253	1605 ((L'.EPrim (Prim.String ">"), loc), fm)
adamc@559	1606 \| L.ECApp ((L.EFfi ("Basis", "sql_ge"), _), _) =>
adamc@253	1607 ((L'.EPrim (Prim.String ">="), loc), fm)
adamc@253	1608
adamc@559	1609 \| L.ECApp ((L.EFfi ("Basis", "sql_plus"), _), _) =>
adamc@559	1610 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adamc@559	1611 (L'.EPrim (Prim.String "+"), loc)), loc), fm)
adamc@559	1612 \| L.ECApp ((L.EFfi ("Basis", "sql_minus"), _), _) =>
adamc@559	1613 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adamc@559	1614 (L'.EPrim (Prim.String "-"), loc)), loc), fm)
adamc@559	1615 \| L.ECApp ((L.EFfi ("Basis", "sql_times"), _), _) =>
adamc@559	1616 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adamc@559	1617 (L'.EPrim (Prim.String "*"), loc)), loc), fm)
adamc@559	1618 \| L.ECApp ((L.EFfi ("Basis", "sql_div"), _), _) =>
adamc@559	1619 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adamc@559	1620 (L'.EPrim (Prim.String "/"), loc)), loc), fm)
adamc@559	1621 \| L.EFfi ("Basis", "sql_mod") =>
adamc@559	1622 ((L'.EPrim (Prim.String "%"), loc), fm)
adamc@559	1623
adamc@253	1624 \| L.ECApp (
adamc@253	1625 (L.ECApp (
adamc@253	1626 (L.ECApp (
adamc@253	1627 (L.ECApp (
adamc@254	1628 (L.ECApp (
adamc@264	1629 (L.EFfi ("Basis", "sql_unary"), _),
adamc@264	1630 _), _),
adamc@264	1631 _), _),
adamc@264	1632 _), _),
adamc@264	1633 _), _),
adamc@264	1634 _) =>
adamc@264	1635 let
adamc@264	1636 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@264	1637 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@264	1638 in
adamc@264	1639 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adamc@264	1640 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
adamc@598	1641 strcat [sc "(",
adamc@598	1642 (L'.ERel 1, loc),
adamc@598	1643 sc " ",
adamc@598	1644 (L'.ERel 0, loc),
adamc@598	1645 sc ")"]), loc)), loc),
adamc@264	1646 fm)
adamc@264	1647 end
adamc@264	1648 \| L.EFfi ("Basis", "sql_not") => ((L'.EPrim (Prim.String "NOT"), loc), fm)
adamc@559	1649 \| L.ECApp ((L.EFfi ("Basis", "sql_neg"), _), _) =>
adamc@559	1650 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adamc@559	1651 (L'.EPrim (Prim.String "-"), loc)), loc), fm)
adamc@264	1652
adamc@264	1653 \| L.ECApp (
adamc@264	1654 (L.ECApp (
adamc@264	1655 (L.ECApp (
adamc@264	1656 (L.ECApp (
adamc@264	1657 (L.ECApp (
adamc@254	1658 (L.ECApp (
adamc@254	1659 (L.EFfi ("Basis", "sql_binary"), _),
adamc@254	1660 _), _),
adamc@254	1661 _), _),
adamc@254	1662 _), _),
adamc@254	1663 _), _),
adamc@254	1664 _), _),
adamc@254	1665 _) =>
adamc@254	1666 let
adamc@254	1667 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@254	1668 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@254	1669 in
adamc@254	1670 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adamc@254	1671 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
adamc@254	1672 (L'.EAbs ("e2", s, s,
adamc@598	1673 strcat [sc "(",
adamc@598	1674 (L'.ERel 1, loc),
adamc@598	1675 sc " ",
adamc@598	1676 (L'.ERel 2, loc),
adamc@598	1677 sc " ",
adamc@598	1678 (L'.ERel 0, loc),
adamc@598	1679 sc ")"]), loc)), loc)), loc),
adamc@254	1680 fm)
adamc@254	1681 end
adamc@254	1682 \| L.EFfi ("Basis", "sql_and") => ((L'.EPrim (Prim.String "AND"), loc), fm)
adamc@254	1683 \| L.EFfi ("Basis", "sql_or") => ((L'.EPrim (Prim.String "OR"), loc), fm)
adamc@254	1684
adamc@254	1685 \| L.ECApp (
adamc@254	1686 (L.ECApp (
adamc@254	1687 (L.ECApp (
adamc@254	1688 (L.ECApp (
adamc@253	1689 (L.ECApp (
adamc@253	1690 (L.ECApp (
adamc@253	1691 (L.ECApp (
adamc@253	1692 (L.EFfi ("Basis", "sql_field"), _),
adamc@253	1693 _), _),
adamc@253	1694 _), _),
adamc@253	1695 _), _),
adamc@253	1696 _), _),
adamc@253	1697 _), _),
adamc@253	1698 (L.CName tab, _)), _),
adamc@311	1699 (L.CName field, _)) => ((L'.EPrim (Prim.String (tab ^ ".uw_" ^ field)), loc), fm)
adamc@260	1700
adamc@260	1701 \| L.ECApp (
adamc@260	1702 (L.ECApp (
adamc@260	1703 (L.ECApp (
adamc@260	1704 (L.ECApp (
adamc@261	1705 (L.ECApp (
adamc@261	1706 (L.EFfi ("Basis", "sql_exp"), _),
adamc@261	1707 _), _),
adamc@261	1708 _), _),
adamc@261	1709 _), _),
adamc@261	1710 _), _),
adamc@261	1711 (L.CName nm, _)) => ((L'.EPrim (Prim.String ("_" ^ nm)), loc), fm)
adamc@261	1712
adamc@261	1713 \| L.ECApp (
adamc@261	1714 (L.ECApp (
adamc@261	1715 (L.ECApp (
adamc@261	1716 (L.ECApp (
adamc@260	1717 (L.EFfi ("Basis", "sql_relop"), _),
adamc@260	1718 _), _),
adamc@260	1719 _), _),
adamc@260	1720 _), _),
adamc@260	1721 _) =>
adamc@260	1722 let
adamc@260	1723 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@260	1724 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@260	1725 in
adamc@260	1726 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adamc@260	1727 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
adamc@260	1728 (L'.EAbs ("e2", s, s,
adamc@598	1729 strcat [sc "((",
adamc@598	1730 (L'.ERel 1, loc),
adamc@598	1731 sc ") ",
adamc@598	1732 (L'.ERel 2, loc),
adamc@598	1733 sc " (",
adamc@598	1734 (L'.ERel 0, loc),
adamc@598	1735 sc "))"]), loc)), loc)), loc),
adamc@260	1736 fm)
adamc@260	1737 end
adamc@260	1738
adamc@260	1739 \| L.EFfi ("Basis", "sql_union") => ((L'.EPrim (Prim.String "UNION"), loc), fm)
adamc@260	1740 \| L.EFfi ("Basis", "sql_intersect") => ((L'.EPrim (Prim.String "INTERSECT"), loc), fm)
adamc@260	1741 \| L.EFfi ("Basis", "sql_except") => ((L'.EPrim (Prim.String "EXCEPT"), loc), fm)
adamc@260	1742
adamc@265	1743 \| L.ECApp (
adamc@265	1744 (L.ECApp (
adamc@265	1745 (L.ECApp (
adamc@265	1746 (L.EFfi ("Basis", "sql_count"), _),
adamc@265	1747 _), _),
adamc@265	1748 _), _),
adamc@544	1749 _) => ((L'.EPrim (Prim.String "COUNT(*)"), loc),
adamc@265	1750 fm)
adamc@266	1751
adamc@266	1752 \| L.ECApp (
adamc@266	1753 (L.ECApp (
adamc@266	1754 (L.ECApp (
adamc@266	1755 (L.ECApp (
adamc@266	1756 (L.EFfi ("Basis", "sql_aggregate"), _),
adamc@266	1757 _), _),
adamc@266	1758 _), _),
adamc@266	1759 _), _),
adamc@266	1760 _) =>
adamc@266	1761 let
adamc@266	1762 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@266	1763 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@266	1764 in
adamc@266	1765 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adamc@266	1766 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
adamc@598	1767 strcat [(L'.ERel 1, loc),
adamc@598	1768 sc "(",
adamc@598	1769 (L'.ERel 0, loc),
adamc@598	1770 sc ")"]), loc)), loc),
adamc@266	1771 fm)
adamc@266	1772 end
adamc@266	1773
adamc@266	1774 \| L.EFfi ("Basis", "sql_summable_int") => ((L'.ERecord [], loc), fm)
adamc@266	1775 \| L.EFfi ("Basis", "sql_summable_float") => ((L'.ERecord [], loc), fm)
adamc@266	1776 \| L.ECApp ((L.EFfi ("Basis", "sql_avg"), _), _) =>
adamc@266	1777 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adamc@266	1778 (L'.EPrim (Prim.String "AVG"), loc)), loc),
adamc@266	1779 fm)
adamc@266	1780 \| L.ECApp ((L.EFfi ("Basis", "sql_sum"), _), _) =>
adamc@266	1781 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adamc@266	1782 (L'.EPrim (Prim.String "SUM"), loc)), loc),
adamc@266	1783 fm)
adamc@266	1784
adamc@559	1785 \| L.EFfi ("Basis", "sql_arith_int") => ((L'.ERecord [], loc), fm)
adamc@559	1786 \| L.EFfi ("Basis", "sql_arith_float") => ((L'.ERecord [], loc), fm)
adamc@559	1787
adamc@266	1788 \| L.EFfi ("Basis", "sql_maxable_int") => ((L'.ERecord [], loc), fm)
adamc@266	1789 \| L.EFfi ("Basis", "sql_maxable_float") => ((L'.ERecord [], loc), fm)
adamc@266	1790 \| L.EFfi ("Basis", "sql_maxable_string") => ((L'.ERecord [], loc), fm)
adamc@266	1791 \| L.ECApp ((L.EFfi ("Basis", "sql_max"), _), _) =>
adamc@266	1792 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adamc@266	1793 (L'.EPrim (Prim.String "MAX"), loc)), loc),
adamc@266	1794 fm)
adamc@266	1795 \| L.ECApp ((L.EFfi ("Basis", "sql_min"), _), _) =>
adamc@266	1796 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adamc@266	1797 (L'.EPrim (Prim.String "MIN"), loc)), loc),
adamc@266	1798 fm)
adamc@266	1799
adamc@268	1800 \| L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm)
adamc@268	1801 \| L.EFfi ("Basis", "sql_desc") => ((L'.EPrim (Prim.String " DESC"), loc), fm)
adamc@268	1802
adamc@441	1803 \| L.ECApp (
adamc@441	1804 (L.ECApp (
adamc@441	1805 (L.ECApp (
adamc@441	1806 (L.ECApp (
adamc@441	1807 (L.EFfi ("Basis", "sql_nfunc"), _),
adamc@441	1808 _), _),
adamc@441	1809 _), _),
adamc@441	1810 _), _),
adamc@441	1811 _) =>
adamc@441	1812 let
adamc@441	1813 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@441	1814 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@441	1815 in
adamc@441	1816 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc),
adamc@441	1817 fm)
adamc@441	1818 end
adamc@441	1819 \| L.EFfi ("Basis", "sql_current_timestamp") => ((L'.EPrim (Prim.String "CURRENT_TIMESTAMP"), loc), fm)
adamc@441	1820
adamc@470	1821 \| (L.ECApp (
adamc@470	1822 (L.ECApp (
adamc@470	1823 (L.ECApp (
adamc@470	1824 (L.ECApp (
adamc@470	1825 (L.EFfi ("Basis", "sql_is_null"), _), _),
adamc@470	1826 _), _),
adamc@470	1827 _), _),
adamc@470	1828 _), _)) =>
adamc@470	1829 let
adamc@470	1830 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@470	1831 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@470	1832 in
adamc@470	1833 ((L'.EAbs ("s", s, s,
adamc@598	1834 strcat [sc "(",
adamc@598	1835 (L'.ERel 0, loc),
adamc@598	1836 sc " IS NULL)"]), loc),
adamc@470	1837 fm)
adamc@470	1838 end
adamc@470	1839
adamc@338	1840 \| L.EFfiApp ("Basis", "nextval", [e]) =>
adamc@338	1841 let
adamc@338	1842 val (e, fm) = monoExp (env, st, fm) e
adamc@338	1843 in
adamc@465	1844 ((L'.ENextval e, loc), fm)
adamc@338	1845 end
adamc@338	1846
adamc@139	1847 \| L.EApp (
adamc@139	1848 (L.ECApp (
adamc@141	1849 (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _),
adamc@139	1850 _), _),
adamc@179	1851 se) =>
adamc@179	1852 let
adamc@179	1853 val (se, fm) = monoExp (env, st, fm) se
adamc@179	1854 in
adamc@179	1855 ((L'.EFfiApp ("Basis", "htmlifyString", [se]), loc), fm)
adamc@179	1856 end
adamc@179	1857
adamc@95	1858 \| L.EApp (
adamc@95	1859 (L.EApp (
adamc@95	1860 (L.ECApp (
adamc@95	1861 (L.ECApp (
adamc@95	1862 (L.ECApp (
adamc@139	1863 (L.ECApp (
adamc@140	1864 (L.EFfi ("Basis", "join"),
adamc@139	1865 _), _), _),
adamc@139	1866 _), _),
adamc@95	1867 _), _),
adamc@95	1868 _), _),
adamc@95	1869 xml1), _),
adamc@179	1870 xml2) =>
adamc@179	1871 let
adamc@179	1872 val (xml1, fm) = monoExp (env, st, fm) xml1
adamc@179	1873 val (xml2, fm) = monoExp (env, st, fm) xml2
adamc@179	1874 in
adamc@179	1875 ((L'.EStrcat (xml1, xml2), loc), fm)
adamc@179	1876 end
adamc@95	1877
adamc@95	1878 \| L.EApp (
adamc@95	1879 (L.EApp (
adamc@104	1880 (L.EApp (
adamc@95	1881 (L.ECApp (
adamc@104	1882 (L.ECApp (
adamc@104	1883 (L.ECApp (
adamc@104	1884 (L.ECApp (
adamc@139	1885 (L.ECApp (
adamc@139	1886 (L.ECApp (
adamc@139	1887 (L.ECApp (
adamc@139	1888 (L.ECApp (
adamc@139	1889 (L.EFfi ("Basis", "tag"),
adamc@139	1890 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
adamc@104	1891 attrs), _),
adamc@95	1892 tag), _),
adamc@95	1893 xml) =>
adamc@95	1894 let
adamc@140	1895 fun getTag' (e, _) =
adamc@140	1896 case e of
adamc@143	1897 L.EFfi ("Basis", tag) => (tag, [])
adamc@143	1898 \| L.ECApp (e, t) => let
adamc@143	1899 val (tag, ts) = getTag' e
adamc@143	1900 in
adamc@143	1901 (tag, ts @ [t])
adamc@143	1902 end
adamc@140	1903 \| _ => (E.errorAt loc "Non-constant XML tag";
adamc@140	1904 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
adamc@143	1905 ("", []))
adamc@140	1906
adamc@95	1907 fun getTag (e, _) =
adamc@95	1908 case e of
adamc@143	1909 L.EFfiApp ("Basis", tag, [(L.ERecord [], _)]) => (tag, [])
adamc@140	1910 \| L.EApp (e, (L.ERecord [], _)) => getTag' e
adamc@95	1911 \| _ => (E.errorAt loc "Non-constant XML tag";
adamc@95	1912 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
adamc@143	1913 ("", []))
adamc@95	1914
adamc@143	1915 val (tag, targs) = getTag tag
adamc@95	1916
adamc@179	1917 val (attrs, fm) = monoExp (env, st, fm) attrs
adamc@598	1918 val attrs = case #1 attrs of
adamc@598	1919 L'.ERecord xes => xes
adamc@598	1920 \| _ => raise Fail "Non-record attributes!"
adamc@104	1921
adamc@668	1922 fun findOnload (attrs, acc) =
adamc@668	1923 case attrs of
adamc@668	1924 [] => (NONE, acc)
adamc@668	1925 \| ("Onload", e, _) :: rest => (SOME e, List.revAppend (acc, rest))
adamc@668	1926 \| x :: rest => findOnload (rest, x :: acc)
adamc@679	1927
adamc@668	1928 val (onload, attrs) = findOnload (attrs, [])
adamc@668	1929
adamc@606	1930 fun lowercaseFirst "" = ""
adamc@606	1931 \| lowercaseFirst s = String.str (Char.toLower (String.sub (s, 0)))
adamc@606	1932 ^ String.extract (s, 1, NONE)
adamc@606	1933
adamc@143	1934 fun tagStart tag =
adamc@598	1935 let
adamc@598	1936 val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc)
adamc@598	1937 in
adamc@598	1938 foldl (fn (("Action", _, _), acc) => acc
adamc@598	1939 \| (("Source", _, _), acc) => acc
adamc@598	1940 \| ((x, e, t), (s, fm)) =>
adamc@598	1941 case t of
adamc@598	1942 (L'.TFfi ("Basis", "bool"), _) =>
adamc@598	1943 let
adamc@598	1944 val s' = " " ^ lowercaseFirst x
adamc@598	1945 in
adamc@598	1946 ((L'.ECase (e,
adamc@598	1947 [((L'.PCon (L'.Enum,
adamc@598	1948 L'.PConFfi {mod = "Basis",
adamc@598	1949 datatyp = "bool",
adamc@598	1950 con = "True",
adamc@598	1951 arg = NONE},
adamc@598	1952 NONE), loc),
adamc@598	1953 (L'.EStrcat (s,
adamc@598	1954 (L'.EPrim (Prim.String s'), loc)), loc)),
adamc@598	1955 ((L'.PCon (L'.Enum,
adamc@598	1956 L'.PConFfi {mod = "Basis",
adamc@598	1957 datatyp = "bool",
adamc@598	1958 con = "False",
adamc@598	1959 arg = NONE},
adamc@598	1960 NONE), loc),
adamc@598	1961 s)],
adamc@598	1962 {disc = (L'.TFfi ("Basis", "bool"), loc),
adamc@598	1963 result = (L'.TFfi ("Basis", "string"), loc)}), loc),
adamc@598	1964 fm)
adamc@598	1965 end
adamc@598	1966 \| (L'.TFun _, _) =>
adamc@598	1967 let
adamc@598	1968 val s' = " " ^ lowercaseFirst x ^ "='"
adamc@651	1969 val e = (L'.EApp (e, (L'.ERecord [], loc)), loc)
adamc@598	1970 in
adamc@598	1971 ((L'.EStrcat (s,
adamc@598	1972 (L'.EStrcat (
adamc@598	1973 (L'.EPrim (Prim.String s'), loc),
adamc@598	1974 (L'.EStrcat (
adamc@598	1975 (L'.EJavaScript (L'.Attribute, e, NONE), loc),
adamc@598	1976 (L'.EPrim (Prim.String "'"), loc)), loc)),
adamc@598	1977 loc)), loc),
adamc@598	1978 fm)
adamc@598	1979 end
adamc@598	1980 \| _ =>
adamc@598	1981 let
adamc@598	1982 val fooify =
adamc@598	1983 case x of
adamc@598	1984 "Href" => urlifyExp
adamc@598	1985 \| "Link" => urlifyExp
adamc@598	1986 \| _ => attrifyExp
adamc@120	1987
adamc@598	1988 val xp = " " ^ lowercaseFirst x ^ "=\""
adamc@179	1989
adamc@598	1990 val (e, fm) = fooify env fm (e, t)
adamc@598	1991 in
adamc@598	1992 ((L'.EStrcat (s,
adamc@598	1993 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
adamc@598	1994 (L'.EStrcat (e,
adamc@598	1995 (L'.EPrim (Prim.String "\""),
adamc@598	1996 loc)),
adamc@598	1997 loc)),
adamc@598	1998 loc)), loc),
adamc@598	1999 fm)
adamc@598	2000 end)
adamc@598	2001 (s, fm) attrs
adamc@598	2002 end
adamc@104	2003
adamc@143	2004 fun input typ =
adamc@143	2005 case targs of
adamc@155	2006 [_, (L.CName name, _)] =>
adamc@179	2007 let
adamc@179	2008 val (ts, fm) = tagStart "input"
adamc@179	2009 in
adamc@179	2010 ((L'.EStrcat (ts,
adamc@179	2011 (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\"/>")),
adamc@179	2012 loc)), loc), fm)
adamc@179	2013 end
adamc@143	2014 \| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adamc@153	2015 raise Fail "No name passed to input tag")
adamc@104	2016
adamc@565	2017 fun normal (tag, extra, extraInner) =
adamc@143	2018 let
adamc@179	2019 val (tagStart, fm) = tagStart tag
adamc@152	2020 val tagStart = case extra of
adamc@152	2021 NONE => tagStart
adamc@152	2022 \| SOME extra => (L'.EStrcat (tagStart, extra), loc)
adamc@152	2023
adamc@695	2024 val xml = case extraInner of
adamc@695	2025 NONE => xml
adamc@695	2026 \| SOME ei => (L.EFfiApp ("Basis", "strcat", [ei, xml]), loc)
adamc@695	2027
adamc@143	2028 fun normal () =
adamc@179	2029 let
adamc@179	2030 val (xml, fm) = monoExp (env, st, fm) xml
adamc@179	2031 in
adamc@179	2032 ((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
adamc@179	2033 (L'.EStrcat (xml,
adamc@179	2034 (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])),
adamc@179	2035 loc)), loc)),
adamc@179	2036 loc),
adamc@179	2037 fm)
adamc@179	2038 end
adamc@143	2039 in
adamc@143	2040 case xml of
adamc@143	2041 (L.EApp ((L.ECApp (
adamc@143	2042 (L.ECApp ((L.EFfi ("Basis", "cdata"), _),
adamc@143	2043 _), _),
adamc@143	2044 _), _),
adamc@143	2045 (L.EPrim (Prim.String s), _)), _) =>
adamc@143	2046 if CharVector.all Char.isSpace s then
adamc@179	2047 ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String "/>"), loc)), loc), fm)
adamc@143	2048 else
adamc@143	2049 normal ()
adamc@143	2050 \| _ => normal ()
adamc@143	2051 end
adamc@606	2052
adamc@606	2053 fun setAttrs jexp =
adamc@606	2054 let
adamc@606	2055 val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc)
adamc@606	2056
adamc@606	2057 val assgns = List.mapPartial
adamc@606	2058 (fn ("Source", _, _) => NONE
adamc@606	2059 \| (x, e, _) =>
adamc@606	2060 SOME (strcat [str ("d." ^ lowercaseFirst x ^ "="),
adamc@606	2061 (L'.EJavaScript (L'.Script, e, NONE), loc),
adamc@606	2062 str ";"]))
adamc@606	2063 attrs
adamc@606	2064 in
adamc@606	2065 case assgns of
adamc@606	2066 [] => jexp
adamc@606	2067 \| _ => strcat (str "var d="
adamc@606	2068 :: jexp
adamc@606	2069 :: str ";"
adamc@606	2070 :: assgns)
adamc@606	2071 end
adamc@152	2072 in
adamc@152	2073 case tag of
adamc@679	2074 "body" => let
adamc@668	2075 val onload = case onload of
adamc@668	2076 NONE => (L'.EPrim (Prim.String ""), loc)
adamc@668	2077 \| SOME e =>
adamc@668	2078 let
adamc@668	2079 val e = (L'.EApp (e, (L'.ERecord [], loc)), loc)
adamc@668	2080 in
adamc@668	2081 (L'.EJavaScript (L'.Attribute, e, NONE), loc)
adamc@679	2082 end
adamc@668	2083 in
adamc@668	2084 normal ("body",
adamc@695	2085 SOME (L'.EFfiApp ("Basis", "maybe_onload",
adamc@695	2086 [(L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings",
adamc@695	2087 [(L'.ERecord [], loc)]), loc),
adamc@695	2088 onload), loc)]),
adamc@695	2089 loc),
adamc@695	2090 SOME (L.EFfiApp ("Basis", "get_script", [(L.ERecord [], loc)]), loc))
adamc@668	2091 end
adamc@568	2092
adamc@568	2093 \| "dyn" =>
adamc@598	2094 (case attrs of
adamc@598	2095 [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _),
adamc@598	2096 e), _), _)] => (e, fm)
adamc@598	2097 \| [("Signal", e, _)] =>
adamc@568	2098 ((L'.EStrcat
adamc@603	2099 ((L'.EPrim (Prim.String "<span><script type=\"text/javascript\">dyn("), loc),
adamc@578	2100 (L'.EStrcat ((L'.EJavaScript (L'.Script, e, NONE), loc),
adamc@603	2101 (L'.EPrim (Prim.String ")</script></span>"), loc)), loc)), loc),
adamc@568	2102 fm)
adamc@568	2103 \| _ => raise Fail "Monoize: Bad dyn attributes")
adamc@565	2104
adamc@565	2105 \| "submit" => normal ("input type=\"submit\"", NONE, NONE)
adamc@601	2106 \| "button" => normal ("input type=\"submit\"", NONE, NONE)
adamc@152	2107
adamc@152	2108 \| "textbox" =>
adamc@152	2109 (case targs of
adamc@152	2110 [_, (L.CName name, _)] =>
adamc@598	2111 (case List.find (fn ("Source", _, _) => true \| _ => false) attrs of
adamc@598	2112 NONE =>
adamc@598	2113 let
adamc@598	2114 val (ts, fm) = tagStart "input"
adamc@598	2115 in
adamc@598	2116 ((L'.EStrcat (ts,
adamc@598	2117 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\"/>")),
adamc@598	2118 loc)), loc), fm)
adamc@598	2119 end
adamc@598	2120 \| SOME (_, src, _) =>
adamc@646	2121 (strcat [str "<span><script type=\"text/javascript\">inp(\"input\",",
adamc@598	2122 (L'.EJavaScript (L'.Script, src, NONE), loc),
adamc@646	2123 str ")</script></span>"],
adamc@598	2124 fm))
adamc@152	2125 \| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adamc@598	2126 raise Fail "No name passed to textbox tag"))
adamc@155	2127 \| "password" => input "password"
adamc@361	2128 \| "textarea" =>
adamc@152	2129 (case targs of
adamc@152	2130 [_, (L.CName name, _)] =>
adamc@179	2131 let
adamc@179	2132 val (ts, fm) = tagStart "textarea"
adamc@179	2133 val (xml, fm) = monoExp (env, st, fm) xml
adamc@179	2134 in
adamc@179	2135 ((L'.EStrcat ((L'.EStrcat (ts,
adamc@179	2136 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc),
adamc@179	2137 (L'.EStrcat (xml,
adamc@179	2138 (L'.EPrim (Prim.String "</textarea>"),
adamc@179	2139 loc)), loc)),
adamc@179	2140 loc), fm)
adamc@179	2141 end
adamc@152	2142 \| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adamc@153	2143 raise Fail "No name passed to ltextarea tag"))
adamc@153	2144
adamc@190	2145 \| "checkbox" => input "checkbox"
adamc@190	2146
adamc@153	2147 \| "radio" =>
adamc@153	2148 (case targs of
adamc@153	2149 [_, (L.CName name, _)] =>
adamc@179	2150 monoExp (env, St.setRadioGroup (st, name), fm) xml
adamc@153	2151 \| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adamc@153	2152 raise Fail "No name passed to radio tag"))
adamc@153	2153 \| "radioOption" =>
adamc@153	2154 (case St.radioGroup st of
adamc@153	2155 NONE => raise Fail "No name for radioGroup"
adamc@153	2156 \| SOME name =>
adamc@153	2157 normal ("input",
adamc@565	2158 SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc),
adamc@565	2159 NONE))
adamc@152	2160
adamc@361	2161 \| "select" =>
adamc@154	2162 (case targs of
adamc@154	2163 [_, (L.CName name, _)] =>
adamc@179	2164 let
adamc@179	2165 val (ts, fm) = tagStart "select"
adamc@179	2166 val (xml, fm) = monoExp (env, st, fm) xml
adamc@179	2167 in
adamc@179	2168 ((L'.EStrcat ((L'.EStrcat (ts,
adamc@598	2169 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")),
adamc@598	2170 loc)), loc),
adamc@179	2171 (L'.EStrcat (xml,
adamc@179	2172 (L'.EPrim (Prim.String "</select>"),
adamc@179	2173 loc)), loc)),
adamc@179	2174 loc),
adamc@179	2175 fm)
adamc@179	2176 end
adamc@154	2177 \| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adamc@154	2178 raise Fail "No name passed to lselect tag"))
adamc@154	2179
adamc@601	2180 \| "ctextbox" =>
adamc@601	2181 (case List.find (fn ("Source", _, _) => true \| _ => false) attrs of
adamc@601	2182 NONE =>
adamc@601	2183 let
adamc@601	2184 val (ts, fm) = tagStart "input"
adamc@601	2185 in
adamc@601	2186 ((L'.EStrcat (ts,
adamc@601	2187 (L'.EPrim (Prim.String "/>"), loc)),
adamc@601	2188 loc), fm)
adamc@601	2189 end
adamc@601	2190 \| SOME (_, src, _) =>
adamc@606	2191 let
adamc@606	2192 val sc = strcat [str "inp(\"input\",",
adamc@606	2193 (L'.EJavaScript (L'.Script, src, NONE), loc),
adamc@606	2194 str ")"]
adamc@606	2195 val sc = setAttrs sc
adamc@606	2196 in
adamc@646	2197 (strcat [str "<span><script type=\"text/javascript\">",
adamc@606	2198 sc,
adamc@646	2199 str "</script></span>"],
adamc@606	2200 fm)
adamc@606	2201 end)
adamc@154	2202
adamc@565	2203 \| "tabl" => normal ("table", NONE, NONE)
adamc@565	2204 \| _ => normal (tag, NONE, NONE)
adamc@95	2205 end
adamc@94	2206
adamc@141	2207 \| L.EApp ((L.ECApp (
adamc@361	2208 (L.ECApp ((L.EFfi ("Basis", "form"), _), _), _),
adamc@141	2209 _), _),
adamc@141	2210 xml) =>
adamc@143	2211 let
adamc@143	2212 fun findSubmit (e, _) =
adamc@143	2213 case e of
adamc@143	2214 L.EApp (
adamc@143	2215 (L.EApp (
adamc@143	2216 (L.ECApp (
adamc@143	2217 (L.ECApp (
adamc@143	2218 (L.ECApp (
adamc@143	2219 (L.ECApp (
adamc@143	2220 (L.EFfi ("Basis", "join"),
adamc@143	2221 _), _), _),
adamc@143	2222 _), _),
adamc@143	2223 _), _),
adamc@143	2224 _), _),
adamc@143	2225 xml1), _),
adamc@143	2226 xml2) => (case findSubmit xml1 of
adamc@143	2227 Error => Error
adamc@143	2228 \| NotFound => findSubmit xml2
adamc@143	2229 \| Found e =>
adamc@143	2230 case findSubmit xml2 of
adamc@143	2231 NotFound => Found e
adamc@143	2232 \| _ => Error)
adamc@143	2233 \| L.EApp (
adamc@143	2234 (L.EApp (
adamc@143	2235 (L.EApp (
adamc@143	2236 (L.ECApp (
adamc@143	2237 (L.ECApp (
adamc@143	2238 (L.ECApp (
adamc@143	2239 (L.ECApp (
adamc@143	2240 (L.ECApp (
adamc@143	2241 (L.ECApp (
adamc@143	2242 (L.ECApp (
adamc@143	2243 (L.ECApp (
adamc@143	2244 (L.EFfi ("Basis", "tag"),
adamc@143	2245 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
adamc@143	2246 attrs), _),
adamc@143	2247 _), _),
adamc@143	2248 xml) =>
adamc@143	2249 (case #1 attrs of
adamc@143	2250 L.ERecord xes =>
adamc@143	2251 (case ListUtil.search (fn ((L.CName "Action", _), e, t) => SOME (e, t)
adamc@143	2252 \| _ => NONE) xes of
adamc@143	2253 NONE => findSubmit xml
adamc@143	2254 \| SOME et =>
adamc@143	2255 case findSubmit xml of
adamc@143	2256 NotFound => Found et
adamc@143	2257 \| _ => Error)
adamc@143	2258 \| _ => findSubmit xml)
adamc@143	2259 \| _ => NotFound
adamc@143	2260
adamc@598	2261 val (action, fm) = case findSubmit xml of
adamc@598	2262 NotFound => ((L'.EPrim (Prim.String ""), loc), fm)
adamc@143	2263 \| Error => raise Fail "Not ready for multi-submit lforms yet"
adamc@598	2264 \| Found (action, actionT) =>
adamc@598	2265 let
adamc@598	2266 val actionT = monoType env actionT
adamc@598	2267 val (action, fm) = monoExp (env, st, fm) action
adamc@598	2268 val (action, fm) = urlifyExp env fm (action, actionT)
adamc@598	2269 in
adamc@598	2270 ((L'.EStrcat ((L'.EPrim (Prim.String " action=\""), loc),
adamc@598	2271 (L'.EStrcat (action,
adamc@598	2272 (L'.EPrim (Prim.String "\""), loc)), loc)), loc),
adamc@598	2273 fm)
adamc@598	2274 end
adamc@598	2275
adamc@179	2276 val (xml, fm) = monoExp (env, st, fm) xml
adamc@143	2277 in
adamc@598	2278 ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form"), loc),
adamc@179	2279 (L'.EStrcat (action,
adamc@598	2280 (L'.EPrim (Prim.String ">"), loc)), loc)), loc),
adamc@179	2281 (L'.EStrcat (xml,
adamc@179	2282 (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc),
adamc@179	2283 fm)
adamc@143	2284 end
adamc@141	2285
adamc@148	2286 \| L.EApp ((L.ECApp (
adamc@148	2287 (L.ECApp (
adamc@148	2288 (L.ECApp (
adamc@148	2289 (L.ECApp (
adamc@148	2290 (L.EFfi ("Basis", "useMore"), _), _), _),
adamc@148	2291 _), _),
adamc@148	2292 _), _),
adamc@148	2293 _), _),
adamc@179	2294 xml) => monoExp (env, st, fm) xml
adamc@148	2295
adamc@283	2296 \| L.ECApp ((L.EFfi ("Basis", "error"), _), t) =>
adamc@283	2297 let
adamc@283	2298 val t = monoType env t
adamc@283	2299 in
adamc@283	2300 ((L'.EAbs ("s", (L'.TFfi ("Basis", "string"), loc), t,
adamc@283	2301 (L'.EError ((L'.ERel 0, loc), t), loc)), loc),
adamc@283	2302 fm)
adamc@283	2303 end
adamc@283	2304
adamc@179	2305 \| L.EApp (e1, e2) =>
adamc@179	2306 let
adamc@179	2307 val (e1, fm) = monoExp (env, st, fm) e1
adamc@179	2308 val (e2, fm) = monoExp (env, st, fm) e2
adamc@179	2309 in
adamc@179	2310 ((L'.EApp (e1, e2), loc), fm)
adamc@179	2311 end
adamc@26	2312 \| L.EAbs (x, dom, ran, e) =>
adamc@179	2313 let
adamc@179	2314 val (e, fm) = monoExp (Env.pushERel env x dom, st, fm) e
adamc@179	2315 in
adamc@179	2316 ((L'.EAbs (x, monoType env dom, monoType env ran, e), loc), fm)
adamc@179	2317 end
adamc@25	2318 \| L.ECApp _ => poly ()
adamc@25	2319 \| L.ECAbs _ => poly ()
adamc@25	2320
adamc@252	2321 \| L.EFfi mx => ((L'.EFfi mx, loc), fm)
adamc@252	2322 \| L.EFfiApp (m, x, es) =>
adamc@252	2323 let
adamc@252	2324 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
adamc@252	2325 in
adamc@252	2326 ((L'.EFfiApp (m, x, es), loc), fm)
adamc@252	2327 end
adamc@252	2328
adamc@179	2329 \| L.ERecord xes =>
adamc@179	2330 let
adamc@179	2331 val (xes, fm) = ListUtil.foldlMap
adamc@179	2332 (fn ((x, e, t), fm) =>
adamc@179	2333 let
adamc@179	2334 val (e, fm) = monoExp (env, st, fm) e
adamc@179	2335 in
adamc@179	2336 ((monoName env x,
adamc@179	2337 e,
adamc@179	2338 monoType env t), fm)
adamc@179	2339 end) fm xes
adamc@179	2340 in
adamc@179	2341 ((L'.ERecord xes, loc), fm)
adamc@179	2342 end
adamc@179	2343 \| L.EField (e, x, _) =>
adamc@179	2344 let
adamc@179	2345 val (e, fm) = monoExp (env, st, fm) e
adamc@179	2346 in
adamc@179	2347 ((L'.EField (e, monoName env x), loc), fm)
adamc@179	2348 end
adamc@445	2349 \| L.EConcat _ => poly ()
adamc@149	2350 \| L.ECut _ => poly ()
adamc@493	2351 \| L.ECutMulti _ => poly ()
adamc@177	2352
adamc@182	2353 \| L.ECase (e, pes, {disc, result}) =>
adamc@179	2354 let
adamc@179	2355 val (e, fm) = monoExp (env, st, fm) e
adamc@179	2356 val (pes, fm) = ListUtil.foldlMap
adamc@179	2357 (fn ((p, e), fm) =>
adamc@179	2358 let
adamc@179	2359 val (e, fm) = monoExp (env, st, fm) e
adamc@179	2360 in
adamc@182	2361 ((monoPat env p, e), fm)
adamc@179	2362 end) fm pes
adamc@179	2363 in
adamc@182	2364 ((L'.ECase (e, pes, {disc = monoType env disc, result = monoType env result}), loc), fm)
adamc@179	2365 end
adamc@177	2366
adamc@179	2367 \| L.EWrite e =>
adamc@179	2368 let
adamc@179	2369 val (e, fm) = monoExp (env, st, fm) e
adamc@179	2370 in
adamc@252	2371 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
adamc@252	2372 (L'.EWrite (liftExpInExp 0 e), loc)), loc), fm)
adamc@179	2373 end
adamc@110	2374
adamc@179	2375 \| L.EClosure (n, es) =>
adamc@179	2376 let
adamc@179	2377 val (es, fm) = ListUtil.foldlMap (fn (e, fm) =>
adamc@179	2378 monoExp (env, st, fm) e)
adamc@179	2379 fm es
adamc@179	2380 in
adamc@179	2381 ((L'.EClosure (n, es), loc), fm)
adamc@179	2382 end
adamc@450	2383
adamc@450	2384 \| L.ELet (x, t, e1, e2) =>
adamc@450	2385 let
adamc@450	2386 val t' = monoType env t
adamc@450	2387 val (e1, fm) = monoExp (env, st, fm) e1
adamc@450	2388 val (e2, fm) = monoExp (Env.pushERel env x t, st, fm) e2
adamc@450	2389 in
adamc@450	2390 ((L'.ELet (x, t', e1, e2), loc), fm)
adamc@450	2391 end
adamc@607	2392
adamc@609	2393 \| L.EServerCall (n, es, ek, t) =>
adamc@608	2394 let
adamc@609	2395 val t = monoType env t
adamc@614	2396 val (_, ft, _, name) = Env.lookupENamed env n
adamc@608	2397 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
adamc@614	2398
adamc@614	2399 fun encodeArgs (es, ft, acc, fm) =
adamc@614	2400 case (es, ft) of
adamc@614	2401 ([], _) => (rev acc, fm)
adamc@614	2402 \| (e :: es, (L.TFun (dom, ran), _)) =>
adamc@614	2403 let
adamc@614	2404 val (e, fm) = urlifyExp env fm (e, monoType env dom)
adamc@614	2405 in
adamc@614	2406 encodeArgs (es, ran, e
adamc@614	2407 :: (L'.EPrim (Prim.String "/"), loc)
adamc@614	2408 :: acc, fm)
adamc@614	2409 end
adamc@614	2410 \| _ => raise Fail "Monoize: Not enough arguments visible in RPC function type"
adamc@614	2411
adamc@614	2412 val (call, fm) = encodeArgs (es, ft, [], fm)
adamc@614	2413 val call = foldl (fn (e, call) => (L'.EStrcat (call, e), loc))
adamc@614	2414 (L'.EPrim (Prim.String name), loc) call
adamc@614	2415
adamc@608	2416 val (ek, fm) = monoExp (env, st, fm) ek
adamc@609	2417
adamc@609	2418 val ekf = (L'.EAbs ("f",
adamc@609	2419 (L'.TFun (t,
adamc@609	2420 (L'.TFun ((L'.TRecord [], loc),
adamc@609	2421 (L'.TRecord [], loc)), loc)), loc),
adamc@609	2422 (L'.TFun (t,
adamc@609	2423 (L'.TRecord [], loc)), loc),
adamc@609	2424 (L'.EAbs ("x",
adamc@609	2425 t,
adamc@609	2426 (L'.TRecord [], loc),
adamc@609	2427 (L'.EApp ((L'.EApp ((L'.ERel 1, loc),
adamc@609	2428 (L'.ERel 0, loc)), loc),
adamc@609	2429 (L'.ERecord [], loc)), loc)), loc)), loc)
adamc@609	2430 val ek = (L'.EApp (ekf, ek), loc)
adamc@651	2431 val e = (L'.EServerCall (call, ek, t), loc)
adamc@651	2432 val e = liftExpInExp 0 e
adamc@651	2433 val unit = (L'.TRecord [], loc)
adamc@651	2434 val e = (L'.EAbs ("_", unit, unit, e), loc)
adamc@608	2435 in
adamc@651	2436 (e, fm)
adamc@608	2437 end
adamc@626	2438
adamc@626	2439 \| L.EKAbs _ => poly ()
adamc@626	2440 \| L.EKApp _ => poly ()
adamc@25	2441 end
adamc@25	2442
adamc@179	2443 fun monoDecl (env, fm) (all as (d, loc)) =
adamc@25	2444 let
adamc@25	2445 fun poly () =
adamc@25	2446 (E.errorAt loc "Unsupported declaration";
adamc@25	2447 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
adamc@25	2448 NONE)
adamc@25	2449 in
adamc@25	2450 case d of
adamc@25	2451 L.DCon _ => NONE
adamc@193	2452 \| L.DDatatype (x, n, [], xncs) =>
adamc@193	2453 let
adamc@196	2454 val env' = Env.declBinds env all
adamc@196	2455 val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env') to)) xncs), loc)
adamc@164	2456 in
adamc@273	2457 SOME (env', fm, [d])
adamc@193	2458 end
adamc@193	2459 \| L.DDatatype _ => poly ()
adamc@179	2460 \| L.DVal (x, n, t, e, s) =>
adamc@179	2461 let
adamc@179	2462 val (e, fm) = monoExp (env, St.empty, fm) e
adamc@179	2463 in
adamc@179	2464 SOME (Env.pushENamed env x n t NONE s,
adamc@179	2465 fm,
adamc@273	2466 [(L'.DVal (x, n, monoType env t, e, s), loc)])
adamc@179	2467 end
adamc@128	2468 \| L.DValRec vis =>
adamc@128	2469 let
adamc@128	2470 val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis
adamc@179	2471
adamc@179	2472 val (vis, fm) = ListUtil.foldlMap
adamc@179	2473 (fn ((x, n, t, e, s), fm) =>
adamc@179	2474 let
adamc@179	2475 val (e, fm) = monoExp (env, St.empty, fm) e
adamc@179	2476 in
adamc@179	2477 ((x, n, monoType env t, e, s), fm)
adamc@179	2478 end)
adamc@179	2479 fm vis
adamc@128	2480 in
adamc@128	2481 SOME (env,
adamc@179	2482 fm,
adamc@273	2483 [(L'.DValRec vis, loc)])
adamc@128	2484 end
adamc@144	2485 \| L.DExport (ek, n) =>
adamc@115	2486 let
adamc@120	2487 val (_, t, _, s) = Env.lookupENamed env n
adamc@120	2488
adamc@609	2489 fun unwind (t, args) =
adamc@609	2490 case #1 t of
adamc@609	2491 L.TFun (dom, ran) => unwind (ran, dom :: args)
adamc@314	2492 \| L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
adamc@609	2493 unwind (t, (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) :: args)
adamc@609	2494 \| _ => (rev args, t)
adamc@120	2495
adamc@609	2496 val (ts, ran) = unwind (t, [])
adamc@609	2497 val ts = map (monoType env) ts
adamc@609	2498 val ran = monoType env ran
adamc@115	2499 in
adamc@609	2500 SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)])
adamc@115	2501 end
adamc@705	2502 \| L.DTable (x, n, (L.CRecord (_, xts), _), s, e, _) =>
adamc@251	2503 let
adamc@251	2504 val t = (L.CFfi ("Basis", "string"), loc)
adamc@251	2505 val t' = (L'.TFfi ("Basis", "string"), loc)
adamc@311	2506 val s = "uw_" ^ s
adamc@704	2507 val e_name = (L'.EPrim (Prim.String s), loc)
adamc@273	2508
adamc@273	2509 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
adamc@704	2510
adamc@704	2511 val (e, fm) = monoExp (env, St.empty, fm) e
adamc@251	2512 in
adamc@251	2513 SOME (Env.pushENamed env x n t NONE s,
adamc@251	2514 fm,
adamc@704	2515 [(L'.DTable (s, xts, e), loc),
adamc@704	2516 (L'.DVal (x, n, t', e_name, s), loc)])
adamc@251	2517 end
adamc@273	2518 \| L.DTable _ => poly ()
adamc@338	2519 \| L.DSequence (x, n, s) =>
adamc@338	2520 let
adamc@338	2521 val t = (L.CFfi ("Basis", "string"), loc)
adamc@338	2522 val t' = (L'.TFfi ("Basis", "string"), loc)
adamc@338	2523 val s = "uw_" ^ s
adamc@338	2524 val e = (L'.EPrim (Prim.String s), loc)
adamc@338	2525 in
adamc@338	2526 SOME (Env.pushENamed env x n t NONE s,
adamc@338	2527 fm,
adamc@338	2528 [(L'.DSequence s, loc),
adamc@338	2529 (L'.DVal (x, n, t', e, s), loc)])
adamc@338	2530 end
adamc@683	2531 \| L.DDatabase _ => NONE
adamc@462	2532 \| L.DCookie (x, n, t, s) =>
adamc@462	2533 let
adamc@462	2534 val t = (L.CFfi ("Basis", "string"), loc)
adamc@462	2535 val t' = (L'.TFfi ("Basis", "string"), loc)
adamc@462	2536 val e = (L'.EPrim (Prim.String s), loc)
adamc@462	2537 in
adamc@462	2538 SOME (Env.pushENamed env x n t NONE s,
adamc@462	2539 fm,
adamc@462	2540 [(L'.DVal (x, n, t', e, s), loc)])
adamc@462	2541 end
adamc@25	2542 end
adamc@25	2543
adamc@683	2544 datatype expungable = Client \| Channel
adamc@683	2545
adamc@683	2546 fun monoize env file =
adamc@25	2547 let
adamc@385	2548 val p = !urlPrefix
adamc@385	2549 val () =
adamc@385	2550 if p = "" then
adamc@385	2551 urlPrefix := "/"
adamc@385	2552 else if String.sub (p, size p - 1) <> #"/" then
adamc@385	2553 urlPrefix := p ^ "/"
adamc@385	2554 else
adamc@385	2555 ()
adamc@385	2556
adamc@683	2557 val loc = E.dummySpan
adamc@683	2558 val client = (L'.TFfi ("Basis", "client"), loc)
adamc@683	2559 val unit = (L'.TRecord [], loc)
adamc@687	2560
adamc@687	2561 fun calcClientish xts =
adamc@687	2562 foldl (fn ((x : L.con, t : L.con), st as (nullable, notNullable)) =>
adamc@687	2563 case #1 x of
adamc@687	2564 L.CName x =>
adamc@687	2565 (case #1 t of
adamc@687	2566 L.CFfi ("Basis", "client") =>
adamc@687	2567 (nullable, (x, Client) :: notNullable)
adamc@687	2568 \| L.CApp ((L.CFfi ("Basis", "option"), _),
adamc@687	2569 (L.CFfi ("Basis", "client"), _)) =>
adamc@687	2570 ((x, Client) :: nullable, notNullable)
adamc@687	2571 \| L.CApp ((L.CFfi ("Basis", "channel"), _), _) =>
adamc@687	2572 (nullable, (x, Channel) :: notNullable)
adamc@687	2573 \| L.CApp ((L.CFfi ("Basis", "option"), _),
adamc@687	2574 (L.CApp ((L.CFfi ("Basis", "channel"), _), _), _)) =>
adamc@687	2575 ((x, Channel) :: nullable, notNullable)
adamc@687	2576 \| _ => st)
adamc@687	2577 \| _ => st) ([], []) xts
adamc@687	2578
adamc@683	2579 fun expunger () =
adamc@683	2580 let
adamc@683	2581 val target = (L'.EFfiApp ("Basis", "sqlifyClient", [(L'.ERel 0, loc)]), loc)
adamc@683	2582
adamc@683	2583 fun doTable (tab, xts, e) =
adamc@683	2584 case xts of
adamc@683	2585 L.CRecord (_, xts) =>
adamc@683	2586 let
adamc@687	2587 val (nullable, notNullable) = calcClientish xts
adamc@683	2588
adamc@684	2589 fun cond (x, v) =
adamc@684	2590 (L'.EStrcat ((L'.EPrim (Prim.String ("uw_" ^ x
adamc@684	2591 ^ (case v of
adamc@684	2592 Client => ""
adamc@684	2593 \| Channel => " >> 32")
adamc@684	2594 ^ " = ")), loc),
adamc@684	2595 target), loc)
adamc@684	2596
adamc@684	2597 val e =
adamc@684	2598 foldl (fn ((x, v), e) =>
adamc@684	2599 (L'.ESeq (
adamc@684	2600 (L'.EDml (L'.EStrcat (
adamc@684	2601 (L'.EPrim (Prim.String ("UPDATE uw_"
adamc@684	2602 ^ tab
adamc@684	2603 ^ " SET uw_"
adamc@684	2604 ^ x
adamc@684	2605 ^ " = NULL WHERE ")), loc),
adamc@684	2606 cond (x, v)), loc), loc),
adamc@684	2607 e), loc))
adamc@684	2608 e nullable
adamc@684	2609
adamc@683	2610 val e =
adamc@683	2611 case notNullable of
adamc@683	2612 [] => e
adamc@683	2613 \| eb :: ebs =>
adamc@684	2614 (L'.ESeq (
adamc@684	2615 (L'.EDml (foldl
adamc@684	2616 (fn (eb, s) =>
adamc@684	2617 (L'.EStrcat (s,
adamc@687	2618 (L'.EStrcat ((L'.EPrim (Prim.String " OR "),
adamc@684	2619 loc),
adamc@684	2620 cond eb), loc)), loc))
adamc@684	2621 (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM uw_"
adamc@684	2622 ^ tab
adamc@684	2623 ^ " WHERE ")), loc),
adamc@684	2624 cond eb), loc)
adamc@684	2625 ebs), loc),
adamc@684	2626 e), loc)
adamc@683	2627 in
adamc@683	2628 e
adamc@683	2629 end
adamc@683	2630 \| _ => e
adamc@683	2631
adamc@683	2632 val e = (L'.ERecord [], loc)
adamc@683	2633 in
adamc@683	2634 foldl (fn ((d, _), e) =>
adamc@683	2635 case d of
adamc@705	2636 L.DTable (_, _, xts, tab, _, _) => doTable (tab, #1 xts, e)
adamc@683	2637 \| _ => e) e file
adamc@683	2638 end
adamc@683	2639
adamc@687	2640 fun initializer () =
adamc@687	2641 let
adamc@687	2642 fun doTable (tab, xts, e) =
adamc@687	2643 case xts of
adamc@687	2644 L.CRecord (_, xts) =>
adamc@687	2645 let
adamc@687	2646 val (nullable, notNullable) = calcClientish xts
adamc@687	2647
adamc@687	2648 val e =
adamc@687	2649 case nullable of
adamc@687	2650 [] => e
adamc@687	2651 \| (x, _) :: ebs =>
adamc@687	2652 (L'.ESeq (
adamc@687	2653 (L'.EDml (L'.EPrim (Prim.String
adamc@687	2654 (foldl (fn ((x, _), s) =>
adamc@687	2655 s ^ ", uw_" ^ x ^ " = NULL")
adamc@687	2656 ("UPDATE uw_"
adamc@687	2657 ^ tab
adamc@687	2658 ^ " SET uw_"
adamc@687	2659 ^ x
adamc@687	2660 ^ " = NULL")
adamc@687	2661 ebs)), loc), loc),
adamc@687	2662 e), loc)
adamc@687	2663
adamc@687	2664 val e =
adamc@687	2665 case notNullable of
adamc@687	2666 [] => e
adamc@687	2667 \| eb :: ebs =>
adamc@687	2668 (L'.ESeq (
adamc@687	2669 (L'.EDml (L'.EPrim (Prim.String ("DELETE FROM uw_"
adamc@687	2670 ^ tab)), loc), loc),
adamc@687	2671 e), loc)
adamc@687	2672 in
adamc@687	2673 e
adamc@687	2674 end
adamc@687	2675 \| _ => e
adamc@687	2676
adamc@687	2677 val e = (L'.ERecord [], loc)
adamc@687	2678 in
adamc@687	2679 foldl (fn ((d, _), e) =>
adamc@687	2680 case d of
adamc@705	2681 L.DTable (_, _, xts, tab, _, _) => doTable (tab, #1 xts, e)
adamc@687	2682 \| _ => e) e file
adamc@687	2683 end
adamc@687	2684
adamc@179	2685 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
adamc@683	2686 case #1 d of
adamc@683	2687 L.DDatabase s =>
adamc@683	2688 let
adamc@687	2689 val (nExp, fm) = Fm.freshName fm
adamc@687	2690 val (nIni, fm) = Fm.freshName fm
adamc@687	2691
adamc@687	2692 val dExp = L'.DVal ("expunger",
adamc@687	2693 nExp,
adamc@687	2694 (L'.TFun (client, unit), loc),
adamc@687	2695 (L'.EAbs ("cli", client, unit, expunger ()), loc),
adamc@687	2696 "expunger")
adamc@687	2697 val dIni = L'.DVal ("initializer",
adamc@687	2698 nIni,
adamc@687	2699 (L'.TFun (unit, unit), loc),
adamc@687	2700 (L'.EAbs ("_", unit, unit, initializer ()), loc),
adamc@687	2701 "initializer")
adamc@683	2702 in
adamc@687	2703 (env, Fm.enter fm, (L'.DDatabase {name = s,
adamc@687	2704 expunge = nExp,
adamc@687	2705 initialize = nIni}, loc)
adamc@687	2706 :: (dExp, loc)
adamc@687	2707 :: (dIni, loc)
adamc@683	2708 :: ds)
adamc@683	2709 end
adamc@683	2710 \| _ =>
adamc@683	2711 case monoDecl (env, fm) d of
adamc@683	2712 NONE => (env, fm, ds)
adamc@683	2713 \| SOME (env, fm, ds') =>
adamc@683	2714 (env,
adamc@683	2715 Fm.enter fm,
adamc@683	2716 ds' @ Fm.decls fm @ ds))
adamc@683	2717 (env, Fm.empty (CoreUtil.File.maxName file + 1), []) file
adamc@25	2718 in
adamc@25	2719 rev ds
adamc@25	2720 end
adamc@25	2721
adamc@25	2722 end

Mercurial > urweb

annotate src/monoize.sml @ 706:1fb318c17546