Mercurial > urweb

annotate src/monoize.sml @ 2254:44ae2254f8fb

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