Mercurial > urweb

annotate src/monoize.sml @ 1698:aaae710417df

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