Mercurial > urweb

annotate src/monoize.sml @ 2256:6f2ea4ed573a

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