Mercurial > urweb

annotate src/monoize.sml @ 1611:217384f4b8ea

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Tweak error message about Basis.get to use that name instead of internal name
author Adam Chlipala <adam@chlipala.net>
date Thu, 24 Nov 2011 11:56:05 -0500
parents da788bd72c9e
children 15e0c935c91b
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 "*",
adamc@390 1034 floatBin "/",
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)
adamc@1207 2788 | L.ECApp ((L.EFfi ("Basis", "sql_known"), _), _) =>
adamc@1207 2789 ((L'.EFfi ("Basis", "sql_known"), loc), fm)
adamc@746 2790
adamc@470 2791 | (L.ECApp (
adamc@470 2792 (L.ECApp (
adamc@470 2793 (L.ECApp (
adamc@470 2794 (L.ECApp (
adamc@470 2795 (L.EFfi ("Basis", "sql_is_null"), _), _),
adamc@470 2796 _), _),
adamc@470 2797 _), _),
adamc@470 2798 _), _)) =>
adamc@470 2799 let
adamc@470 2800 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@470 2801 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@470 2802 in
adamc@470 2803 ((L'.EAbs ("s", s, s,
adamc@598 2804 strcat [sc "(",
adamc@598 2805 (L'.ERel 0, loc),
adamc@598 2806 sc " IS NULL)"]), loc),
adamc@470 2807 fm)
adamc@470 2808 end
adamc@470 2809
kkallio@1572 2810 | (L.ECApp (
kkallio@1572 2811 (L.ECApp (
kkallio@1572 2812 (L.ECApp (
kkallio@1572 2813 (L.ECApp (
adam@1602 2814 (L.EFfi ("Basis", "sql_coalesce"), _), _),
adam@1602 2815 _), _),
adam@1602 2816 _), _),
adam@1602 2817 _), _)) =>
adam@1602 2818 let
adam@1602 2819 val s = (L'.TFfi ("Basis", "string"), loc)
adam@1602 2820 fun sc s = (L'.EPrim (Prim.String s), loc)
adam@1602 2821 in
adam@1602 2822 ((L'.EAbs ("x1", s, (L'.TFun (s, s), loc),
adam@1602 2823 (L'.EAbs ("x1", s, s,
adam@1602 2824 strcat [sc "COALESCE(",
adam@1602 2825 (L'.ERel 1, loc),
adam@1602 2826 sc ",",
adam@1602 2827 (L'.ERel 0, loc),
adam@1602 2828 sc ")"]), loc)), loc),
adam@1602 2829 fm)
adam@1602 2830 end
adam@1602 2831
adam@1602 2832 | (L.ECApp (
adam@1602 2833 (L.ECApp (
adam@1602 2834 (L.ECApp (
adam@1602 2835 (L.ECApp (
kkallio@1572 2836 (L.EFfi ("Basis", "sql_if_then_else"), _), _),
kkallio@1572 2837 _), _),
kkallio@1572 2838 _), _),
kkallio@1572 2839 _), _)) =>
kkallio@1572 2840 let
kkallio@1572 2841 val s = (L'.TFfi ("Basis", "string"), loc)
kkallio@1572 2842 fun sc s = (L'.EPrim (Prim.String s), loc)
kkallio@1572 2843 in
adam@1573 2844 ((L'.EAbs ("if", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
kkallio@1572 2845 (L'.EAbs ("then", s, (L'.TFun (s, s), loc),
adam@1573 2846 (L'.EAbs ("else", s, s,
kkallio@1572 2847 strcat [sc "(CASE WHEN (",
kkallio@1572 2848 (L'.ERel 2, loc),
kkallio@1572 2849 sc ") THEN (",
kkallio@1572 2850 (L'.ERel 1, loc),
kkallio@1572 2851 sc ") ELSE (",
kkallio@1572 2852 (L'.ERel 0, loc),
kkallio@1572 2853 sc ") END)"]), loc)), loc)), loc),
kkallio@1572 2854 fm)
kkallio@1572 2855 end
kkallio@1572 2856
adamc@1081 2857 | L.ECApp (
adamc@1081 2858 (L.ECApp (
adamc@1081 2859 (L.ECApp (
adamc@1081 2860 (L.ECApp (
adamc@1081 2861 (L.EFfi ("Basis", "sql_nullable"), _),
adamc@1081 2862 _), _),
adamc@1081 2863 _), _),
adamc@1081 2864 _), _),
adamc@1081 2865 _) =>
adamc@1081 2866 let
adamc@1081 2867 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@1081 2868 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@1081 2869 in
adamc@1081 2870 ((L'.EAbs ("u", (L'.TRecord [], loc), (L'.TFun (s, s), loc),
adamc@1081 2871 (L'.EAbs ("x", s, s,
adamc@1081 2872 (L'.ERel 0, loc)), loc)), loc),
adamc@1081 2873 fm)
adamc@1081 2874 end
adamc@1191 2875
adamc@1191 2876 | L.ECApp (
adamc@1191 2877 (L.ECApp (
adamc@1191 2878 (L.ECApp (
adamc@1191 2879 (L.ECApp (
adamc@1191 2880 (L.ECApp (
adam@1421 2881 (L.ECApp (
adam@1421 2882 (L.EFfi ("Basis", "sql_subquery"), _),
adam@1421 2883 _), _),
adamc@1191 2884 _), _),
adamc@1191 2885 _), _),
adamc@1191 2886 _), _),
adamc@1191 2887 _), _),
adamc@1191 2888 _) =>
adamc@1191 2889 let
adamc@1191 2890 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@1191 2891 fun sc s = (L'.EPrim (Prim.String s), loc)
adamc@1191 2892 in
adam@1421 2893 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, s), loc),
adam@1421 2894 (L'.EAbs ("x", s, s,
adam@1421 2895 strcat [sc "(",
adam@1421 2896 (L'.ERel 0, loc),
adam@1421 2897 sc ")"]), loc)), loc),
adamc@1191 2898 fm)
adamc@1191 2899 end
adamc@1081 2900
adamc@338 2901 | L.EFfiApp ("Basis", "nextval", [e]) =>
adamc@338 2902 let
adamc@338 2903 val (e, fm) = monoExp (env, st, fm) e
adamc@338 2904 in
adamc@465 2905 ((L'.ENextval e, loc), fm)
adamc@338 2906 end
adamc@1073 2907 | L.EFfiApp ("Basis", "setval", [e1, e2]) =>
adamc@1073 2908 let
adamc@1073 2909 val (e1, fm) = monoExp (env, st, fm) e1
adamc@1073 2910 val (e2, fm) = monoExp (env, st, fm) e2
adamc@1073 2911 in
adamc@1073 2912 ((L'.ESetval (e1, e2), loc), fm)
adamc@1073 2913 end
adamc@338 2914
adam@1567 2915 | L.EFfi ("Basis", "null") => ((L'.EPrim (Prim.String ""), loc), fm)
adam@1567 2916
adam@1292 2917 | L.EFfiApp ("Basis", "classes", [s1, s2]) =>
adam@1292 2918 let
adam@1292 2919 val (s1, fm) = monoExp (env, st, fm) s1
adam@1292 2920 val (s2, fm) = monoExp (env, st, fm) s2
adam@1292 2921 in
adam@1292 2922 ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc),
adam@1292 2923 fm)
adam@1292 2924 end
adam@1292 2925
adamc@139 2926 | L.EApp (
adamc@139 2927 (L.ECApp (
adamc@720 2928 (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _),
adamc@139 2929 _), _),
adamc@179 2930 se) =>
adamc@179 2931 let
adamc@179 2932 val (se, fm) = monoExp (env, st, fm) se
adamc@179 2933 in
adamc@179 2934 ((L'.EFfiApp ("Basis", "htmlifyString", [se]), loc), fm)
adamc@179 2935 end
adam@1358 2936 | L.ECApp (
adam@1358 2937 (L.ECApp ((L.EFfi ("Basis", "cdataChar"), _), _), _),
adam@1358 2938 _) =>
adam@1358 2939 ((L'.EAbs ("ch", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "string"), loc),
adam@1358 2940 (L'.EFfiApp ("Basis", "htmlifySpecialChar", [(L'.ERel 0, loc)]), loc)), loc), fm)
adamc@179 2941
adamc@95 2942 | L.EApp (
adamc@95 2943 (L.EApp (
adamc@720 2944 (L.ECApp (
adamc@720 2945 (L.ECApp (
adamc@95 2946 (L.ECApp (
adamc@139 2947 (L.ECApp (
adamc@720 2948 (L.EFfi ("Basis", "join"),
adamc@720 2949 _), _), _),
adamc@139 2950 _), _),
adamc@720 2951 _), _),
adamc@720 2952 _), _),
adamc@720 2953 xml1), _),
adamc@720 2954 xml2) =>
adamc@179 2955 let
adamc@179 2956 val (xml1, fm) = monoExp (env, st, fm) xml1
adamc@179 2957 val (xml2, fm) = monoExp (env, st, fm) xml2
adamc@179 2958 in
adamc@179 2959 ((L'.EStrcat (xml1, xml2), loc), fm)
adamc@179 2960 end
adamc@95 2961
adamc@95 2962 | L.EApp (
adamc@95 2963 (L.EApp (
adamc@104 2964 (L.EApp (
adamc@721 2965 (L.EApp (
adamc@720 2966 (L.ECApp (
adamc@104 2967 (L.ECApp (
adamc@104 2968 (L.ECApp (
adamc@139 2969 (L.ECApp (
adamc@139 2970 (L.ECApp (
adamc@139 2971 (L.ECApp (
adamc@139 2972 (L.ECApp (
adamc@721 2973 (L.ECApp (
adamc@721 2974 (L.EFfi ("Basis", "tag"),
adamc@1272 2975 _), (L.CRecord (_, attrsGiven), _)), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
adamc@721 2976 class), _),
adamc@720 2977 attrs), _),
adamc@720 2978 tag), _),
adamc@95 2979 xml) =>
adamc@95 2980 let
adamc@140 2981 fun getTag' (e, _) =
adamc@140 2982 case e of
adamc@143 2983 L.EFfi ("Basis", tag) => (tag, [])
adamc@143 2984 | L.ECApp (e, t) => let
adamc@143 2985 val (tag, ts) = getTag' e
adamc@143 2986 in
adamc@143 2987 (tag, ts @ [t])
adamc@143 2988 end
adamc@140 2989 | _ => (E.errorAt loc "Non-constant XML tag";
adamc@140 2990 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
adamc@143 2991 ("", []))
adamc@140 2992
adamc@95 2993 fun getTag (e, _) =
adamc@95 2994 case e of
adamc@143 2995 L.EFfiApp ("Basis", tag, [(L.ERecord [], _)]) => (tag, [])
adamc@140 2996 | L.EApp (e, (L.ERecord [], _)) => getTag' e
adamc@95 2997 | _ => (E.errorAt loc "Non-constant XML tag";
adamc@95 2998 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
adamc@143 2999 ("", []))
adamc@95 3000
adamc@143 3001 val (tag, targs) = getTag tag
adamc@95 3002
adamc@179 3003 val (attrs, fm) = monoExp (env, st, fm) attrs
adamc@598 3004 val attrs = case #1 attrs of
adamc@598 3005 L'.ERecord xes => xes
adamc@1272 3006 | _ => map (fn ((L.CName x, _), t) => (x, (L'.EField (attrs, x), loc), monoType env t)
adamc@1272 3007 | (c, t) => (E.errorAt loc "Non-constant field name for HTML tag attribute";
adamc@1272 3008 Print.eprefaces' [("Name", CorePrint.p_con env c)];
adamc@1272 3009 ("", (L'.EField (attrs, ""), loc), monoType env t))) attrsGiven
adamc@104 3010
adamc@717 3011 val attrs =
adamc@717 3012 if List.exists (fn ("Link", _, _) => true
adamc@717 3013 | _ => false) attrs then
adamc@717 3014 List.filter (fn ("Href", _, _) => false
adamc@717 3015 | _ => true) attrs
adamc@717 3016 else
adamc@717 3017 attrs
adamc@717 3018
adamc@1042 3019 fun findOnload (attrs, onload, onunload, acc) =
adamc@668 3020 case attrs of
adamc@1042 3021 [] => (onload, onunload, acc)
adamc@1042 3022 | ("Onload", e, _) :: rest => findOnload (rest, SOME e, onunload, acc)
adamc@1042 3023 | ("Onunload", e, _) :: rest => findOnload (rest, onload, SOME e, acc)
adamc@1042 3024 | x :: rest => findOnload (rest, onload, onunload, x :: acc)
adamc@679 3025
adamc@1042 3026 val (onload, onunload, attrs) = findOnload (attrs, NONE, NONE, [])
adamc@668 3027
adamc@721 3028 val (class, fm) = monoExp (env, st, fm) class
adamc@721 3029
adam@1479 3030 fun tagStart tag' =
adamc@598 3031 let
adamc@721 3032 val t = (L'.TFfi ("Basis", "string"), loc)
adam@1479 3033 val s = (L'.EPrim (Prim.String (String.concat ["<", tag'])), loc)
adamc@721 3034
adamc@721 3035 val s = (L'.ECase (class,
adamc@721 3036 [((L'.PNone t, loc),
adamc@721 3037 s),
adamc@721 3038 ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc),
adamc@721 3039 (L'.EStrcat (s,
adamc@721 3040 (L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc),
adamc@721 3041 (L'.EStrcat ((L'.ERel 0, loc),
adamc@721 3042 (L'.EPrim (Prim.String "\""), loc)),
adamc@721 3043 loc)), loc)), loc))],
adamc@721 3044 {disc = (L'.TOption t, loc),
adamc@721 3045 result = t}), loc)
adam@1479 3046
adam@1479 3047 val (s, fm) = foldl (fn (("Action", _, _), acc) => acc
adam@1479 3048 | (("Source", _, _), acc) => acc
adam@1479 3049 | ((x, e, t), (s, fm)) =>
adam@1479 3050 case t of
adam@1479 3051 (L'.TFfi ("Basis", "bool"), _) =>
adam@1479 3052 let
adam@1479 3053 val s' = " " ^ lowercaseFirst x
adam@1479 3054 in
adam@1479 3055 ((L'.ECase (e,
adam@1479 3056 [((L'.PCon (L'.Enum,
adam@1479 3057 L'.PConFfi {mod = "Basis",
adam@1479 3058 datatyp = "bool",
adam@1479 3059 con = "True",
adam@1479 3060 arg = NONE},
adam@1479 3061 NONE), loc),
adam@1479 3062 (L'.EStrcat (s,
adam@1479 3063 (L'.EPrim (Prim.String s'), loc)), loc)),
adam@1479 3064 ((L'.PCon (L'.Enum,
adam@1479 3065 L'.PConFfi {mod = "Basis",
adam@1479 3066 datatyp = "bool",
adam@1479 3067 con = "False",
adam@1479 3068 arg = NONE},
adam@1479 3069 NONE), loc),
adam@1479 3070 s)],
adam@1479 3071 {disc = (L'.TFfi ("Basis", "bool"), loc),
adam@1479 3072 result = (L'.TFfi ("Basis", "string"), loc)}), loc),
adam@1479 3073 fm)
adam@1479 3074 end
adam@1479 3075 | (L'.TFun (dom, _), _) =>
adam@1479 3076 let
adam@1479 3077 val s' = " " ^ lowercaseFirst x ^ "='"
adam@1479 3078 val (e, s') =
adam@1479 3079 case #1 dom of
adam@1479 3080 L'.TRecord [] => ((L'.EApp (e, (L'.ERecord [], loc)), loc), s')
adam@1479 3081 | _ => ((L'.EApp ((L'.EApp (e, (L'.EFfiApp ("Basis", "kc", []), loc)),
adam@1479 3082 loc), (L'.ERecord [], loc)), loc),
adam@1479 3083 s' ^ "uw_event=event;")
adam@1479 3084 val s' = s' ^ "exec("
adam@1479 3085 in
adam@1479 3086 ((L'.EStrcat (s,
adam@1479 3087 (L'.EStrcat (
adam@1479 3088 (L'.EPrim (Prim.String s'), loc),
adam@1479 3089 (L'.EStrcat (
adam@1479 3090 (L'.EJavaScript (L'.Attribute, e), loc),
adam@1479 3091 (L'.EPrim (Prim.String ");return false'"), loc)), loc)),
adam@1479 3092 loc)), loc),
adam@1479 3093 fm)
adam@1479 3094 end
adam@1479 3095 | _ =>
adam@1479 3096 let
adam@1479 3097 val fooify =
adam@1479 3098 case x of
adam@1479 3099 "Link" => urlifyExp
adam@1479 3100 | "Action" => urlifyExp
adam@1479 3101 | _ => attrifyExp
adam@1479 3102
adam@1479 3103 val x =
adam@1479 3104 case x of
adam@1479 3105 "Typ" => "Type"
adam@1479 3106 | "Link" => "Href"
adam@1479 3107 | _ => x
adam@1479 3108 val xp = " " ^ lowercaseFirst x ^ "=\""
adam@1479 3109
adam@1479 3110 val (e, fm) = fooify env fm (e, t)
adam@1479 3111 val e = case (tag, x) of
adam@1479 3112 ("coption", "Value") => (L'.EStrcat ((L'.EPrim (Prim.String "x"), loc), e), loc)
adam@1479 3113 | _ => e
adam@1479 3114 in
adam@1479 3115 ((L'.EStrcat (s,
adam@1479 3116 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
adam@1479 3117 (L'.EStrcat (e,
adam@1479 3118 (L'.EPrim (Prim.String "\""),
adam@1479 3119 loc)),
adam@1479 3120 loc)),
adam@1479 3121 loc)), loc),
adam@1479 3122 fm)
adam@1479 3123 end)
adam@1479 3124 (s, fm) attrs
adamc@598 3125 in
adam@1479 3126 (if tag = "coption" andalso List.all (fn ("Value", _, _) => false | _ => true) attrs then
adam@1479 3127 (L'.EStrcat (s,
adam@1479 3128 (L'.EPrim (Prim.String " value=\"\""), loc)), loc)
adam@1479 3129 else
adam@1479 3130 s,
adam@1479 3131 fm)
adamc@598 3132 end
adamc@104 3133
adamc@143 3134 fun input typ =
adamc@143 3135 case targs of
adamc@155 3136 [_, (L.CName name, _)] =>
adamc@179 3137 let
adamc@179 3138 val (ts, fm) = tagStart "input"
adamc@179 3139 in
adamc@179 3140 ((L'.EStrcat (ts,
adamc@802 3141 (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\" />")),
adamc@179 3142 loc)), loc), fm)
adamc@179 3143 end
adamc@143 3144 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adamc@153 3145 raise Fail "No name passed to input tag")
adamc@104 3146
adamc@565 3147 fun normal (tag, extra, extraInner) =
adamc@143 3148 let
adamc@179 3149 val (tagStart, fm) = tagStart tag
adamc@152 3150 val tagStart = case extra of
adamc@152 3151 NONE => tagStart
adamc@152 3152 | SOME extra => (L'.EStrcat (tagStart, extra), loc)
adamc@152 3153
adamc@143 3154 fun normal () =
adamc@179 3155 let
adamc@179 3156 val (xml, fm) = monoExp (env, st, fm) xml
adamc@916 3157
adamc@916 3158 val xml = case extraInner of
adamc@916 3159 NONE => xml
adamc@916 3160 | SOME ei => (L'.EStrcat (ei, xml), loc)
adamc@179 3161 in
adamc@179 3162 ((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
adamc@179 3163 (L'.EStrcat (xml,
adamc@179 3164 (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])),
adamc@179 3165 loc)), loc)),
adamc@179 3166 loc),
adamc@179 3167 fm)
adamc@179 3168 end
adamc@984 3169
adamc@984 3170 fun isSingleton () =
adamc@984 3171 let
adamc@984 3172 val (bef, aft) = Substring.splitl (not o Char.isSpace) (Substring.full tag)
adamc@984 3173 in
adamc@984 3174 SS.member (singletons, if Substring.isEmpty aft then
adamc@984 3175 tag
adamc@984 3176 else
adamc@984 3177 Substring.string bef)
adamc@984 3178 end
adamc@143 3179 in
adamc@143 3180 case xml of
adamc@143 3181 (L.EApp ((L.ECApp (
adamc@143 3182 (L.ECApp ((L.EFfi ("Basis", "cdata"), _),
adamc@143 3183 _), _),
adamc@143 3184 _), _),
adamc@143 3185 (L.EPrim (Prim.String s), _)), _) =>
adamc@984 3186 if CharVector.all Char.isSpace s andalso isSingleton () then
adamc@802 3187 ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String " />"), loc)), loc), fm)
adamc@143 3188 else
adamc@143 3189 normal ()
adamc@143 3190 | _ => normal ()
adamc@143 3191 end
adamc@606 3192
adamc@606 3193 fun setAttrs jexp =
adamc@606 3194 let
adamc@606 3195 val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc)
adamc@606 3196
adamc@606 3197 val assgns = List.mapPartial
adamc@606 3198 (fn ("Source", _, _) => NONE
adamc@800 3199 | ("Onchange", e, _) =>
adamc@970 3200 SOME (strcat [str "addOnChange(d,exec(",
adamc@815 3201 (L'.EJavaScript (L'.Script, e), loc),
adam@1398 3202 str "));"])
adam@1290 3203 | (x, e, (L'.TFun ((L'.TRecord [], _), _), _)) =>
adamc@970 3204 SOME (strcat [str ("d." ^ lowercaseFirst x ^ "=exec("),
adamc@815 3205 (L'.EJavaScript (L'.Script, e), loc),
adam@1290 3206 str ");"])
adam@1290 3207 | (x, e, _) =>
adam@1398 3208 if String.isPrefix "On" x then
adam@1398 3209 let
adam@1398 3210 val e = (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
adam@1398 3211 (L'.EApp ((L'.EApp (liftExpInExp 0 e,
adam@1398 3212 (L'.EFfiApp ("Basis", "kc", []), loc)),
adam@1398 3213 loc), (L'.ERecord [], loc)), loc)), loc)
adam@1398 3214 in
adam@1398 3215 case x of
adam@1398 3216 "Onkeyup" =>
adam@1398 3217 SOME (strcat [str ("((function(c){addOnKeyUp(d,function(){window.uw_event=window.event;return c();});})(exec("),
adam@1398 3218 (L'.EJavaScript (L'.Script, e), loc),
adam@1398 3219 str ")));"])
adam@1398 3220 | _ =>
adam@1398 3221 SOME (strcat [str ("((function(c){d." ^ lowercaseFirst x ^ "=function(){window.uw_event=window.event;return c();};})(exec("),
adam@1398 3222 (L'.EJavaScript (L'.Script, e), loc),
adam@1398 3223 str ")));"])
adam@1398 3224 end
adam@1398 3225 else
adam@1398 3226 SOME (strcat [str ("d." ^ lowercaseFirst x ^ "=exec("),
adam@1398 3227 (L'.EJavaScript (L'.Script, e), loc),
adam@1398 3228 str ");"]))
adamc@606 3229 attrs
adamc@1173 3230
adamc@1173 3231 val t = (L'.TFfi ("Basis", "string"), loc)
adamc@1173 3232 val setClass = (L'.ECase (class,
adamc@1173 3233 [((L'.PNone t, loc),
adamc@1173 3234 str ""),
adamc@1173 3235 ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc),
adamc@1173 3236 (L'.EStrcat ((L'.EPrim (Prim.String "d.className=\""), loc),
adamc@1173 3237 (L'.EStrcat ((L'.ERel 0, loc),
adamc@1173 3238 (L'.EPrim (Prim.String "\";"), loc)), loc)),
adamc@1173 3239 loc))],
adamc@1173 3240 {disc = (L'.TOption t, loc),
adamc@1173 3241 result = t}), loc)
adamc@606 3242 in
adamc@606 3243 case assgns of
adamc@1173 3244 [] => strcat [str "var d=",
adamc@1173 3245 jexp,
adamc@1173 3246 str ";",
adamc@1173 3247 setClass]
adamc@606 3248 | _ => strcat (str "var d="
adamc@606 3249 :: jexp
adamc@606 3250 :: str ";"
adamc@1173 3251 :: setClass
adamc@606 3252 :: assgns)
adamc@606 3253 end
adamc@1042 3254
adamc@1042 3255 fun execify e =
adamc@1042 3256 case e of
adamc@1042 3257 NONE => (L'.EPrim (Prim.String ""), loc)
adamc@1042 3258 | SOME e =>
adamc@1042 3259 let
adamc@1042 3260 val e = (L'.EApp (e, (L'.ERecord [], loc)), loc)
adamc@1042 3261 in
adamc@1042 3262 (L'.EStrcat ((L'.EPrim (Prim.String "exec("), loc),
adamc@1042 3263 (L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc),
adamc@1042 3264 (L'.EPrim (Prim.String ")"), loc)), loc)), loc)
adamc@1042 3265 end
adamc@152 3266 in
adamc@1065 3267 (case tag of
adamc@1065 3268 "body" => let
adamc@1065 3269 val onload = execify onload
adamc@1065 3270 val onunload = execify onunload
adamc@1065 3271 in
adamc@1065 3272 normal ("body",
adamc@1065 3273 SOME (L'.EStrcat ((L'.EFfiApp ("Basis", "maybe_onload",
adamc@1065 3274 [(L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings",
adamc@1065 3275 [(L'.ERecord [], loc)]), loc),
adamc@1065 3276 onload), loc)]),
adamc@1065 3277 loc),
adamc@1065 3278 (L'.EFfiApp ("Basis", "maybe_onunload",
adamc@1065 3279 [onunload]),
adamc@1065 3280 loc)), loc),
adamc@1065 3281 SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc))
adamc@1065 3282 end
adamc@568 3283
adamc@1065 3284 | "dyn" =>
adamc@1065 3285 let
adamc@1065 3286 fun inTag tag = case targs of
adamc@1065 3287 (L.CRecord (_, ctx), _) :: _ =>
adamc@1065 3288 List.exists (fn ((L.CName tag', _), _) => tag' = tag
adamc@1065 3289 | _ => false) ctx
adamc@1065 3290 | _ => false
adamc@1065 3291
adamc@1065 3292 val tag = if inTag "Tr" then
adamc@1065 3293 "tr"
adamc@1065 3294 else if inTag "Table" then
adamc@1065 3295 "table"
adamc@1065 3296 else
adamc@1065 3297 "span"
adamc@1065 3298 in
adamc@1065 3299 case attrs of
adamc@1065 3300 [("Signal", e, _)] =>
adamc@1065 3301 ((L'.EStrcat
adamc@1065 3302 ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">dyn(\""
adamc@1065 3303 ^ tag ^ "\", execD(")), loc),
adamc@1065 3304 (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
adamc@1065 3305 (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc),
adamc@1065 3306 fm)
adamc@1065 3307 | _ => raise Fail "Monoize: Bad dyn attributes"
adamc@1065 3308 end
adamc@1065 3309
adamc@1065 3310 | "submit" => normal ("input type=\"submit\"", NONE, NONE)
adam@1517 3311 | "image" => normal ("input type=\"image\"", NONE, NONE)
adamc@1065 3312 | "button" => normal ("input type=\"submit\"", NONE, NONE)
adamc@1065 3313 | "hidden" => input "hidden"
adamc@152 3314
adamc@1065 3315 | "textbox" =>
adamc@1065 3316 (case targs of
adamc@1065 3317 [_, (L.CName name, _)] =>
adamc@1065 3318 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
adamc@1065 3319 NONE =>
adamc@1065 3320 let
adamc@1065 3321 val (ts, fm) = tagStart "input"
adamc@1065 3322 in
adamc@1065 3323 ((L'.EStrcat (ts,
adamc@1065 3324 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\" />")),
adamc@1065 3325 loc)), loc), fm)
adamc@1065 3326 end
adamc@1065 3327 | SOME (_, src, _) =>
adamc@1065 3328 (strcat [str "<script type=\"text/javascript\">inp(exec(",
adamc@1065 3329 (L'.EJavaScript (L'.Script, src), loc),
adam@1463 3330 str "), \"",
adam@1463 3331 str name,
adam@1463 3332 str "\")</script>"],
adamc@1065 3333 fm))
adamc@1065 3334 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adamc@1065 3335 raise Fail "No name passed to textbox tag"))
adamc@1065 3336 | "password" => input "password"
adamc@1065 3337 | "textarea" =>
adamc@1065 3338 (case targs of
adamc@1065 3339 [_, (L.CName name, _)] =>
adamc@1065 3340 let
adamc@1065 3341 val (ts, fm) = tagStart "textarea"
adamc@1065 3342 val (xml, fm) = monoExp (env, st, fm) xml
adamc@1065 3343 in
adamc@1065 3344 ((L'.EStrcat ((L'.EStrcat (ts,
adamc@1065 3345 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc),
adamc@1065 3346 (L'.EStrcat (xml,
adamc@1065 3347 (L'.EPrim (Prim.String "</textarea>"),
adamc@1065 3348 loc)), loc)),
adamc@1065 3349 loc), fm)
adamc@1065 3350 end
adamc@1065 3351 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adamc@1065 3352 raise Fail "No name passed to ltextarea tag"))
adamc@153 3353
adamc@1065 3354 | "checkbox" => input "checkbox"
adamc@1065 3355 | "upload" => input "file"
adamc@190 3356
adamc@1065 3357 | "radio" =>
adamc@1065 3358 (case targs of
adamc@1065 3359 [_, (L.CName name, _)] =>
adamc@1065 3360 monoExp (env, St.setRadioGroup (st, name), fm) xml
adamc@1065 3361 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adamc@1065 3362 raise Fail "No name passed to radio tag"))
adamc@1065 3363 | "radioOption" =>
adamc@1065 3364 (case St.radioGroup st of
adamc@1065 3365 NONE => raise Fail "No name for radioGroup"
adamc@1065 3366 | SOME name =>
adamc@1065 3367 normal ("input",
adamc@1065 3368 SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc),
adamc@1065 3369 NONE))
adamc@152 3370
adamc@1065 3371 | "select" =>
adamc@1065 3372 (case targs of
adamc@1065 3373 [_, (L.CName name, _)] =>
adamc@1065 3374 let
adamc@1065 3375 val (ts, fm) = tagStart "select"
adamc@1065 3376 val (xml, fm) = monoExp (env, st, fm) xml
adamc@1065 3377 in
adamc@1065 3378 ((L'.EStrcat ((L'.EStrcat (ts,
adamc@1065 3379 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")),
adamc@1065 3380 loc)), loc),
adamc@1065 3381 (L'.EStrcat (xml,
adamc@1065 3382 (L'.EPrim (Prim.String "</select>"),
adamc@1065 3383 loc)), loc)),
adamc@1065 3384 loc),
adamc@1065 3385 fm)
adamc@1065 3386 end
adamc@1065 3387 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adamc@1065 3388 raise Fail "No name passed to lselect tag"))
adamc@154 3389
adamc@1065 3390 | "ctextbox" =>
adamc@1065 3391 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
adamc@1065 3392 NONE =>
adamc@1065 3393 let
adamc@1065 3394 val (ts, fm) = tagStart "input"
adamc@1065 3395 in
adamc@1065 3396 ((L'.EStrcat (ts,
adamc@1065 3397 (L'.EPrim (Prim.String " />"), loc)),
adamc@1065 3398 loc), fm)
adamc@1065 3399 end
adamc@1065 3400 | SOME (_, src, _) =>
adamc@1065 3401 let
adamc@1065 3402 val sc = strcat [str "inp(exec(",
adamc@1065 3403 (L'.EJavaScript (L'.Script, src), loc),
adamc@1065 3404 str "))"]
adamc@1065 3405 val sc = setAttrs sc
adamc@1065 3406 in
adamc@1065 3407 (strcat [str "<script type=\"text/javascript\">",
adamc@1065 3408 sc,
adamc@1065 3409 str "</script>"],
adamc@1065 3410 fm)
adamc@1065 3411 end)
adamc@797 3412
adamc@1065 3413 | "ccheckbox" =>
adamc@1065 3414 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
adamc@1065 3415 NONE =>
adamc@1065 3416 let
adamc@1065 3417 val (ts, fm) = tagStart "input type=\"checkbox\""
adamc@1065 3418 in
adamc@1065 3419 ((L'.EStrcat (ts,
adamc@1065 3420 (L'.EPrim (Prim.String " />"), loc)),
adamc@1065 3421 loc), fm)
adamc@1065 3422 end
adamc@1065 3423 | SOME (_, src, _) =>
adamc@1065 3424 let
adamc@1065 3425 val sc = strcat [str "chk(exec(",
adamc@1065 3426 (L'.EJavaScript (L'.Script, src), loc),
adamc@1065 3427 str "))"]
adamc@1065 3428 val sc = setAttrs sc
adamc@1065 3429 in
adamc@1065 3430 (strcat [str "<script type=\"text/javascript\">",
adamc@1065 3431 sc,
adamc@1065 3432 str "</script>"],
adamc@1065 3433 fm)
adamc@1065 3434 end)
adamc@817 3435
adamc@1065 3436 | "cselect" =>
adamc@1065 3437 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
adamc@1065 3438 NONE =>
adamc@1065 3439 let
adamc@1065 3440 val (xml, fm) = monoExp (env, st, fm) xml
adamc@1065 3441 val (ts, fm) = tagStart "select"
adamc@1065 3442 in
adamc@1065 3443 (strcat [ts,
adamc@1065 3444 str ">",
adamc@1065 3445 xml,
adamc@1065 3446 str "</select>"],
adamc@1065 3447 fm)
adamc@1065 3448 end
adamc@1065 3449 | SOME (_, src, _) =>
adamc@1065 3450 let
adamc@1065 3451 val (xml, fm) = monoExp (env, st, fm) xml
adamc@797 3452
adamc@1065 3453 val sc = strcat [str "sel(exec(",
adamc@1065 3454 (L'.EJavaScript (L'.Script, src), loc),
adamc@1065 3455 str "),exec(",
adamc@1065 3456 (L'.EJavaScript (L'.Script, xml), loc),
adamc@1065 3457 str "))"]
adamc@1065 3458 val sc = setAttrs sc
adamc@1065 3459 in
adamc@1065 3460 (strcat [str "<script type=\"text/javascript\">",
adamc@1065 3461 sc,
adamc@1065 3462 str "</script>"],
adamc@1065 3463 fm)
adamc@1065 3464 end)
adamc@154 3465
adamc@1065 3466 | "coption" => normal ("option", NONE, NONE)
adamc@797 3467
adamc@1099 3468 | "ctextarea" =>
adamc@1099 3469 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
adamc@1099 3470 NONE =>
adamc@1099 3471 let
adamc@1099 3472 val (ts, fm) = tagStart "textarea"
adamc@1099 3473 in
adamc@1099 3474 ((L'.EStrcat (ts,
adamc@1099 3475 (L'.EPrim (Prim.String " />"), loc)),
adamc@1099 3476 loc), fm)
adamc@1099 3477 end
adamc@1099 3478 | SOME (_, src, _) =>
adamc@1099 3479 let
adamc@1099 3480 val sc = strcat [str "tbx(exec(",
adamc@1099 3481 (L'.EJavaScript (L'.Script, src), loc),
adamc@1099 3482 str "))"]
adamc@1099 3483 val sc = setAttrs sc
adamc@1099 3484 in
adamc@1099 3485 (strcat [str "<script type=\"text/javascript\">",
adamc@1099 3486 sc,
adamc@1099 3487 str "</script>"],
adamc@1099 3488 fm)
adamc@1099 3489 end)
adamc@1099 3490
adamc@1065 3491 | "tabl" => normal ("table", NONE, NONE)
adamc@1065 3492 | _ => normal (tag, NONE, NONE))
adamc@95 3493 end
adamc@94 3494
adam@1412 3495 | L.EApp (
adam@1412 3496 (L.EApp ((L.ECApp (
adam@1412 3497 (L.ECApp ((L.EFfi ("Basis", "form"), _), _), _),
adam@1412 3498 (L.CRecord (_, fields), _)), _),
adam@1412 3499 class), _),
adam@1412 3500 xml) =>
adamc@143 3501 let
adamc@143 3502 fun findSubmit (e, _) =
adamc@143 3503 case e of
adamc@143 3504 L.EApp (
adamc@143 3505 (L.EApp (
adamc@143 3506 (L.ECApp (
adamc@143 3507 (L.ECApp (
adamc@143 3508 (L.ECApp (
adamc@143 3509 (L.ECApp (
adamc@143 3510 (L.EFfi ("Basis", "join"),
adamc@143 3511 _), _), _),
adamc@143 3512 _), _),
adamc@143 3513 _), _),
adamc@143 3514 _), _),
adamc@143 3515 xml1), _),
adamc@143 3516 xml2) => (case findSubmit xml1 of
adamc@143 3517 Error => Error
adamc@143 3518 | NotFound => findSubmit xml2
adamc@143 3519 | Found e =>
adamc@143 3520 case findSubmit xml2 of
adamc@143 3521 NotFound => Found e
adamc@143 3522 | _ => Error)
adamc@143 3523 | L.EApp (
adamc@143 3524 (L.EApp (
adamc@143 3525 (L.EApp (
adamc@730 3526 (L.EApp (
adamc@143 3527 (L.ECApp (
adamc@143 3528 (L.ECApp (
adamc@143 3529 (L.ECApp (
adamc@143 3530 (L.ECApp (
adamc@143 3531 (L.ECApp (
adamc@143 3532 (L.ECApp (
adamc@143 3533 (L.ECApp (
adamc@730 3534 (L.ECApp (
adamc@730 3535 (L.EFfi ("Basis", "tag"),
adamc@730 3536 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
adamc@730 3537 _), _),
adamc@143 3538 attrs), _),
adamc@143 3539 _), _),
adamc@143 3540 xml) =>
adamc@143 3541 (case #1 attrs of
adamc@143 3542 L.ERecord xes =>
adamc@143 3543 (case ListUtil.search (fn ((L.CName "Action", _), e, t) => SOME (e, t)
adamc@143 3544 | _ => NONE) xes of
adamc@143 3545 NONE => findSubmit xml
adamc@143 3546 | SOME et =>
adamc@143 3547 case findSubmit xml of
adamc@143 3548 NotFound => Found et
adamc@143 3549 | _ => Error)
adamc@143 3550 | _ => findSubmit xml)
adamc@143 3551 | _ => NotFound
adamc@143 3552
adamc@735 3553 val (func, action, fm) = case findSubmit xml of
adamc@735 3554 NotFound => (0, (L'.EPrim (Prim.String ""), loc), fm)
adamc@143 3555 | Error => raise Fail "Not ready for multi-submit lforms yet"
adamc@598 3556 | Found (action, actionT) =>
adamc@598 3557 let
adamc@735 3558 val func = case #1 action of
adamc@735 3559 L.EClosure (n, _) => n
adamc@735 3560 | _ => raise Fail "Monoize: Action is not a closure"
adamc@598 3561 val actionT = monoType env actionT
adamc@598 3562 val (action, fm) = monoExp (env, st, fm) action
adamc@598 3563 val (action, fm) = urlifyExp env fm (action, actionT)
adamc@598 3564 in
adamc@735 3565 (func,
adamc@735 3566 (L'.EStrcat ((L'.EPrim (Prim.String " action=\""), loc),
adamc@598 3567 (L'.EStrcat (action,
adamc@598 3568 (L'.EPrim (Prim.String "\""), loc)), loc)), loc),
adamc@598 3569 fm)
adamc@598 3570 end
adamc@734 3571
adamc@737 3572 val hasUpload = CoreUtil.Exp.exists {kind = fn _ => false,
adamc@737 3573 con = fn _ => false,
adamc@737 3574 exp = fn e =>
adamc@737 3575 case e of
adamc@737 3576 L.EFfi ("Basis", "upload") => true
adamc@737 3577 | _ => false} xml
adamc@737 3578
adamc@179 3579 val (xml, fm) = monoExp (env, st, fm) xml
adamc@735 3580
adamc@735 3581 val xml =
adamc@735 3582 if IS.member (!readCookie, func) then
adamc@735 3583 let
adamc@735 3584 fun inFields s = List.exists (fn ((L.CName s', _), _) => s' = s
adamc@735 3585 | _ => true) fields
adamc@735 3586
adamc@735 3587 fun getSigName () =
adamc@735 3588 let
adamc@735 3589 fun getSigName' n =
adamc@735 3590 let
adamc@735 3591 val s = "Sig" ^ Int.toString n
adamc@735 3592 in
adamc@735 3593 if inFields s then
adamc@735 3594 getSigName' (n + 1)
adamc@735 3595 else
adamc@735 3596 s
adamc@735 3597 end
adamc@735 3598 in
adamc@735 3599 if inFields "Sig" then
adamc@735 3600 getSigName' 0
adamc@735 3601 else
adamc@735 3602 "Sig"
adamc@735 3603 end
adamc@735 3604
adamc@735 3605 val sigName = getSigName ()
adamc@735 3606 val sigSet = (L'.EFfiApp ("Basis", "sigString", [(L'.ERecord [], loc)]), loc)
adamc@735 3607 val sigSet = (L'.EStrcat ((L'.EPrim (Prim.String ("<input type=\"hidden\" name=\""
adamc@735 3608 ^ sigName
adamc@735 3609 ^ "\" value=\"")), loc),
adamc@735 3610 sigSet), loc)
adamc@735 3611 val sigSet = (L'.EStrcat (sigSet,
adamc@803 3612 (L'.EPrim (Prim.String "\" />"), loc)), loc)
adamc@735 3613 in
adamc@735 3614 (L'.EStrcat (sigSet, xml), loc)
adamc@735 3615 end
adamc@735 3616 else
adamc@735 3617 xml
adamc@737 3618
adamc@737 3619 val action = if hasUpload then
adamc@737 3620 (L'.EStrcat (action,
adamc@737 3621 (L'.EPrim (Prim.String " enctype=\"multipart/form-data\""), loc)), loc)
adamc@737 3622 else
adamc@737 3623 action
adamc@737 3624
adam@1412 3625 val stt = (L'.TFfi ("Basis", "string"), loc)
adam@1412 3626 val (class, fm) = monoExp (env, st, fm) class
adam@1412 3627 val action = (L'.EStrcat (action,
adam@1412 3628 (L'.ECase (class,
adam@1412 3629 [((L'.PNone stt, loc),
adam@1412 3630 (L'.EPrim (Prim.String ""), loc)),
adam@1412 3631 ((L'.PSome (stt, (L'.PVar ("x", stt), loc)), loc),
adam@1412 3632 (L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc),
adam@1412 3633 (L'.EStrcat ((L'.ERel 0, loc),
adam@1412 3634 (L'.EPrim (Prim.String "\""), loc)), loc)), loc))],
adam@1412 3635 {disc = (L'.TOption stt, loc),
adam@1412 3636 result = stt}), loc)), loc)
adamc@143 3637 in
adamc@1026 3638 ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form method=\"post\""), loc),
adamc@179 3639 (L'.EStrcat (action,
adamc@598 3640 (L'.EPrim (Prim.String ">"), loc)), loc)), loc),
adamc@179 3641 (L'.EStrcat (xml,
adamc@179 3642 (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc),
adamc@179 3643 fm)
adamc@143 3644 end
adamc@141 3645
adamc@756 3646 | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp (
adamc@756 3647 (L.EFfi ("Basis", "subform"), _), _), _), _),
adamc@756 3648 _), _), _), (L.CName nm, loc)) =>
adamc@756 3649 let
adamc@756 3650 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@756 3651 in
adamc@756 3652 ((L'.EAbs ("xml", s, s,
adamc@756 3653 strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".b\" value=\""
adamc@803 3654 ^ nm ^ "\" />")), loc),
adamc@756 3655 (L'.ERel 0, loc),
adamc@803 3656 (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\" />")), loc)]),
adamc@756 3657 loc),
adamc@756 3658 fm)
adamc@756 3659 end
adamc@756 3660
adamc@758 3661 | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp (
adamc@758 3662 (L.EFfi ("Basis", "subforms"), _), _), _), _),
adamc@758 3663 _), _), _), (L.CName nm, loc)) =>
adamc@758 3664 let
adamc@758 3665 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@758 3666 in
adamc@758 3667 ((L'.EAbs ("xml", s, s,
adamc@758 3668 strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".s\" value=\""
adamc@803 3669 ^ nm ^ "\" />")), loc),
adamc@758 3670 (L'.ERel 0, loc),
adamc@803 3671 (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\" />")), loc)]),
adamc@758 3672 loc),
adamc@758 3673 fm)
adamc@758 3674 end
adamc@758 3675
adamc@758 3676 | L.ECApp ((L.ECApp (
adamc@758 3677 (L.EFfi ("Basis", "entry"), _), _), _), _) =>
adamc@758 3678 let
adamc@758 3679 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@758 3680 in
adamc@758 3681 ((L'.EAbs ("xml", s, s,
adamc@803 3682 strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".i\" value=\"1\" />")), loc),
adamc@758 3683 (L'.ERel 0, loc),
adamc@803 3684 (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\" />")), loc)]),
adamc@758 3685 loc),
adamc@758 3686 fm)
adamc@758 3687 end
adamc@758 3688
adamc@148 3689 | L.EApp ((L.ECApp (
adamc@148 3690 (L.ECApp (
adamc@148 3691 (L.ECApp (
adamc@148 3692 (L.ECApp (
adamc@148 3693 (L.EFfi ("Basis", "useMore"), _), _), _),
adamc@148 3694 _), _),
adamc@148 3695 _), _),
adamc@148 3696 _), _),
adamc@179 3697 xml) => monoExp (env, st, fm) xml
adamc@148 3698
adamc@283 3699 | L.ECApp ((L.EFfi ("Basis", "error"), _), t) =>
adamc@283 3700 let
adamc@283 3701 val t = monoType env t
adamc@283 3702 in
adamc@283 3703 ((L'.EAbs ("s", (L'.TFfi ("Basis", "string"), loc), t,
adamc@283 3704 (L'.EError ((L'.ERel 0, loc), t), loc)), loc),
adamc@283 3705 fm)
adamc@283 3706 end
adamc@741 3707 | L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t) =>
adamc@741 3708 let
adamc@741 3709 val t = monoType env t
adamc@741 3710 val un = (L'.TRecord [], loc)
adamc@741 3711 in
adamc@741 3712 ((L'.EAbs ("b", (L'.TFfi ("Basis", "blob"), loc),
adamc@741 3713 (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc)), loc),
adamc@741 3714 (L'.EAbs ("mt", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
adamc@741 3715 (L'.EAbs ("_", un, t,
adamc@741 3716 (L'.EReturnBlob {blob = (L'.ERel 2, loc),
adamc@741 3717 mimeType = (L'.ERel 1, loc),
adamc@741 3718 t = t}, loc)), loc)), loc)), loc),
adamc@741 3719 fm)
adamc@741 3720 end
adamc@1065 3721 | L.ECApp ((L.EFfi ("Basis", "redirect"), _), t) =>
adamc@1065 3722 let
adamc@1065 3723 val t = monoType env t
adamc@1065 3724 val un = (L'.TRecord [], loc)
adamc@1065 3725 in
adamc@1065 3726 ((L'.EAbs ("url", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
adamc@1065 3727 (L'.EAbs ("_", un, t,
adamc@1065 3728 (L'.ERedirect ((L'.ERel 1, loc), t), loc)), loc)), loc),
adamc@1065 3729 fm)
adamc@1065 3730 end
adamc@283 3731
adamc@1104 3732 | L.ECApp ((L.EFfi ("Basis", "serialize"), _), t) =>
adamc@1104 3733 let
adamc@1104 3734 val t = monoType env t
adamc@1104 3735 val (e, fm) = urlifyExp env fm ((L'.ERel 0, loc), t)
adamc@1104 3736 in
adamc@1104 3737 ((L'.EAbs ("v", t, (L'.TFfi ("Basis", "string"), loc), e), loc),
adamc@1104 3738 fm)
adamc@1104 3739 end
adamc@1104 3740 | L.ECApp ((L.EFfi ("Basis", "deserialize"), _), t) =>
adamc@1104 3741 let
adamc@1104 3742 val t = monoType env t
adamc@1104 3743 in
adamc@1112 3744 ((L'.EAbs ("v", (L'.TFfi ("Basis", "string"), loc), t, (L'.EUnurlify ((L'.ERel 0, loc), t, false),
adamc@1112 3745 loc)), loc),
adamc@1104 3746 fm)
adamc@1104 3747 end
adamc@1104 3748
adamc@1067 3749 | L.EFfiApp ("Basis", "url", [e]) =>
adamc@1067 3750 let
adamc@1067 3751 val (e, fm) = monoExp (env, st, fm) e
adam@1370 3752 val (e, fm) = urlifyExp env fm (e, dummyTyp)
adamc@1067 3753 in
adam@1370 3754 ((L'.EStrcat ((L'.EPrim (Prim.String (Settings.getUrlPrePrefix ())), loc), e), loc), fm)
adamc@1067 3755 end
adamc@1067 3756
adamc@179 3757 | L.EApp (e1, e2) =>
adamc@179 3758 let
adamc@179 3759 val (e1, fm) = monoExp (env, st, fm) e1
adamc@179 3760 val (e2, fm) = monoExp (env, st, fm) e2
adamc@179 3761 in
adamc@179 3762 ((L'.EApp (e1, e2), loc), fm)
adamc@179 3763 end
adamc@26 3764 | L.EAbs (x, dom, ran, e) =>
adamc@179 3765 let
adamc@179 3766 val (e, fm) = monoExp (Env.pushERel env x dom, st, fm) e
adamc@179 3767 in
adamc@179 3768 ((L'.EAbs (x, monoType env dom, monoType env ran, e), loc), fm)
adamc@179 3769 end
adamc@25 3770 | L.ECApp _ => poly ()
adamc@25 3771 | L.ECAbs _ => poly ()
adamc@25 3772
adamc@252 3773 | L.EFfi mx => ((L'.EFfi mx, loc), fm)
adamc@252 3774 | L.EFfiApp (m, x, es) =>
adamc@252 3775 let
adamc@252 3776 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
adamc@252 3777 in
adamc@252 3778 ((L'.EFfiApp (m, x, es), loc), fm)
adamc@252 3779 end
adamc@252 3780
adamc@179 3781 | L.ERecord xes =>
adamc@179 3782 let
adamc@179 3783 val (xes, fm) = ListUtil.foldlMap
adamc@179 3784 (fn ((x, e, t), fm) =>
adamc@179 3785 let
adamc@179 3786 val (e, fm) = monoExp (env, st, fm) e
adamc@179 3787 in
adamc@179 3788 ((monoName env x,
adamc@179 3789 e,
adamc@179 3790 monoType env t), fm)
adamc@179 3791 end) fm xes
adamc@905 3792
adamc@905 3793 val xes = ListMergeSort.sort (fn ((x, _, _), (y, _, _)) => String.compare (x, y) = GREATER) xes
adamc@179 3794 in
adamc@179 3795 ((L'.ERecord xes, loc), fm)
adamc@179 3796 end
adamc@179 3797 | L.EField (e, x, _) =>
adamc@179 3798 let
adamc@179 3799 val (e, fm) = monoExp (env, st, fm) e
adamc@179 3800 in
adamc@179 3801 ((L'.EField (e, monoName env x), loc), fm)
adamc@179 3802 end
adamc@445 3803 | L.EConcat _ => poly ()
adamc@149 3804 | L.ECut _ => poly ()
adamc@493 3805 | L.ECutMulti _ => poly ()
adamc@177 3806
adamc@182 3807 | L.ECase (e, pes, {disc, result}) =>
adamc@179 3808 let
adamc@179 3809 val (e, fm) = monoExp (env, st, fm) e
adamc@179 3810 val (pes, fm) = ListUtil.foldlMap
adamc@179 3811 (fn ((p, e), fm) =>
adamc@179 3812 let
adamc@179 3813 val (e, fm) = monoExp (env, st, fm) e
adamc@179 3814 in
adamc@182 3815 ((monoPat env p, e), fm)
adamc@179 3816 end) fm pes
adamc@179 3817 in
adamc@182 3818 ((L'.ECase (e, pes, {disc = monoType env disc, result = monoType env result}), loc), fm)
adamc@179 3819 end
adamc@177 3820
adamc@179 3821 | L.EWrite e =>
adamc@179 3822 let
adamc@179 3823 val (e, fm) = monoExp (env, st, fm) e
adamc@179 3824 in
adamc@252 3825 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
adamc@252 3826 (L'.EWrite (liftExpInExp 0 e), loc)), loc), fm)
adamc@179 3827 end
adamc@110 3828
adamc@179 3829 | L.EClosure (n, es) =>
adamc@179 3830 let
adamc@179 3831 val (es, fm) = ListUtil.foldlMap (fn (e, fm) =>
adamc@179 3832 monoExp (env, st, fm) e)
adamc@1065 3833 fm es
adamc@1065 3834 val e = (L'.EClosure (n, es), loc)
adamc@179 3835 in
adamc@1067 3836 (e, fm)
adamc@179 3837 end
adamc@450 3838
adamc@450 3839 | L.ELet (x, t, e1, e2) =>
adamc@450 3840 let
adamc@450 3841 val t' = monoType env t
adamc@450 3842 val (e1, fm) = monoExp (env, st, fm) e1
adamc@450 3843 val (e2, fm) = monoExp (Env.pushERel env x t, st, fm) e2
adamc@450 3844 in
adamc@450 3845 ((L'.ELet (x, t', e1, e2), loc), fm)
adamc@450 3846 end
adamc@607 3847
adamc@1020 3848 | L.EServerCall (n, es, t) =>
adamc@608 3849 let
adamc@609 3850 val t = monoType env t
adamc@614 3851 val (_, ft, _, name) = Env.lookupENamed env n
adamc@608 3852 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
adamc@614 3853
adamc@614 3854 fun encodeArgs (es, ft, acc, fm) =
adamc@614 3855 case (es, ft) of
adamc@614 3856 ([], _) => (rev acc, fm)
adamc@614 3857 | (e :: es, (L.TFun (dom, ran), _)) =>
adamc@614 3858 let
adamc@614 3859 val (e, fm) = urlifyExp env fm (e, monoType env dom)
adamc@614 3860 in
adamc@614 3861 encodeArgs (es, ran, e
adamc@614 3862 :: (L'.EPrim (Prim.String "/"), loc)
adamc@614 3863 :: acc, fm)
adamc@614 3864 end
adamc@614 3865 | _ => raise Fail "Monoize: Not enough arguments visible in RPC function type"
adamc@614 3866
adamc@614 3867 val (call, fm) = encodeArgs (es, ft, [], fm)
adamc@614 3868 val call = foldl (fn (e, call) => (L'.EStrcat (call, e), loc))
adamc@614 3869 (L'.EPrim (Prim.String name), loc) call
adamc@614 3870
adamc@905 3871 val unit = (L'.TRecord [], loc)
adamc@905 3872
adamc@736 3873 val eff = if IS.member (!readCookie, n) then
adamc@736 3874 L'.ReadCookieWrite
adamc@736 3875 else
adamc@736 3876 L'.ReadOnly
adamc@905 3877
adamc@1020 3878 val e = (L'.EServerCall (call, t, eff), loc)
adamc@651 3879 val e = liftExpInExp 0 e
adamc@651 3880 val e = (L'.EAbs ("_", unit, unit, e), loc)
adamc@608 3881 in
adamc@651 3882 (e, fm)
adamc@608 3883 end
adamc@626 3884
adamc@626 3885 | L.EKAbs _ => poly ()
adamc@626 3886 | L.EKApp _ => poly ()
adamc@25 3887 end
adamc@25 3888
adamc@179 3889 fun monoDecl (env, fm) (all as (d, loc)) =
adamc@25 3890 let
adamc@25 3891 fun poly () =
adamc@25 3892 (E.errorAt loc "Unsupported declaration";
adamc@25 3893 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
adamc@25 3894 NONE)
adamc@25 3895 in
adamc@25 3896 case d of
adamc@25 3897 L.DCon _ => NONE
adamc@808 3898 | L.DDatatype [("list", n, [_], [("Nil", _, NONE),
adamc@808 3899 ("Cons", _, SOME (L.TRecord (L.CRecord (_,
adamc@808 3900 [((L.CName "1", _),
adamc@808 3901 (L.CRel 0, _)),
adamc@808 3902 ((L.CName "2", _),
adamc@808 3903 (L.CApp ((L.CNamed n', _),
adamc@808 3904 (L.CRel 0, _)),
adamc@808 3905 _))]), _), _))])] =>
adamc@757 3906 if n = n' then
adamc@757 3907 NONE
adamc@757 3908 else
adamc@757 3909 poly ()
adamc@808 3910 | L.DDatatype dts =>
adamc@808 3911 let
adamc@808 3912 val env' = Env.declBinds env all
adamc@808 3913 val dts = map (fn (x, n, [], xncs) =>
adamc@808 3914 (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env') to)) xncs)
adamc@808 3915 | _ => (E.errorAt loc "Polymorphic datatype needed too late";
adamc@808 3916 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
adamc@808 3917 ("", 0, []))) dts
adamc@808 3918 val d = (L'.DDatatype dts, loc)
adamc@808 3919 in
adamc@808 3920 SOME (env', fm, [d])
adamc@808 3921 end
adamc@179 3922 | L.DVal (x, n, t, e, s) =>
adamc@179 3923 let
adamc@179 3924 val (e, fm) = monoExp (env, St.empty, fm) e
adamc@179 3925 in
adamc@179 3926 SOME (Env.pushENamed env x n t NONE s,
adamc@179 3927 fm,
adamc@273 3928 [(L'.DVal (x, n, monoType env t, e, s), loc)])
adamc@179 3929 end
adamc@128 3930 | L.DValRec vis =>
adamc@128 3931 let
adamc@1107 3932 val vis = map (fn (x, n, t, e, s) =>
adamc@1107 3933 let
adamc@1107 3934 fun maybeTransaction (t, e) =
adamc@1107 3935 case (#1 t, #1 e) of
adamc@1107 3936 (L.CApp ((L.CFfi ("Basis", "transaction"), _), _), _) =>
adamc@1107 3937 SOME (L.EAbs ("_",
adamc@1107 3938 (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc),
adamc@1107 3939 t,
adamc@1107 3940 (L.EApp (CoreEnv.liftExpInExp 0 e,
adamc@1107 3941 (L.ERecord [], loc)), loc)), loc)
adamc@1107 3942 | (L.TFun (dom, ran), L.EAbs (x, _, _, e)) =>
adamc@1107 3943 (case maybeTransaction (ran, e) of
adamc@1107 3944 NONE => NONE
adamc@1107 3945 | SOME e => SOME (L.EAbs (x, dom, ran, e), loc))
adamc@1107 3946 | _ => NONE
adamc@1107 3947 in
adamc@1107 3948 (x, n, t,
adamc@1107 3949 case maybeTransaction (t, e) of
adamc@1107 3950 NONE => e
adamc@1107 3951 | SOME e => e,
adamc@1107 3952 s)
adamc@1107 3953 end) vis
adamc@1107 3954
adamc@128 3955 val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis
adamc@179 3956
adamc@179 3957 val (vis, fm) = ListUtil.foldlMap
adamc@179 3958 (fn ((x, n, t, e, s), fm) =>
adamc@179 3959 let
adamc@179 3960 val (e, fm) = monoExp (env, St.empty, fm) e
adamc@179 3961 in
adamc@179 3962 ((x, n, monoType env t, e, s), fm)
adamc@179 3963 end)
adamc@179 3964 fm vis
adamc@128 3965 in
adamc@128 3966 SOME (env,
adamc@179 3967 fm,
adamc@273 3968 [(L'.DValRec vis, loc)])
adamc@128 3969 end
adamc@1104 3970 | L.DExport (ek, n, b) =>
adamc@115 3971 let
adamc@120 3972 val (_, t, _, s) = Env.lookupENamed env n
adamc@120 3973
adamc@609 3974 fun unwind (t, args) =
adamc@609 3975 case #1 t of
adamc@609 3976 L.TFun (dom, ran) => unwind (ran, dom :: args)
adamc@314 3977 | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
adamc@609 3978 unwind (t, (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) :: args)
adamc@609 3979 | _ => (rev args, t)
adamc@120 3980
adamc@609 3981 val (ts, ran) = unwind (t, [])
adamc@609 3982 val ts = map (monoType env) ts
adamc@609 3983 val ran = monoType env ran
adamc@115 3984 in
adamc@1104 3985 SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran, b), loc)])
adamc@115 3986 end
adamc@707 3987 | L.DTable (x, n, (L.CRecord (_, xts), _), s, pe, _, ce, _) =>
adamc@251 3988 let
adamc@251 3989 val t = (L.CFfi ("Basis", "string"), loc)
adamc@251 3990 val t' = (L'.TFfi ("Basis", "string"), loc)
adamc@311 3991 val s = "uw_" ^ s
adamc@704 3992 val e_name = (L'.EPrim (Prim.String s), loc)
adamc@273 3993
adamc@273 3994 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
adamc@704 3995
adamc@707 3996 val (pe, fm) = monoExp (env, St.empty, fm) pe
adamc@707 3997 val (ce, fm) = monoExp (env, St.empty, fm) ce
adamc@251 3998 in
adamc@251 3999 SOME (Env.pushENamed env x n t NONE s,
adamc@251 4000 fm,
adamc@707 4001 [(L'.DTable (s, xts, pe, ce), loc),
adamc@704 4002 (L'.DVal (x, n, t', e_name, s), loc)])
adamc@251 4003 end
adamc@273 4004 | L.DTable _ => poly ()
adamc@754 4005 | L.DView (x, n, s, e, (L.CRecord (_, xts), _)) =>
adamc@754 4006 let
adamc@754 4007 val t = (L.CFfi ("Basis", "string"), loc)
adamc@754 4008 val t' = (L'.TFfi ("Basis", "string"), loc)
adamc@754 4009 val s = "uw_" ^ s
adamc@754 4010 val e_name = (L'.EPrim (Prim.String s), loc)
adamc@754 4011
adamc@754 4012 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
adamc@754 4013
adamc@754 4014 val (e, fm) = monoExp (env, St.empty, fm) e
adamc@754 4015 val e = (L'.EFfiApp ("Basis", "viewify", [e]), loc)
adamc@754 4016 in
adamc@754 4017 SOME (Env.pushENamed env x n t NONE s,
adamc@754 4018 fm,
adamc@754 4019 [(L'.DView (s, xts, e), loc),
adamc@754 4020 (L'.DVal (x, n, t', e_name, s), loc)])
adamc@754 4021 end
adamc@754 4022 | L.DView _ => poly ()
adamc@338 4023 | L.DSequence (x, n, s) =>
adamc@338 4024 let
adamc@338 4025 val t = (L.CFfi ("Basis", "string"), loc)
adamc@338 4026 val t' = (L'.TFfi ("Basis", "string"), loc)
adamc@338 4027 val s = "uw_" ^ s
adamc@338 4028 val e = (L'.EPrim (Prim.String s), loc)
adamc@338 4029 in
adamc@338 4030 SOME (Env.pushENamed env x n t NONE s,
adamc@338 4031 fm,
adamc@338 4032 [(L'.DSequence s, loc),
adamc@338 4033 (L'.DVal (x, n, t', e, s), loc)])
adamc@338 4034 end
adamc@683 4035 | L.DDatabase _ => NONE
adamc@462 4036 | L.DCookie (x, n, t, s) =>
adamc@462 4037 let
adamc@462 4038 val t = (L.CFfi ("Basis", "string"), loc)
adamc@462 4039 val t' = (L'.TFfi ("Basis", "string"), loc)
adamc@462 4040 val e = (L'.EPrim (Prim.String s), loc)
adamc@462 4041 in
adamc@462 4042 SOME (Env.pushENamed env x n t NONE s,
adamc@462 4043 fm,
adamc@725 4044 [(L'.DCookie s, loc),
adamc@725 4045 (L'.DVal (x, n, t', e, s), loc)])
adamc@462 4046 end
adamc@720 4047 | L.DStyle (x, n, s) =>
adamc@718 4048 let
adamc@718 4049 val t = (L.CFfi ("Basis", "string"), loc)
adamc@718 4050 val t' = (L'.TFfi ("Basis", "string"), loc)
adamc@718 4051 val e = (L'.EPrim (Prim.String s), loc)
adamc@718 4052 in
adamc@718 4053 SOME (Env.pushENamed env x n t NONE s,
adamc@718 4054 fm,
adamc@720 4055 [(L'.DStyle s, loc),
adamc@718 4056 (L'.DVal (x, n, t', e, s), loc)])
adamc@718 4057 end
adamc@1075 4058 | L.DTask (e1, e2) =>
adamc@1073 4059 let
adamc@1075 4060 val (e1, fm) = monoExp (env, St.empty, fm) e1
adamc@1075 4061 val (e2, fm) = monoExp (env, St.empty, fm) e2
adamc@1073 4062 in
adamc@1073 4063 SOME (env,
adamc@1073 4064 fm,
adamc@1075 4065 [(L'.DTask (e1, e2), loc)])
adamc@1073 4066 end
adamc@1199 4067 | L.DPolicy e =>
adamc@1199 4068 let
adamc@1240 4069 fun policies (e, fm) =
adamc@1199 4070 case #1 e of
adamc@1240 4071 L.EFfiApp ("Basis", "also", [e1, e2]) =>
adamc@1240 4072 let
adamc@1240 4073 val (ps1, fm) = policies (e1, fm)
adamc@1240 4074 val (ps2, fm) = policies (e2, fm)
adamc@1240 4075 in
adamc@1240 4076 (ps1 @ ps2, fm)
adamc@1240 4077 end
adamc@1240 4078 | _ =>
adamc@1240 4079 let
adamc@1240 4080 val (e, make) =
adamc@1240 4081 case #1 e of
adamc@1240 4082 L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sendClient"), _), _), _), _), _), e) =>
adamc@1240 4083 (e, L'.PolClient)
adamc@1240 4084 | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayInsert"), _), _), _), _), _), e) =>
adamc@1240 4085 (e, L'.PolInsert)
adamc@1240 4086 | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayDelete"), _), _), _), _), _), e) =>
adamc@1240 4087 (e, L'.PolDelete)
adamc@1240 4088 | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayUpdate"), _), _), _), _), _), e) =>
adamc@1240 4089 (e, L'.PolUpdate)
adamc@1240 4090 | L.EFfiApp ("Basis", "sendOwnIds", [e]) =>
adamc@1240 4091 (e, L'.PolSequence)
adamc@1240 4092 | _ => (poly (); (e, L'.PolClient))
adamc@1199 4093
adamc@1240 4094 val (e, fm) = monoExp (env, St.empty, fm) e
adamc@1240 4095 in
adamc@1240 4096 ([(L'.DPolicy (make e), loc)], fm)
adamc@1240 4097 end
adamc@1240 4098
adamc@1240 4099 val (ps, fm) = policies (e, fm)
adamc@1199 4100 in
adamc@1240 4101 SOME (env, fm, ps)
adamc@1199 4102 end
adam@1294 4103 | L.DOnError n => SOME (env,
adam@1294 4104 fm,
adam@1294 4105 [(L'.DOnError n, loc)])
adamc@25 4106 end
adamc@25 4107
adamc@683 4108 datatype expungable = Client | Channel
adamc@683 4109
adamc@683 4110 fun monoize env file =
adamc@25 4111 let
adam@1287 4112 val () = pvars := RM.empty
adam@1287 4113
adamc@735 4114 (* Calculate which exported functions need cookie signature protection *)
adamc@735 4115 val rcook = foldl (fn ((d, _), rcook) =>
adamc@735 4116 case d of
adamc@1104 4117 L.DExport (L.Action L.ReadCookieWrite, n, _) => IS.add (rcook, n)
adamc@1104 4118 | L.DExport (L.Rpc L.ReadCookieWrite, n, _) => IS.add (rcook, n)
adamc@735 4119 | _ => rcook)
adamc@735 4120 IS.empty file
adamc@735 4121 val () = readCookie := rcook
adamc@735 4122
adamc@683 4123 val loc = E.dummySpan
adamc@683 4124 val client = (L'.TFfi ("Basis", "client"), loc)
adamc@683 4125 val unit = (L'.TRecord [], loc)
adamc@687 4126
adamc@687 4127 fun calcClientish xts =
adamc@687 4128 foldl (fn ((x : L.con, t : L.con), st as (nullable, notNullable)) =>
adamc@687 4129 case #1 x of
adamc@687 4130 L.CName x =>
adamc@687 4131 (case #1 t of
adamc@687 4132 L.CFfi ("Basis", "client") =>
adamc@687 4133 (nullable, (x, Client) :: notNullable)
adamc@687 4134 | L.CApp ((L.CFfi ("Basis", "option"), _),
adamc@687 4135 (L.CFfi ("Basis", "client"), _)) =>
adamc@687 4136 ((x, Client) :: nullable, notNullable)
adamc@687 4137 | L.CApp ((L.CFfi ("Basis", "channel"), _), _) =>
adamc@687 4138 (nullable, (x, Channel) :: notNullable)
adamc@687 4139 | L.CApp ((L.CFfi ("Basis", "option"), _),
adamc@687 4140 (L.CApp ((L.CFfi ("Basis", "channel"), _), _), _)) =>
adamc@687 4141 ((x, Channel) :: nullable, notNullable)
adamc@687 4142 | _ => st)
adamc@687 4143 | _ => st) ([], []) xts
adamc@687 4144
adamc@683 4145 fun expunger () =
adamc@683 4146 let
adamc@683 4147 val target = (L'.EFfiApp ("Basis", "sqlifyClient", [(L'.ERel 0, loc)]), loc)
adamc@683 4148
adamc@683 4149 fun doTable (tab, xts, e) =
adamc@683 4150 case xts of
adamc@683 4151 L.CRecord (_, xts) =>
adamc@683 4152 let
adamc@687 4153 val (nullable, notNullable) = calcClientish xts
adamc@683 4154
adamc@684 4155 fun cond (x, v) =
adamc@684 4156 (L'.EStrcat ((L'.EPrim (Prim.String ("uw_" ^ x
adamc@684 4157 ^ (case v of
adamc@684 4158 Client => ""
adamc@684 4159 | Channel => " >> 32")
adamc@684 4160 ^ " = ")), loc),
adamc@684 4161 target), loc)
adamc@684 4162
adamc@684 4163 val e =
adamc@684 4164 foldl (fn ((x, v), e) =>
adamc@684 4165 (L'.ESeq (
adam@1293 4166 (L'.EDml ((L'.EStrcat (
adam@1293 4167 (L'.EPrim (Prim.String ("UPDATE uw_"
adam@1293 4168 ^ tab
adam@1293 4169 ^ " SET uw_"
adam@1293 4170 ^ x
adam@1293 4171 ^ " = NULL WHERE ")), loc),
adam@1293 4172 cond (x, v)), loc), L'.Error), loc),
adamc@684 4173 e), loc))
adamc@684 4174 e nullable
adamc@684 4175
adamc@683 4176 val e =
adamc@683 4177 case notNullable of
adamc@683 4178 [] => e
adamc@683 4179 | eb :: ebs =>
adamc@684 4180 (L'.ESeq (
adamc@684 4181 (L'.EDml (foldl
adamc@684 4182 (fn (eb, s) =>
adamc@684 4183 (L'.EStrcat (s,
adamc@687 4184 (L'.EStrcat ((L'.EPrim (Prim.String " OR "),
adamc@684 4185 loc),
adamc@684 4186 cond eb), loc)), loc))
adamc@684 4187 (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM uw_"
adamc@684 4188 ^ tab
adamc@684 4189 ^ " WHERE ")), loc),
adamc@684 4190 cond eb), loc)
adam@1293 4191 ebs, L'.Error), loc),
adamc@684 4192 e), loc)
adamc@683 4193 in
adamc@683 4194 e
adamc@683 4195 end
adamc@683 4196 | _ => e
adamc@683 4197
adamc@683 4198 val e = (L'.ERecord [], loc)
adamc@683 4199 in
adamc@683 4200 foldl (fn ((d, _), e) =>
adamc@683 4201 case d of
adamc@707 4202 L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e)
adamc@683 4203 | _ => e) e file
adamc@683 4204 end
adamc@683 4205
adamc@687 4206 fun initializer () =
adamc@687 4207 let
adamc@687 4208 fun doTable (tab, xts, e) =
adamc@687 4209 case xts of
adamc@687 4210 L.CRecord (_, xts) =>
adamc@687 4211 let
adamc@687 4212 val (nullable, notNullable) = calcClientish xts
adamc@687 4213
adamc@687 4214 val e =
adamc@687 4215 case nullable of
adamc@687 4216 [] => e
adamc@687 4217 | (x, _) :: ebs =>
adamc@687 4218 (L'.ESeq (
adam@1293 4219 (L'.EDml ((L'.EPrim (Prim.String
adam@1293 4220 (foldl (fn ((x, _), s) =>
adam@1293 4221 s ^ ", uw_" ^ x ^ " = NULL")
adam@1293 4222 ("UPDATE uw_"
adam@1293 4223 ^ tab
adam@1293 4224 ^ " SET uw_"
adam@1293 4225 ^ x
adam@1293 4226 ^ " = NULL")
adam@1293 4227 ebs)), loc), L'.Error), loc),
adamc@687 4228 e), loc)
adamc@687 4229
adamc@687 4230 val e =
adamc@687 4231 case notNullable of
adamc@687 4232 [] => e
adamc@687 4233 | eb :: ebs =>
adamc@687 4234 (L'.ESeq (
adam@1293 4235 (L'.EDml ((L'.EPrim (Prim.String ("DELETE FROM uw_"
adam@1293 4236 ^ tab)), loc), L'.Error), loc),
adamc@687 4237 e), loc)
adamc@687 4238 in
adamc@687 4239 e
adamc@687 4240 end
adamc@687 4241 | _ => e
adamc@687 4242
adamc@687 4243 val e = (L'.ERecord [], loc)
adamc@687 4244 in
adamc@687 4245 foldl (fn ((d, _), e) =>
adamc@687 4246 case d of
adamc@707 4247 L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e)
adamc@687 4248 | _ => e) e file
adamc@687 4249 end
adamc@687 4250
adam@1287 4251 val mname = CoreUtil.File.maxName file + 1
adam@1287 4252 val () = nextPvar := mname
adam@1287 4253
adamc@179 4254 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
adamc@683 4255 case #1 d of
adamc@683 4256 L.DDatabase s =>
adamc@683 4257 let
adamc@687 4258 val (nExp, fm) = Fm.freshName fm
adamc@687 4259 val (nIni, fm) = Fm.freshName fm
adamc@687 4260
adamc@687 4261 val dExp = L'.DVal ("expunger",
adamc@687 4262 nExp,
adamc@687 4263 (L'.TFun (client, unit), loc),
adamc@687 4264 (L'.EAbs ("cli", client, unit, expunger ()), loc),
adamc@687 4265 "expunger")
adamc@687 4266 val dIni = L'.DVal ("initializer",
adamc@687 4267 nIni,
adamc@687 4268 (L'.TFun (unit, unit), loc),
adamc@687 4269 (L'.EAbs ("_", unit, unit, initializer ()), loc),
adamc@687 4270 "initializer")
adamc@683 4271 in
adamc@687 4272 (env, Fm.enter fm, (L'.DDatabase {name = s,
adamc@687 4273 expunge = nExp,
adamc@687 4274 initialize = nIni}, loc)
adamc@687 4275 :: (dExp, loc)
adamc@687 4276 :: (dIni, loc)
adamc@683 4277 :: ds)
adamc@683 4278 end
adamc@683 4279 | _ =>
adam@1287 4280 (pvarDefs := [];
adam@1288 4281 pvarOldDefs := [];
adam@1287 4282 case monoDecl (env, fm) d of
adam@1287 4283 NONE => (env, fm, ds)
adam@1287 4284 | SOME (env, fm, ds') =>
adam@1288 4285 (foldr (fn ((n, cs), env) =>
adam@1288 4286 Env.declBinds env (L.DDatatype [("$poly" ^ Int.toString n,
adam@1288 4287 n,
adam@1288 4288 [],
adam@1288 4289 cs)], loc))
adam@1288 4290 env (!pvarOldDefs),
adam@1287 4291 Fm.enter fm,
adam@1287 4292 ds' @ Fm.decls fm @ !pvarDefs @ ds)))
adam@1287 4293 (env, Fm.empty mname, []) file
adamc@25 4294 in
adam@1287 4295 pvars := RM.empty;
adam@1287 4296 pvarDefs := [];
adam@1288 4297 pvarOldDefs := [];
adamc@25 4298 rev ds
adamc@25 4299 end
adamc@25 4300
adamc@25 4301 end