Mercurial > urweb

annotate src/monoize.sml @ 713:baaae037e7f6

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