Mercurial > urweb

annotate src/monoize.sml @ 1665:f9ffe8497742

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