Mercurial > urweb

annotate src/monoize.sml @ 1076:dcf98ae3c48d

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