Mercurial > urweb

annotate src/monoize.sml @ 1856:3683d1a8c1c8

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