Mercurial > urweb

annotate src/monoize.sml @ 2057:f4a6ccb7937f

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