Mercurial > urweb

annotate src/monoize.sml @ 853:19fdeef40ada

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