Mercurial > urweb

annotate src/monoize.sml @ 1836:276fa06428ba

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