Ur/Web: src/monoize.sml annotate

annotate src/monoize.sml @ 1193:1da49fd79e20

Add subqueries to the manual

author	Adam Chlipala <adamc@hcoop.net>
date	Thu, 25 Mar 2010 16:27:10 -0400
parents	9c82548c97e9
children	aff5e661b5f8

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

Mercurial > urweb

annotate src/monoize.sml @ 1193:1da49fd79e20