Mercurial > urweb

annotate src/monoize.sml @ 2191:849404a3af27

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