Ur/Web: src/monoize.sml annotate

annotate src/monoize.sml @ 933:6a284a3519ba

Fix some MySQL bugs

author	Adam Chlipala <adamc@hcoop.net>
date	Sun, 13 Sep 2009 15:33:11 -0400
parents	358fca527886
children	2a50da66ffd8

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@735	37 structure IS = IntBinarySet
adamc@196	38
adamc@196	39 val dummyTyp = (L'.TDatatype (0, ref (L'.Enum, [])), E.dummySpan)
adamc@25	40
adamc@252	41 structure U = MonoUtil
adamc@252	42
adamc@252	43 val liftExpInExp =
adamc@252	44 U.Exp.mapB {typ = fn t => t,
adamc@252	45 exp = fn bound => fn e =>
adamc@252	46 case e of
adamc@252	47 L'.ERel xn =>
adamc@252	48 if xn < bound then
adamc@252	49 e
adamc@252	50 else
adamc@252	51 L'.ERel (xn + 1)
adamc@252	52 \| _ => e,
adamc@252	53 bind = fn (bound, U.Exp.RelE _) => bound + 1
adamc@252	54 \| (bound, _) => bound}
adamc@252	55
adamc@25	56 fun monoName env (all as (c, loc)) =
adamc@25	57 let
adamc@25	58 fun poly () =
adamc@25	59 (E.errorAt loc "Unsupported name constructor";
adamc@25	60 Print.eprefaces' [("Constructor", CorePrint.p_con env all)];
adamc@25	61 "")
adamc@25	62 in
adamc@25	63 case c of
adamc@25	64 L.CName s => s
adamc@25	65 \| _ => poly ()
adamc@25	66 end
adamc@25	67
adamc@877	68 fun lowercaseFirst "" = ""
adamc@877	69 \| lowercaseFirst s = String.str (Char.toLower (String.sub (s, 0)))
adamc@877	70 ^ String.extract (s, 1, NONE)
adamc@877	71
adamc@877	72 fun monoNameLc env c = lowercaseFirst (monoName env c)
adamc@877	73
adamc@292	74 fun readType' (t, loc) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc),
adamc@292	75 (L'.TOption t, loc)), loc)
adamc@292	76 fun readErrType (t, loc) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc),
adamc@292	77 t), loc)
adamc@292	78 fun readType (t, loc) =
adamc@292	79 (L'.TRecord [("Read", readType' (t, loc)),
adamc@292	80 ("ReadError", readErrType (t, loc))],
adamc@292	81 loc)
adamc@292	82
adamc@196	83 fun monoType env =
adamc@25	84 let
adamc@196	85 fun mt env dtmap (all as (c, loc)) =
adamc@196	86 let
adamc@196	87 fun poly () =
adamc@196	88 (E.errorAt loc "Unsupported type constructor";
adamc@196	89 Print.eprefaces' [("Constructor", CorePrint.p_con env all)];
adamc@196	90 dummyTyp)
adamc@196	91 in
adamc@196	92 case c of
adamc@196	93 L.TFun (c1, c2) => (L'.TFun (mt env dtmap c1, mt env dtmap c2), loc)
adamc@196	94 \| L.TCFun _ => poly ()
adamc@196	95 \| L.TRecord (L.CRecord ((L.KType, _), xcs), _) =>
adamc@905	96 let
adamc@905	97 val xcs = map (fn (x, t) => (monoName env x, mt env dtmap t)) xcs
adamc@905	98 val xcs = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) xcs
adamc@905	99 in
adamc@905	100 (L'.TRecord xcs, loc)
adamc@905	101 end
adamc@196	102 \| L.TRecord _ => poly ()
adamc@196	103
adamc@288	104 \| L.CApp ((L.CFfi ("Basis", "option"), _), t) =>
adamc@288	105 (L'.TOption (mt env dtmap t), loc)
adamc@757	106 \| L.CApp ((L.CFfi ("Basis", "list"), _), t) =>
adamc@757	107 (L'.TList (mt env dtmap t), loc)
adamc@288	108
adamc@820	109 \| L.CApp ((L.CFfi ("Basis", "monad"), _), _) =>
adamc@820	110 (L'.TRecord [], loc)
adamc@820	111
adamc@387	112 \| L.CApp ((L.CFfi ("Basis", "eq"), _), t) =>
adamc@387	113 let
adamc@387	114 val t = mt env dtmap t
adamc@387	115 in
adamc@387	116 (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)
adamc@387	117 end
adamc@389	118 \| L.CApp ((L.CFfi ("Basis", "num"), _), t) =>
adamc@389	119 let
adamc@389	120 val t = mt env dtmap t
adamc@389	121 in
adamc@417	122 (L'.TRecord [("Zero", t),
adamc@417	123 ("Neg", (L'.TFun (t, t), loc)),
adamc@389	124 ("Plus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	125 ("Minus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	126 ("Times", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	127 ("Div", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	128 ("Mod", (L'.TFun (t, (L'.TFun (t, t), loc)), loc))],
adamc@389	129 loc)
adamc@389	130 end
adamc@391	131 \| L.CApp ((L.CFfi ("Basis", "ord"), _), t) =>
adamc@391	132 let
adamc@391	133 val t = mt env dtmap t
adamc@391	134 in
adamc@391	135 (L'.TRecord [("Lt", (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)),
adamc@391	136 ("Le", (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc))],
adamc@391	137 loc)
adamc@391	138 end
adamc@286	139 \| L.CApp ((L.CFfi ("Basis", "show"), _), t) =>
adamc@286	140 (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
adamc@290	141 \| L.CApp ((L.CFfi ("Basis", "read"), _), t) =>
adamc@292	142 readType (mt env dtmap t, loc)
adamc@286	143
adamc@717	144 \| L.CFfi ("Basis", "url") => (L'.TFfi ("Basis", "string"), loc)
adamc@741	145 \| L.CFfi ("Basis", "mimeType") => (L'.TFfi ("Basis", "string"), loc)
adamc@720	146 \| L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) =>
adamc@196	147 (L'.TFfi ("Basis", "string"), loc)
adamc@196	148 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) =>
adamc@196	149 (L'.TFfi ("Basis", "string"), loc)
adamc@721	150 \| L.CFfi ("Basis", "css_class") => (L'.TFfi ("Basis", "string"), loc)
adamc@196	151
adamc@251	152 \| L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
adamc@252	153 (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc)
adamc@565	154 \| L.CApp ((L.CFfi ("Basis", "source"), _), t) =>
adamc@577	155 (L'.TSource, loc)
adamc@568	156 \| L.CApp ((L.CFfi ("Basis", "signal"), _), t) =>
adamc@568	157 (L'.TSignal (mt env dtmap t), loc)
adamc@462	158 \| L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) =>
adamc@462	159 (L'.TFfi ("Basis", "string"), loc)
adamc@705	160 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_table"), _), _), _), _) =>
adamc@252	161 (L'.TFfi ("Basis", "string"), loc)
adamc@823	162 \| L.CApp ((L.CFfi ("Basis", "sql_view"), _), _) =>
adamc@823	163 (L'.TFfi ("Basis", "string"), loc)
adamc@338	164 \| L.CFfi ("Basis", "sql_sequence") =>
adamc@338	165 (L'.TFfi ("Basis", "string"), loc)
adamc@252	166 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query"), _), _), _), _) =>
adamc@252	167 (L'.TFfi ("Basis", "string"), loc)
adamc@252	168 \| L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query1"), _), _), _), _), _), _) =>
adamc@252	169 (L'.TFfi ("Basis", "string"), loc)
adamc@748	170 \| L.CApp ((L.CFfi ("Basis", "sql_from_items"), _), _) =>
adamc@748	171 (L'.TFfi ("Basis", "string"), loc)
adamc@252	172 \| L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _) =>
adamc@252	173 (L'.TFfi ("Basis", "string"), loc)
adamc@707	174 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "primary_key"), _), _), _), _) =>
adamc@707	175 (L'.TFfi ("Basis", "string"), loc)
adamc@704	176 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraints"), _), _), _), _) =>
adamc@704	177 (L'.TFfi ("Basis", "sql_constraints"), loc)
adamc@705	178 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraint"), _), _), _), _) =>
adamc@704	179 (L'.TFfi ("Basis", "string"), loc)
adamc@712	180 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "linkable"), _), _), _), _) =>
adamc@712	181 (L'.TRecord [], loc)
adamc@709	182 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "matching"), _), _), _), _) =>
adamc@709	183 let
adamc@709	184 val string = (L'.TFfi ("Basis", "string"), loc)
adamc@709	185 in
adamc@709	186 (L'.TRecord [("1", string), ("2", string)], loc)
adamc@709	187 end
adamc@709	188 \| L.CApp ((L.CFfi ("Basis", "propagation_mode"), _), _) =>
adamc@709	189 (L'.TFfi ("Basis", "string"), loc)
adamc@252	190
adamc@252	191 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_subset"), _), _), _), _) =>
adamc@252	192 (L'.TRecord [], loc)
adamc@252	193 \| L.CFfi ("Basis", "sql_relop") =>
adamc@252	194 (L'.TFfi ("Basis", "string"), loc)
adamc@252	195 \| L.CFfi ("Basis", "sql_direction") =>
adamc@252	196 (L'.TFfi ("Basis", "string"), loc)
adamc@252	197 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_order_by"), _), _), _), _) =>
adamc@252	198 (L'.TFfi ("Basis", "string"), loc)
adamc@252	199 \| L.CFfi ("Basis", "sql_limit") =>
adamc@252	200 (L'.TFfi ("Basis", "string"), loc)
adamc@252	201 \| L.CFfi ("Basis", "sql_offset") =>
adamc@252	202 (L'.TFfi ("Basis", "string"), loc)
adamc@753	203 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "fieldsOf"), _), _), _), _) =>
adamc@753	204 (L'.TRecord [], loc)
adamc@252	205
adamc@676	206 \| L.CApp ((L.CFfi ("Basis", "sql_injectable_prim"), _), t) =>
adamc@676	207 (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
adamc@252	208 \| L.CApp ((L.CFfi ("Basis", "sql_injectable"), _), t) =>
adamc@252	209 (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
adamc@750	210 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "nullify"), _), _), _), _) =>
adamc@750	211 (L'.TRecord [], loc)
adamc@252	212 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_unary"), _), _), _), _) =>
adamc@252	213 (L'.TFfi ("Basis", "string"), loc)
adamc@252	214 \| L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_binary"), _), _), _), _), _), _) =>
adamc@252	215 (L'.TFfi ("Basis", "string"), loc)
adamc@252	216 \| L.CApp ((L.CFfi ("Basis", "sql_aggregate"), _), t) =>
adamc@252	217 (L'.TFfi ("Basis", "string"), loc)
adamc@252	218 \| L.CApp ((L.CFfi ("Basis", "sql_summable"), _), _) =>
adamc@252	219 (L'.TRecord [], loc)
adamc@252	220 \| L.CApp ((L.CFfi ("Basis", "sql_maxable"), _), _) =>
adamc@252	221 (L'.TRecord [], loc)
adamc@559	222 \| L.CApp ((L.CFfi ("Basis", "sql_arith"), _), _) =>
adamc@559	223 (L'.TRecord [], loc)
adamc@441	224 \| L.CApp ((L.CFfi ("Basis", "sql_nfunc"), _), _) =>
adamc@441	225 (L'.TFfi ("Basis", "string"), loc)
adamc@746	226 \| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_ufunc"), _), _), _), _) =>
adamc@746	227 (L'.TFfi ("Basis", "string"), loc)
adamc@251	228
adamc@668	229 \| L.CApp ((L.CFfi ("Basis", "channel"), _), _) =>
adamc@668	230 (L'.TFfi ("Basis", "channel"), loc)
adamc@668	231
adamc@196	232 \| L.CRel _ => poly ()
adamc@196	233 \| L.CNamed n =>
adamc@196	234 (case IM.find (dtmap, n) of
adamc@196	235 SOME r => (L'.TDatatype (n, r), loc)
adamc@196	236 \| NONE =>
adamc@196	237 let
adamc@196	238 val r = ref (L'.Default, [])
adamc@196	239 val (_, xs, xncs) = Env.lookupDatatype env n
adamc@196	240
adamc@196	241 val dtmap' = IM.insert (dtmap, n, r)
adamc@196	242
adamc@196	243 val xncs = map (fn (x, n, to) => (x, n, Option.map (mt env dtmap') to)) xncs
adamc@196	244 in
adamc@196	245 case xs of
adamc@198	246 [] =>(r := (ElabUtil.classifyDatatype xncs, xncs);
adamc@196	247 (L'.TDatatype (n, r), loc))
adamc@196	248 \| _ => poly ()
adamc@196	249 end)
adamc@196	250 \| L.CFfi mx => (L'.TFfi mx, loc)
adamc@196	251 \| L.CApp _ => poly ()
adamc@196	252 \| L.CAbs _ => poly ()
adamc@196	253
adamc@196	254 \| L.CName _ => poly ()
adamc@196	255
adamc@196	256 \| L.CRecord _ => poly ()
adamc@196	257 \| L.CConcat _ => poly ()
adamc@621	258 \| L.CMap _ => poly ()
adamc@196	259 \| L.CUnit => poly ()
adamc@214	260
adamc@214	261 \| L.CTuple _ => poly ()
adamc@214	262 \| L.CProj _ => poly ()
adamc@626	263
adamc@626	264 \| L.CKAbs _ => poly ()
adamc@626	265 \| L.CKApp _ => poly ()
adamc@626	266 \| L.TKFun _ => poly ()
adamc@196	267 end
adamc@25	268 in
adamc@196	269 mt env IM.empty
adamc@25	270 end
adamc@25	271
adamc@25	272 val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan)
adamc@25	273
adamc@179	274 structure IM = IntBinaryMap
adamc@179	275
adamc@179	276 datatype foo_kind =
adamc@179	277 Attr
adamc@179	278 \| Url
adamc@179	279
adamc@179	280 fun fk2s fk =
adamc@179	281 case fk of
adamc@179	282 Attr => "attr"
adamc@179	283 \| Url => "url"
adamc@179	284
adamc@179	285 structure Fm :> sig
adamc@179	286 type t
adamc@179	287
adamc@179	288 val empty : int -> t
adamc@179	289
adamc@179	290 val lookup : t -> foo_kind -> int -> (int -> t -> L'.decl * t) -> t * int
adamc@758	291 val lookupList : t -> foo_kind -> L'.typ -> (int -> t -> L'.decl * t) -> t * int
adamc@179	292 val enter : t -> t
adamc@179	293 val decls : t -> L'.decl list
adamc@683	294
adamc@683	295 val freshName : t -> int * t
adamc@179	296 end = struct
adamc@179	297
adamc@179	298 structure M = BinaryMapFn(struct
adamc@179	299 type ord_key = foo_kind
adamc@179	300 fun compare x =
adamc@179	301 case x of
adamc@179	302 (Attr, Attr) => EQUAL
adamc@179	303 \| (Attr, _) => LESS
adamc@179	304 \| (_, Attr) => GREATER
adamc@179	305
adamc@179	306 \| (Url, Url) => EQUAL
adamc@179	307 end)
adamc@179	308
adamc@758	309 structure TM = BinaryMapFn(struct
adamc@758	310 type ord_key = L'.typ
adamc@758	311 val compare = MonoUtil.Typ.compare
adamc@758	312 end)
adamc@758	313
adamc@179	314 type t = {
adamc@179	315 count : int,
adamc@179	316 map : int IM.map M.map,
adamc@758	317 listMap : int TM.map M.map,
adamc@179	318 decls : L'.decl list
adamc@179	319 }
adamc@179	320
adamc@179	321 fun empty count = {
adamc@179	322 count = count,
adamc@179	323 map = M.empty,
adamc@758	324 listMap = M.empty,
adamc@179	325 decls = []
adamc@179	326 }
adamc@179	327
adamc@758	328 fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []}
adamc@758	329 fun freshName {count, map, listMap, decls} = (count, {count = count + 1, map = map, listMap = listMap, decls = decls})
adamc@179	330 fun decls ({decls, ...} : t) = decls
adamc@179	331
adamc@758	332 fun lookup (t as {count, map, listMap, decls}) k n thunk =
adamc@120	333 let
adamc@179	334 val im = Option.getOpt (M.find (map, k), IM.empty)
adamc@179	335 in
adamc@179	336 case IM.find (im, n) of
adamc@179	337 NONE =>
adamc@179	338 let
adamc@179	339 val n' = count
adamc@758	340 val (d, {count, map, listMap, decls}) =
adamc@758	341 thunk count {count = count + 1,
adamc@758	342 map = M.insert (map, k, IM.insert (im, n, n')),
adamc@758	343 listMap = listMap,
adamc@758	344 decls = decls}
adamc@179	345 in
adamc@179	346 ({count = count,
adamc@179	347 map = map,
adamc@758	348 listMap = listMap,
adamc@758	349 decls = d :: decls}, n')
adamc@758	350 end
adamc@758	351 \| SOME n' => (t, n')
adamc@758	352 end
adamc@758	353
adamc@758	354 fun lookupList (t as {count, map, listMap, decls}) k tp thunk =
adamc@758	355 let
adamc@758	356 val tm = Option.getOpt (M.find (listMap, k), TM.empty)
adamc@758	357 in
adamc@758	358 case TM.find (tm, tp) of
adamc@758	359 NONE =>
adamc@758	360 let
adamc@758	361 val n' = count
adamc@758	362 val (d, {count, map, listMap, decls}) =
adamc@758	363 thunk count {count = count + 1,
adamc@758	364 map = map,
adamc@758	365 listMap = M.insert (listMap, k, TM.insert (tm, tp, n')),
adamc@758	366 decls = decls}
adamc@758	367 in
adamc@758	368 ({count = count,
adamc@758	369 map = map,
adamc@758	370 listMap = listMap,
adamc@179	371 decls = d :: decls}, n')
adamc@179	372 end
adamc@179	373 \| SOME n' => (t, n')
adamc@179	374 end
adamc@179	375
adamc@179	376 end
adamc@185	377
adamc@185	378
adamc@185	379 fun capitalize s =
adamc@185	380 if s = "" then
adamc@185	381 s
adamc@185	382 else
adamc@185	383 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
adamc@179	384
adamc@179	385 fun fooifyExp fk env =
adamc@179	386 let
adamc@179	387 fun fooify fm (e, tAll as (t, loc)) =
adamc@120	388 case #1 e of
adamc@120	389 L'.EClosure (fnam, [(L'.ERecord [], _)]) =>
adamc@120	390 let
adamc@120	391 val (_, _, _, s) = Env.lookupENamed env fnam
adamc@120	392 in
adamc@764	393 ((L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm)
adamc@120	394 end
adamc@120	395 \| L'.EClosure (fnam, args) =>
adamc@120	396 let
adamc@120	397 val (_, ft, _, s) = Env.lookupENamed env fnam
adamc@120	398 val ft = monoType env ft
adamc@111	399
adamc@179	400 fun attrify (args, ft, e, fm) =
adamc@120	401 case (args, ft) of
adamc@179	402 ([], _) => (e, fm)
adamc@120	403 \| (arg :: args, (L'.TFun (t, ft), _)) =>
adamc@179	404 let
adamc@179	405 val (arg', fm) = fooify fm (arg, t)
adamc@179	406 in
adamc@179	407 attrify (args, ft,
adamc@179	408 (L'.EStrcat (e,
adamc@179	409 (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc),
adamc@179	410 arg'), loc)), loc),
adamc@179	411 fm)
adamc@179	412 end
adamc@120	413 \| _ => (E.errorAt loc "Type mismatch encoding attribute";
adamc@179	414 (e, fm))
adamc@120	415 in
adamc@764	416 attrify (args, ft, (L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm)
adamc@120	417 end
adamc@120	418 \| _ =>
adamc@120	419 case t of
adamc@185	420 L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [e]), loc), fm)
adamc@200	421
adamc@179	422 \| L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm)
adamc@200	423 \| L'.TRecord ((x, t) :: xts) =>
adamc@200	424 let
adamc@200	425 val (se, fm) = fooify fm ((L'.EField (e, x), loc), t)
adamc@200	426 in
adamc@200	427 foldl (fn ((x, t), (se, fm)) =>
adamc@200	428 let
adamc@200	429 val (se', fm) = fooify fm ((L'.EField (e, x), loc), t)
adamc@200	430 in
adamc@200	431 ((L'.EStrcat (se,
adamc@200	432 (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc),
adamc@200	433 se'), loc)), loc),
adamc@200	434 fm)
adamc@200	435 end) (se, fm) xts
adamc@200	436 end
adamc@111	437
adamc@196	438 \| L'.TDatatype (i, ref (dk, _)) =>
adamc@179	439 let
adamc@179	440 fun makeDecl n fm =
adamc@179	441 let
adamc@193	442 val (x, _, xncs) = Env.lookupDatatype env i
adamc@179	443
adamc@179	444 val (branches, fm) =
adamc@179	445 ListUtil.foldlMap
adamc@179	446 (fn ((x, n, to), fm) =>
adamc@179	447 case to of
adamc@179	448 NONE =>
adamc@188	449 (((L'.PCon (dk, L'.PConVar n, NONE), loc),
adamc@179	450 (L'.EPrim (Prim.String x), loc)),
adamc@179	451 fm)
adamc@179	452 \| SOME t =>
adamc@179	453 let
adamc@182	454 val t = monoType env t
adamc@182	455 val (arg, fm) = fooify fm ((L'.ERel 0, loc), t)
adamc@179	456 in
adamc@188	457 (((L'.PCon (dk, L'.PConVar n, SOME (L'.PVar ("a", t), loc)), loc),
adamc@179	458 (L'.EStrcat ((L'.EPrim (Prim.String (x ^ "/")), loc),
adamc@179	459 arg), loc)),
adamc@179	460 fm)
adamc@179	461 end)
adamc@179	462 fm xncs
adamc@179	463
adamc@179	464 val dom = tAll
adamc@179	465 val ran = (L'.TFfi ("Basis", "string"), loc)
adamc@179	466 in
adamc@179	467 ((L'.DValRec [(fk2s fk ^ "ify_" ^ x,
adamc@179	468 n,
adamc@179	469 (L'.TFun (dom, ran), loc),
adamc@179	470 (L'.EAbs ("x",
adamc@179	471 dom,
adamc@179	472 ran,
adamc@179	473 (L'.ECase ((L'.ERel 0, loc),
adamc@179	474 branches,
adamc@182	475 {disc = dom,
adamc@182	476 result = ran}), loc)), loc),
adamc@179	477 "")], loc),
adamc@179	478 fm)
adamc@179	479 end
adamc@179	480
adamc@179	481 val (fm, n) = Fm.lookup fm fk i makeDecl
adamc@179	482 in
adamc@179	483 ((L'.EApp ((L'.ENamed n, loc), e), loc), fm)
adamc@179	484 end
adamc@164	485
adamc@471	486 \| L'.TOption t =>
adamc@471	487 let
adamc@471	488 val (body, fm) = fooify fm ((L'.ERel 0, loc), t)
adamc@471	489 in
adamc@471	490 ((L'.ECase (e,
adamc@471	491 [((L'.PNone t, loc),
adamc@471	492 (L'.EPrim (Prim.String "None"), loc)),
adamc@471	493
adamc@471	494 ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc),
adamc@471	495 (L'.EStrcat ((L'.EPrim (Prim.String "Some/"), loc),
adamc@471	496 body), loc))],
adamc@471	497 {disc = tAll,
adamc@471	498 result = (L'.TFfi ("Basis", "string"), loc)}), loc),
adamc@471	499 fm)
adamc@471	500 end
adamc@471	501
adamc@758	502 \| L'.TList t =>
adamc@758	503 let
adamc@758	504 fun makeDecl n fm =
adamc@758	505 let
adamc@758	506 val rt = (L'.TRecord [("1", t), ("2", (L'.TList t, loc))], loc)
adamc@758	507 val (arg, fm) = fooify fm ((L'.ERel 0, loc), rt)
adamc@758	508
adamc@758	509 val branches = [((L'.PNone rt, loc),
adamc@758	510 (L'.EPrim (Prim.String "Nil"), loc)),
adamc@758	511 ((L'.PSome (rt, (L'.PVar ("a", rt), loc)), loc),
adamc@758	512 (L'.EStrcat ((L'.EPrim (Prim.String "Cons/"), loc),
adamc@758	513 arg), loc))]
adamc@758	514
adamc@758	515 val dom = tAll
adamc@758	516 val ran = (L'.TFfi ("Basis", "string"), loc)
adamc@758	517 in
adamc@758	518 ((L'.DValRec [(fk2s fk ^ "ify_list",
adamc@758	519 n,
adamc@758	520 (L'.TFun (dom, ran), loc),
adamc@758	521 (L'.EAbs ("x",
adamc@758	522 dom,
adamc@758	523 ran,
adamc@758	524 (L'.ECase ((L'.ERel 0, loc),
adamc@758	525 branches,
adamc@758	526 {disc = dom,
adamc@758	527 result = ran}), loc)), loc),
adamc@758	528 "")], loc),
adamc@758	529 fm)
adamc@758	530 end
adamc@758	531
adamc@758	532 val (fm, n) = Fm.lookupList fm fk t makeDecl
adamc@758	533 in
adamc@758	534 ((L'.EApp ((L'.ENamed n, loc), e), loc), fm)
adamc@758	535 end
adamc@758	536
adamc@490	537 \| _ => (E.errorAt loc "Don't know how to encode attribute/URL type";
adamc@120	538 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
adamc@179	539 (dummyExp, fm))
adamc@120	540 in
adamc@120	541 fooify
adamc@120	542 end
adamc@120	543
adamc@179	544 val attrifyExp = fooifyExp Attr
adamc@179	545 val urlifyExp = fooifyExp Url
adamc@105	546
adamc@143	547 datatype 'a failable_search =
adamc@143	548 Found of 'a
adamc@143	549 \| NotFound
adamc@143	550 \| Error
adamc@143	551
adamc@153	552 structure St :> sig
adamc@153	553 type t
adamc@153	554
adamc@153	555 val empty : t
adamc@153	556
adamc@153	557 val radioGroup : t -> string option
adamc@153	558 val setRadioGroup : t * string -> t
adamc@153	559 end = struct
adamc@153	560
adamc@153	561 type t = {
adamc@153	562 radioGroup : string option
adamc@153	563 }
adamc@153	564
adamc@153	565 val empty = {radioGroup = NONE}
adamc@153	566
adamc@153	567 fun radioGroup (t : t) = #radioGroup t
adamc@153	568
adamc@153	569 fun setRadioGroup (t : t, x) = {radioGroup = SOME x}
adamc@153	570
adamc@153	571 end
adamc@153	572
adamc@186	573 fun monoPatCon env pc =
adamc@178	574 case pc of
adamc@178	575 L.PConVar n => L'.PConVar n
adamc@188	576 \| L.PConFfi {mod = m, datatyp, con, arg, ...} => L'.PConFfi {mod = m, datatyp = datatyp, con = con,
adamc@188	577 arg = Option.map (monoType env) arg}
adamc@178	578
adamc@193	579 val dummyPat = (L'.PPrim (Prim.Int 0), ErrorMsg.dummySpan)
adamc@193	580
adamc@757	581
adamc@757	582 fun listify t = (L'.TRecord [("1", t), ("2", (L'.TList t, #2 t))], #2 t)
adamc@757	583
adamc@193	584 fun monoPat env (all as (p, loc)) =
adamc@193	585 let
adamc@193	586 fun poly () =
adamc@193	587 (E.errorAt loc "Unsupported pattern";
adamc@193	588 Print.eprefaces' [("Pattern", CorePrint.p_pat env all)];
adamc@193	589 dummyPat)
adamc@193	590 in
adamc@193	591 case p of
adamc@193	592 L.PWild => (L'.PWild, loc)
adamc@193	593 \| L.PVar (x, t) => (L'.PVar (x, monoType env t), loc)
adamc@193	594 \| L.PPrim p => (L'.PPrim p, loc)
adamc@193	595 \| L.PCon (dk, pc, [], po) => (L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc)
adamc@757	596 \| L.PCon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], NONE) =>
adamc@757	597 (L'.PNone (listify (monoType env t)), loc)
adamc@757	598 \| L.PCon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], SOME p) =>
adamc@757	599 (L'.PSome (listify (monoType env t), monoPat env p), loc)
adamc@288	600 \| L.PCon (L.Option, _, [t], NONE) => (L'.PNone (monoType env t), loc)
adamc@757	601 \| L.PCon (L.Option, pc, [t], SOME p) => (L'.PSome (monoType env t, monoPat env p), loc)
adamc@193	602 \| L.PCon _ => poly ()
adamc@193	603 \| L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc)
adamc@193	604 end
adamc@178	605
adamc@252	606 fun strcat loc es =
adamc@252	607 case es of
adamc@252	608 [] => (L'.EPrim (Prim.String ""), loc)
adamc@252	609 \| [e] => e
adamc@252	610 \| _ =>
adamc@252	611 let
adamc@252	612 val e2 = List.last es
adamc@252	613 val es = List.take (es, length es - 1)
adamc@252	614 val e1 = List.last es
adamc@252	615 val es = List.take (es, length es - 1)
adamc@252	616 in
adamc@252	617 foldr (fn (e, e') => (L'.EStrcat (e, e'), loc))
adamc@252	618 (L'.EStrcat (e1, e2), loc) es
adamc@252	619 end
adamc@252	620
adamc@252	621 fun strcatComma loc es =
adamc@252	622 case es of
adamc@252	623 [] => (L'.EPrim (Prim.String ""), loc)
adamc@252	624 \| [e] => e
adamc@252	625 \| _ =>
adamc@252	626 let
adamc@252	627 val e1 = List.last es
adamc@252	628 val es = List.take (es, length es - 1)
adamc@252	629 in
adamc@252	630 foldr (fn (e, e') =>
adamc@265	631 case (e, e') of
adamc@265	632 ((L'.EPrim (Prim.String ""), _), _) => e'
adamc@265	633 \| (_, (L'.EPrim (Prim.String ""), _)) => e
adamc@252	634 \| _ =>
adamc@252	635 (L'.EStrcat (e,
adamc@252	636 (L'.EStrcat ((L'.EPrim (Prim.String ", "), loc), e'), loc)), loc))
adamc@252	637 e1 es
adamc@252	638 end
adamc@252	639
adamc@252	640 fun strcatR loc e xs = strcatComma loc (map (fn (x, _) => (L'.EField (e, x), loc)) xs)
adamc@252	641
adamc@735	642 val readCookie = ref IS.empty
adamc@735	643
adamc@877	644 fun isBlobby (t : L.con) =
adamc@877	645 case #1 t of
adamc@877	646 L.CFfi ("Basis", "string") => true
adamc@877	647 \| L.CFfi ("Basis", "blob") => true
adamc@877	648 \| _ => false
adamc@877	649
adamc@179	650 fun monoExp (env, st, fm) (all as (e, loc)) =
adamc@25	651 let
adamc@598	652 val strcat = strcat loc
adamc@598	653 val strcatComma = strcatComma loc
adamc@598	654 fun str s = (L'.EPrim (Prim.String s), loc)
adamc@598	655
adamc@25	656 fun poly () =
adamc@25	657 (E.errorAt loc "Unsupported expression";
adamc@25	658 Print.eprefaces' [("Expression", CorePrint.p_exp env all)];
adamc@179	659 (dummyExp, fm))
adamc@389	660
adamc@389	661 fun numTy t =
adamc@417	662 (L'.TRecord [("Zero", t),
adamc@417	663 ("Neg", (L'.TFun (t, t), loc)),
adamc@389	664 ("Plus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	665 ("Minus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	666 ("Times", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	667 ("Div", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	668 ("Mod", (L'.TFun (t, (L'.TFun (t, t), loc)), loc))], loc)
adamc@417	669 fun numEx (t, zero, neg, plus, minus, times, dv, md) =
adamc@417	670 ((L'.ERecord [("Zero", (L'.EPrim zero, loc), t),
adamc@417	671 ("Neg", neg, (L'.TFun (t, t), loc)),
adamc@389	672 ("Plus", plus, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	673 ("Minus", minus, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	674 ("Times", times, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	675 ("Div", dv, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
adamc@389	676 ("Mod", md, (L'.TFun (t, (L'.TFun (t, t), loc)), loc))], loc), fm)
adamc@391	677
adamc@391	678 fun ordTy t =
adamc@391	679 (L'.TRecord [("Lt", (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)),
adamc@391	680 ("Le", (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc))], loc)
adamc@391	681 fun ordEx (t, lt, le) =
adamc@391	682 ((L'.ERecord [("Lt", lt, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)),
adamc@391	683 ("Le", le, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc))],
adamc@391	684 loc), fm)
adamc@750	685
adamc@750	686 fun outerRec xts =
adamc@750	687 (L'.TRecord (map (fn ((L.CName x, _), (L.CRecord (_, xts), _)) =>
adamc@750	688 (x, (L'.TRecord (map (fn (x', _) => (x, (L'.TRecord [], loc))) xts), loc))
adamc@750	689 \| (x, all as (_, loc)) =>
adamc@750	690 (E.errorAt loc "Unsupported record field constructor";
adamc@750	691 Print.eprefaces' [("Name", CorePrint.p_con env x),
adamc@750	692 ("Constructor", CorePrint.p_con env all)];
adamc@750	693 ("", dummyTyp))) xts), loc)
adamc@25	694 in
adamc@25	695 case e of
adamc@179	696 L.EPrim p => ((L'.EPrim p, loc), fm)
adamc@179	697 \| L.ERel n => ((L'.ERel n, loc), fm)
adamc@179	698 \| L.ENamed n => ((L'.ENamed n, loc), fm)
adamc@193	699 \| L.ECon (dk, pc, [], eo) =>
adamc@193	700 let
adamc@179	701 val (eo, fm) =
adamc@179	702 case eo of
adamc@179	703 NONE => (NONE, fm)
adamc@179	704 \| SOME e =>
adamc@179	705 let
adamc@179	706 val (e, fm) = monoExp (env, st, fm) e
adamc@179	707 in
adamc@179	708 (SOME e, fm)
adamc@179	709 end
adamc@179	710 in
adamc@188	711 ((L'.ECon (dk, monoPatCon env pc, eo), loc), fm)
adamc@193	712 end
adamc@757	713 \| L.ECon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], NONE) =>
adamc@757	714 ((L'.ENone (listify (monoType env t)), loc), fm)
adamc@757	715 \| L.ECon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], SOME e) =>
adamc@757	716 let
adamc@757	717 val (e, fm) = monoExp (env, st, fm) e
adamc@757	718 in
adamc@757	719 ((L'.ESome (listify (monoType env t), e), loc), fm)
adamc@757	720 end
adamc@297	721 \| L.ECon (L.Option, _, [t], NONE) =>
adamc@297	722 ((L'.ENone (monoType env t), loc), fm)
adamc@297	723 \| L.ECon (L.Option, _, [t], SOME e) =>
adamc@297	724 let
adamc@297	725 val (e, fm) = monoExp (env, st, fm) e
adamc@297	726 in
adamc@297	727 ((L'.ESome (monoType env t, e), loc), fm)
adamc@297	728 end
adamc@193	729 \| L.ECon _ => poly ()
adamc@94	730
adamc@387	731 \| L.ECApp ((L.EFfi ("Basis", "eq"), _), t) =>
adamc@387	732 let
adamc@387	733 val t = monoType env t
adamc@387	734 val b = (L'.TFfi ("Basis", "bool"), loc)
adamc@387	735 val dom = (L'.TFun (t, (L'.TFun (t, b), loc)), loc)
adamc@387	736 in
adamc@387	737 ((L'.EAbs ("f", dom, dom,
adamc@387	738 (L'.ERel 0, loc)), loc), fm)
adamc@387	739 end
adamc@387	740 \| L.ECApp ((L.EFfi ("Basis", "ne"), _), t) =>
adamc@387	741 let
adamc@387	742 val t = monoType env t
adamc@387	743 val b = (L'.TFfi ("Basis", "bool"), loc)
adamc@387	744 val dom = (L'.TFun (t, (L'.TFun (t, b), loc)), loc)
adamc@387	745 in
adamc@387	746 ((L'.EAbs ("f", dom, dom,
adamc@387	747 (L'.EAbs ("x", t, (L'.TFun (t, b), loc),
adamc@387	748 (L'.EAbs ("y", t, b,
adamc@387	749 (L'.EUnop ("!", (L'.EApp ((L'.EApp ((L'.ERel 2, loc),
adamc@387	750 (L'.ERel 1, loc)), loc),
adamc@387	751 (L'.ERel 0, loc)), loc)), loc)),
adamc@387	752 loc)),
adamc@387	753 loc)),
adamc@387	754 loc), fm)
adamc@387	755 end
adamc@387	756 \| L.EFfi ("Basis", "eq_int") =>
adamc@387	757 ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc),
adamc@387	758 (L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@387	759 (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc),
adamc@387	760 (L'.TFfi ("Basis", "bool"), loc),
adamc@387	761 (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
adamc@387	762 fm)
adamc@394	763 \| L.EFfi ("Basis", "eq_float") =>
adamc@394	764 ((L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc),
adamc@394	765 (L'.TFun ((L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@394	766 (L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc),
adamc@394	767 (L'.TFfi ("Basis", "bool"), loc),
adamc@394	768 (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
adamc@394	769 fm)
adamc@388	770 \| L.EFfi ("Basis", "eq_bool") =>
adamc@388	771 ((L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc),
adamc@388	772 (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@388	773 (L'.EAbs ("y", (L'.TFfi ("Basis", "bool"), loc),
adamc@388	774 (L'.TFfi ("Basis", "bool"), loc),
adamc@388	775 (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
adamc@388	776 fm)
adamc@388	777 \| L.EFfi ("Basis", "eq_string") =>
adamc@388	778 ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc),
adamc@388	779 (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@388	780 (L'.EAbs ("y", (L'.TFfi ("Basis", "string"), loc),
adamc@388	781 (L'.TFfi ("Basis", "bool"), loc),
adamc@388	782 (L'.EBinop ("!strcmp", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
adamc@388	783 fm)
adamc@821	784 \| L.EFfi ("Basis", "eq_char") =>
adamc@821	785 ((L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc),
adamc@821	786 (L'.TFun ((L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@821	787 (L'.EAbs ("y", (L'.TFfi ("Basis", "char"), loc),
adamc@821	788 (L'.TFfi ("Basis", "bool"), loc),
adamc@821	789 (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
adamc@821	790 fm)
adamc@437	791 \| L.EFfi ("Basis", "eq_time") =>
adamc@437	792 ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc),
adamc@437	793 (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@437	794 (L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc),
adamc@437	795 (L'.TFfi ("Basis", "bool"), loc),
adamc@437	796 (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
adamc@437	797 fm)
adamc@844	798
adamc@422	799 \| L.ECApp ((L.EFfi ("Basis", "mkEq"), _), t) =>
adamc@422	800 let
adamc@422	801 val t = monoType env t
adamc@422	802 val b = (L'.TFfi ("Basis", "bool"), loc)
adamc@422	803 val dom = (L'.TFun (t, (L'.TFun (t, b), loc)), loc)
adamc@422	804 in
adamc@422	805 ((L'.EAbs ("f", dom, dom,
adamc@422	806 (L'.ERel 0, loc)), loc), fm)
adamc@422	807 end
adamc@387	808
adamc@417	809 \| L.ECApp ((L.EFfi ("Basis", "zero"), _), t) =>
adamc@417	810 let
adamc@417	811 val t = monoType env t
adamc@417	812 in
adamc@417	813 ((L'.EAbs ("r", numTy t, t,
adamc@417	814 (L'.EField ((L'.ERel 0, loc), "Zero"), loc)), loc), fm)
adamc@417	815 end
adamc@389	816 \| L.ECApp ((L.EFfi ("Basis", "neg"), _), t) =>
adamc@389	817 let
adamc@389	818 val t = monoType env t
adamc@389	819 in
adamc@389	820 ((L'.EAbs ("r", numTy t, (L'.TFun (t, t), loc),
adamc@389	821 (L'.EField ((L'.ERel 0, loc), "Neg"), loc)), loc), fm)
adamc@389	822 end
adamc@389	823 \| L.ECApp ((L.EFfi ("Basis", "plus"), _), t) =>
adamc@389	824 let
adamc@389	825 val t = monoType env t
adamc@389	826 in
adamc@389	827 ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
adamc@389	828 (L'.EField ((L'.ERel 0, loc), "Plus"), loc)), loc), fm)
adamc@389	829 end
adamc@389	830 \| L.ECApp ((L.EFfi ("Basis", "minus"), _), t) =>
adamc@389	831 let
adamc@389	832 val t = monoType env t
adamc@389	833 in
adamc@389	834 ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
adamc@389	835 (L'.EField ((L'.ERel 0, loc), "Minus"), loc)), loc), fm)
adamc@389	836 end
adamc@389	837 \| L.ECApp ((L.EFfi ("Basis", "times"), _), t) =>
adamc@389	838 let
adamc@389	839 val t = monoType env t
adamc@389	840 in
adamc@389	841 ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
adamc@389	842 (L'.EField ((L'.ERel 0, loc), "Times"), loc)), loc), fm)
adamc@389	843 end
adamc@775	844 \| L.ECApp ((L.EFfi ("Basis", "divide"), _), t) =>
adamc@389	845 let
adamc@389	846 val t = monoType env t
adamc@389	847 in
adamc@389	848 ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
adamc@389	849 (L'.EField ((L'.ERel 0, loc), "Div"), loc)), loc), fm)
adamc@389	850 end
adamc@389	851 \| L.ECApp ((L.EFfi ("Basis", "mod"), _), t) =>
adamc@389	852 let
adamc@389	853 val t = monoType env t
adamc@389	854 in
adamc@389	855 ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
adamc@389	856 (L'.EField ((L'.ERel 0, loc), "Mod"), loc)), loc), fm)
adamc@389	857 end
adamc@389	858 \| L.EFfi ("Basis", "num_int") =>
adamc@389	859 let
adamc@389	860 fun intBin s =
adamc@389	861 (L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc),
adamc@389	862 (L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "int"), loc)), loc),
adamc@389	863 (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc),
adamc@389	864 (L'.TFfi ("Basis", "int"), loc),
adamc@389	865 (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
adamc@389	866 in
adamc@389	867 numEx ((L'.TFfi ("Basis", "int"), loc),
adamc@417	868 Prim.Int (Int64.fromInt 0),
adamc@389	869 (L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc),
adamc@389	870 (L'.TFfi ("Basis", "int"), loc),
adamc@389	871 (L'.EUnop ("-", (L'.ERel 0, loc)), loc)), loc),
adamc@389	872 intBin "+",
adamc@389	873 intBin "-",
adamc@389	874 intBin "*",
adamc@389	875 intBin "/",
adamc@389	876 intBin "%")
adamc@389	877 end
adamc@390	878 \| L.EFfi ("Basis", "num_float") =>
adamc@390	879 let
adamc@390	880 fun floatBin s =
adamc@390	881 (L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc),
adamc@390	882 (L'.TFun ((L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "float"), loc)), loc),
adamc@390	883 (L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc),
adamc@390	884 (L'.TFfi ("Basis", "float"), loc),
adamc@390	885 (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
adamc@390	886 in
adamc@390	887 numEx ((L'.TFfi ("Basis", "float"), loc),
adamc@417	888 Prim.Float 0.0,
adamc@390	889 (L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc),
adamc@390	890 (L'.TFfi ("Basis", "float"), loc),
adamc@390	891 (L'.EUnop ("-", (L'.ERel 0, loc)), loc)), loc),
adamc@390	892 floatBin "+",
adamc@390	893 floatBin "-",
adamc@390	894 floatBin "*",
adamc@390	895 floatBin "/",
adamc@390	896 floatBin "fmod")
adamc@390	897 end
adamc@391	898
adamc@391	899 \| L.ECApp ((L.EFfi ("Basis", "lt"), _), t) =>
adamc@391	900 let
adamc@391	901 val t = monoType env t
adamc@391	902 in
adamc@391	903 ((L'.EAbs ("r", ordTy t, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc),
adamc@391	904 (L'.EField ((L'.ERel 0, loc), "Lt"), loc)), loc), fm)
adamc@391	905 end
adamc@391	906 \| L.ECApp ((L.EFfi ("Basis", "le"), _), t) =>
adamc@391	907 let
adamc@391	908 val t = monoType env t
adamc@391	909 in
adamc@391	910 ((L'.EAbs ("r", ordTy t, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc),
adamc@391	911 (L'.EField ((L'.ERel 0, loc), "Le"), loc)), loc), fm)
adamc@391	912 end
adamc@392	913 \| L.ECApp ((L.EFfi ("Basis", "gt"), _), t) =>
adamc@392	914 let
adamc@392	915 val t = monoType env t
adamc@392	916 val b = (L'.TFfi ("Basis", "bool"), loc)
adamc@392	917 in
adamc@392	918 ((L'.EAbs ("f", ordTy t, (L'.TFun (t, (L'.TFun (t, b), loc)), loc),
adamc@392	919 (L'.EAbs ("x", t, (L'.TFun (t, b), loc),
adamc@392	920 (L'.EAbs ("y", t, b,
adamc@392	921 (L'.EUnop ("!",
adamc@392	922 (L'.EApp ((L'.EApp ((L'.EField ((L'.ERel 2, loc),
adamc@392	923 "Le"), loc),
adamc@392	924 (L'.ERel 1, loc)), loc),
adamc@392	925 (L'.ERel 0, loc)), loc)), loc)), loc)),
adamc@392	926 loc)),
adamc@392	927 loc), fm)
adamc@392	928 end
adamc@392	929 \| L.ECApp ((L.EFfi ("Basis", "ge"), _), t) =>
adamc@392	930 let
adamc@392	931 val t = monoType env t
adamc@392	932 val b = (L'.TFfi ("Basis", "bool"), loc)
adamc@392	933 in
adamc@392	934 ((L'.EAbs ("f", ordTy t, (L'.TFun (t, (L'.TFun (t, b), loc)), loc),
adamc@392	935 (L'.EAbs ("x", t, (L'.TFun (t, b), loc),
adamc@392	936 (L'.EAbs ("y", t, b,
adamc@392	937 (L'.EUnop ("!",
adamc@392	938 (L'.EApp ((L'.EApp ((L'.EField ((L'.ERel 2, loc),
adamc@392	939 "Lt"), loc),
adamc@392	940 (L'.ERel 1, loc)), loc),
adamc@392	941 (L'.ERel 0, loc)), loc)), loc)), loc)),
adamc@392	942 loc)),
adamc@392	943 loc), fm)
adamc@392	944 end
adamc@391	945 \| L.EFfi ("Basis", "ord_int") =>
adamc@391	946 let
adamc@391	947 fun intBin s =
adamc@391	948 (L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc),
adamc@391	949 (L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@391	950 (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc),
adamc@391	951 (L'.TFfi ("Basis", "bool"), loc),
adamc@391	952 (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
adamc@391	953 in
adamc@391	954 ordEx ((L'.TFfi ("Basis", "int"), loc),
adamc@391	955 intBin "<",
adamc@391	956 intBin "<=")
adamc@391	957 end
adamc@394	958 \| L.EFfi ("Basis", "ord_float") =>
adamc@394	959 let
adamc@394	960 fun floatBin s =
adamc@394	961 (L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc),
adamc@394	962 (L'.TFun ((L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@394	963 (L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc),
adamc@394	964 (L'.TFfi ("Basis", "bool"), loc),
adamc@394	965 (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
adamc@394	966 in
adamc@394	967 ordEx ((L'.TFfi ("Basis", "float"), loc),
adamc@394	968 floatBin "<",
adamc@394	969 floatBin "<=")
adamc@394	970 end
adamc@394	971 \| L.EFfi ("Basis", "ord_bool") =>
adamc@394	972 let
adamc@394	973 fun boolBin s =
adamc@394	974 (L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc),
adamc@394	975 (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@394	976 (L'.EAbs ("y", (L'.TFfi ("Basis", "bool"), loc),
adamc@394	977 (L'.TFfi ("Basis", "bool"), loc),
adamc@394	978 (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
adamc@394	979 in
adamc@394	980 ordEx ((L'.TFfi ("Basis", "bool"), loc),
adamc@394	981 boolBin "<",
adamc@394	982 boolBin "<=")
adamc@394	983 end
adamc@395	984 \| L.EFfi ("Basis", "ord_string") =>
adamc@395	985 let
adamc@395	986 fun boolBin s =
adamc@395	987 (L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc),
adamc@395	988 (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@395	989 (L'.EAbs ("y", (L'.TFfi ("Basis", "string"), loc),
adamc@395	990 (L'.TFfi ("Basis", "bool"), loc),
adamc@395	991 (L'.EBinop (s,
adamc@395	992 (L'.EBinop ("strcmp",
adamc@395	993 (L'.ERel 1, loc),
adamc@395	994 (L'.ERel 0, loc)), loc),
adamc@395	995 (L'.EPrim (Prim.Int (Int64.fromInt 0)), loc)), loc)), loc)), loc)
adamc@395	996 in
adamc@395	997 ordEx ((L'.TFfi ("Basis", "string"), loc),
adamc@395	998 boolBin "<",
adamc@395	999 boolBin "<=")
adamc@395	1000 end
adamc@821	1001 \| L.EFfi ("Basis", "ord_char") =>
adamc@821	1002 let
adamc@821	1003 fun charBin s =
adamc@821	1004 (L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc),
adamc@821	1005 (L'.TFun ((L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@821	1006 (L'.EAbs ("y", (L'.TFfi ("Basis", "char"), loc),
adamc@821	1007 (L'.TFfi ("Basis", "bool"), loc),
adamc@821	1008 (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
adamc@821	1009 in
adamc@821	1010 ordEx ((L'.TFfi ("Basis", "char"), loc),
adamc@821	1011 charBin "<",
adamc@821	1012 charBin "<=")
adamc@821	1013 end
adamc@437	1014 \| L.EFfi ("Basis", "ord_time") =>
adamc@437	1015 let
adamc@437	1016 fun boolBin s =
adamc@437	1017 (L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc),
adamc@437	1018 (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
adamc@437	1019 (L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc),
adamc@437	1020 (L'.TFfi ("Basis", "bool"), loc),
adamc@437	1021 (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
adamc@437	1022 in
adamc@437	1023 ordEx ((L'.TFfi ("Basis", "time"), loc),
adamc@437	1024 boolBin "<",
adamc@437	1025 boolBin "<=")
adamc@437	1026 end
adamc@389	1027
adamc@286	1028 \| L.ECApp ((L.EFfi ("Basis", "show"), _), t) =>
adamc@286	1029 let
adamc@286	1030 val t = monoType env t
adamc@286	1031 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@286	1032 in
adamc@286	1033 ((L'.EAbs ("f", (L'.TFun (t, s), loc), (L'.TFun (t, s), loc),
adamc@286	1034 (L'.ERel 0, loc)), loc), fm)
adamc@286	1035 end
adamc@286	1036 \| L.EFfi ("Basis", "show_int") =>
adamc@286	1037 ((L'.EFfi ("Basis", "intToString"), loc), fm)
adamc@286	1038 \| L.EFfi ("Basis", "show_float") =>
adamc@286	1039 ((L'.EFfi ("Basis", "floatToString"), loc), fm)
adamc@286	1040 \| L.EFfi ("Basis", "show_string") =>
adamc@286	1041 let
adamc@286	1042 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@286	1043 in
adamc@286	1044 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm)
adamc@286	1045 end
adamc@821	1046 \| L.EFfi ("Basis", "show_char") =>
adamc@821	1047 ((L'.EFfi ("Basis", "charToString"), loc), fm)
adamc@286	1048 \| L.EFfi ("Basis", "show_bool") =>
adamc@286	1049 ((L'.EFfi ("Basis", "boolToString"), loc), fm)
adamc@436	1050 \| L.EFfi ("Basis", "show_time") =>
adamc@436	1051 ((L'.EFfi ("Basis", "timeToString"), loc), fm)
adamc@727	1052 \| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "show_xml"), _), _),_), _), _), _) =>
adamc@727	1053 let
adamc@727	1054 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@727	1055 in
adamc@727	1056 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm)
adamc@727	1057 end
adamc@452	1058 \| L.ECApp ((L.EFfi ("Basis", "mkShow"), _), t) =>
adamc@452	1059 let
adamc@452	1060 val t = monoType env t
adamc@452	1061 val b = (L'.TFfi ("Basis", "string"), loc)
adamc@452	1062 val dom = (L'.TFun (t, b), loc)
adamc@452	1063 in
adamc@452	1064 ((L'.EAbs ("f", dom, dom,
adamc@452	1065 (L'.ERel 0, loc)), loc), fm)
adamc@452	1066 end
adamc@286	1067
adamc@290	1068 \| L.ECApp ((L.EFfi ("Basis", "read"), _), t) =>
adamc@290	1069 let
adamc@290	1070 val t = monoType env t
adamc@290	1071 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@290	1072 in
adamc@292	1073 ((L'.EAbs ("f", readType (t, loc), readType' (t, loc),
adamc@292	1074 (L'.EField ((L'.ERel 0, loc), "Read"), loc)), loc), fm)
adamc@292	1075 end
adamc@292	1076 \| L.ECApp ((L.EFfi ("Basis", "readError"), _), t) =>
adamc@292	1077 let
adamc@292	1078 val t = monoType env t
adamc@292	1079 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@292	1080 in
adamc@292	1081 ((L'.EAbs ("f", readType (t, loc), readErrType (t, loc),
adamc@292	1082 (L'.EField ((L'.ERel 0, loc), "ReadError"), loc)), loc), fm)
adamc@290	1083 end
adamc@777	1084 \| L.ECApp ((L.EFfi ("Basis", "mkRead"), _), t) =>
adamc@777	1085 let
adamc@777	1086 val t = monoType env t
adamc@777	1087 val b = (L'.TFfi ("Basis", "string"), loc)
adamc@777	1088 val b' = (L'.TOption b, loc)
adamc@777	1089 val dom = (L'.TFun (t, b), loc)
adamc@777	1090 val dom' = (L'.TFun (t, b'), loc)
adamc@777	1091 in
adamc@777	1092 ((L'.EAbs ("f", dom, (L'.TFun (dom', readType (t, loc)), loc),
adamc@777	1093 (L'.EAbs ("f'", dom', readType (t, loc),
adamc@777	1094 (L'.ERecord [("Read", (L'.ERel 0, loc), dom),
adamc@777	1095 ("ReadError", (L'.ERel 1, loc), dom')], loc)), loc)), loc),
adamc@777	1096 fm)
adamc@777	1097 end
adamc@290	1098 \| L.EFfi ("Basis", "read_int") =>
adamc@292	1099 let
adamc@292	1100 val t = (L'.TFfi ("Basis", "int"), loc)
adamc@292	1101 in
adamc@292	1102 ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToInt"), loc), readType' (t, loc)),
adamc@292	1103 ("ReadError", (L'.EFfi ("Basis", "stringToInt_error"), loc), readErrType (t, loc))],
adamc@292	1104 loc),
adamc@292	1105 fm)
adamc@292	1106 end
adamc@290	1107 \| L.EFfi ("Basis", "read_float") =>
adamc@292	1108 let
adamc@292	1109 val t = (L'.TFfi ("Basis", "float"), loc)
adamc@292	1110 in
adamc@292	1111 ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToFloat"), loc), readType' (t, loc)),
adamc@292	1112 ("ReadError", (L'.EFfi ("Basis", "stringToFloat_error"), loc), readErrType (t, loc))],
adamc@292	1113 loc),
adamc@292	1114 fm)
adamc@292	1115 end
adamc@290	1116 \| L.EFfi ("Basis", "read_string") =>
adamc@290	1117 let
adamc@290	1118 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@290	1119 in
adamc@292	1120 ((L'.ERecord [("Read", (L'.EAbs ("s", s, (L'.TOption s, loc),
adamc@292	1121 (L'.ESome (s, (L'.ERel 0, loc)), loc)), loc), readType' (s, loc)),
adamc@292	1122 ("ReadError", (L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), readErrType (s, loc))], loc),
adamc@292	1123 fm)
adamc@290	1124 end
adamc@821	1125 \| L.EFfi ("Basis", "read_char") =>
adamc@821	1126 let
adamc@821	1127 val t = (L'.TFfi ("Basis", "char"), loc)
adamc@821	1128 in
adamc@821	1129 ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToChar"), loc), readType' (t, loc)),
adamc@821	1130 ("ReadError", (L'.EFfi ("Basis", "stringToChar_error"), loc), readErrType (t, loc))],
adamc@821	1131 loc),
adamc@821	1132 fm)
adamc@821	1133 end
adamc@290	1134 \| L.EFfi ("Basis", "read_bool") =>
adamc@292	1135 let
adamc@292	1136 val t = (L'.TFfi ("Basis", "bool"), loc)
adamc@292	1137 in
adamc@292	1138 ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToBool"), loc), readType' (t, loc)),
adamc@292	1139 ("ReadError", (L'.EFfi ("Basis", "stringToBool_error"), loc), readErrType (t, loc))],
adamc@292	1140 loc),
adamc@292	1141 fm)
adamc@292	1142 end
adamc@436	1143 \| L.EFfi ("Basis", "read_time") =>
adamc@436	1144 let
adamc@436	1145 val t = (L'.TFfi ("Basis", "time"), loc)
adamc@436	1146 in
adamc@436	1147 ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToTime"), loc), readType' (t, loc)),
adamc@436	1148 ("ReadError", (L'.EFfi ("Basis", "stringToTime_error"), loc), readErrType (t, loc))],
adamc@436	1149 loc),
adamc@436	1150 fm)
adamc@436	1151 end
adamc@290	1152
adamc@820	1153 \| L.EFfi ("Basis", "transaction_monad") => ((L'.ERecord [], loc), fm)
adamc@820	1154 \| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), (L.CFfi ("Basis", "transaction"), _)), _), t) =>
adamc@252	1155 let
adamc@252	1156 val t = monoType env t
adamc@252	1157 in
adamc@820	1158 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), t), loc)), loc),
adamc@820	1159 (L'.EAbs ("x", t,
adamc@820	1160 (L'.TFun ((L'.TRecord [], loc), t), loc),
adamc@820	1161 (L'.EAbs ("_", (L'.TRecord [], loc), t,
adamc@820	1162 (L'.ERel 1, loc)), loc)), loc)), loc),
adamc@820	1163 fm)
adamc@252	1164 end
adamc@820	1165 \| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), (L.CFfi ("Basis", "transaction"), _)), _),
adamc@820	1166 t1), _), t2) =>
adamc@251	1167 let
adamc@251	1168 val t1 = monoType env t1
adamc@251	1169 val t2 = monoType env t2
adamc@251	1170 val un = (L'.TRecord [], loc)
adamc@252	1171 val mt1 = (L'.TFun (un, t1), loc)
adamc@252	1172 val mt2 = (L'.TFun (un, t2), loc)
adamc@251	1173 in
adamc@820	1174 ((L'.EAbs ("_", un,
adamc@820	1175 (L'.TFun (mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc)), loc)), loc),
adamc@820	1176 (L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc)), loc),
adamc@820	1177 (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc),
adamc@820	1178 (L'.EAbs ("_", un, un,
adamc@820	1179 (L'.ELet ("r", t1, (L'.EApp ((L'.ERel 2, loc),
adamc@820	1180 (L'.ERecord [], loc)), loc),
adamc@820	1181 (L'.EApp (
adamc@820	1182 (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc),
adamc@820	1183 (L'.ERecord [], loc)),
adamc@820	1184 loc)), loc)), loc)), loc)), loc)), loc),
adamc@251	1185 fm)
adamc@251	1186 end
adamc@697	1187
adamc@670	1188 \| L.EApp ((L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), _), _), t2), _),
adamc@670	1189 (L.EFfi ("Basis", "transaction_monad"), _)), _),
adamc@670	1190 (L.EApp ((L.ECApp ((L.EFfi ("Basis", "recv"), _), t1), _),
adamc@670	1191 ch), loc)) =>
adamc@670	1192 let
adamc@670	1193 val t1 = monoType env t1
adamc@670	1194 val t2 = monoType env t2
adamc@670	1195 val un = (L'.TRecord [], loc)
adamc@670	1196 val mt2 = (L'.TFun (un, t2), loc)
adamc@670	1197 val (ch, fm) = monoExp (env, st, fm) ch
adamc@670	1198 in
adamc@670	1199 ((L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc),
adamc@670	1200 (L'.EAbs ("_", un, un,
adamc@670	1201 (L'.ERecv (liftExpInExp 0 (liftExpInExp 0 ch),
adamc@670	1202 (L'.ERel 1, loc),
adamc@670	1203 t1), loc)), loc)), loc),
adamc@670	1204 fm)
adamc@670	1205 end
adamc@697	1206 \| L.EFfiApp ("Basis", "recv", _) => poly ()
adamc@697	1207
adamc@695	1208 \| L.EApp ((L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), _), _), t2), _),
adamc@695	1209 (L.EFfi ("Basis", "transaction_monad"), _)), _),
adamc@695	1210 (L.EAbs (_, _, _,
adamc@695	1211 (L.EFfiApp ("Basis", "sleep", [n]), _)), loc)) =>
adamc@695	1212 let
adamc@695	1213 val t2 = monoType env t2
adamc@695	1214 val un = (L'.TRecord [], loc)
adamc@695	1215 val mt2 = (L'.TFun (un, t2), loc)
adamc@695	1216 val (n, fm) = monoExp (env, st, fm) n
adamc@695	1217 in
adamc@695	1218 ((L'.EAbs ("m2", (L'.TFun (un, mt2), loc), (L'.TFun (un, un), loc),
adamc@695	1219 (L'.EAbs ("_", un, un,
adamc@697	1220 (L'.ESleep (liftExpInExp 0 n, (L'.EApp ((L'.ERel 1, loc),
adamc@695	1221 (L'.ERecord [], loc)), loc)),
adamc@695	1222 loc)), loc)), loc),
adamc@695	1223 fm)
adamc@695	1224 end
adamc@697	1225 \| L.EFfiApp ("Basis", "sleep", _) => poly ()
adamc@251	1226
adamc@565	1227 \| L.ECApp ((L.EFfi ("Basis", "source"), _), t) =>
adamc@565	1228 let
adamc@565	1229 val t = monoType env t
adamc@565	1230 in
adamc@577	1231 ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TSource, loc)), loc),
adamc@577	1232 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TSource, loc),
adamc@577	1233 (L'.EFfiApp ("Basis", "new_client_source",
adamc@815	1234 [(L'.EJavaScript (L'.Source t, (L'.ERel 1, loc)), loc)]),
adamc@578	1235 loc)), loc)),
adamc@565	1236 loc),
adamc@565	1237 fm)
adamc@565	1238 end
adamc@575	1239 \| L.ECApp ((L.EFfi ("Basis", "set"), _), t) =>
adamc@575	1240 let
adamc@575	1241 val t = monoType env t
adamc@575	1242 in
adamc@577	1243 ((L'.EAbs ("src", (L'.TSource, loc),
adamc@575	1244 (L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc)), loc),
adamc@575	1245 (L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc),
adamc@575	1246 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
adamc@575	1247 (L'.EFfiApp ("Basis", "set_client_source",
adamc@577	1248 [(L'.ERel 2, loc),
adamc@590	1249 (L'.EJavaScript (L'.Source t,
adamc@815	1250 (L'.ERel 1, loc)), loc)]),
adamc@575	1251 loc)), loc)), loc)), loc),
adamc@575	1252 fm)
adamc@575	1253 end
adamc@601	1254 \| L.ECApp ((L.EFfi ("Basis", "get"), _), t) =>
adamc@601	1255 let
adamc@601	1256 val t = monoType env t
adamc@601	1257 in
adamc@601	1258 ((L'.EAbs ("src", (L'.TSource, loc),
adamc@601	1259 (L'.TFun ((L'.TRecord [], loc), t), loc),
adamc@601	1260 (L'.EAbs ("_", (L'.TRecord [], loc), t,
adamc@601	1261 (L'.EFfiApp ("Basis", "get_client_source",
adamc@601	1262 [(L'.ERel 1, loc)]),
adamc@601	1263 loc)), loc)), loc),
adamc@601	1264 fm)
adamc@601	1265 end
adamc@841	1266 \| L.ECApp ((L.EFfi ("Basis", "current"), _), t) =>
adamc@841	1267 let
adamc@841	1268 val t = monoType env t
adamc@841	1269 in
adamc@841	1270 ((L'.EAbs ("src", (L'.TSource, loc),
adamc@841	1271 (L'.TFun ((L'.TRecord [], loc), t), loc),
adamc@841	1272 (L'.EAbs ("_", (L'.TRecord [], loc), t,
adamc@841	1273 (L'.EFfiApp ("Basis", "current",
adamc@841	1274 [(L'.ERel 1, loc)]),
adamc@841	1275 loc)), loc)), loc),
adamc@841	1276 fm)
adamc@841	1277 end
adamc@565	1278
adamc@694	1279 \| L.EFfiApp ("Basis", "spawn", [e]) =>
adamc@694	1280 let
adamc@694	1281 val (e, fm) = monoExp (env, st, fm) e
adamc@694	1282 in
adamc@694	1283 ((L'.EApp (e, (L'.ERecord [], loc)), loc), fm)
adamc@694	1284 end
adamc@694	1285
adamc@820	1286 \| L.EFfi ("Basis", "signal_monad") => ((L'.ERecord [], loc), fm)
adamc@820	1287 \| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), (L.CFfi ("Basis", "signal"), _)), _), t) =>
adamc@568	1288 let
adamc@568	1289 val t = monoType env t
adamc@568	1290 in
adamc@820	1291 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (t, (L'.TSignal t, loc)), loc),
adamc@820	1292 (L'.EAbs ("x", t, (L'.TSignal t, loc),
adamc@820	1293 (L'.ESignalReturn (L'.ERel 0, loc), loc)), loc)), loc),
adamc@568	1294 fm)
adamc@568	1295 end
adamc@820	1296 \| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), (L.CFfi ("Basis", "signal"), _)), _),
adamc@820	1297 t1), _), t2) =>
adamc@572	1298 let
adamc@572	1299 val t1 = monoType env t1
adamc@572	1300 val t2 = monoType env t2
adamc@572	1301 val un = (L'.TRecord [], loc)
adamc@572	1302 val mt1 = (L'.TSignal t1, loc)
adamc@572	1303 val mt2 = (L'.TSignal t2, loc)
adamc@572	1304 in
adamc@820	1305 ((L'.EAbs ("_", un, (L'.TFun (mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), mt2), loc)), loc),
adamc@820	1306 (L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), mt2), loc),
adamc@820	1307 (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), mt2,
adamc@820	1308 (L'.ESignalBind ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)),
adamc@820	1309 loc),
adamc@572	1310 fm)
adamc@572	1311 end
adamc@574	1312 \| L.ECApp ((L.EFfi ("Basis", "signal"), _), t) =>
adamc@574	1313 let
adamc@574	1314 val t = monoType env t
adamc@574	1315 in
adamc@574	1316 ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), (L'.TSignal t, loc),
adamc@574	1317 (L'.ESignalSource (L'.ERel 0, loc), loc)), loc),
adamc@574	1318 fm)
adamc@574	1319 end
adamc@568	1320
adamc@462	1321 \| L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) =>
adamc@462	1322 let
adamc@462	1323 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@462	1324 val un = (L'.TRecord [], loc)
adamc@462	1325 val t = monoType env t
adamc@462	1326 in
adamc@462	1327 ((L'.EAbs ("c", s, (L'.TFun (un, s), loc),
adamc@462	1328 (L'.EAbs ("_", un, s,
adamc@463	1329 (L'.EUnurlify ((L'.EFfiApp ("Basis", "get_cookie", [(L'.ERel 1, loc)]), loc),
adamc@463	1330 t),
adamc@463	1331 loc)), loc)), loc),
adamc@462	1332 fm)
adamc@462	1333 end
adamc@462	1334
adamc@462	1335 \| L.ECApp ((L.EFfi ("Basis", "setCookie"), _), t) =>
adamc@462	1336 let
adamc@462	1337 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@462	1338 val un = (L'.TRecord [], loc)
adamc@462	1339 val t = monoType env t
adamc@462	1340 val (e, fm) = urlifyExp env fm ((L'.ERel 1, loc), t)
adamc@462	1341 in
adamc@462	1342 ((L'.EAbs ("c", s, (L'.TFun (t, (L'.TFun (un, un), loc)), loc),
adamc@462	1343 (L'.EAbs ("v", t, (L'.TFun (un, un), loc),
adamc@462	1344 (L'.EAbs ("_", un, un,
adamc@764	1345 (L'.EFfiApp ("Basis", "set_cookie", [(L'.EPrim (Prim.String
adamc@764	1346 (Settings.getUrlPrefix ())),
adamc@466	1347 loc),
adamc@466	1348 (L'.ERel 2, loc),
adamc@466	1349 e]), loc)),
adamc@462	1350 loc)), loc)), loc),
adamc@462	1351 fm)
adamc@462	1352 end
adamc@462	1353
adamc@668	1354 \| L.ECApp ((L.EFfi ("Basis", "channel"), _), t) =>
adamc@668	1355 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "channel"), loc),
adamc@668	1356 (L'.EFfiApp ("Basis", "new_channel", [(L'.ERecord [], loc)]), loc)), loc),
adamc@668	1357 fm)
adamc@668	1358 \| L.ECApp ((L.EFfi ("Basis", "send"), _), t) =>
adamc@668	1359 let
adamc@668	1360 val t = monoType env t
adamc@668	1361 val (e, fm) = urlifyExp env fm ((L'.ERel 1, loc), t)
adamc@668	1362 in
adamc@668	1363 ((L'.EAbs ("ch", (L'.TFfi ("Basis", "channel"), loc),
adamc@668	1364 (L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc)), loc),
adamc@668	1365 (L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc),
adamc@668	1366 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
adamc@668	1367 (L'.EFfiApp ("Basis", "send",
adamc@668	1368 [(L'.ERel 2, loc),
adamc@668	1369 e]),
adamc@668	1370 loc)), loc)), loc)), loc),
adamc@668	1371 fm)
adamc@668	1372 end
adamc@668	1373
adamc@707	1374 \| L.ECApp ((L.EFfi ("Basis", "no_primary_key"), _), _) =>
adamc@707	1375 ((L'.EPrim (Prim.String ""), loc),
adamc@707	1376 fm)
adamc@707	1377 \| L.ECApp (
adamc@707	1378 (L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "primary_key"), _), _), _), t), _),
adamc@707	1379 nm), _),
adamc@707	1380 (L.CRecord (_, unique), _)) =>
adamc@707	1381 let
adamc@707	1382 val unique = (nm, t) :: unique
adamc@707	1383 val witnesses = (L'.TRecord (map (fn (nm, _) => (monoName env nm, (L'.TRecord [], loc))) unique), loc)
adamc@707	1384 in
adamc@707	1385 ((L'.EAbs ("_", witnesses, (L'.TFfi ("Basis", "string"), loc),
adamc@707	1386 (L'.EPrim (Prim.String
adamc@707	1387 (String.concatWith ", "
adamc@877	1388 (map (fn (x, _) =>
adamc@877	1389 "uw_" ^ monoNameLc env x
adamc@877	1390 ^ (if #textKeysNeedLengths (Settings.currentDbms ())
adamc@877	1391 andalso isBlobby t then
adamc@877	1392 "(767)"
adamc@877	1393 else
adamc@877	1394 "")) unique))),
adamc@707	1395 loc)), loc),
adamc@707	1396 fm)
adamc@707	1397 end
adamc@707	1398
adamc@704	1399 \| L.ECApp ((L.EFfi ("Basis", "no_constraint"), _), _) =>
adamc@704	1400 ((L'.ERecord [], loc),
adamc@704	1401 fm)
adamc@705	1402 \| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "one_constraint"), _), _), _), _), _), (L.CName name, _)) =>
adamc@704	1403 ((L'.EAbs ("c",
adamc@704	1404 (L'.TFfi ("Basis", "string"), loc),
adamc@704	1405 (L'.TFfi ("Basis", "sql_constraints"), loc),
adamc@704	1406 (L'.ERecord [(name, (L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))], loc)), loc),
adamc@704	1407 fm)
adamc@705	1408 \| L.ECApp (
adamc@705	1409 (L.ECApp (
adamc@705	1410 (L.ECApp (
adamc@705	1411 (L.EFfi ("Basis", "join_constraints"), _),
adamc@705	1412 _), _),
adamc@705	1413 _), _),
adamc@705	1414 _) =>
adamc@704	1415 let
adamc@704	1416 val constraints = (L'.TFfi ("Basis", "sql_constraints"), loc)
adamc@704	1417 in
adamc@704	1418 ((L'.EAbs ("cs1", constraints, (L'.TFun (constraints, constraints), loc),
adamc@704	1419 (L'.EAbs ("cs2", constraints, constraints,
adamc@704	1420 (L'.EStrcat ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
adamc@704	1421 fm)
adamc@704	1422 end
adamc@704	1423
adamc@705	1424 \| L.ECApp (
adamc@705	1425 (L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "unique"), _), _), _), t), _),
adamc@705	1426 nm), _),
adamc@705	1427 (L.CRecord (_, unique), _)) =>
adamc@705	1428 let
adamc@705	1429 val unique = (nm, t) :: unique
adamc@705	1430 in
adamc@705	1431 ((L'.EPrim (Prim.String ("UNIQUE ("
adamc@877	1432 ^ String.concatWith ", "
adamc@877	1433 (map (fn (x, t) => "uw_" ^ monoNameLc env x
adamc@877	1434 ^ (if #textKeysNeedLengths (Settings.currentDbms ())
adamc@877	1435 andalso isBlobby t then
adamc@877	1436 "(767)"
adamc@877	1437 else
adamc@877	1438 "")) unique)
adamc@705	1439 ^ ")")), loc),
adamc@705	1440 fm)
adamc@705	1441 end
adamc@704	1442
adamc@712	1443 \| L.ECApp ((L.EFfi ("Basis", "linkable_same"), loc), _) =>
adamc@712	1444 ((L'.ERecord [], loc), fm)
adamc@712	1445 \| L.ECApp ((L.EFfi ("Basis", "linkable_from_nullable"), loc), _) =>
adamc@712	1446 ((L'.ERecord [], loc), fm)
adamc@712	1447 \| L.ECApp ((L.EFfi ("Basis", "linkable_to_nullable"), loc), _) =>
adamc@712	1448 ((L'.ERecord [], loc), fm)
adamc@712	1449
adamc@709	1450 \| L.EFfi ("Basis", "mat_nil") =>
adamc@709	1451 let
adamc@709	1452 val string = (L'.TFfi ("Basis", "string"), loc)
adamc@709	1453 val stringE = (L'.EPrim (Prim.String ""), loc)
adamc@709	1454 in
adamc@709	1455 ((L'.ERecord [("1", stringE, string),
adamc@709	1456 ("2", stringE, string)], loc), fm)
adamc@709	1457 end
adamc@709	1458 \| L.ECApp (
adamc@709	1459 (L.ECApp (
adamc@709	1460 (L.ECApp (
adamc@709	1461 (L.ECApp (
adamc@709	1462 (L.ECApp (
adamc@712	1463 (L.ECApp (
adamc@712	1464 (L.EFfi ("Basis", "mat_cons"), _),
adamc@712	1465 _), _),
adamc@709	1466 _), _),
adamc@709	1467 _), _),
adamc@709	1468 _), _),
adamc@709	1469 (L.CName nm1, _)), _),
adamc@709	1470 (L.CName nm2, _)) =>
adamc@709	1471 let
adamc@709	1472 val string = (L'.TFfi ("Basis", "string"), loc)
adamc@709	1473 val mat = (L'.TRecord [("1", string), ("2", string)], loc)
adamc@709	1474 in
adamc@712	1475 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (mat, mat), loc),
adamc@712	1476 (L'.EAbs ("m", mat, mat,
adamc@712	1477 (L'.ECase ((L'.EField ((L'.ERel 0, loc), "1"), loc),
adamc@712	1478 [((L'.PPrim (Prim.String ""), loc),
adamc@877	1479 (L'.ERecord [("1", (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm1)),
adamc@712	1480 loc), string),
adamc@877	1481 ("2", (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm2)),
adamc@712	1482 loc), string)], loc)),
adamc@712	1483 ((L'.PWild, loc),
adamc@712	1484 (L'.ERecord [("1", (L'.EStrcat (
adamc@877	1485 (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm1
adamc@877	1486 ^ ", ")),
adamc@712	1487 loc),
adamc@712	1488 (L'.EField ((L'.ERel 0, loc), "1"), loc)),
adamc@712	1489 loc), string),
adamc@712	1490 ("2", (L'.EStrcat (
adamc@877	1491 (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm2
adamc@877	1492 ^ ", ")), loc),
adamc@712	1493 (L'.EField ((L'.ERel 0, loc), "2"), loc)),
adamc@712	1494 loc), string)],
adamc@712	1495 loc))],
adamc@712	1496 {disc = string,
adamc@712	1497 result = mat}), loc)), loc)), loc),
adamc@709	1498 fm)
adamc@709	1499 end
adamc@709	1500
adamc@709	1501 \| L.ECApp ((L.EFfi ("Basis", "restrict"), _), _) => ((L'.EPrim (Prim.String "RESTRICT"), loc), fm)
adamc@709	1502 \| L.ECApp ((L.EFfi ("Basis", "cascade"), _), _) => ((L'.EPrim (Prim.String "CASCADE"), loc), fm)
adamc@709	1503 \| L.ECApp ((L.EFfi ("Basis", "no_action"), _), _) => ((L'.EPrim (Prim.String "NO ACTION"), loc), fm)
adamc@709	1504 \| L.ECApp ((L.EFfi ("Basis", "set_null"), _), _) => ((L'.EPrim (Prim.String "SET NULL"), loc), fm)
adamc@709	1505
adamc@709	1506 \| L.ECApp (
adamc@709	1507 (L.ECApp (
adamc@709	1508 (L.ECApp (
adamc@709	1509 (L.ECApp (
adamc@709	1510 (L.ECApp (
adamc@709	1511 (L.ECApp (
adamc@709	1512 (L.ECApp (
adamc@709	1513 (L.ECApp (
adamc@709	1514 (L.EFfi ("Basis", "foreign_key"), _),
adamc@709	1515 _), _),
adamc@709	1516 _), _),
adamc@709	1517 _), _),
adamc@709	1518 _), _),
adamc@709	1519 _), _),
adamc@709	1520 _), _),
adamc@709	1521 _), _),
adamc@709	1522 _) =>
adamc@709	1523 let
adamc@709	1524 val unit = (L'.TRecord [], loc)
adamc@709	1525 val string = (L'.TFfi ("Basis", "string"), loc)
adamc@709	1526 val mat = (L'.TRecord [("1", string), ("2", string)], loc)
adamc@709	1527 val recd = (L'.TRecord [("OnDelete", string),
adamc@709	1528 ("OnUpdate", string)], loc)
adamc@709	1529
adamc@709	1530 fun strcat [] = raise Fail "Monoize.strcat"
adamc@709	1531 \| strcat [e] = e
adamc@709	1532 \| strcat (e1 :: es) = (L'.EStrcat (e1, strcat es), loc)
adamc@709	1533
adamc@709	1534 fun prop (fd, kw) =
adamc@709	1535 (L'.ECase ((L'.EField ((L'.ERel 0, loc), fd), loc),
adamc@709	1536 [((L'.PPrim (Prim.String "NO ACTION"), loc),
adamc@709	1537 (L'.EPrim (Prim.String ""), loc)),
adamc@709	1538 ((L'.PWild, loc),
adamc@709	1539 strcat [(L'.EPrim (Prim.String (" ON " ^ kw ^ " ")), loc),
adamc@709	1540 (L'.EField ((L'.ERel 0, loc), fd), loc)])],
adamc@709	1541 {disc = string,
adamc@709	1542 result = string}), loc)
adamc@709	1543 in
adamc@709	1544 ((L'.EAbs ("m", mat, (L'.TFun (string, (L'.TFun (recd, string), loc)), loc),
adamc@709	1545 (L'.EAbs ("tab", string, (L'.TFun (recd, string), loc),
adamc@709	1546 (L'.EAbs ("pr", recd, string,
adamc@709	1547 strcat [(L'.EPrim (Prim.String "FOREIGN KEY ("), loc),
adamc@709	1548 (L'.EField ((L'.ERel 2, loc), "1"), loc),
adamc@709	1549 (L'.EPrim (Prim.String ") REFERENCES "), loc),
adamc@709	1550 (L'.ERel 1, loc),
adamc@709	1551 (L'.EPrim (Prim.String " ("), loc),
adamc@709	1552 (L'.EField ((L'.ERel 2, loc), "2"), loc),
adamc@709	1553 (L'.EPrim (Prim.String ")"), loc),
adamc@709	1554 prop ("OnDelete", "DELETE"),
adamc@709	1555 prop ("OnUpdate", "UPDATE")]), loc)), loc)), loc),
adamc@709	1556 fm)
adamc@709	1557 end
adamc@709	1558
adamc@714	1559 \| L.ECApp ((L.EFfi ("Basis", "check"), _), _) =>
adamc@714	1560 let
adamc@714	1561 val string = (L'.TFfi ("Basis", "string"), loc)
adamc@714	1562 in
adamc@714	1563 ((L'.EAbs ("e", string, string,
adamc@714	1564 (L'.EStrcat ((L'.EPrim (Prim.String "CHECK "), loc),
adamc@714	1565 (L'.EFfiApp ("Basis", "checkString",
adamc@714	1566 [(L'.ERel 0, loc)]), loc)), loc)), loc),
adamc@714	1567 fm)
adamc@714	1568 end
adamc@714	1569
adamc@307	1570 \| L.EFfiApp ("Basis", "dml", [e]) =>
adamc@307	1571 let
adamc@307	1572 val (e, fm) = monoExp (env, st, fm) e
adamc@307	1573 in
adamc@468	1574 ((L'.EDml e, loc),
adamc@307	1575 fm)
adamc@307	1576 end
adamc@308	1577
adamc@705	1578 \| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "insert"), _), fields), _), _) =>
adamc@307	1579 (case monoType env (L.TRecord fields, loc) of
adamc@307	1580 (L'.TRecord fields, _) =>
adamc@307	1581 let
adamc@307	1582 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@307	1583 val fields = map (fn (x, _) => (x, s)) fields
adamc@307	1584 val rt = (L'.TRecord fields, loc)
adamc@307	1585 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@307	1586 in
adamc@307	1587 ((L'.EAbs ("tab", s, (L'.TFun (rt, s), loc),
adamc@307	1588 (L'.EAbs ("fs", rt, s,
adamc@598	1589 strcat [sc "INSERT INTO ",
adamc@598	1590 (L'.ERel 1, loc),
adamc@598	1591 sc " (",
adamc@598	1592 strcatComma (map (fn (x, _) => sc ("uw_" ^ x)) fields),
adamc@598	1593 sc ") VALUES (",
adamc@598	1594 strcatComma (map (fn (x, _) =>
adamc@598	1595 (L'.EField ((L'.ERel 0, loc),
adamc@598	1596 x), loc)) fields),
adamc@598	1597 sc ")"]), loc)), loc),
adamc@307	1598 fm)
adamc@307	1599 end
adamc@307	1600 \| _ => poly ())
adamc@307	1601
adamc@705	1602 \| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "update"), _), _), _), _), _), changed) =>
adamc@308	1603 (case monoType env (L.TRecord changed, loc) of
adamc@308	1604 (L'.TRecord changed, _) =>
adamc@308	1605 let
adamc@308	1606 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@308	1607 val changed = map (fn (x, _) => (x, s)) changed
adamc@308	1608 val rt = (L'.TRecord changed, loc)
adamc@308	1609 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@308	1610 in
adamc@308	1611 ((L'.EAbs ("fs", rt, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adamc@308	1612 (L'.EAbs ("tab", s, (L'.TFun (s, s), loc),
adamc@308	1613 (L'.EAbs ("e", s, s,
adamc@886	1614 if #supportsUpdateAs (Settings.currentDbms ()) then
adamc@886	1615 strcat [sc "UPDATE ",
adamc@886	1616 (L'.ERel 1, loc),
adamc@886	1617 sc " AS T SET ",
adamc@886	1618 strcatComma (map (fn (x, _) =>
adamc@886	1619 strcat [sc ("uw_" ^ x
adamc@886	1620 ^ " = "),
adamc@886	1621 (L'.EField
adamc@886	1622 ((L'.ERel 2,
adamc@886	1623 loc),
adamc@886	1624 x), loc)])
adamc@886	1625 changed),
adamc@886	1626 sc " WHERE ",
adamc@886	1627 (L'.ERel 0, loc)]
adamc@886	1628 else
adamc@886	1629 strcat [sc "UPDATE ",
adamc@886	1630 (L'.ERel 1, loc),
adamc@886	1631 sc " SET ",
adamc@886	1632 strcatComma (map (fn (x, _) =>
adamc@886	1633 strcat [sc ("uw_" ^ x
adamc@886	1634 ^ " = "),
adamc@886	1635 (L'.EField
adamc@886	1636 ((L'.ERel 2,
adamc@886	1637 loc),
adamc@886	1638 x), loc)])
adamc@886	1639 changed),
adamc@886	1640 sc " WHERE ",
adamc@886	1641 (L'.EFfiApp ("Basis", "unAs", [(L'.ERel 0, loc)]), loc)]),
adamc@886	1642 loc)), loc)), loc),
adamc@308	1643 fm)
adamc@308	1644 end
adamc@308	1645 \| _ => poly ())
adamc@308	1646
adamc@705	1647 \| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "delete"), _), _), _), _) =>
adamc@309	1648 let
adamc@309	1649 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@309	1650 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@309	1651 in
adamc@309	1652 ((L'.EAbs ("tab", s, (L'.TFun (s, s), loc),
adamc@309	1653 (L'.EAbs ("e", s, s,
adamc@874	1654 if #supportsDeleteAs (Settings.currentDbms ()) then
adamc@874	1655 strcat [sc "DELETE FROM ",
adamc@874	1656 (L'.ERel 1, loc),
adamc@874	1657 sc " AS T WHERE ",
adamc@874	1658 (L'.ERel 0, loc)]
adamc@874	1659 else
adamc@874	1660 strcat [sc "DELETE FROM ",
adamc@874	1661 (L'.ERel 1, loc),
adamc@874	1662 sc " WHERE ",
adamc@874	1663 (L'.EFfiApp ("Basis", "unAs", [(L'.ERel 0, loc)]), loc)]), loc)), loc),
adamc@309	1664 fm)
adamc@309	1665 end
adamc@309	1666
adamc@252	1667 \| L.ECApp (
adamc@252	1668 (L.ECApp (
adamc@252	1669 (L.ECApp ((L.EFfi ("Basis", "query"), _), (L.CRecord (_, tables), _)), _),
adamc@252	1670 exps), _),
adamc@252	1671 state) =>
adamc@252	1672 (case monoType env (L.TRecord exps, loc) of
adamc@252	1673 (L'.TRecord exps, _) =>
adamc@252	1674 let
adamc@252	1675 val tables = map (fn ((L.CName x, _), xts) =>
adamc@252	1676 (case monoType env (L.TRecord xts, loc) of
adamc@252	1677 (L'.TRecord xts, _) => SOME (x, xts)
adamc@252	1678 \| _ => NONE)
adamc@252	1679 \| _ => NONE) tables
adamc@252	1680 in
adamc@252	1681 if List.exists (fn x => x = NONE) tables then
adamc@252	1682 poly ()
adamc@252	1683 else
adamc@252	1684 let
adamc@252	1685 val tables = List.mapPartial (fn x => x) tables
adamc@252	1686 val state = monoType env state
adamc@252	1687 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@252	1688 val un = (L'.TRecord [], loc)
adamc@252	1689
adamc@252	1690 val rt = exps @ map (fn (x, xts) => (x, (L'.TRecord xts, loc))) tables
adamc@252	1691 val ft = (L'.TFun ((L'.TRecord rt, loc),
adamc@252	1692 (L'.TFun (state,
adamc@252	1693 (L'.TFun (un, state), loc)),
adamc@252	1694 loc)), loc)
adamc@252	1695
adamc@267	1696 val body' = (L'.EApp (
adamc@267	1697 (L'.EApp (
adamc@267	1698 (L'.EApp ((L'.ERel 4, loc),
adamc@267	1699 (L'.ERel 1, loc)), loc),
adamc@267	1700 (L'.ERel 0, loc)), loc),
adamc@267	1701 (L'.ERecord [], loc)), loc)
adamc@252	1702
adamc@252	1703 val body = (L'.EQuery {exps = exps,
adamc@252	1704 tables = tables,
adamc@252	1705 state = state,
adamc@252	1706 query = (L'.ERel 3, loc),
adamc@252	1707 body = body',
adamc@252	1708 initial = (L'.ERel 1, loc)},
adamc@252	1709 loc)
adamc@252	1710 in
adamc@252	1711 ((L'.EAbs ("q", s, (L'.TFun (ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc)), loc),
adamc@252	1712 (L'.EAbs ("f", ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc),
adamc@252	1713 (L'.EAbs ("i", state, (L'.TFun (un, state), loc),
adamc@252	1714 (L'.EAbs ("_", un, state,
adamc@252	1715 body), loc)), loc)), loc)), loc), fm)
adamc@252	1716 end
adamc@252	1717 end
adamc@252	1718 \| _ => poly ())
adamc@252	1719
adamc@252	1720 \| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_query"), _), _), _), _), _), _) =>
adamc@252	1721 let
adamc@252	1722 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@252	1723 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@252	1724 fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc)
adamc@252	1725 in
adamc@252	1726 ((L'.EAbs ("r",
adamc@252	1727 (L'.TRecord [("Rows", s), ("OrderBy", s), ("Limit", s), ("Offset", s)], loc),
adamc@252	1728 s,
adamc@598	1729 strcat [gf "Rows",
adamc@598	1730 (L'.ECase (gf "OrderBy",
adamc@598	1731 [((L'.PPrim (Prim.String ""), loc), sc ""),
adamc@598	1732 ((L'.PWild, loc),
adamc@598	1733 strcat [sc " ORDER BY ",
adamc@598	1734 gf "OrderBy"])],
adamc@598	1735 {disc = s, result = s}), loc),
adamc@598	1736 gf "Limit",
adamc@598	1737 gf "Offset"]), loc), fm)
adamc@252	1738 end
adamc@252	1739
adamc@252	1740 \| L.ECApp (
adamc@252	1741 (L.ECApp (
adamc@252	1742 (L.ECApp (
adamc@252	1743 (L.ECApp (
adamc@252	1744 (L.EFfi ("Basis", "sql_query1"), _),
adamc@252	1745 (L.CRecord (_, tables), _)), _),
adamc@252	1746 (L.CRecord (_, grouped), _)), _),
adamc@252	1747 (L.CRecord (_, stables), _)), _),
adamc@252	1748 sexps) =>
adamc@252	1749 let
adamc@252	1750 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@252	1751 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@252	1752 val un = (L'.TRecord [], loc)
adamc@252	1753 fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc)
adamc@252	1754
adamc@252	1755 fun doTables tables =
adamc@252	1756 let
adamc@252	1757 val tables = map (fn ((L.CName x, _), xts) =>
adamc@252	1758 (case monoType env (L.TRecord xts, loc) of
adamc@252	1759 (L'.TRecord xts, _) => SOME (x, xts)
adamc@252	1760 \| _ => NONE)
adamc@252	1761 \| _ => NONE) tables
adamc@252	1762 in
adamc@252	1763 if List.exists (fn x => x = NONE) tables then
adamc@252	1764 NONE
adamc@252	1765 else
adamc@260	1766 let
adamc@260	1767 val tables = List.mapPartial (fn x => x) tables
adamc@260	1768 val tables = ListMergeSort.sort
adamc@260	1769 (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER)
adamc@260	1770 tables
adamc@260	1771 val tables = map (fn (x, xts) =>
adamc@260	1772 (x, ListMergeSort.sort
adamc@260	1773 (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER)
adamc@260	1774 xts)) tables
adamc@260	1775 in
adamc@260	1776 SOME tables
adamc@260	1777 end
adamc@252	1778 end
adamc@252	1779 in
adamc@252	1780 case (doTables tables, doTables grouped, doTables stables, monoType env (L.TRecord sexps, loc)) of
adamc@252	1781 (SOME tables, SOME grouped, SOME stables, (L'.TRecord sexps, _)) =>
adamc@441	1782 let
adamc@441	1783 val sexps = ListMergeSort.sort
adamc@441	1784 (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) sexps
adamc@441	1785 in
adamc@441	1786 ((L'.EAbs ("r",
adamc@748	1787 (L'.TRecord [("From", s),
adamc@441	1788 ("Where", s),
adamc@441	1789 ("GroupBy", un),
adamc@441	1790 ("Having", s),
adamc@441	1791 ("SelectFields", un),
adamc@441	1792 ("SelectExps", (L'.TRecord (map (fn (x, _) => (x, s)) sexps), loc))],
adamc@441	1793 loc),
adamc@441	1794 s,
adamc@598	1795 strcat [sc "SELECT ",
adamc@598	1796 strcatComma (map (fn (x, t) =>
adamc@598	1797 strcat [
adamc@598	1798 (L'.EField (gf "SelectExps", x), loc),
adamc@598	1799 sc (" AS _" ^ x)
adamc@598	1800 ]) sexps
adamc@598	1801 @ map (fn (x, xts) =>
adamc@598	1802 strcatComma
adamc@598	1803 (map (fn (x', _) =>
adamc@598	1804 sc (x ^ ".uw_" ^ x'))
adamc@598	1805 xts)) stables),
adamc@598	1806 sc " FROM ",
adamc@748	1807 gf "From",
adamc@598	1808 (L'.ECase (gf "Where",
adamc@598	1809 [((L'.PPrim (Prim.String "TRUE"), loc),
adamc@598	1810 sc ""),
adamc@598	1811 ((L'.PWild, loc),
adamc@598	1812 strcat [sc " WHERE ", gf "Where"])],
adamc@598	1813 {disc = s,
adamc@598	1814 result = s}), loc),
adamc@598	1815
adamc@598	1816 if List.all (fn (x, xts) =>
adamc@598	1817 case List.find (fn (x', _) => x' = x) grouped of
adamc@598	1818 NONE => List.null xts
adamc@598	1819 \| SOME (_, xts') =>
adamc@598	1820 List.all (fn (x, _) =>
adamc@598	1821 List.exists (fn (x', _) => x' = x)
adamc@598	1822 xts') xts) tables then
adamc@598	1823 sc ""
adamc@598	1824 else
adamc@598	1825 strcat [
adamc@598	1826 sc " GROUP BY ",
adamc@598	1827 strcatComma (map (fn (x, xts) =>
adamc@598	1828 strcatComma
adamc@598	1829 (map (fn (x', _) =>
adamc@598	1830 sc (x ^ ".uw_" ^ x'))
adamc@598	1831 xts)) grouped)
adamc@598	1832 ],
adamc@259	1833
adamc@598	1834 (L'.ECase (gf "Having",
adamc@598	1835 [((L'.PPrim (Prim.String "TRUE"), loc),
adamc@598	1836 sc ""),
adamc@598	1837 ((L'.PWild, loc),
adamc@598	1838 strcat [sc " HAVING ", gf "Having"])],
adamc@598	1839 {disc = s,
adamc@598	1840 result = s}), loc)
adamc@441	1841 ]), loc),
adamc@441	1842 fm)
adamc@441	1843 end
adamc@252	1844 \| _ => poly ()
adamc@252	1845 end
adamc@252	1846
adamc@252	1847 \| L.ECApp (
adamc@252	1848 (L.ECApp (
adamc@252	1849 (L.ECApp (
adamc@252	1850 (L.ECApp (
adamc@252	1851 (L.EFfi ("Basis", "sql_inject"), _),
adamc@252	1852 _), _),
adamc@252	1853 _), _),
adamc@252	1854 _), _),
adamc@252	1855 t) =>
adamc@252	1856 let
adamc@252	1857 val t = monoType env t
adamc@252	1858 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@252	1859 in
adamc@252	1860 ((L'.EAbs ("f", (L'.TFun (t, s), loc), (L'.TFun (t, s), loc),
adamc@252	1861 (L'.ERel 0, loc)), loc), fm)
adamc@252	1862 end
adamc@252	1863
adamc@253	1864 \| L.EFfi ("Basis", "sql_int") =>
adamc@253	1865 ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "string"), loc),
adamc@253	1866 (L'.EFfiApp ("Basis", "sqlifyInt", [(L'.ERel 0, loc)]), loc)), loc),
adamc@253	1867 fm)
adamc@253	1868 \| L.EFfi ("Basis", "sql_float") =>
adamc@253	1869 ((L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "string"), loc),
adamc@253	1870 (L'.EFfiApp ("Basis", "sqlifyFloat", [(L'.ERel 0, loc)]), loc)), loc),
adamc@253	1871 fm)
adamc@253	1872 \| L.EFfi ("Basis", "sql_bool") =>
adamc@253	1873 ((L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "string"), loc),
adamc@253	1874 (L'.EFfiApp ("Basis", "sqlifyBool", [(L'.ERel 0, loc)]), loc)), loc),
adamc@253	1875 fm)
adamc@253	1876 \| L.EFfi ("Basis", "sql_string") =>
adamc@253	1877 ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc),
adamc@253	1878 (L'.EFfiApp ("Basis", "sqlifyString", [(L'.ERel 0, loc)]), loc)), loc),
adamc@253	1879 fm)
adamc@439	1880 \| L.EFfi ("Basis", "sql_time") =>
adamc@439	1881 ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "string"), loc),
adamc@439	1882 (L'.EFfiApp ("Basis", "sqlifyTime", [(L'.ERel 0, loc)]), loc)), loc),
adamc@439	1883 fm)
adamc@737	1884 \| L.EFfi ("Basis", "sql_blob") =>
adamc@737	1885 ((L'.EAbs ("x", (L'.TFfi ("Basis", "blob"), loc), (L'.TFfi ("Basis", "string"), loc),
adamc@737	1886 (L'.EFfiApp ("Basis", "sqlifyBlob", [(L'.ERel 0, loc)]), loc)), loc),
adamc@737	1887 fm)
adamc@678	1888 \| L.ECApp ((L.EFfi ("Basis", "sql_channel"), _), _) =>
adamc@678	1889 ((L'.EAbs ("x", (L'.TFfi ("Basis", "channel"), loc), (L'.TFfi ("Basis", "string"), loc),
adamc@678	1890 (L'.EFfiApp ("Basis", "sqlifyChannel", [(L'.ERel 0, loc)]), loc)), loc),
adamc@678	1891 fm)
adamc@682	1892 \| L.EFfi ("Basis", "sql_client") =>
adamc@682	1893 ((L'.EAbs ("x", (L'.TFfi ("Basis", "client"), loc), (L'.TFfi ("Basis", "string"), loc),
adamc@682	1894 (L'.EFfiApp ("Basis", "sqlifyClient", [(L'.ERel 0, loc)]), loc)), loc),
adamc@682	1895 fm)
adamc@676	1896 \| L.ECApp ((L.EFfi ("Basis", "sql_prim"), _), t) =>
adamc@676	1897 let
adamc@676	1898 val t = monoType env t
adamc@676	1899 val tf = (L'.TFun (t, (L'.TFfi ("Basis", "string"), loc)), loc)
adamc@676	1900 in
adamc@676	1901 ((L'.EAbs ("f", tf, tf, (L'.ERel 0, loc)), loc),
adamc@676	1902 fm)
adamc@676	1903 end
adamc@676	1904 \| L.ECApp ((L.EFfi ("Basis", "sql_option_prim"), _), t) =>
adamc@676	1905 let
adamc@676	1906 val t = monoType env t
adamc@676	1907 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@676	1908 in
adamc@676	1909 ((L'.EAbs ("f",
adamc@676	1910 (L'.TFun (t, s), loc),
adamc@676	1911 (L'.TFun ((L'.TOption t, loc), s), loc),
adamc@676	1912 (L'.EAbs ("x",
adamc@676	1913 (L'.TOption t, loc),
adamc@676	1914 s,
adamc@676	1915 (L'.ECase ((L'.ERel 0, loc),
adamc@676	1916 [((L'.PNone t, loc),
adamc@676	1917 (L'.EPrim (Prim.String "NULL"), loc)),
adamc@676	1918 ((L'.PSome (t, (L'.PVar ("y", t), loc)), loc),
adamc@676	1919 (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc))],
adamc@676	1920 {disc = (L'.TOption t, loc),
adamc@676	1921 result = s}), loc)), loc)), loc),
adamc@676	1922 fm)
adamc@676	1923 end
adamc@253	1924
adamc@750	1925 \| L.ECApp ((L.EFfi ("Basis", "nullify_option"), _), _) =>
adamc@750	1926 ((L'.ERecord [], loc), fm)
adamc@750	1927 \| L.ECApp ((L.EFfi ("Basis", "nullify_prim"), _), _) =>
adamc@750	1928 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
adamc@750	1929 (L'.ERecord [], loc)), loc),
adamc@750	1930 fm)
adamc@750	1931
adamc@252	1932 \| L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) =>
adamc@252	1933 ((L'.ERecord [], loc), fm)
adamc@252	1934 \| L.ECApp ((L.EFfi ("Basis", "sql_subset_all"), _), _) =>
adamc@252	1935 ((L'.ERecord [], loc), fm)
adamc@252	1936
adamc@753	1937 \| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "fieldsOf_table"), _), _), _), _) =>
adamc@753	1938 ((L'.ERecord [], loc), fm)
adamc@753	1939 \| L.ECApp ((L.EFfi ("Basis", "fieldsOf_view"), _), _) =>
adamc@753	1940 ((L'.ERecord [], loc), fm)
adamc@753	1941
adamc@753	1942 \| L.ECApp ((L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_table"), _), _), _), _), _), _), _),
adamc@753	1943 (L.CName name, _)) =>
adamc@748	1944 let
adamc@748	1945 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@748	1946 in
adamc@748	1947 ((L'.EAbs ("tab", s, s,
adamc@748	1948 strcat [(L'.ERel 0, loc),
adamc@748	1949 (L'.EPrim (Prim.String (" AS " ^ name)), loc)]), loc),
adamc@748	1950 fm)
adamc@748	1951 end
adamc@748	1952 \| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_comma"), _), _), _), _) =>
adamc@748	1953 let
adamc@748	1954 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@748	1955 in
adamc@748	1956 ((L'.EAbs ("tab1", s, (L'.TFun (s, s), loc),
adamc@748	1957 (L'.EAbs ("tab2", s, s,
adamc@748	1958 strcat [(L'.ERel 1, loc),
adamc@748	1959 (L'.EPrim (Prim.String ", "), loc),
adamc@748	1960 (L'.ERel 0, loc)]), loc)), loc),
adamc@748	1961 fm)
adamc@748	1962 end
adamc@749	1963 \| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_inner_join"), _), _), _), _) =>
adamc@749	1964 let
adamc@749	1965 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@749	1966 in
adamc@749	1967 ((L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adamc@749	1968 (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
adamc@749	1969 (L'.EAbs ("on", s, s,
adamc@749	1970 strcat [(L'.EPrim (Prim.String "("), loc),
adamc@749	1971 (L'.ERel 2, loc),
adamc@749	1972 (L'.EPrim (Prim.String " JOIN "), loc),
adamc@749	1973 (L'.ERel 1, loc),
adamc@749	1974 (L'.EPrim (Prim.String " ON "), loc),
adamc@749	1975 (L'.ERel 0, loc),
adamc@749	1976 (L'.EPrim (Prim.String ")"), loc)]), loc)), loc)), loc),
adamc@749	1977 fm)
adamc@749	1978 end
adamc@750	1979 \| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_left_join"), _), _), _), (L.CRecord (_, right), _)) =>
adamc@750	1980 let
adamc@750	1981 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@750	1982 in
adamc@750	1983 ((L'.EAbs ("_", outerRec right,
adamc@750	1984 (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
adamc@750	1985 (L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adamc@750	1986 (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
adamc@750	1987 (L'.EAbs ("on", s, s,
adamc@750	1988 strcat [(L'.EPrim (Prim.String "("), loc),
adamc@750	1989 (L'.ERel 2, loc),
adamc@750	1990 (L'.EPrim (Prim.String " LEFT JOIN "), loc),
adamc@750	1991 (L'.ERel 1, loc),
adamc@750	1992 (L'.EPrim (Prim.String " ON "), loc),
adamc@750	1993 (L'.ERel 0, loc),
adamc@750	1994 (L'.EPrim (Prim.String ")"), loc)]),
adamc@750	1995 loc)), loc)), loc)), loc),
adamc@750	1996 fm)
adamc@750	1997 end
adamc@751	1998 \| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_right_join"), _), (L.CRecord (_, left), _)), _), _) =>
adamc@751	1999 let
adamc@751	2000 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@751	2001 in
adamc@751	2002 ((L'.EAbs ("_", outerRec left,
adamc@751	2003 (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
adamc@751	2004 (L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adamc@751	2005 (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
adamc@751	2006 (L'.EAbs ("on", s, s,
adamc@751	2007 strcat [(L'.EPrim (Prim.String "("), loc),
adamc@751	2008 (L'.ERel 2, loc),
adamc@751	2009 (L'.EPrim (Prim.String " RIGHT JOIN "), loc),
adamc@751	2010 (L'.ERel 1, loc),
adamc@751	2011 (L'.EPrim (Prim.String " ON "), loc),
adamc@751	2012 (L'.ERel 0, loc),
adamc@751	2013 (L'.EPrim (Prim.String ")"), loc)]),
adamc@751	2014 loc)), loc)), loc)), loc),
adamc@751	2015 fm)
adamc@751	2016 end
adamc@751	2017 \| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_full_join"), _), (L.CRecord (_, left), _)), _),
adamc@751	2018 (L.CRecord (_, right), _)) =>
adamc@751	2019 let
adamc@751	2020 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@751	2021 in
adamc@751	2022 ((L'.EAbs ("_", outerRec (left @ right),
adamc@751	2023 (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
adamc@751	2024 (L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adamc@751	2025 (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
adamc@751	2026 (L'.EAbs ("on", s, s,
adamc@751	2027 strcat [(L'.EPrim (Prim.String "("), loc),
adamc@751	2028 (L'.ERel 2, loc),
adamc@751	2029 (L'.EPrim (Prim.String " FULL JOIN "), loc),
adamc@751	2030 (L'.ERel 1, loc),
adamc@751	2031 (L'.EPrim (Prim.String " ON "), loc),
adamc@751	2032 (L'.ERel 0, loc),
adamc@751	2033 (L'.EPrim (Prim.String ")"), loc)]),
adamc@751	2034 loc)), loc)), loc)), loc),
adamc@751	2035 fm)
adamc@751	2036 end
adamc@748	2037
adamc@252	2038 \| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) =>
adamc@252	2039 ((L'.EPrim (Prim.String ""), loc), fm)
adamc@261	2040 \| L.ECApp (
adamc@261	2041 (L.ECApp (
adamc@261	2042 (L.ECApp (
adamc@261	2043 (L.EFfi ("Basis", "sql_order_by_Cons"), _),
adamc@261	2044 _), _),
adamc@261	2045 _), _),
adamc@261	2046 _) =>
adamc@261	2047 let
adamc@261	2048 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@261	2049 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@261	2050 in
adamc@268	2051 ((L'.EAbs ("e1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adamc@268	2052 (L'.EAbs ("d", s, (L'.TFun (s, s), loc),
adamc@268	2053 (L'.EAbs ("e2", s, s,
adamc@268	2054 (L'.ECase ((L'.ERel 0, loc),
adamc@268	2055 [((L'.PPrim (Prim.String ""), loc),
adamc@598	2056 strcat [(L'.ERel 2, loc),
adamc@598	2057 (L'.ERel 1, loc)]),
adamc@268	2058 ((L'.PWild, loc),
adamc@598	2059 strcat [(L'.ERel 2, loc),
adamc@598	2060 (L'.ERel 1, loc),
adamc@598	2061 sc ", ",
adamc@598	2062 (L'.ERel 0, loc)])],
adamc@268	2063 {disc = s, result = s}), loc)), loc)), loc)), loc),
adamc@261	2064 fm)
adamc@261	2065 end
adamc@252	2066
adamc@252	2067 \| L.EFfi ("Basis", "sql_no_limit") =>
adamc@252	2068 ((L'.EPrim (Prim.String ""), loc), fm)
adamc@262	2069 \| L.EFfiApp ("Basis", "sql_limit", [e]) =>
adamc@262	2070 let
adamc@262	2071 val (e, fm) = monoExp (env, st, fm) e
adamc@262	2072 in
adamc@598	2073 (strcat [
adamc@262	2074 (L'.EPrim (Prim.String " LIMIT "), loc),
adamc@262	2075 (L'.EFfiApp ("Basis", "sqlifyInt", [e]), loc)
adamc@262	2076 ],
adamc@262	2077 fm)
adamc@262	2078 end
adamc@262	2079
adamc@252	2080 \| L.EFfi ("Basis", "sql_no_offset") =>
adamc@252	2081 ((L'.EPrim (Prim.String ""), loc), fm)
adamc@263	2082 \| L.EFfiApp ("Basis", "sql_offset", [e]) =>
adamc@263	2083 let
adamc@263	2084 val (e, fm) = monoExp (env, st, fm) e
adamc@263	2085 in
adamc@598	2086 (strcat [
adamc@263	2087 (L'.EPrim (Prim.String " OFFSET "), loc),
adamc@263	2088 (L'.EFfiApp ("Basis", "sqlifyInt", [e]), loc)
adamc@263	2089 ],
adamc@263	2090 fm)
adamc@263	2091 end
adamc@253	2092
adamc@559	2093 \| L.ECApp ((L.EFfi ("Basis", "sql_eq"), _), _) =>
adamc@253	2094 ((L'.EPrim (Prim.String "="), loc), fm)
adamc@559	2095 \| L.ECApp ((L.EFfi ("Basis", "sql_ne"), _), _) =>
adamc@253	2096 ((L'.EPrim (Prim.String "<>"), loc), fm)
adamc@559	2097 \| L.ECApp ((L.EFfi ("Basis", "sql_lt"), _), _) =>
adamc@253	2098 ((L'.EPrim (Prim.String "<"), loc), fm)
adamc@559	2099 \| L.ECApp ((L.EFfi ("Basis", "sql_le"), _), _) =>
adamc@253	2100 ((L'.EPrim (Prim.String "<="), loc), fm)
adamc@559	2101 \| L.ECApp ((L.EFfi ("Basis", "sql_gt"), _), _) =>
adamc@253	2102 ((L'.EPrim (Prim.String ">"), loc), fm)
adamc@559	2103 \| L.ECApp ((L.EFfi ("Basis", "sql_ge"), _), _) =>
adamc@253	2104 ((L'.EPrim (Prim.String ">="), loc), fm)
adamc@253	2105
adamc@559	2106 \| L.ECApp ((L.EFfi ("Basis", "sql_plus"), _), _) =>
adamc@559	2107 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adamc@559	2108 (L'.EPrim (Prim.String "+"), loc)), loc), fm)
adamc@559	2109 \| L.ECApp ((L.EFfi ("Basis", "sql_minus"), _), _) =>
adamc@559	2110 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adamc@559	2111 (L'.EPrim (Prim.String "-"), loc)), loc), fm)
adamc@559	2112 \| L.ECApp ((L.EFfi ("Basis", "sql_times"), _), _) =>
adamc@559	2113 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adamc@559	2114 (L'.EPrim (Prim.String "*"), loc)), loc), fm)
adamc@559	2115 \| L.ECApp ((L.EFfi ("Basis", "sql_div"), _), _) =>
adamc@559	2116 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adamc@559	2117 (L'.EPrim (Prim.String "/"), loc)), loc), fm)
adamc@559	2118 \| L.EFfi ("Basis", "sql_mod") =>
adamc@559	2119 ((L'.EPrim (Prim.String "%"), loc), fm)
adamc@559	2120
adamc@253	2121 \| L.ECApp (
adamc@253	2122 (L.ECApp (
adamc@253	2123 (L.ECApp (
adamc@253	2124 (L.ECApp (
adamc@254	2125 (L.ECApp (
adamc@264	2126 (L.EFfi ("Basis", "sql_unary"), _),
adamc@264	2127 _), _),
adamc@264	2128 _), _),
adamc@264	2129 _), _),
adamc@264	2130 _), _),
adamc@264	2131 _) =>
adamc@264	2132 let
adamc@264	2133 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@264	2134 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@264	2135 in
adamc@264	2136 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adamc@264	2137 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
adamc@598	2138 strcat [sc "(",
adamc@598	2139 (L'.ERel 1, loc),
adamc@598	2140 sc " ",
adamc@598	2141 (L'.ERel 0, loc),
adamc@598	2142 sc ")"]), loc)), loc),
adamc@264	2143 fm)
adamc@264	2144 end
adamc@264	2145 \| L.EFfi ("Basis", "sql_not") => ((L'.EPrim (Prim.String "NOT"), loc), fm)
adamc@559	2146 \| L.ECApp ((L.EFfi ("Basis", "sql_neg"), _), _) =>
adamc@559	2147 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adamc@559	2148 (L'.EPrim (Prim.String "-"), loc)), loc), fm)
adamc@264	2149
adamc@264	2150 \| L.ECApp (
adamc@264	2151 (L.ECApp (
adamc@264	2152 (L.ECApp (
adamc@264	2153 (L.ECApp (
adamc@264	2154 (L.ECApp (
adamc@254	2155 (L.ECApp (
adamc@254	2156 (L.EFfi ("Basis", "sql_binary"), _),
adamc@254	2157 _), _),
adamc@254	2158 _), _),
adamc@254	2159 _), _),
adamc@254	2160 _), _),
adamc@254	2161 _), _),
adamc@254	2162 _) =>
adamc@254	2163 let
adamc@254	2164 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@254	2165 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@254	2166 in
adamc@254	2167 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adamc@254	2168 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
adamc@254	2169 (L'.EAbs ("e2", s, s,
adamc@598	2170 strcat [sc "(",
adamc@598	2171 (L'.ERel 1, loc),
adamc@598	2172 sc " ",
adamc@598	2173 (L'.ERel 2, loc),
adamc@598	2174 sc " ",
adamc@598	2175 (L'.ERel 0, loc),
adamc@598	2176 sc ")"]), loc)), loc)), loc),
adamc@254	2177 fm)
adamc@254	2178 end
adamc@254	2179 \| L.EFfi ("Basis", "sql_and") => ((L'.EPrim (Prim.String "AND"), loc), fm)
adamc@254	2180 \| L.EFfi ("Basis", "sql_or") => ((L'.EPrim (Prim.String "OR"), loc), fm)
adamc@254	2181
adamc@254	2182 \| L.ECApp (
adamc@254	2183 (L.ECApp (
adamc@254	2184 (L.ECApp (
adamc@254	2185 (L.ECApp (
adamc@253	2186 (L.ECApp (
adamc@253	2187 (L.ECApp (
adamc@253	2188 (L.ECApp (
adamc@253	2189 (L.EFfi ("Basis", "sql_field"), _),
adamc@253	2190 _), _),
adamc@253	2191 _), _),
adamc@253	2192 _), _),
adamc@253	2193 _), _),
adamc@253	2194 _), _),
adamc@253	2195 (L.CName tab, _)), _),
adamc@877	2196 (L.CName field, _)) => ((L'.EPrim (Prim.String (tab ^ ".uw_" ^ lowercaseFirst field)), loc), fm)
adamc@260	2197
adamc@260	2198 \| L.ECApp (
adamc@260	2199 (L.ECApp (
adamc@260	2200 (L.ECApp (
adamc@260	2201 (L.ECApp (
adamc@261	2202 (L.ECApp (
adamc@261	2203 (L.EFfi ("Basis", "sql_exp"), _),
adamc@261	2204 _), _),
adamc@261	2205 _), _),
adamc@261	2206 _), _),
adamc@261	2207 _), _),
adamc@877	2208 (L.CName nm, _)) => ((L'.EPrim (Prim.String ("_" ^ lowercaseFirst nm)), loc), fm)
adamc@261	2209
adamc@261	2210 \| L.ECApp (
adamc@261	2211 (L.ECApp (
adamc@261	2212 (L.ECApp (
adamc@261	2213 (L.ECApp (
adamc@260	2214 (L.EFfi ("Basis", "sql_relop"), _),
adamc@260	2215 _), _),
adamc@260	2216 _), _),
adamc@260	2217 _), _),
adamc@260	2218 _) =>
adamc@260	2219 let
adamc@260	2220 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@260	2221 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@260	2222 in
adamc@260	2223 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adamc@260	2224 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
adamc@260	2225 (L'.EAbs ("e2", s, s,
adamc@598	2226 strcat [sc "((",
adamc@598	2227 (L'.ERel 1, loc),
adamc@598	2228 sc ") ",
adamc@598	2229 (L'.ERel 2, loc),
adamc@598	2230 sc " (",
adamc@598	2231 (L'.ERel 0, loc),
adamc@598	2232 sc "))"]), loc)), loc)), loc),
adamc@260	2233 fm)
adamc@260	2234 end
adamc@260	2235
adamc@260	2236 \| L.EFfi ("Basis", "sql_union") => ((L'.EPrim (Prim.String "UNION"), loc), fm)
adamc@260	2237 \| L.EFfi ("Basis", "sql_intersect") => ((L'.EPrim (Prim.String "INTERSECT"), loc), fm)
adamc@260	2238 \| L.EFfi ("Basis", "sql_except") => ((L'.EPrim (Prim.String "EXCEPT"), loc), fm)
adamc@260	2239
adamc@265	2240 \| L.ECApp (
adamc@265	2241 (L.ECApp (
adamc@265	2242 (L.ECApp (
adamc@265	2243 (L.EFfi ("Basis", "sql_count"), _),
adamc@265	2244 _), _),
adamc@265	2245 _), _),
adamc@544	2246 _) => ((L'.EPrim (Prim.String "COUNT(*)"), loc),
adamc@265	2247 fm)
adamc@266	2248
adamc@266	2249 \| L.ECApp (
adamc@266	2250 (L.ECApp (
adamc@266	2251 (L.ECApp (
adamc@266	2252 (L.ECApp (
adamc@266	2253 (L.EFfi ("Basis", "sql_aggregate"), _),
adamc@266	2254 _), _),
adamc@266	2255 _), _),
adamc@266	2256 _), _),
adamc@266	2257 _) =>
adamc@266	2258 let
adamc@266	2259 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@266	2260 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@266	2261 in
adamc@266	2262 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adamc@266	2263 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
adamc@598	2264 strcat [(L'.ERel 1, loc),
adamc@598	2265 sc "(",
adamc@598	2266 (L'.ERel 0, loc),
adamc@598	2267 sc ")"]), loc)), loc),
adamc@266	2268 fm)
adamc@266	2269 end
adamc@266	2270
adamc@266	2271 \| L.EFfi ("Basis", "sql_summable_int") => ((L'.ERecord [], loc), fm)
adamc@266	2272 \| L.EFfi ("Basis", "sql_summable_float") => ((L'.ERecord [], loc), fm)
adamc@266	2273 \| L.ECApp ((L.EFfi ("Basis", "sql_avg"), _), _) =>
adamc@266	2274 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adamc@266	2275 (L'.EPrim (Prim.String "AVG"), loc)), loc),
adamc@266	2276 fm)
adamc@266	2277 \| L.ECApp ((L.EFfi ("Basis", "sql_sum"), _), _) =>
adamc@266	2278 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adamc@266	2279 (L'.EPrim (Prim.String "SUM"), loc)), loc),
adamc@266	2280 fm)
adamc@266	2281
adamc@559	2282 \| L.EFfi ("Basis", "sql_arith_int") => ((L'.ERecord [], loc), fm)
adamc@559	2283 \| L.EFfi ("Basis", "sql_arith_float") => ((L'.ERecord [], loc), fm)
adamc@559	2284
adamc@266	2285 \| L.EFfi ("Basis", "sql_maxable_int") => ((L'.ERecord [], loc), fm)
adamc@266	2286 \| L.EFfi ("Basis", "sql_maxable_float") => ((L'.ERecord [], loc), fm)
adamc@266	2287 \| L.EFfi ("Basis", "sql_maxable_string") => ((L'.ERecord [], loc), fm)
adamc@266	2288 \| L.ECApp ((L.EFfi ("Basis", "sql_max"), _), _) =>
adamc@266	2289 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adamc@266	2290 (L'.EPrim (Prim.String "MAX"), loc)), loc),
adamc@266	2291 fm)
adamc@266	2292 \| L.ECApp ((L.EFfi ("Basis", "sql_min"), _), _) =>
adamc@266	2293 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adamc@266	2294 (L'.EPrim (Prim.String "MIN"), loc)), loc),
adamc@266	2295 fm)
adamc@266	2296
adamc@268	2297 \| L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm)
adamc@268	2298 \| L.EFfi ("Basis", "sql_desc") => ((L'.EPrim (Prim.String " DESC"), loc), fm)
adamc@268	2299
adamc@441	2300 \| L.ECApp (
adamc@441	2301 (L.ECApp (
adamc@441	2302 (L.ECApp (
adamc@441	2303 (L.ECApp (
adamc@441	2304 (L.EFfi ("Basis", "sql_nfunc"), _),
adamc@441	2305 _), _),
adamc@441	2306 _), _),
adamc@441	2307 _), _),
adamc@441	2308 _) =>
adamc@441	2309 let
adamc@441	2310 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@441	2311 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@441	2312 in
adamc@441	2313 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc),
adamc@441	2314 fm)
adamc@441	2315 end
adamc@441	2316 \| L.EFfi ("Basis", "sql_current_timestamp") => ((L'.EPrim (Prim.String "CURRENT_TIMESTAMP"), loc), fm)
adamc@441	2317
adamc@746	2318 \| L.ECApp (
adamc@746	2319 (L.ECApp (
adamc@746	2320 (L.ECApp (
adamc@746	2321 (L.ECApp (
adamc@746	2322 (L.ECApp (
adamc@746	2323 (L.EFfi ("Basis", "sql_ufunc"), _),
adamc@746	2324 _), _),
adamc@746	2325 _), _),
adamc@746	2326 _), _),
adamc@746	2327 _), _),
adamc@746	2328 _) =>
adamc@746	2329 let
adamc@746	2330 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@746	2331 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@746	2332 in
adamc@746	2333 ((L'.EAbs ("f", s, (L'.TFun (s, s), loc),
adamc@746	2334 (L'.EAbs ("x", s, s,
adamc@746	2335 strcat [(L'.ERel 1, loc),
adamc@746	2336 sc "(",
adamc@746	2337 (L'.ERel 0, loc),
adamc@746	2338 sc ")"]), loc)), loc),
adamc@746	2339 fm)
adamc@746	2340 end
adamc@890	2341 \| L.EFfi ("Basis", "sql_octet_length") =>
adamc@890	2342 ((L'.EPrim (Prim.String (if #supportsOctetLength (Settings.currentDbms ()) then
adamc@890	2343 "octet_length"
adamc@890	2344 else
adamc@890	2345 "length")), loc), fm)
adamc@746	2346
adamc@470	2347 \| (L.ECApp (
adamc@470	2348 (L.ECApp (
adamc@470	2349 (L.ECApp (
adamc@470	2350 (L.ECApp (
adamc@470	2351 (L.EFfi ("Basis", "sql_is_null"), _), _),
adamc@470	2352 _), _),
adamc@470	2353 _), _),
adamc@470	2354 _), _)) =>
adamc@470	2355 let
adamc@470	2356 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@470	2357 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@470	2358 in
adamc@470	2359 ((L'.EAbs ("s", s, s,
adamc@598	2360 strcat [sc "(",
adamc@598	2361 (L'.ERel 0, loc),
adamc@598	2362 sc " IS NULL)"]), loc),
adamc@470	2363 fm)
adamc@470	2364 end
adamc@470	2365
adamc@338	2366 \| L.EFfiApp ("Basis", "nextval", [e]) =>
adamc@338	2367 let
adamc@338	2368 val (e, fm) = monoExp (env, st, fm) e
adamc@338	2369 in
adamc@465	2370 ((L'.ENextval e, loc), fm)
adamc@338	2371 end
adamc@338	2372
adamc@139	2373 \| L.EApp (
adamc@139	2374 (L.ECApp (
adamc@720	2375 (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _),
adamc@139	2376 _), _),
adamc@179	2377 se) =>
adamc@179	2378 let
adamc@179	2379 val (se, fm) = monoExp (env, st, fm) se
adamc@179	2380 in
adamc@179	2381 ((L'.EFfiApp ("Basis", "htmlifyString", [se]), loc), fm)
adamc@179	2382 end
adamc@179	2383
adamc@95	2384 \| L.EApp (
adamc@95	2385 (L.EApp (
adamc@720	2386 (L.ECApp (
adamc@720	2387 (L.ECApp (
adamc@95	2388 (L.ECApp (
adamc@139	2389 (L.ECApp (
adamc@720	2390 (L.EFfi ("Basis", "join"),
adamc@720	2391 _), _), _),
adamc@139	2392 _), _),
adamc@720	2393 _), _),
adamc@720	2394 _), _),
adamc@720	2395 xml1), _),
adamc@720	2396 xml2) =>
adamc@179	2397 let
adamc@179	2398 val (xml1, fm) = monoExp (env, st, fm) xml1
adamc@179	2399 val (xml2, fm) = monoExp (env, st, fm) xml2
adamc@179	2400 in
adamc@179	2401 ((L'.EStrcat (xml1, xml2), loc), fm)
adamc@179	2402 end
adamc@95	2403
adamc@95	2404 \| L.EApp (
adamc@95	2405 (L.EApp (
adamc@104	2406 (L.EApp (
adamc@721	2407 (L.EApp (
adamc@720	2408 (L.ECApp (
adamc@104	2409 (L.ECApp (
adamc@104	2410 (L.ECApp (
adamc@139	2411 (L.ECApp (
adamc@139	2412 (L.ECApp (
adamc@139	2413 (L.ECApp (
adamc@139	2414 (L.ECApp (
adamc@721	2415 (L.ECApp (
adamc@721	2416 (L.EFfi ("Basis", "tag"),
adamc@721	2417 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
adamc@721	2418 class), _),
adamc@720	2419 attrs), _),
adamc@720	2420 tag), _),
adamc@95	2421 xml) =>
adamc@95	2422 let
adamc@140	2423 fun getTag' (e, _) =
adamc@140	2424 case e of
adamc@143	2425 L.EFfi ("Basis", tag) => (tag, [])
adamc@143	2426 \| L.ECApp (e, t) => let
adamc@143	2427 val (tag, ts) = getTag' e
adamc@143	2428 in
adamc@143	2429 (tag, ts @ [t])
adamc@143	2430 end
adamc@140	2431 \| _ => (E.errorAt loc "Non-constant XML tag";
adamc@140	2432 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
adamc@143	2433 ("", []))
adamc@140	2434
adamc@95	2435 fun getTag (e, _) =
adamc@95	2436 case e of
adamc@143	2437 L.EFfiApp ("Basis", tag, [(L.ERecord [], _)]) => (tag, [])
adamc@140	2438 \| L.EApp (e, (L.ERecord [], _)) => getTag' e
adamc@95	2439 \| _ => (E.errorAt loc "Non-constant XML tag";
adamc@95	2440 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
adamc@143	2441 ("", []))
adamc@95	2442
adamc@143	2443 val (tag, targs) = getTag tag
adamc@95	2444
adamc@179	2445 val (attrs, fm) = monoExp (env, st, fm) attrs
adamc@598	2446 val attrs = case #1 attrs of
adamc@598	2447 L'.ERecord xes => xes
adamc@598	2448 \| _ => raise Fail "Non-record attributes!"
adamc@104	2449
adamc@717	2450 val attrs =
adamc@717	2451 if List.exists (fn ("Link", _, _) => true
adamc@717	2452 \| _ => false) attrs then
adamc@717	2453 List.filter (fn ("Href", _, _) => false
adamc@717	2454 \| _ => true) attrs
adamc@717	2455 else
adamc@717	2456 attrs
adamc@717	2457
adamc@668	2458 fun findOnload (attrs, acc) =
adamc@668	2459 case attrs of
adamc@668	2460 [] => (NONE, acc)
adamc@668	2461 \| ("Onload", e, _) :: rest => (SOME e, List.revAppend (acc, rest))
adamc@668	2462 \| x :: rest => findOnload (rest, x :: acc)
adamc@679	2463
adamc@668	2464 val (onload, attrs) = findOnload (attrs, [])
adamc@668	2465
adamc@721	2466 val (class, fm) = monoExp (env, st, fm) class
adamc@721	2467
adamc@143	2468 fun tagStart tag =
adamc@598	2469 let
adamc@721	2470 val t = (L'.TFfi ("Basis", "string"), loc)
adamc@598	2471 val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc)
adamc@721	2472
adamc@721	2473 val s = (L'.ECase (class,
adamc@721	2474 [((L'.PNone t, loc),
adamc@721	2475 s),
adamc@721	2476 ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc),
adamc@721	2477 (L'.EStrcat (s,
adamc@721	2478 (L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc),
adamc@721	2479 (L'.EStrcat ((L'.ERel 0, loc),
adamc@721	2480 (L'.EPrim (Prim.String "\""), loc)),
adamc@721	2481 loc)), loc)), loc))],
adamc@721	2482 {disc = (L'.TOption t, loc),
adamc@721	2483 result = t}), loc)
adamc@598	2484 in
adamc@598	2485 foldl (fn (("Action", _, _), acc) => acc
adamc@598	2486 \| (("Source", _, _), acc) => acc
adamc@598	2487 \| ((x, e, t), (s, fm)) =>
adamc@598	2488 case t of
adamc@598	2489 (L'.TFfi ("Basis", "bool"), _) =>
adamc@598	2490 let
adamc@598	2491 val s' = " " ^ lowercaseFirst x
adamc@598	2492 in
adamc@598	2493 ((L'.ECase (e,
adamc@598	2494 [((L'.PCon (L'.Enum,
adamc@598	2495 L'.PConFfi {mod = "Basis",
adamc@598	2496 datatyp = "bool",
adamc@598	2497 con = "True",
adamc@598	2498 arg = NONE},
adamc@598	2499 NONE), loc),
adamc@598	2500 (L'.EStrcat (s,
adamc@598	2501 (L'.EPrim (Prim.String s'), loc)), loc)),
adamc@598	2502 ((L'.PCon (L'.Enum,
adamc@598	2503 L'.PConFfi {mod = "Basis",
adamc@598	2504 datatyp = "bool",
adamc@598	2505 con = "False",
adamc@598	2506 arg = NONE},
adamc@598	2507 NONE), loc),
adamc@598	2508 s)],
adamc@598	2509 {disc = (L'.TFfi ("Basis", "bool"), loc),
adamc@598	2510 result = (L'.TFfi ("Basis", "string"), loc)}), loc),
adamc@598	2511 fm)
adamc@598	2512 end
adamc@895	2513 \| (L'.TFun (dom, _), _) =>
adamc@598	2514 let
adamc@598	2515 val s' = " " ^ lowercaseFirst x ^ "='"
adamc@895	2516 val e = case #1 dom of
adamc@895	2517 L'.TRecord [] => (L'.EApp (e, (L'.ERecord [], loc)), loc)
adamc@895	2518 \| _ => (L'.EApp ((L'.EApp (e, (L'.EFfiApp ("Basis", "kc", []), loc)),
adamc@895	2519 loc), (L'.ERecord [], loc)), loc)
adamc@598	2520 in
adamc@598	2521 ((L'.EStrcat (s,
adamc@598	2522 (L'.EStrcat (
adamc@598	2523 (L'.EPrim (Prim.String s'), loc),
adamc@598	2524 (L'.EStrcat (
adamc@815	2525 (L'.EJavaScript (L'.Attribute, e), loc),
adamc@926	2526 (L'.EPrim (Prim.String ";return false'"), loc)), loc)),
adamc@598	2527 loc)), loc),
adamc@598	2528 fm)
adamc@598	2529 end
adamc@598	2530 \| _ =>
adamc@598	2531 let
adamc@598	2532 val fooify =
adamc@598	2533 case x of
adamc@717	2534 "Link" => urlifyExp
adamc@717	2535 \| "Action" => urlifyExp
adamc@598	2536 \| _ => attrifyExp
adamc@120	2537
adamc@724	2538 val x =
adamc@724	2539 case x of
adamc@724	2540 "Typ" => "Type"
adamc@907	2541 \| "Link" => "Href"
adamc@724	2542 \| _ => x
adamc@598	2543 val xp = " " ^ lowercaseFirst x ^ "=\""
adamc@179	2544
adamc@598	2545 val (e, fm) = fooify env fm (e, t)
adamc@598	2546 in
adamc@598	2547 ((L'.EStrcat (s,
adamc@598	2548 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
adamc@598	2549 (L'.EStrcat (e,
adamc@598	2550 (L'.EPrim (Prim.String "\""),
adamc@598	2551 loc)),
adamc@598	2552 loc)),
adamc@598	2553 loc)), loc),
adamc@598	2554 fm)
adamc@598	2555 end)
adamc@598	2556 (s, fm) attrs
adamc@598	2557 end
adamc@104	2558
adamc@143	2559 fun input typ =
adamc@143	2560 case targs of
adamc@155	2561 [_, (L.CName name, _)] =>
adamc@179	2562 let
adamc@179	2563 val (ts, fm) = tagStart "input"
adamc@179	2564 in
adamc@179	2565 ((L'.EStrcat (ts,
adamc@802	2566 (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\" />")),
adamc@179	2567 loc)), loc), fm)
adamc@179	2568 end
adamc@143	2569 \| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adamc@153	2570 raise Fail "No name passed to input tag")
adamc@104	2571
adamc@565	2572 fun normal (tag, extra, extraInner) =
adamc@143	2573 let
adamc@179	2574 val (tagStart, fm) = tagStart tag
adamc@152	2575 val tagStart = case extra of
adamc@152	2576 NONE => tagStart
adamc@152	2577 \| SOME extra => (L'.EStrcat (tagStart, extra), loc)
adamc@152	2578
adamc@143	2579 fun normal () =
adamc@179	2580 let
adamc@179	2581 val (xml, fm) = monoExp (env, st, fm) xml
adamc@916	2582
adamc@916	2583 val xml = case extraInner of
adamc@916	2584 NONE => xml
adamc@916	2585 \| SOME ei => (L'.EStrcat (ei, xml), loc)
adamc@179	2586 in
adamc@179	2587 ((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
adamc@179	2588 (L'.EStrcat (xml,
adamc@179	2589 (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])),
adamc@179	2590 loc)), loc)),
adamc@179	2591 loc),
adamc@179	2592 fm)
adamc@179	2593 end
adamc@143	2594 in
adamc@143	2595 case xml of
adamc@143	2596 (L.EApp ((L.ECApp (
adamc@143	2597 (L.ECApp ((L.EFfi ("Basis", "cdata"), _),
adamc@143	2598 _), _),
adamc@143	2599 _), _),
adamc@143	2600 (L.EPrim (Prim.String s), _)), _) =>
adamc@143	2601 if CharVector.all Char.isSpace s then
adamc@802	2602 ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String " />"), loc)), loc), fm)
adamc@143	2603 else
adamc@143	2604 normal ()
adamc@143	2605 \| _ => normal ()
adamc@143	2606 end
adamc@606	2607
adamc@606	2608 fun setAttrs jexp =
adamc@606	2609 let
adamc@606	2610 val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc)
adamc@606	2611
adamc@606	2612 val assgns = List.mapPartial
adamc@606	2613 (fn ("Source", _, _) => NONE
adamc@800	2614 \| ("Onchange", e, _) =>
adamc@800	2615 SOME (strcat [str "addOnChange(d,",
adamc@815	2616 (L'.EJavaScript (L'.Script, e), loc),
adamc@800	2617 str ")"])
adamc@606	2618 \| (x, e, _) =>
adamc@606	2619 SOME (strcat [str ("d." ^ lowercaseFirst x ^ "="),
adamc@815	2620 (L'.EJavaScript (L'.Script, e), loc),
adamc@606	2621 str ";"]))
adamc@606	2622 attrs
adamc@606	2623 in
adamc@606	2624 case assgns of
adamc@606	2625 [] => jexp
adamc@606	2626 \| _ => strcat (str "var d="
adamc@606	2627 :: jexp
adamc@606	2628 :: str ";"
adamc@606	2629 :: assgns)
adamc@606	2630 end
adamc@152	2631 in
adamc@152	2632 case tag of
adamc@679	2633 "body" => let
adamc@668	2634 val onload = case onload of
adamc@668	2635 NONE => (L'.EPrim (Prim.String ""), loc)
adamc@668	2636 \| SOME e =>
adamc@668	2637 let
adamc@668	2638 val e = (L'.EApp (e, (L'.ERecord [], loc)), loc)
adamc@668	2639 in
adamc@815	2640 (L'.EJavaScript (L'.Attribute, e), loc)
adamc@679	2641 end
adamc@668	2642 in
adamc@668	2643 normal ("body",
adamc@695	2644 SOME (L'.EFfiApp ("Basis", "maybe_onload",
adamc@695	2645 [(L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings",
adamc@695	2646 [(L'.ERecord [], loc)]), loc),
adamc@695	2647 onload), loc)]),
adamc@695	2648 loc),
adamc@916	2649 SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc))
adamc@668	2650 end
adamc@568	2651
adamc@568	2652 \| "dyn" =>
adamc@901	2653 let
adamc@903	2654 fun inTag tag = case targs of
adamc@903	2655 (L.CRecord (_, ctx), _) :: _ =>
adamc@903	2656 List.exists (fn ((L.CName tag', _), _) => tag' = tag
adamc@903	2657 \| _ => false) ctx
adamc@903	2658 \| _ => false
adamc@901	2659
adamc@903	2660 val tag = if inTag "Tr" then
adamc@903	2661 "tr"
adamc@903	2662 else if inTag "Table" then
adamc@901	2663 "table"
adamc@901	2664 else
adamc@901	2665 "span"
adamc@901	2666 in
adamc@901	2667 case attrs of
adamc@901	2668 [("Signal", e, _)] =>
adamc@901	2669 ((L'.EStrcat
adamc@901	2670 ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">dyn(\""
adamc@901	2671 ^ tag ^ "\", ")), loc),
adamc@901	2672 (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
adamc@901	2673 (L'.EPrim (Prim.String (")</script>")), loc)), loc)), loc),
adamc@901	2674 fm)
adamc@901	2675 \| _ => raise Fail "Monoize: Bad dyn attributes"
adamc@901	2676 end
adamc@565	2677
adamc@565	2678 \| "submit" => normal ("input type=\"submit\"", NONE, NONE)
adamc@601	2679 \| "button" => normal ("input type=\"submit\"", NONE, NONE)
adamc@761	2680 \| "hidden" => input "hidden"
adamc@152	2681
adamc@152	2682 \| "textbox" =>
adamc@152	2683 (case targs of
adamc@152	2684 [_, (L.CName name, _)] =>
adamc@598	2685 (case List.find (fn ("Source", _, _) => true \| _ => false) attrs of
adamc@598	2686 NONE =>
adamc@598	2687 let
adamc@598	2688 val (ts, fm) = tagStart "input"
adamc@598	2689 in
adamc@598	2690 ((L'.EStrcat (ts,
adamc@802	2691 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\" />")),
adamc@598	2692 loc)), loc), fm)
adamc@598	2693 end
adamc@598	2694 \| SOME (_, src, _) =>
adamc@899	2695 (strcat [str "<script type=\"text/javascript\">inp(",
adamc@815	2696 (L'.EJavaScript (L'.Script, src), loc),
adamc@899	2697 str ")</script>"],
adamc@598	2698 fm))
adamc@152	2699 \| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adamc@598	2700 raise Fail "No name passed to textbox tag"))
adamc@155	2701 \| "password" => input "password"
adamc@361	2702 \| "textarea" =>
adamc@152	2703 (case targs of
adamc@152	2704 [_, (L.CName name, _)] =>
adamc@179	2705 let
adamc@179	2706 val (ts, fm) = tagStart "textarea"
adamc@179	2707 val (xml, fm) = monoExp (env, st, fm) xml
adamc@179	2708 in
adamc@179	2709 ((L'.EStrcat ((L'.EStrcat (ts,
adamc@179	2710 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc),
adamc@179	2711 (L'.EStrcat (xml,
adamc@179	2712 (L'.EPrim (Prim.String "</textarea>"),
adamc@179	2713 loc)), loc)),
adamc@179	2714 loc), fm)
adamc@179	2715 end
adamc@152	2716 \| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adamc@153	2717 raise Fail "No name passed to ltextarea tag"))
adamc@153	2718
adamc@190	2719 \| "checkbox" => input "checkbox"
adamc@737	2720 \| "upload" => input "file"
adamc@190	2721
adamc@153	2722 \| "radio" =>
adamc@153	2723 (case targs of
adamc@153	2724 [_, (L.CName name, _)] =>
adamc@179	2725 monoExp (env, St.setRadioGroup (st, name), fm) xml
adamc@153	2726 \| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adamc@153	2727 raise Fail "No name passed to radio tag"))
adamc@153	2728 \| "radioOption" =>
adamc@153	2729 (case St.radioGroup st of
adamc@153	2730 NONE => raise Fail "No name for radioGroup"
adamc@153	2731 \| SOME name =>
adamc@153	2732 normal ("input",
adamc@565	2733 SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc),
adamc@565	2734 NONE))
adamc@152	2735
adamc@361	2736 \| "select" =>
adamc@154	2737 (case targs of
adamc@154	2738 [_, (L.CName name, _)] =>
adamc@179	2739 let
adamc@179	2740 val (ts, fm) = tagStart "select"
adamc@179	2741 val (xml, fm) = monoExp (env, st, fm) xml
adamc@179	2742 in
adamc@179	2743 ((L'.EStrcat ((L'.EStrcat (ts,
adamc@598	2744 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")),
adamc@598	2745 loc)), loc),
adamc@179	2746 (L'.EStrcat (xml,
adamc@179	2747 (L'.EPrim (Prim.String "</select>"),
adamc@179	2748 loc)), loc)),
adamc@179	2749 loc),
adamc@179	2750 fm)
adamc@179	2751 end
adamc@154	2752 \| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adamc@154	2753 raise Fail "No name passed to lselect tag"))
adamc@154	2754
adamc@601	2755 \| "ctextbox" =>
adamc@601	2756 (case List.find (fn ("Source", _, _) => true \| _ => false) attrs of
adamc@601	2757 NONE =>
adamc@601	2758 let
adamc@601	2759 val (ts, fm) = tagStart "input"
adamc@601	2760 in
adamc@601	2761 ((L'.EStrcat (ts,
adamc@802	2762 (L'.EPrim (Prim.String " />"), loc)),
adamc@601	2763 loc), fm)
adamc@601	2764 end
adamc@601	2765 \| SOME (_, src, _) =>
adamc@606	2766 let
adamc@816	2767 val sc = strcat [str "inp(",
adamc@815	2768 (L'.EJavaScript (L'.Script, src), loc),
adamc@816	2769 str ")"]
adamc@797	2770 val sc = setAttrs sc
adamc@797	2771 in
adamc@899	2772 (strcat [str "<script type=\"text/javascript\">",
adamc@797	2773 sc,
adamc@899	2774 str "</script>"],
adamc@797	2775 fm)
adamc@797	2776 end)
adamc@797	2777
adamc@817	2778 \| "ccheckbox" =>
adamc@817	2779 (case List.find (fn ("Source", _, _) => true \| _ => false) attrs of
adamc@817	2780 NONE =>
adamc@817	2781 let
adamc@817	2782 val (ts, fm) = tagStart "input type=\"checkbox\""
adamc@817	2783 in
adamc@817	2784 ((L'.EStrcat (ts,
adamc@817	2785 (L'.EPrim (Prim.String " />"), loc)),
adamc@817	2786 loc), fm)
adamc@817	2787 end
adamc@817	2788 \| SOME (_, src, _) =>
adamc@817	2789 let
adamc@817	2790 val sc = strcat [str "chk(",
adamc@817	2791 (L'.EJavaScript (L'.Script, src), loc),
adamc@817	2792 str ")"]
adamc@817	2793 val sc = setAttrs sc
adamc@817	2794 in
adamc@899	2795 (strcat [str "<script type=\"text/javascript\">",
adamc@817	2796 sc,
adamc@899	2797 str "</script>"],
adamc@817	2798 fm)
adamc@817	2799 end)
adamc@817	2800
adamc@797	2801 \| "cselect" =>
adamc@797	2802 (case List.find (fn ("Source", _, _) => true \| _ => false) attrs of
adamc@797	2803 NONE =>
adamc@797	2804 let
adamc@834	2805 val (xml, fm) = monoExp (env, st, fm) xml
adamc@797	2806 val (ts, fm) = tagStart "select"
adamc@797	2807 in
adamc@834	2808 (strcat [ts,
adamc@834	2809 str ">",
adamc@834	2810 xml,
adamc@834	2811 str "</select>"],
adamc@834	2812 fm)
adamc@797	2813 end
adamc@797	2814 \| SOME (_, src, _) =>
adamc@797	2815 let
adamc@797	2816 val (xml, fm) = monoExp (env, st, fm) xml
adamc@797	2817
adamc@816	2818 val sc = strcat [str "sel(",
adamc@815	2819 (L'.EJavaScript (L'.Script, src), loc),
adamc@797	2820 str ",",
adamc@815	2821 (L'.EJavaScript (L'.Script, xml), loc),
adamc@606	2822 str ")"]
adamc@606	2823 val sc = setAttrs sc
adamc@606	2824 in
adamc@899	2825 (strcat [str "<script type=\"text/javascript\">",
adamc@606	2826 sc,
adamc@899	2827 str "</script>"],
adamc@606	2828 fm)
adamc@606	2829 end)
adamc@154	2830
adamc@797	2831 \| "coption" => normal ("option", NONE, NONE)
adamc@797	2832
adamc@565	2833 \| "tabl" => normal ("table", NONE, NONE)
adamc@565	2834 \| _ => normal (tag, NONE, NONE)
adamc@95	2835 end
adamc@94	2836
adamc@141	2837 \| L.EApp ((L.ECApp (
adamc@361	2838 (L.ECApp ((L.EFfi ("Basis", "form"), _), _), _),
adamc@734	2839 (L.CRecord (_, fields), _)), _),
adamc@141	2840 xml) =>
adamc@143	2841 let
adamc@143	2842 fun findSubmit (e, _) =
adamc@143	2843 case e of
adamc@143	2844 L.EApp (
adamc@143	2845 (L.EApp (
adamc@143	2846 (L.ECApp (
adamc@143	2847 (L.ECApp (
adamc@143	2848 (L.ECApp (
adamc@143	2849 (L.ECApp (
adamc@143	2850 (L.EFfi ("Basis", "join"),
adamc@143	2851 _), _), _),
adamc@143	2852 _), _),
adamc@143	2853 _), _),
adamc@143	2854 _), _),
adamc@143	2855 xml1), _),
adamc@143	2856 xml2) => (case findSubmit xml1 of
adamc@143	2857 Error => Error
adamc@143	2858 \| NotFound => findSubmit xml2
adamc@143	2859 \| Found e =>
adamc@143	2860 case findSubmit xml2 of
adamc@143	2861 NotFound => Found e
adamc@143	2862 \| _ => Error)
adamc@143	2863 \| L.EApp (
adamc@143	2864 (L.EApp (
adamc@143	2865 (L.EApp (
adamc@730	2866 (L.EApp (
adamc@143	2867 (L.ECApp (
adamc@143	2868 (L.ECApp (
adamc@143	2869 (L.ECApp (
adamc@143	2870 (L.ECApp (
adamc@143	2871 (L.ECApp (
adamc@143	2872 (L.ECApp (
adamc@143	2873 (L.ECApp (
adamc@730	2874 (L.ECApp (
adamc@730	2875 (L.EFfi ("Basis", "tag"),
adamc@730	2876 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
adamc@730	2877 _), _),
adamc@143	2878 attrs), _),
adamc@143	2879 _), _),
adamc@143	2880 xml) =>
adamc@143	2881 (case #1 attrs of
adamc@143	2882 L.ERecord xes =>
adamc@143	2883 (case ListUtil.search (fn ((L.CName "Action", _), e, t) => SOME (e, t)
adamc@143	2884 \| _ => NONE) xes of
adamc@143	2885 NONE => findSubmit xml
adamc@143	2886 \| SOME et =>
adamc@143	2887 case findSubmit xml of
adamc@143	2888 NotFound => Found et
adamc@143	2889 \| _ => Error)
adamc@143	2890 \| _ => findSubmit xml)
adamc@143	2891 \| _ => NotFound
adamc@143	2892
adamc@735	2893 val (func, action, fm) = case findSubmit xml of
adamc@735	2894 NotFound => (0, (L'.EPrim (Prim.String ""), loc), fm)
adamc@143	2895 \| Error => raise Fail "Not ready for multi-submit lforms yet"
adamc@598	2896 \| Found (action, actionT) =>
adamc@598	2897 let
adamc@735	2898 val func = case #1 action of
adamc@735	2899 L.EClosure (n, _) => n
adamc@735	2900 \| _ => raise Fail "Monoize: Action is not a closure"
adamc@598	2901 val actionT = monoType env actionT
adamc@598	2902 val (action, fm) = monoExp (env, st, fm) action
adamc@598	2903 val (action, fm) = urlifyExp env fm (action, actionT)
adamc@598	2904 in
adamc@735	2905 (func,
adamc@735	2906 (L'.EStrcat ((L'.EPrim (Prim.String " action=\""), loc),
adamc@598	2907 (L'.EStrcat (action,
adamc@598	2908 (L'.EPrim (Prim.String "\""), loc)), loc)), loc),
adamc@598	2909 fm)
adamc@598	2910 end
adamc@734	2911
adamc@737	2912 val hasUpload = CoreUtil.Exp.exists {kind = fn _ => false,
adamc@737	2913 con = fn _ => false,
adamc@737	2914 exp = fn e =>
adamc@737	2915 case e of
adamc@737	2916 L.EFfi ("Basis", "upload") => true
adamc@737	2917 \| _ => false} xml
adamc@737	2918
adamc@179	2919 val (xml, fm) = monoExp (env, st, fm) xml
adamc@735	2920
adamc@735	2921 val xml =
adamc@735	2922 if IS.member (!readCookie, func) then
adamc@735	2923 let
adamc@735	2924 fun inFields s = List.exists (fn ((L.CName s', _), _) => s' = s
adamc@735	2925 \| _ => true) fields
adamc@735	2926
adamc@735	2927 fun getSigName () =
adamc@735	2928 let
adamc@735	2929 fun getSigName' n =
adamc@735	2930 let
adamc@735	2931 val s = "Sig" ^ Int.toString n
adamc@735	2932 in
adamc@735	2933 if inFields s then
adamc@735	2934 getSigName' (n + 1)
adamc@735	2935 else
adamc@735	2936 s
adamc@735	2937 end
adamc@735	2938 in
adamc@735	2939 if inFields "Sig" then
adamc@735	2940 getSigName' 0
adamc@735	2941 else
adamc@735	2942 "Sig"
adamc@735	2943 end
adamc@735	2944
adamc@735	2945 val sigName = getSigName ()
adamc@735	2946 val sigSet = (L'.EFfiApp ("Basis", "sigString", [(L'.ERecord [], loc)]), loc)
adamc@735	2947 val sigSet = (L'.EStrcat ((L'.EPrim (Prim.String ("<input type=\"hidden\" name=\""
adamc@735	2948 ^ sigName
adamc@735	2949 ^ "\" value=\"")), loc),
adamc@735	2950 sigSet), loc)
adamc@735	2951 val sigSet = (L'.EStrcat (sigSet,
adamc@803	2952 (L'.EPrim (Prim.String "\" />"), loc)), loc)
adamc@735	2953 in
adamc@735	2954 (L'.EStrcat (sigSet, xml), loc)
adamc@735	2955 end
adamc@735	2956 else
adamc@735	2957 xml
adamc@737	2958
adamc@737	2959 val action = if hasUpload then
adamc@737	2960 (L'.EStrcat (action,
adamc@737	2961 (L'.EPrim (Prim.String " enctype=\"multipart/form-data\""), loc)), loc)
adamc@737	2962 else
adamc@737	2963 action
adamc@737	2964
adamc@143	2965 in
adamc@730	2966 ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form method=\"post\""), loc),
adamc@179	2967 (L'.EStrcat (action,
adamc@598	2968 (L'.EPrim (Prim.String ">"), loc)), loc)), loc),
adamc@179	2969 (L'.EStrcat (xml,
adamc@179	2970 (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc),
adamc@179	2971 fm)
adamc@143	2972 end
adamc@141	2973
adamc@756	2974 \| L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp (
adamc@756	2975 (L.EFfi ("Basis", "subform"), _), _), _), _),
adamc@756	2976 _), _), _), (L.CName nm, loc)) =>
adamc@756	2977 let
adamc@756	2978 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@756	2979 in
adamc@756	2980 ((L'.EAbs ("xml", s, s,
adamc@756	2981 strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".b\" value=\""
adamc@803	2982 ^ nm ^ "\" />")), loc),
adamc@756	2983 (L'.ERel 0, loc),
adamc@803	2984 (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\" />")), loc)]),
adamc@756	2985 loc),
adamc@756	2986 fm)
adamc@756	2987 end
adamc@756	2988
adamc@758	2989 \| L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp (
adamc@758	2990 (L.EFfi ("Basis", "subforms"), _), _), _), _),
adamc@758	2991 _), _), _), (L.CName nm, loc)) =>
adamc@758	2992 let
adamc@758	2993 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@758	2994 in
adamc@758	2995 ((L'.EAbs ("xml", s, s,
adamc@758	2996 strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".s\" value=\""
adamc@803	2997 ^ nm ^ "\" />")), loc),
adamc@758	2998 (L'.ERel 0, loc),
adamc@803	2999 (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\" />")), loc)]),
adamc@758	3000 loc),
adamc@758	3001 fm)
adamc@758	3002 end
adamc@758	3003
adamc@758	3004 \| L.ECApp ((L.ECApp (
adamc@758	3005 (L.EFfi ("Basis", "entry"), _), _), _), _) =>
adamc@758	3006 let
adamc@758	3007 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@758	3008 in
adamc@758	3009 ((L'.EAbs ("xml", s, s,
adamc@803	3010 strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".i\" value=\"1\" />")), loc),
adamc@758	3011 (L'.ERel 0, loc),
adamc@803	3012 (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\" />")), loc)]),
adamc@758	3013 loc),
adamc@758	3014 fm)
adamc@758	3015 end
adamc@758	3016
adamc@148	3017 \| L.EApp ((L.ECApp (
adamc@148	3018 (L.ECApp (
adamc@148	3019 (L.ECApp (
adamc@148	3020 (L.ECApp (
adamc@148	3021 (L.EFfi ("Basis", "useMore"), _), _), _),
adamc@148	3022 _), _),
adamc@148	3023 _), _),
adamc@148	3024 _), _),
adamc@179	3025 xml) => monoExp (env, st, fm) xml
adamc@148	3026
adamc@283	3027 \| L.ECApp ((L.EFfi ("Basis", "error"), _), t) =>
adamc@283	3028 let
adamc@283	3029 val t = monoType env t
adamc@283	3030 in
adamc@283	3031 ((L'.EAbs ("s", (L'.TFfi ("Basis", "string"), loc), t,
adamc@283	3032 (L'.EError ((L'.ERel 0, loc), t), loc)), loc),
adamc@283	3033 fm)
adamc@283	3034 end
adamc@741	3035 \| L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t) =>
adamc@741	3036 let
adamc@741	3037 val t = monoType env t
adamc@741	3038 val un = (L'.TRecord [], loc)
adamc@741	3039 in
adamc@741	3040 ((L'.EAbs ("b", (L'.TFfi ("Basis", "blob"), loc),
adamc@741	3041 (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc)), loc),
adamc@741	3042 (L'.EAbs ("mt", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
adamc@741	3043 (L'.EAbs ("_", un, t,
adamc@741	3044 (L'.EReturnBlob {blob = (L'.ERel 2, loc),
adamc@741	3045 mimeType = (L'.ERel 1, loc),
adamc@741	3046 t = t}, loc)), loc)), loc)), loc),
adamc@741	3047 fm)
adamc@741	3048 end
adamc@283	3049
adamc@179	3050 \| L.EApp (e1, e2) =>
adamc@179	3051 let
adamc@179	3052 val (e1, fm) = monoExp (env, st, fm) e1
adamc@179	3053 val (e2, fm) = monoExp (env, st, fm) e2
adamc@179	3054 in
adamc@179	3055 ((L'.EApp (e1, e2), loc), fm)
adamc@179	3056 end
adamc@26	3057 \| L.EAbs (x, dom, ran, e) =>
adamc@179	3058 let
adamc@179	3059 val (e, fm) = monoExp (Env.pushERel env x dom, st, fm) e
adamc@179	3060 in
adamc@179	3061 ((L'.EAbs (x, monoType env dom, monoType env ran, e), loc), fm)
adamc@179	3062 end
adamc@25	3063 \| L.ECApp _ => poly ()
adamc@25	3064 \| L.ECAbs _ => poly ()
adamc@25	3065
adamc@252	3066 \| L.EFfi mx => ((L'.EFfi mx, loc), fm)
adamc@252	3067 \| L.EFfiApp (m, x, es) =>
adamc@252	3068 let
adamc@252	3069 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
adamc@252	3070 in
adamc@252	3071 ((L'.EFfiApp (m, x, es), loc), fm)
adamc@252	3072 end
adamc@252	3073
adamc@179	3074 \| L.ERecord xes =>
adamc@179	3075 let
adamc@179	3076 val (xes, fm) = ListUtil.foldlMap
adamc@179	3077 (fn ((x, e, t), fm) =>
adamc@179	3078 let
adamc@179	3079 val (e, fm) = monoExp (env, st, fm) e
adamc@179	3080 in
adamc@179	3081 ((monoName env x,
adamc@179	3082 e,
adamc@179	3083 monoType env t), fm)
adamc@179	3084 end) fm xes
adamc@905	3085
adamc@905	3086 val xes = ListMergeSort.sort (fn ((x, _, _), (y, _, _)) => String.compare (x, y) = GREATER) xes
adamc@179	3087 in
adamc@179	3088 ((L'.ERecord xes, loc), fm)
adamc@179	3089 end
adamc@179	3090 \| L.EField (e, x, _) =>
adamc@179	3091 let
adamc@179	3092 val (e, fm) = monoExp (env, st, fm) e
adamc@179	3093 in
adamc@179	3094 ((L'.EField (e, monoName env x), loc), fm)
adamc@179	3095 end
adamc@445	3096 \| L.EConcat _ => poly ()
adamc@149	3097 \| L.ECut _ => poly ()
adamc@493	3098 \| L.ECutMulti _ => poly ()
adamc@177	3099
adamc@182	3100 \| L.ECase (e, pes, {disc, result}) =>
adamc@179	3101 let
adamc@179	3102 val (e, fm) = monoExp (env, st, fm) e
adamc@179	3103 val (pes, fm) = ListUtil.foldlMap
adamc@179	3104 (fn ((p, e), fm) =>
adamc@179	3105 let
adamc@179	3106 val (e, fm) = monoExp (env, st, fm) e
adamc@179	3107 in
adamc@182	3108 ((monoPat env p, e), fm)
adamc@179	3109 end) fm pes
adamc@179	3110 in
adamc@182	3111 ((L'.ECase (e, pes, {disc = monoType env disc, result = monoType env result}), loc), fm)
adamc@179	3112 end
adamc@177	3113
adamc@179	3114 \| L.EWrite e =>
adamc@179	3115 let
adamc@179	3116 val (e, fm) = monoExp (env, st, fm) e
adamc@179	3117 in
adamc@252	3118 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
adamc@252	3119 (L'.EWrite (liftExpInExp 0 e), loc)), loc), fm)
adamc@179	3120 end
adamc@110	3121
adamc@179	3122 \| L.EClosure (n, es) =>
adamc@179	3123 let
adamc@179	3124 val (es, fm) = ListUtil.foldlMap (fn (e, fm) =>
adamc@179	3125 monoExp (env, st, fm) e)
adamc@179	3126 fm es
adamc@179	3127 in
adamc@179	3128 ((L'.EClosure (n, es), loc), fm)
adamc@179	3129 end
adamc@450	3130
adamc@450	3131 \| L.ELet (x, t, e1, e2) =>
adamc@450	3132 let
adamc@450	3133 val t' = monoType env t
adamc@450	3134 val (e1, fm) = monoExp (env, st, fm) e1
adamc@450	3135 val (e2, fm) = monoExp (Env.pushERel env x t, st, fm) e2
adamc@450	3136 in
adamc@450	3137 ((L'.ELet (x, t', e1, e2), loc), fm)
adamc@450	3138 end
adamc@607	3139
adamc@908	3140 \| L.EServerCall (n, es, ek, t, (L.TRecord (L.CRecord (_, []), _), _)) =>
adamc@608	3141 let
adamc@609	3142 val t = monoType env t
adamc@614	3143 val (_, ft, _, name) = Env.lookupENamed env n
adamc@608	3144 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
adamc@614	3145
adamc@614	3146 fun encodeArgs (es, ft, acc, fm) =
adamc@614	3147 case (es, ft) of
adamc@614	3148 ([], _) => (rev acc, fm)
adamc@614	3149 \| (e :: es, (L.TFun (dom, ran), _)) =>
adamc@614	3150 let
adamc@614	3151 val (e, fm) = urlifyExp env fm (e, monoType env dom)
adamc@614	3152 in
adamc@614	3153 encodeArgs (es, ran, e
adamc@614	3154 :: (L'.EPrim (Prim.String "/"), loc)
adamc@614	3155 :: acc, fm)
adamc@614	3156 end
adamc@614	3157 \| _ => raise Fail "Monoize: Not enough arguments visible in RPC function type"
adamc@614	3158
adamc@614	3159 val (call, fm) = encodeArgs (es, ft, [], fm)
adamc@614	3160 val call = foldl (fn (e, call) => (L'.EStrcat (call, e), loc))
adamc@614	3161 (L'.EPrim (Prim.String name), loc) call
adamc@614	3162
adamc@608	3163 val (ek, fm) = monoExp (env, st, fm) ek
adamc@609	3164
adamc@905	3165 val unit = (L'.TRecord [], loc)
adamc@905	3166
adamc@609	3167 val ekf = (L'.EAbs ("f",
adamc@609	3168 (L'.TFun (t,
adamc@609	3169 (L'.TFun ((L'.TRecord [], loc),
adamc@609	3170 (L'.TRecord [], loc)), loc)), loc),
adamc@609	3171 (L'.TFun (t,
adamc@609	3172 (L'.TRecord [], loc)), loc),
adamc@609	3173 (L'.EAbs ("x",
adamc@609	3174 t,
adamc@609	3175 (L'.TRecord [], loc),
adamc@609	3176 (L'.EApp ((L'.EApp ((L'.ERel 1, loc),
adamc@609	3177 (L'.ERel 0, loc)), loc),
adamc@609	3178 (L'.ERecord [], loc)), loc)), loc)), loc)
adamc@609	3179 val ek = (L'.EApp (ekf, ek), loc)
adamc@736	3180 val eff = if IS.member (!readCookie, n) then
adamc@736	3181 L'.ReadCookieWrite
adamc@736	3182 else
adamc@736	3183 L'.ReadOnly
adamc@905	3184
adamc@910	3185 val e = (L'.EServerCall (call, ek, t, eff), loc)
adamc@651	3186 val e = liftExpInExp 0 e
adamc@651	3187 val e = (L'.EAbs ("_", unit, unit, e), loc)
adamc@608	3188 in
adamc@651	3189 (e, fm)
adamc@608	3190 end
adamc@908	3191 \| L.EServerCall _ => (E.errorAt loc "Full scope of server call continuation isn't known";
adamc@908	3192 Print.eprefaces' [("Expression", CorePrint.p_exp env all)];
adamc@908	3193 (dummyExp, fm))
adamc@626	3194
adamc@626	3195 \| L.EKAbs _ => poly ()
adamc@626	3196 \| L.EKApp _ => poly ()
adamc@25	3197 end
adamc@25	3198
adamc@179	3199 fun monoDecl (env, fm) (all as (d, loc)) =
adamc@25	3200 let
adamc@25	3201 fun poly () =
adamc@25	3202 (E.errorAt loc "Unsupported declaration";
adamc@25	3203 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
adamc@25	3204 NONE)
adamc@25	3205 in
adamc@25	3206 case d of
adamc@25	3207 L.DCon _ => NONE
adamc@808	3208 \| L.DDatatype [("list", n, [_], [("Nil", _, NONE),
adamc@808	3209 ("Cons", _, SOME (L.TRecord (L.CRecord (_,
adamc@808	3210 [((L.CName "1", _),
adamc@808	3211 (L.CRel 0, _)),
adamc@808	3212 ((L.CName "2", _),
adamc@808	3213 (L.CApp ((L.CNamed n', _),
adamc@808	3214 (L.CRel 0, _)),
adamc@808	3215 _))]), _), _))])] =>
adamc@757	3216 if n = n' then
adamc@757	3217 NONE
adamc@757	3218 else
adamc@757	3219 poly ()
adamc@808	3220 \| L.DDatatype dts =>
adamc@808	3221 let
adamc@808	3222 val env' = Env.declBinds env all
adamc@808	3223 val dts = map (fn (x, n, [], xncs) =>
adamc@808	3224 (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env') to)) xncs)
adamc@808	3225 \| _ => (E.errorAt loc "Polymorphic datatype needed too late";
adamc@808	3226 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
adamc@808	3227 ("", 0, []))) dts
adamc@808	3228 val d = (L'.DDatatype dts, loc)
adamc@808	3229 in
adamc@808	3230 SOME (env', fm, [d])
adamc@808	3231 end
adamc@179	3232 \| L.DVal (x, n, t, e, s) =>
adamc@179	3233 let
adamc@179	3234 val (e, fm) = monoExp (env, St.empty, fm) e
adamc@179	3235 in
adamc@179	3236 SOME (Env.pushENamed env x n t NONE s,
adamc@179	3237 fm,
adamc@273	3238 [(L'.DVal (x, n, monoType env t, e, s), loc)])
adamc@179	3239 end
adamc@128	3240 \| L.DValRec vis =>
adamc@128	3241 let
adamc@128	3242 val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis
adamc@179	3243
adamc@179	3244 val (vis, fm) = ListUtil.foldlMap
adamc@179	3245 (fn ((x, n, t, e, s), fm) =>
adamc@179	3246 let
adamc@179	3247 val (e, fm) = monoExp (env, St.empty, fm) e
adamc@179	3248 in
adamc@179	3249 ((x, n, monoType env t, e, s), fm)
adamc@179	3250 end)
adamc@179	3251 fm vis
adamc@128	3252 in
adamc@128	3253 SOME (env,
adamc@179	3254 fm,
adamc@273	3255 [(L'.DValRec vis, loc)])
adamc@128	3256 end
adamc@144	3257 \| L.DExport (ek, n) =>
adamc@115	3258 let
adamc@120	3259 val (_, t, _, s) = Env.lookupENamed env n
adamc@120	3260
adamc@609	3261 fun unwind (t, args) =
adamc@609	3262 case #1 t of
adamc@609	3263 L.TFun (dom, ran) => unwind (ran, dom :: args)
adamc@314	3264 \| L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
adamc@609	3265 unwind (t, (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) :: args)
adamc@609	3266 \| _ => (rev args, t)
adamc@120	3267
adamc@609	3268 val (ts, ran) = unwind (t, [])
adamc@609	3269 val ts = map (monoType env) ts
adamc@609	3270 val ran = monoType env ran
adamc@115	3271 in
adamc@609	3272 SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)])
adamc@115	3273 end
adamc@707	3274 \| L.DTable (x, n, (L.CRecord (_, xts), _), s, pe, _, ce, _) =>
adamc@251	3275 let
adamc@251	3276 val t = (L.CFfi ("Basis", "string"), loc)
adamc@251	3277 val t' = (L'.TFfi ("Basis", "string"), loc)
adamc@311	3278 val s = "uw_" ^ s
adamc@704	3279 val e_name = (L'.EPrim (Prim.String s), loc)
adamc@273	3280
adamc@273	3281 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
adamc@704	3282
adamc@707	3283 val (pe, fm) = monoExp (env, St.empty, fm) pe
adamc@707	3284 val (ce, fm) = monoExp (env, St.empty, fm) ce
adamc@251	3285 in
adamc@251	3286 SOME (Env.pushENamed env x n t NONE s,
adamc@251	3287 fm,
adamc@707	3288 [(L'.DTable (s, xts, pe, ce), loc),
adamc@704	3289 (L'.DVal (x, n, t', e_name, s), loc)])
adamc@251	3290 end
adamc@273	3291 \| L.DTable _ => poly ()
adamc@754	3292 \| L.DView (x, n, s, e, (L.CRecord (_, xts), _)) =>
adamc@754	3293 let
adamc@754	3294 val t = (L.CFfi ("Basis", "string"), loc)
adamc@754	3295 val t' = (L'.TFfi ("Basis", "string"), loc)
adamc@754	3296 val s = "uw_" ^ s
adamc@754	3297 val e_name = (L'.EPrim (Prim.String s), loc)
adamc@754	3298
adamc@754	3299 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
adamc@754	3300
adamc@754	3301 val (e, fm) = monoExp (env, St.empty, fm) e
adamc@754	3302 val e = (L'.EFfiApp ("Basis", "viewify", [e]), loc)
adamc@754	3303 in
adamc@754	3304 SOME (Env.pushENamed env x n t NONE s,
adamc@754	3305 fm,
adamc@754	3306 [(L'.DView (s, xts, e), loc),
adamc@754	3307 (L'.DVal (x, n, t', e_name, s), loc)])
adamc@754	3308 end
adamc@754	3309 \| L.DView _ => poly ()
adamc@338	3310 \| L.DSequence (x, n, s) =>
adamc@338	3311 let
adamc@338	3312 val t = (L.CFfi ("Basis", "string"), loc)
adamc@338	3313 val t' = (L'.TFfi ("Basis", "string"), loc)
adamc@338	3314 val s = "uw_" ^ s
adamc@338	3315 val e = (L'.EPrim (Prim.String s), loc)
adamc@338	3316 in
adamc@338	3317 SOME (Env.pushENamed env x n t NONE s,
adamc@338	3318 fm,
adamc@338	3319 [(L'.DSequence s, loc),
adamc@338	3320 (L'.DVal (x, n, t', e, s), loc)])
adamc@338	3321 end
adamc@683	3322 \| L.DDatabase _ => NONE
adamc@462	3323 \| L.DCookie (x, n, t, s) =>
adamc@462	3324 let
adamc@462	3325 val t = (L.CFfi ("Basis", "string"), loc)
adamc@462	3326 val t' = (L'.TFfi ("Basis", "string"), loc)
adamc@462	3327 val e = (L'.EPrim (Prim.String s), loc)
adamc@462	3328 in
adamc@462	3329 SOME (Env.pushENamed env x n t NONE s,
adamc@462	3330 fm,
adamc@725	3331 [(L'.DCookie s, loc),
adamc@725	3332 (L'.DVal (x, n, t', e, s), loc)])
adamc@462	3333 end
adamc@720	3334 \| L.DStyle (x, n, s) =>
adamc@718	3335 let
adamc@718	3336 val t = (L.CFfi ("Basis", "string"), loc)
adamc@718	3337 val t' = (L'.TFfi ("Basis", "string"), loc)
adamc@718	3338 val e = (L'.EPrim (Prim.String s), loc)
adamc@718	3339 in
adamc@718	3340 SOME (Env.pushENamed env x n t NONE s,
adamc@718	3341 fm,
adamc@720	3342 [(L'.DStyle s, loc),
adamc@718	3343 (L'.DVal (x, n, t', e, s), loc)])
adamc@718	3344 end
adamc@25	3345 end
adamc@25	3346
adamc@683	3347 datatype expungable = Client \| Channel
adamc@683	3348
adamc@683	3349 fun monoize env file =
adamc@25	3350 let
adamc@735	3351 (* Calculate which exported functions need cookie signature protection *)
adamc@735	3352 val rcook = foldl (fn ((d, _), rcook) =>
adamc@735	3353 case d of
adamc@735	3354 L.DExport (L.Action L.ReadCookieWrite, n) => IS.add (rcook, n)
adamc@735	3355 \| L.DExport (L.Rpc L.ReadCookieWrite, n) => IS.add (rcook, n)
adamc@735	3356 \| _ => rcook)
adamc@735	3357 IS.empty file
adamc@735	3358 val () = readCookie := rcook
adamc@735	3359
adamc@683	3360 val loc = E.dummySpan
adamc@683	3361 val client = (L'.TFfi ("Basis", "client"), loc)
adamc@683	3362 val unit = (L'.TRecord [], loc)
adamc@687	3363
adamc@687	3364 fun calcClientish xts =
adamc@687	3365 foldl (fn ((x : L.con, t : L.con), st as (nullable, notNullable)) =>
adamc@687	3366 case #1 x of
adamc@687	3367 L.CName x =>
adamc@687	3368 (case #1 t of
adamc@687	3369 L.CFfi ("Basis", "client") =>
adamc@687	3370 (nullable, (x, Client) :: notNullable)
adamc@687	3371 \| L.CApp ((L.CFfi ("Basis", "option"), _),
adamc@687	3372 (L.CFfi ("Basis", "client"), _)) =>
adamc@687	3373 ((x, Client) :: nullable, notNullable)
adamc@687	3374 \| L.CApp ((L.CFfi ("Basis", "channel"), _), _) =>
adamc@687	3375 (nullable, (x, Channel) :: notNullable)
adamc@687	3376 \| L.CApp ((L.CFfi ("Basis", "option"), _),
adamc@687	3377 (L.CApp ((L.CFfi ("Basis", "channel"), _), _), _)) =>
adamc@687	3378 ((x, Channel) :: nullable, notNullable)
adamc@687	3379 \| _ => st)
adamc@687	3380 \| _ => st) ([], []) xts
adamc@687	3381
adamc@683	3382 fun expunger () =
adamc@683	3383 let
adamc@683	3384 val target = (L'.EFfiApp ("Basis", "sqlifyClient", [(L'.ERel 0, loc)]), loc)
adamc@683	3385
adamc@683	3386 fun doTable (tab, xts, e) =
adamc@683	3387 case xts of
adamc@683	3388 L.CRecord (_, xts) =>
adamc@683	3389 let
adamc@687	3390 val (nullable, notNullable) = calcClientish xts
adamc@683	3391
adamc@684	3392 fun cond (x, v) =
adamc@684	3393 (L'.EStrcat ((L'.EPrim (Prim.String ("uw_" ^ x
adamc@684	3394 ^ (case v of
adamc@684	3395 Client => ""
adamc@684	3396 \| Channel => " >> 32")
adamc@684	3397 ^ " = ")), loc),
adamc@684	3398 target), loc)
adamc@684	3399
adamc@684	3400 val e =
adamc@684	3401 foldl (fn ((x, v), e) =>
adamc@684	3402 (L'.ESeq (
adamc@684	3403 (L'.EDml (L'.EStrcat (
adamc@684	3404 (L'.EPrim (Prim.String ("UPDATE uw_"
adamc@684	3405 ^ tab
adamc@684	3406 ^ " SET uw_"
adamc@684	3407 ^ x
adamc@684	3408 ^ " = NULL WHERE ")), loc),
adamc@684	3409 cond (x, v)), loc), loc),
adamc@684	3410 e), loc))
adamc@684	3411 e nullable
adamc@684	3412
adamc@683	3413 val e =
adamc@683	3414 case notNullable of
adamc@683	3415 [] => e
adamc@683	3416 \| eb :: ebs =>
adamc@684	3417 (L'.ESeq (
adamc@684	3418 (L'.EDml (foldl
adamc@684	3419 (fn (eb, s) =>
adamc@684	3420 (L'.EStrcat (s,
adamc@687	3421 (L'.EStrcat ((L'.EPrim (Prim.String " OR "),
adamc@684	3422 loc),
adamc@684	3423 cond eb), loc)), loc))
adamc@684	3424 (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM uw_"
adamc@684	3425 ^ tab
adamc@684	3426 ^ " WHERE ")), loc),
adamc@684	3427 cond eb), loc)
adamc@684	3428 ebs), loc),
adamc@684	3429 e), loc)
adamc@683	3430 in
adamc@683	3431 e
adamc@683	3432 end
adamc@683	3433 \| _ => e
adamc@683	3434
adamc@683	3435 val e = (L'.ERecord [], loc)
adamc@683	3436 in
adamc@683	3437 foldl (fn ((d, _), e) =>
adamc@683	3438 case d of
adamc@707	3439 L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e)
adamc@683	3440 \| _ => e) e file
adamc@683	3441 end
adamc@683	3442
adamc@687	3443 fun initializer () =
adamc@687	3444 let
adamc@687	3445 fun doTable (tab, xts, e) =
adamc@687	3446 case xts of
adamc@687	3447 L.CRecord (_, xts) =>
adamc@687	3448 let
adamc@687	3449 val (nullable, notNullable) = calcClientish xts
adamc@687	3450
adamc@687	3451 val e =
adamc@687	3452 case nullable of
adamc@687	3453 [] => e
adamc@687	3454 \| (x, _) :: ebs =>
adamc@687	3455 (L'.ESeq (
adamc@687	3456 (L'.EDml (L'.EPrim (Prim.String
adamc@687	3457 (foldl (fn ((x, _), s) =>
adamc@687	3458 s ^ ", uw_" ^ x ^ " = NULL")
adamc@687	3459 ("UPDATE uw_"
adamc@687	3460 ^ tab
adamc@687	3461 ^ " SET uw_"
adamc@687	3462 ^ x
adamc@687	3463 ^ " = NULL")
adamc@687	3464 ebs)), loc), loc),
adamc@687	3465 e), loc)
adamc@687	3466
adamc@687	3467 val e =
adamc@687	3468 case notNullable of
adamc@687	3469 [] => e
adamc@687	3470 \| eb :: ebs =>
adamc@687	3471 (L'.ESeq (
adamc@687	3472 (L'.EDml (L'.EPrim (Prim.String ("DELETE FROM uw_"
adamc@687	3473 ^ tab)), loc), loc),
adamc@687	3474 e), loc)
adamc@687	3475 in
adamc@687	3476 e
adamc@687	3477 end
adamc@687	3478 \| _ => e
adamc@687	3479
adamc@687	3480 val e = (L'.ERecord [], loc)
adamc@687	3481 in
adamc@687	3482 foldl (fn ((d, _), e) =>
adamc@687	3483 case d of
adamc@707	3484 L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e)
adamc@687	3485 \| _ => e) e file
adamc@687	3486 end
adamc@687	3487
adamc@179	3488 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
adamc@683	3489 case #1 d of
adamc@683	3490 L.DDatabase s =>
adamc@683	3491 let
adamc@687	3492 val (nExp, fm) = Fm.freshName fm
adamc@687	3493 val (nIni, fm) = Fm.freshName fm
adamc@687	3494
adamc@687	3495 val dExp = L'.DVal ("expunger",
adamc@687	3496 nExp,
adamc@687	3497 (L'.TFun (client, unit), loc),
adamc@687	3498 (L'.EAbs ("cli", client, unit, expunger ()), loc),
adamc@687	3499 "expunger")
adamc@687	3500 val dIni = L'.DVal ("initializer",
adamc@687	3501 nIni,
adamc@687	3502 (L'.TFun (unit, unit), loc),
adamc@687	3503 (L'.EAbs ("_", unit, unit, initializer ()), loc),
adamc@687	3504 "initializer")
adamc@683	3505 in
adamc@687	3506 (env, Fm.enter fm, (L'.DDatabase {name = s,
adamc@687	3507 expunge = nExp,
adamc@687	3508 initialize = nIni}, loc)
adamc@687	3509 :: (dExp, loc)
adamc@687	3510 :: (dIni, loc)
adamc@683	3511 :: ds)
adamc@683	3512 end
adamc@683	3513 \| _ =>
adamc@683	3514 case monoDecl (env, fm) d of
adamc@683	3515 NONE => (env, fm, ds)
adamc@683	3516 \| SOME (env, fm, ds') =>
adamc@683	3517 (env,
adamc@683	3518 Fm.enter fm,
adamc@683	3519 ds' @ Fm.decls fm @ ds))
adamc@683	3520 (env, Fm.empty (CoreUtil.File.maxName file + 1), []) file
adamc@25	3521 in
adamc@25	3522 rev ds
adamc@25	3523 end
adamc@25	3524
adamc@25	3525 end

Mercurial > urweb

annotate src/monoize.sml @ 933:6a284a3519ba