Mercurial > urweb

annotate src/monoize.sml @ 1659:8de2ea0a0701

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