Mercurial > urweb

annotate src/monoize.sml @ 1932:98895243b5b6

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