Mercurial > urweb

annotate src/monoize.sml @ 1651:dfc854e478bb

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