Mercurial > urweb

annotate src/monoize.sml @ 709:0406e9cccb72

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