Mercurial > urweb

annotate src/monoize.sml @ 2160:72fe1cc704c5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Tag NULLs with their types in SQL, to help the DBMS do type inference
author Adam Chlipala <adam@chlipala.net>
date Sat, 04 Jul 2015 19:24:26 -0400
parents 5a010f408f36
children 849404a3af27 2b1af5dc6dee
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 _), _),
adamc@254 2595 _), _),
adamc@254 2596 _), _),
adamc@254 2597 _) =>
adamc@254 2598 let
adamc@254 2599 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@254 2600 in
adamc@254 2601 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adamc@254 2602 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
adamc@254 2603 (L'.EAbs ("e2", s, s,
adam@2048 2604 strcat [str "(",
adamc@598 2605 (L'.ERel 1, loc),
adam@2048 2606 str " ",
adamc@598 2607 (L'.ERel 2, loc),
adam@2048 2608 str " ",
adamc@598 2609 (L'.ERel 0, loc),
adam@2048 2610 str ")"]), loc)), loc)), loc),
adamc@254 2611 fm)
adamc@254 2612 end
adam@2048 2613 | L.EFfi ("Basis", "sql_and") => (str "AND", fm)
adam@2048 2614 | L.EFfi ("Basis", "sql_or") => (str "OR", fm)
adamc@254 2615
adamc@254 2616 | L.ECApp (
adamc@254 2617 (L.ECApp (
adamc@254 2618 (L.ECApp (
adamc@254 2619 (L.ECApp (
adamc@253 2620 (L.ECApp (
adamc@253 2621 (L.ECApp (
adamc@253 2622 (L.ECApp (
adam@1778 2623 (L.EFfi ("Basis", "sql_field"), _),
adamc@253 2624 _), _),
adamc@253 2625 _), _),
adamc@253 2626 _), _),
adamc@253 2627 _), _),
adamc@253 2628 _), _),
adamc@253 2629 (L.CName tab, _)), _),
adam@2048 2630 (L.CName field, _)) => (str ("T_" ^ tab ^ "." ^ Settings.mangleSql (lowercaseFirst field)), fm)
adamc@260 2631
adamc@260 2632 | L.ECApp (
adamc@260 2633 (L.ECApp (
adamc@260 2634 (L.ECApp (
adamc@260 2635 (L.ECApp (
adamc@261 2636 (L.ECApp (
adam@1778 2637 (L.EFfi ("Basis", "sql_exp"), _),
adamc@261 2638 _), _),
adamc@261 2639 _), _),
adamc@261 2640 _), _),
adamc@261 2641 _), _),
adam@2048 2642 (L.CName nm, _)) => (str (Settings.mangleSql (lowercaseFirst nm)), fm)
adamc@261 2643
adamc@261 2644 | L.ECApp (
adamc@261 2645 (L.ECApp (
adamc@261 2646 (L.ECApp (
adamc@261 2647 (L.ECApp (
adamc@1191 2648 (L.ECApp (
adam@1416 2649 (L.ECApp (
adam@1416 2650 (L.EFfi ("Basis", "sql_relop"), _),
adam@1416 2651 _), _),
adamc@1191 2652 _), _),
adamc@260 2653 _), _),
adamc@260 2654 _), _),
adamc@260 2655 _), _),
adamc@260 2656 _) =>
adamc@260 2657 let
adamc@260 2658 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@260 2659 in
adamc@1196 2660 (if #nestedRelops (Settings.currentDbms ()) then
adam@1427 2661 (L'.EAbs ("c", s, (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
adam@1427 2662 (L'.EAbs ("all", (L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adam@1427 2663 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
adam@1427 2664 (L'.EAbs ("e2", s, s,
adam@2048 2665 strcat [str "((",
adam@1427 2666 (L'.ERel 1, loc),
adam@2048 2667 str ") ",
adam@1427 2668 (L'.ERel 3, loc),
adam@1427 2669 (L'.ECase ((L'.ERel 2, loc),
adam@1427 2670 [((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis",
adam@1427 2671 datatyp = "bool",
adam@1427 2672 con = "True",
adam@1427 2673 arg = NONE}, NONE), loc),
adam@2048 2674 str " ALL"),
adam@1427 2675 ((L'.PWild, loc),
adam@2048 2676 str "")],
adam@1427 2677 {disc = (L'.TFfi ("Basis", "bool"), loc),
adam@1427 2678 result = s}), loc),
adam@2048 2679 str " (",
adam@1427 2680 (L'.ERel 0, loc),
adam@2048 2681 str "))"]), loc)), loc)), loc)), loc)
adamc@1196 2682 else
adam@1427 2683 (L'.EAbs ("c", s, (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
adam@1427 2684 (L'.EAbs ("all", (L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adam@1427 2685 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
adam@1427 2686 (L'.EAbs ("e2", s, s,
adam@1427 2687 strcat [(L'.ERel 1, loc),
adam@2048 2688 str " ",
adam@1427 2689 (L'.ERel 3, loc),
adam@1427 2690 (L'.ECase ((L'.ERel 2, loc),
adam@1427 2691 [((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis",
adam@1427 2692 datatyp = "bool",
adam@1427 2693 con = "True",
adam@1427 2694 arg = NONE}, NONE), loc),
adam@2048 2695 str " ALL"),
adam@1427 2696 ((L'.PWild, loc),
adam@2048 2697 str "")],
adam@1427 2698 {disc = (L'.TFfi ("Basis", "bool"), loc),
adam@1427 2699 result = s}), loc),
adam@2048 2700 str " ",
adam@1427 2701 (L'.ERel 0, loc)]), loc)), loc)), loc)), loc),
adamc@260 2702 fm)
adamc@260 2703 end
adamc@1071 2704 | L.ECApp (
adamc@1071 2705 (L.ECApp (
adamc@1071 2706 (L.ECApp (
adamc@1191 2707 (L.ECApp (
adam@1394 2708 (L.ECApp (
adam@1394 2709 (L.EFfi ("Basis", "sql_forget_tables"), _),
adam@1394 2710 _), _),
adamc@1191 2711 _), _),
adamc@1071 2712 _), _),
adamc@1071 2713 _), _),
adamc@1071 2714 _) =>
adamc@1071 2715 let
adamc@1071 2716 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@1071 2717 in
adamc@1071 2718 ((L'.EAbs ("x", s, s, (L'.ERel 0, loc)), loc),
adamc@1071 2719 fm)
adamc@1071 2720 end
adamc@260 2721
adam@2048 2722 | L.EFfi ("Basis", "sql_union") => (str "UNION", fm)
adamc@1196 2723 | L.EFfi ("Basis", "sql_intersect") =>
adamc@1196 2724 (if #onlyUnion (Settings.currentDbms ()) then
adamc@1196 2725 ErrorMsg.errorAt loc "The DBMS you've selected doesn't support INTERSECT."
adamc@1196 2726 else
adamc@1196 2727 ();
adam@2048 2728 (str "INTERSECT", fm))
adamc@1196 2729 | L.EFfi ("Basis", "sql_except") =>
adamc@1196 2730 (if #onlyUnion (Settings.currentDbms ()) then
adamc@1196 2731 ErrorMsg.errorAt loc "The DBMS you've selected doesn't support EXCEPT."
adamc@1196 2732 else
adamc@1196 2733 ();
adam@2048 2734 (str "EXCEPT", fm))
adamc@260 2735
adamc@265 2736 | L.ECApp (
adamc@265 2737 (L.ECApp (
adamc@265 2738 (L.ECApp (
adam@1778 2739 (L.EFfi ("Basis", "sql_count"), _),
adamc@265 2740 _), _),
adamc@265 2741 _), _),
adam@2048 2742 _) => (str "COUNT(*)", fm)
adamc@266 2743
adamc@266 2744 | L.ECApp (
adamc@266 2745 (L.ECApp (
adamc@266 2746 (L.ECApp (
adamc@266 2747 (L.ECApp (
adamc@1187 2748 (L.ECApp (
adam@1778 2749 (L.EFfi ("Basis", "sql_aggregate"), _),
adamc@1187 2750 _), _),
adamc@266 2751 _), _),
adamc@266 2752 _), _),
adamc@266 2753 _), _),
adamc@1168 2754 t) =>
adamc@266 2755 let
adamc@266 2756 val s = (L'.TFfi ("Basis", "string"), loc)
adam@1357 2757
adam@1357 2758 val main = strcat [(L'.ERel 1, loc),
adam@2048 2759 str "(",
adam@1357 2760 (L'.ERel 0, loc),
adam@2048 2761 str ")"]
adamc@266 2762 in
adamc@266 2763 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adam@1778 2764 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), main), loc)), loc),
adamc@266 2765 fm)
adamc@266 2766 end
adamc@266 2767
adamc@1187 2768 | L.ECApp ((L.EFfi ("Basis", "sql_count_col"), _), _) =>
adam@2048 2769 (str "COUNT", fm)
adamc@1187 2770
adamc@266 2771 | L.EFfi ("Basis", "sql_summable_int") => ((L'.ERecord [], loc), fm)
adamc@266 2772 | L.EFfi ("Basis", "sql_summable_float") => ((L'.ERecord [], loc), fm)
adam@1357 2773 | L.ECApp ((L.EFfi ("Basis", "sql_summable_option"), _), _) =>
adam@1357 2774 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
adam@1357 2775 (L'.ERecord [], loc)), loc),
adam@1357 2776 fm)
adam@1777 2777 | L.ECApp ((L.EFfi ("Basis", "sql_avg"), _), _) =>
adam@1777 2778 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adam@2048 2779 str "AVG"), loc),
adamc@266 2780 fm)
adam@1394 2781 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_sum"), _), _), _), _) =>
adam@1394 2782 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc),
adam@1394 2783 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adam@2048 2784 str "SUM"), loc)), loc),
adamc@266 2785 fm)
adamc@266 2786
adamc@559 2787 | L.EFfi ("Basis", "sql_arith_int") => ((L'.ERecord [], loc), fm)
adamc@559 2788 | L.EFfi ("Basis", "sql_arith_float") => ((L'.ERecord [], loc), fm)
adam@1427 2789 | L.ECApp ((L.EFfi ("Basis", "sql_arith_option"), _), _) =>
adam@1427 2790 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
adam@1427 2791 (L'.ERecord [], loc)), loc),
adam@1427 2792 fm)
adamc@559 2793
adamc@266 2794 | L.EFfi ("Basis", "sql_maxable_int") => ((L'.ERecord [], loc), fm)
adamc@266 2795 | L.EFfi ("Basis", "sql_maxable_float") => ((L'.ERecord [], loc), fm)
adamc@266 2796 | L.EFfi ("Basis", "sql_maxable_string") => ((L'.ERecord [], loc), fm)
adam@1357 2797 | L.ECApp ((L.EFfi ("Basis", "sql_maxable_option"), _), _) =>
adam@1357 2798 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
adam@1357 2799 (L'.ERecord [], loc)), loc),
adam@1357 2800 fm)
adam@1394 2801 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_max"), _), _), _), _) =>
adam@1394 2802 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc),
adam@1394 2803 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adam@2048 2804 str "MAX"), loc)), loc),
adamc@266 2805 fm)
adam@1394 2806 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_min"), _), _), _), _) =>
adam@1394 2807 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc),
adam@1394 2808 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
adam@2048 2809 str "MIN"), loc)), loc),
adamc@266 2810 fm)
adamc@266 2811
adam@2048 2812 | L.EFfi ("Basis", "sql_asc") => (str "", fm)
adam@2048 2813 | L.EFfi ("Basis", "sql_desc") => (str " DESC", fm)
adam@1777 2814 | L.ECApp (
adam@1777 2815 (L.ECApp (
adam@1777 2816 (L.ECApp (
adam@1777 2817 (L.ECApp (
adam@1778 2818 (L.EFfi ("Basis", "sql_nfunc"), _),
adam@1778 2819 _), _),
adam@1778 2820 _), _),
adam@1778 2821 _), _),
adam@1778 2822 _) =>
adam@1778 2823 let
adam@1778 2824 val s = (L'.TFfi ("Basis", "string"), loc)
adam@1778 2825 in
adam@1778 2826 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc),
adam@1778 2827 fm)
adam@1778 2828 end
adam@1778 2829
adam@1778 2830 | L.EFfi ("Basis", "sql_window_normal") => ((L'.ERecord [], loc), fm)
adam@1778 2831 | L.EFfi ("Basis", "sql_window_fancy") => ((L'.ERecord [], loc), fm)
adam@1778 2832 | L.ECApp (
adam@1778 2833 (L.ECApp (
adam@1778 2834 (L.ECApp (
adam@1778 2835 (L.ECApp (
adam@1778 2836 (L.ECApp (
adam@1778 2837 (L.EFfi ("Basis", "sql_window"), _),
adam@1778 2838 _), _),
adam@1777 2839 _), _),
adam@1777 2840 _), _),
adam@1777 2841 _), _),
adam@1777 2842 _) =>
adam@1777 2843 let
adam@1777 2844 val s = (L'.TFfi ("Basis", "string"), loc)
adam@1777 2845 in
adam@1778 2846 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, s), loc),
adam@1778 2847 (L'.EAbs ("e", s, s,
adam@1778 2848 (L'.ERel 0, loc)), loc)), loc),
adam@1777 2849 fm)
adam@1777 2850 end
adam@1777 2851
adam@2048 2852 | L.EFfi ("Basis", "sql_current_timestamp") => (str "CURRENT_TIMESTAMP", fm)
adam@1776 2853
adam@1776 2854 | L.ECApp (
adam@1776 2855 (L.ECApp (
adam@1776 2856 (L.ECApp (
adam@1776 2857 (L.ECApp (
adam@1776 2858 (L.ECApp (
adam@1778 2859 (L.EFfi ("Basis", "sql_ufunc"), _),
adamc@746 2860 _), _),
adamc@746 2861 _), _),
adamc@746 2862 _), _),
adamc@746 2863 _), _),
adamc@746 2864 _) =>
adamc@746 2865 let
adamc@746 2866 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@746 2867 in
adamc@746 2868 ((L'.EAbs ("f", s, (L'.TFun (s, s), loc),
adamc@746 2869 (L'.EAbs ("x", s, s,
adamc@746 2870 strcat [(L'.ERel 1, loc),
adam@2048 2871 str "(",
adamc@746 2872 (L'.ERel 0, loc),
adam@2048 2873 str ")"]), loc)), loc),
adamc@746 2874 fm)
adamc@746 2875 end
adamc@890 2876 | L.EFfi ("Basis", "sql_octet_length") =>
adam@2048 2877 (str (if #supportsOctetLength (Settings.currentDbms ()) then
adam@2048 2878 "octet_length"
adam@2048 2879 else
adam@2048 2880 "length"), fm)
adam@1636 2881 | L.EFfi ("Basis", "sql_lower") =>
adam@2048 2882 (str "lower", fm)
adam@1636 2883 | L.EFfi ("Basis", "sql_upper") =>
adam@2048 2884 (str "upper", fm)
adamc@1207 2885 | L.ECApp ((L.EFfi ("Basis", "sql_known"), _), _) =>
adamc@1207 2886 ((L'.EFfi ("Basis", "sql_known"), loc), fm)
adamc@746 2887
adamc@470 2888 | (L.ECApp (
adamc@470 2889 (L.ECApp (
adamc@470 2890 (L.ECApp (
adamc@470 2891 (L.ECApp (
adam@1778 2892 (L.EFfi ("Basis", "sql_is_null"), _), _),
adamc@470 2893 _), _),
adamc@470 2894 _), _),
adamc@470 2895 _), _)) =>
adamc@470 2896 let
adamc@470 2897 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@470 2898 in
adamc@470 2899 ((L'.EAbs ("s", s, s,
adam@2048 2900 strcat [str "(",
adamc@598 2901 (L'.ERel 0, loc),
adam@2048 2902 str " IS NULL)"]), loc),
adamc@470 2903 fm)
adamc@470 2904 end
adamc@470 2905
kkallio@1572 2906 | (L.ECApp (
kkallio@1572 2907 (L.ECApp (
kkallio@1572 2908 (L.ECApp (
kkallio@1572 2909 (L.ECApp (
adam@1602 2910 (L.EFfi ("Basis", "sql_coalesce"), _), _),
adam@1602 2911 _), _),
adam@1602 2912 _), _),
adam@1602 2913 _), _)) =>
adam@1602 2914 let
adam@1602 2915 val s = (L'.TFfi ("Basis", "string"), loc)
adam@1602 2916 in
adam@1602 2917 ((L'.EAbs ("x1", s, (L'.TFun (s, s), loc),
adam@1602 2918 (L'.EAbs ("x1", s, s,
adam@2048 2919 strcat [str "COALESCE(",
adam@1602 2920 (L'.ERel 1, loc),
adam@2048 2921 str ",",
adam@1602 2922 (L'.ERel 0, loc),
adam@2048 2923 str ")"]), loc)), loc),
adam@1602 2924 fm)
adam@1602 2925 end
adam@1602 2926
adam@1602 2927 | (L.ECApp (
adam@1602 2928 (L.ECApp (
adam@1602 2929 (L.ECApp (
adam@1602 2930 (L.ECApp (
adam@1778 2931 (L.EFfi ("Basis", "sql_if_then_else"), _), _),
kkallio@1572 2932 _), _),
kkallio@1572 2933 _), _),
kkallio@1572 2934 _), _)) =>
kkallio@1572 2935 let
kkallio@1572 2936 val s = (L'.TFfi ("Basis", "string"), loc)
kkallio@1572 2937 in
adam@1573 2938 ((L'.EAbs ("if", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
kkallio@1572 2939 (L'.EAbs ("then", s, (L'.TFun (s, s), loc),
adam@1573 2940 (L'.EAbs ("else", s, s,
adam@2048 2941 strcat [str "(CASE WHEN (",
kkallio@1572 2942 (L'.ERel 2, loc),
adam@2048 2943 str ") THEN (",
kkallio@1572 2944 (L'.ERel 1, loc),
adam@2048 2945 str ") ELSE (",
kkallio@1572 2946 (L'.ERel 0, loc),
adam@2048 2947 str ") END)"]), loc)), loc)), loc),
kkallio@1572 2948 fm)
kkallio@1572 2949 end
kkallio@1572 2950
adamc@1081 2951 | L.ECApp (
adamc@1081 2952 (L.ECApp (
adamc@1081 2953 (L.ECApp (
adamc@1081 2954 (L.ECApp (
adam@1778 2955 (L.EFfi ("Basis", "sql_nullable"), _),
adamc@1081 2956 _), _),
adamc@1081 2957 _), _),
adamc@1081 2958 _), _),
adamc@1081 2959 _) =>
adamc@1081 2960 let
adamc@1081 2961 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@1081 2962 in
adamc@1081 2963 ((L'.EAbs ("u", (L'.TRecord [], loc), (L'.TFun (s, s), loc),
adamc@1081 2964 (L'.EAbs ("x", s, s,
adamc@1081 2965 (L'.ERel 0, loc)), loc)), loc),
adamc@1081 2966 fm)
adamc@1081 2967 end
adam@1682 2968
adamc@1191 2969 | L.ECApp (
adamc@1191 2970 (L.ECApp (
adamc@1191 2971 (L.ECApp (
adamc@1191 2972 (L.ECApp (
adamc@1191 2973 (L.ECApp (
adam@1421 2974 (L.ECApp (
adam@1778 2975 (L.EFfi ("Basis", "sql_subquery"), _),
adam@1421 2976 _), _),
adamc@1191 2977 _), _),
adamc@1191 2978 _), _),
adamc@1191 2979 _), _),
adamc@1191 2980 _), _),
adamc@1191 2981 _) =>
adamc@1191 2982 let
adamc@1191 2983 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@1191 2984 in
adam@1421 2985 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, s), loc),
adam@1421 2986 (L'.EAbs ("x", s, s,
adam@2048 2987 strcat [str "(",
adam@1421 2988 (L'.ERel 0, loc),
adam@2048 2989 str ")"]), loc)), loc),
adamc@1191 2990 fm)
adamc@1191 2991 end
adamc@1081 2992
adam@1778 2993 | L.ECApp (
adam@1778 2994 (L.ECApp (
adam@1778 2995 (L.ECApp (
adam@1778 2996 (L.EFfi ("Basis", "sql_no_partition"), _),
adam@1778 2997 _), _),
adam@1778 2998 _), _),
adam@2048 2999 _) => (str "", fm)
adam@1778 3000 | L.ECApp (
adam@1778 3001 (L.ECApp (
adam@1778 3002 (L.ECApp (
adam@1778 3003 (L.ECApp (
adam@1778 3004 (L.EFfi ("Basis", "sql_partition"), _),
adam@1778 3005 _), _),
adam@1778 3006 _), _),
adam@1778 3007 _), _),
adam@1778 3008 _) =>
adam@1778 3009 let
adam@1778 3010 val s = (L'.TFfi ("Basis", "string"), loc)
adam@1778 3011 in
adam@2048 3012 ((L'.EAbs ("e", s, s, strcat [str "PARTITION BY ", (L'.ERel 0, loc)]), loc),
adam@1778 3013 fm)
adam@1778 3014 end
adam@1778 3015
adam@1778 3016 | L.ECApp (
adam@1778 3017 (L.ECApp (
adam@1778 3018 (L.ECApp (
adam@1778 3019 (L.ECApp (
adam@1778 3020 (L.EFfi ("Basis", "sql_window_function"), _),
adam@1778 3021 _), _),
adam@1778 3022 _), _),
adam@1778 3023 _), _),
adam@1778 3024 _) =>
adam@1778 3025 let
adam@1778 3026 val () = if #windowFunctions (Settings.currentDbms ()) then
adam@1778 3027 ()
adam@1778 3028 else
adam@1778 3029 ErrorMsg.errorAt loc "The DBMS you've selected doesn't support window functions."
adam@1778 3030
adam@1778 3031 val s = (L'.TFfi ("Basis", "string"), loc)
adam@1778 3032
adam@1778 3033 val main = strcat [(L'.ERel 2, loc),
adam@2048 3034 str " OVER (",
adam@1778 3035 (L'.ERel 1, loc),
adam@1778 3036 (L'.ECase ((L'.ERel 0, loc),
adam@2048 3037 [((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
adam@2048 3038 str ""),
adam@1778 3039 ((L'.PWild, loc),
adam@2048 3040 strcat [str " ORDER BY ",
adam@1778 3041 (L'.ERel 0, loc)])],
adam@1778 3042 {disc = s,
adam@1778 3043 result = s}), loc),
adam@2048 3044 str ")"]
adam@1778 3045 in
adam@1778 3046 ((L'.EAbs ("w", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adam@1778 3047 (L'.EAbs ("p", s, (L'.TFun (s, s), loc),
adam@1778 3048 (L'.EAbs ("o", s, s,
adam@1778 3049 main), loc)), loc)), loc),
adam@1778 3050 fm)
adam@1778 3051 end
adam@1778 3052
adam@1778 3053 | L.ECApp (
adam@1778 3054 (L.ECApp (
adam@1778 3055 (L.ECApp (
adam@1778 3056 (L.ECApp (
adam@1778 3057 (L.ECApp (
adam@1778 3058 (L.EFfi ("Basis", "sql_window_aggregate"), _),
adam@1778 3059 _), _),
adam@1778 3060 _), _),
adam@1778 3061 _), _),
adam@1778 3062 _), _),
adam@1778 3063 _) =>
adam@1778 3064 let
adam@1778 3065 val s = (L'.TFfi ("Basis", "string"), loc)
adam@1778 3066
adam@1778 3067 val main = strcat [(L'.ERel 1, loc),
adam@2048 3068 str "(",
adam@1778 3069 (L'.ERel 0, loc),
adam@2048 3070 str ")"]
adam@1778 3071 in
adam@1778 3072 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
adam@1778 3073 (L'.EAbs ("e1", s, s, main), loc)), loc),
adam@1778 3074 fm)
adam@1778 3075 end
adam@1778 3076
adam@1778 3077 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_window_count"), _), _), _), _), _), _) =>
adam@2048 3078 (str "COUNT(*)", fm)
adam@1778 3079 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_rank"), _), _), _), _), _), _) =>
adam@2048 3080 (str "RANK()", fm)
adam@1778 3081
adam@1663 3082 | L.EFfiApp ("Basis", "nextval", [(e, _)]) =>
adamc@338 3083 let
adamc@338 3084 val (e, fm) = monoExp (env, st, fm) e
adamc@338 3085 in
adamc@465 3086 ((L'.ENextval e, loc), fm)
adamc@338 3087 end
adam@1663 3088 | L.EFfiApp ("Basis", "setval", [(e1, _), (e2, _)]) =>
adamc@1073 3089 let
adamc@1073 3090 val (e1, fm) = monoExp (env, st, fm) e1
adamc@1073 3091 val (e2, fm) = monoExp (env, st, fm) e2
adamc@1073 3092 in
adamc@1073 3093 ((L'.ESetval (e1, e2), loc), fm)
adamc@1073 3094 end
adamc@338 3095
adam@2048 3096 | L.EFfi ("Basis", "null") => (str "", fm)
adam@1567 3097
adam@1663 3098 | L.EFfiApp ("Basis", "classes", [(s1, _), (s2, _)]) =>
adam@1292 3099 let
adam@1292 3100 val (s1, fm) = monoExp (env, st, fm) s1
adam@1292 3101 val (s2, fm) = monoExp (env, st, fm) s2
adam@1292 3102 in
adam@2048 3103 ((L'.EStrcat (s1, (L'.EStrcat (str " ", s2), loc)), loc),
adam@1292 3104 fm)
adam@1292 3105 end
adam@1292 3106
adam@2048 3107 | L.EFfi ("Basis", "data_kind") => (str "data-", fm)
adam@2048 3108 | L.EFfi ("Basis", "aria_kind") => (str "aria-", fm)
adam@2047 3109
adam@2047 3110 | L.EFfiApp ("Basis", "data_attr", [(sk, _), (s1, _), (s2, _)]) =>
adam@2008 3111 let
adam@2047 3112 val (sk, fm) = monoExp (env, st, fm) sk
adam@2008 3113 val (s1, fm) = monoExp (env, st, fm) s1
adam@2008 3114 val (s2, fm) = monoExp (env, st, fm) s2
adam@2008 3115 in
adam@2047 3116 ((L'.EStrcat (sk,
adam@2008 3117 (L'.EStrcat ((L'.EFfiApp ("Basis", "blessData", [(s1, (L'.TFfi ("Basis", "string"), loc))]), loc),
adam@2048 3118 (L'.EStrcat (str "=\"",
adam@2008 3119 (L'.EStrcat ((L'.EFfiApp ("Basis", "attrifyString", [(s2, (L'.TFfi ("Basis", "string"), loc))]), loc),
adam@2048 3120 str "\""), loc)),
adam@2008 3121 loc)), loc)), loc),
adam@2008 3122 fm)
adam@2008 3123 end
adam@2008 3124
adam@2008 3125 | L.EFfiApp ("Basis", "data_attrs", [(s1, _), (s2, _)]) =>
adam@2008 3126 let
adam@2008 3127 val (s1, fm) = monoExp (env, st, fm) s1
adam@2008 3128 val (s2, fm) = monoExp (env, st, fm) s2
adam@2008 3129 in
adam@2048 3130 ((L'.EStrcat (s1, (L'.EStrcat (str " ", s2), loc)), loc),
adam@2008 3131 fm)
adam@2008 3132 end
adam@2008 3133
adam@1750 3134 | L.EFfiApp ("Basis", "css_url", [(s, _)]) =>
adam@1750 3135 let
adam@1750 3136 val (s, fm) = monoExp (env, st, fm) s
adam@1750 3137 in
adam@2048 3138 ((L'.EStrcat (str "url(",
adam@1750 3139 (L'.EStrcat ((L'.EFfiApp ("Basis", "css_url", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc),
adam@2048 3140 str ")"), loc)), loc),
adam@1750 3141 fm)
adam@1750 3142 end
adam@1750 3143
adam@1750 3144 | L.EFfiApp ("Basis", "property", [(s, _)]) =>
adam@1750 3145 let
adam@1750 3146 val (s, fm) = monoExp (env, st, fm) s
adam@1750 3147 in
adam@1750 3148 ((L'.EStrcat ((L'.EFfiApp ("Basis", "property", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc),
adam@2048 3149 str ":"), loc),
adam@1750 3150 fm)
adam@1750 3151 end
adam@1750 3152 | L.EFfiApp ("Basis", "value", [(s1, _), (s2, _)]) =>
adam@1750 3153 let
adam@1750 3154 val (s1, fm) = monoExp (env, st, fm) s1
adam@1750 3155 val (s2, fm) = monoExp (env, st, fm) s2
adam@1750 3156 in
adam@2048 3157 ((L'.EStrcat (s1, (L'.EStrcat (str " ", s2), loc)), loc),
adam@1750 3158 fm)
adam@1750 3159 end
adam@1750 3160
adam@2048 3161 | L.EFfi ("Basis", "noStyle") => (str "", fm)
adam@1750 3162 | L.EFfiApp ("Basis", "oneProperty", [(s1, _), (s2, _)]) =>
adam@1750 3163 let
adam@1750 3164 val (s1, fm) = monoExp (env, st, fm) s1
adam@1750 3165 val (s2, fm) = monoExp (env, st, fm) s2
adam@1750 3166 in
adam@2048 3167 ((L'.EStrcat (s1, (L'.EStrcat (s2, str ";"), loc)), loc),
adam@1750 3168 fm)
adam@1750 3169 end
adam@1750 3170
adamc@139 3171 | L.EApp (
adamc@139 3172 (L.ECApp (
adamc@720 3173 (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _),
adamc@139 3174 _), _),
adamc@179 3175 se) =>
adamc@179 3176 let
adamc@179 3177 val (se, fm) = monoExp (env, st, fm) se
adamc@179 3178 in
adam@1663 3179 ((L'.EFfiApp ("Basis", "htmlifyString", [(se, (L'.TFfi ("Basis", "string"), loc))]), loc), fm)
adamc@179 3180 end
adam@1358 3181 | L.ECApp (
adam@1358 3182 (L.ECApp ((L.EFfi ("Basis", "cdataChar"), _), _), _),
adam@1358 3183 _) =>
adam@1358 3184 ((L'.EAbs ("ch", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "string"), loc),
adam@1663 3185 (L'.EFfiApp ("Basis", "htmlifySpecialChar", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "char"), loc))]), loc)), loc), fm)
adamc@179 3186
adamc@95 3187 | L.EApp (
adamc@95 3188 (L.EApp (
adamc@720 3189 (L.ECApp (
adamc@720 3190 (L.ECApp (
adamc@95 3191 (L.ECApp (
adamc@139 3192 (L.ECApp (
adamc@720 3193 (L.EFfi ("Basis", "join"),
adamc@720 3194 _), _), _),
adamc@139 3195 _), _),
adamc@720 3196 _), _),
adamc@720 3197 _), _),
adamc@720 3198 xml1), _),
adamc@720 3199 xml2) =>
adamc@179 3200 let
adamc@179 3201 val (xml1, fm) = monoExp (env, st, fm) xml1
adamc@179 3202 val (xml2, fm) = monoExp (env, st, fm) xml2
adamc@179 3203 in
adamc@179 3204 ((L'.EStrcat (xml1, xml2), loc), fm)
adamc@179 3205 end
adamc@95 3206
adamc@95 3207 | L.EApp (
adamc@95 3208 (L.EApp (
adamc@104 3209 (L.EApp (
adamc@721 3210 (L.EApp (
adam@1643 3211 (L.EApp (
adam@1750 3212 (L.EApp (
adam@1751 3213 (L.EApp (
adam@1751 3214 (L.ECApp (
adamc@139 3215 (L.ECApp (
adamc@139 3216 (L.ECApp (
adamc@139 3217 (L.ECApp (
adamc@721 3218 (L.ECApp (
adam@1643 3219 (L.ECApp (
adam@1750 3220 (L.ECApp (
adam@1751 3221 (L.ECApp (
adam@1751 3222 (L.EFfi ("Basis", "tag"),
adam@2012 3223 _), (L.CRecord (_, attrsGiven), _)), _), _), _), ctxOuter), _), _), _), _), _), _), _), _), _), _), _),
adam@1751 3224 class), _),
adam@1751 3225 dynClass), _),
adam@1751 3226 style), _),
adam@1751 3227 dynStyle), _),
adamc@720 3228 attrs), _),
adamc@720 3229 tag), _),
adamc@95 3230 xml) =>
adamc@95 3231 let
adamc@140 3232 fun getTag' (e, _) =
adamc@140 3233 case e of
adam@1833 3234 L.EFfi (_, tag) => (tag, [])
adamc@143 3235 | L.ECApp (e, t) => let
adamc@143 3236 val (tag, ts) = getTag' e
adamc@143 3237 in
adamc@143 3238 (tag, ts @ [t])
adamc@143 3239 end
adamc@140 3240 | _ => (E.errorAt loc "Non-constant XML tag";
adamc@140 3241 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
adamc@143 3242 ("", []))
adamc@140 3243
adamc@95 3244 fun getTag (e, _) =
adamc@95 3245 case e of
adam@1833 3246 L.EFfiApp (_, tag, [((L.ERecord [], _), _)]) => (tag, [])
adamc@140 3247 | L.EApp (e, (L.ERecord [], _)) => getTag' e
adamc@95 3248 | _ => (E.errorAt loc "Non-constant XML tag";
adamc@95 3249 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
adamc@143 3250 ("", []))
adamc@95 3251
adamc@143 3252 val (tag, targs) = getTag tag
adamc@95 3253
adamc@179 3254 val (attrs, fm) = monoExp (env, st, fm) attrs
adamc@598 3255 val attrs = case #1 attrs of
adamc@598 3256 L'.ERecord xes => xes
adamc@1272 3257 | _ => map (fn ((L.CName x, _), t) => (x, (L'.EField (attrs, x), loc), monoType env t)
adamc@1272 3258 | (c, t) => (E.errorAt loc "Non-constant field name for HTML tag attribute";
adamc@1272 3259 Print.eprefaces' [("Name", CorePrint.p_con env c)];
adamc@1272 3260 ("", (L'.EField (attrs, ""), loc), monoType env t))) attrsGiven
adamc@104 3261
adamc@717 3262 val attrs =
adamc@717 3263 if List.exists (fn ("Link", _, _) => true
adamc@717 3264 | _ => false) attrs then
adamc@717 3265 List.filter (fn ("Href", _, _) => false
adamc@717 3266 | _ => true) attrs
adamc@717 3267 else
adamc@717 3268 attrs
adamc@717 3269
adamc@1042 3270 fun findOnload (attrs, onload, onunload, acc) =
adamc@668 3271 case attrs of
adamc@1042 3272 [] => (onload, onunload, acc)
adamc@1042 3273 | ("Onload", e, _) :: rest => findOnload (rest, SOME e, onunload, acc)
adamc@1042 3274 | ("Onunload", e, _) :: rest => findOnload (rest, onload, SOME e, acc)
adamc@1042 3275 | x :: rest => findOnload (rest, onload, onunload, x :: acc)
adam@1682 3276
vshabanoff@1711 3277 val (onload, onunload, attrs) =
vshabanoff@1711 3278 if tag = "body" then
vshabanoff@1711 3279 findOnload (attrs, NONE, NONE, [])
vshabanoff@1711 3280 else
vshabanoff@1711 3281 (NONE, NONE, attrs)
adamc@668 3282
adam@2121 3283 val (class, fm) = monoExp (env, st, fm) class
adam@2121 3284 val (dynClass, fm) = monoExp (env, st, fm) dynClass
adam@2121 3285 val (style, fm) = monoExp (env, st, fm) style
adam@2121 3286 val (dynStyle, fm) = monoExp (env, st, fm) dynStyle
adam@2121 3287
adam@2026 3288 (* Special case for <button value=""> *)
adam@2026 3289 val (attrs, extraString) = case tag of
adam@2026 3290 "button" =>
adam@2026 3291 (case List.partition (fn (x, _, _) => x = "Value") attrs of
adam@2026 3292 ([(_, value, _)], rest) =>
adam@2026 3293 (rest, SOME value)
adam@2026 3294 | _ => (attrs, NONE))
adam@2121 3295 | "body" =>
adam@2121 3296 (attrs,
adam@2121 3297 if (case (#1 dynClass, #1 dynStyle) of
adam@2121 3298 (L'.ESome _, _) => true
adam@2121 3299 | (_, L'.ESome _) => true
adam@2121 3300 | _ => false) then
adam@2121 3301 let
adam@2121 3302 fun jsify (e : L'.exp) =
adam@2121 3303 case #1 e of
adam@2121 3304 L'.ESome (_, ds) => strcat [str "execD(",
adam@2121 3305 (L'.EJavaScript (L'.Script, ds), loc),
adam@2121 3306 str ")"]
adam@2121 3307 | _ => str "null"
adam@2121 3308 in
adam@2121 3309 SOME (strcat [str "<script type=\"text/javascript\">bodyDynClass(",
adam@2121 3310 jsify dynClass,
adam@2121 3311 str ",",
adam@2121 3312 jsify dynStyle,
adam@2121 3313 str ")</script>"])
adam@2121 3314 end
adam@2121 3315 else
adam@2121 3316 NONE)
adam@2026 3317 | _ => (attrs, NONE)
ziv@2055 3318
adam@2026 3319
adam@2079 3320 val dynamics = ["dyn", "ctextbox", "cpassword", "ccheckbox", "cselect", "coption", "ctextarea", "active", "script", "cemail", "csearch", "curl", "ctel", "ccolor"]
adam@1651 3321
adam@1751 3322 fun isSome (e, _) =
adam@1751 3323 case e of
adam@1751 3324 L'.ESome _ => true
adam@1751 3325 | _ => false
adam@1751 3326
adam@1751 3327 val () = if isSome dynClass orelse isSome dynStyle then
adam@1751 3328 if List.exists (fn x => x = tag) dynamics then
adam@1751 3329 E.errorAt loc ("Dynamic tag <" ^ tag ^ "> cannot be combined with 'dynClass' or 'dynStyle' attribute; an additional <span> may be useful")
adam@1751 3330 else
adam@1751 3331 ()
adam@1751 3332 else
adam@1751 3333 ()
adam@1651 3334
adam@1479 3335 fun tagStart tag' =
adamc@598 3336 let
adamc@721 3337 val t = (L'.TFfi ("Basis", "string"), loc)
adam@2048 3338 val s = strH (String.concat ["<", tag'])
adamc@721 3339
adam@1817 3340 val s = (L'.EStrcat (s,
adam@1817 3341 (L'.ECase (class,
adam@2048 3342 [((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
adam@2048 3343 strH ""),
adam@1817 3344 ((L'.PVar ("x", t), loc),
adam@2048 3345 (L'.EStrcat (strH " class=\"",
adam@1817 3346 (L'.EStrcat ((L'.ERel 0, loc),
adam@2048 3347 strH "\""),
adam@1817 3348 loc)), loc))],
adam@1817 3349 {disc = t,
adam@1817 3350 result = t}), loc)), loc)
adam@1817 3351
adam@1817 3352 val s = (L'.EStrcat (s,
adam@1817 3353 (L'.ECase (style,
adam@2048 3354 [((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
adam@2048 3355 strH ""),
adam@1817 3356 ((L'.PVar ("x", t), loc),
adam@2048 3357 (L'.EStrcat (strH " style=\"",
adam@1817 3358 (L'.EStrcat ((L'.ERel 0, loc),
adam@2048 3359 strH "\""),
adam@1817 3360 loc)), loc))],
adam@1817 3361 {disc = t,
adam@1817 3362 result = t}), loc)), loc)
adam@1750 3363
adam@1479 3364 val (s, fm) = foldl (fn (("Action", _, _), acc) => acc
adam@1479 3365 | (("Source", _, _), acc) => acc
adam@2008 3366 | (("Data", e, _), (s, fm)) =>
adam@2008 3367 ((L'.EStrcat (s,
adam@2008 3368 (L'.EStrcat (
adam@2048 3369 strH " ",
adam@2008 3370 e), loc)), loc),
adam@2008 3371 fm)
adam@1479 3372 | ((x, e, t), (s, fm)) =>
adam@1479 3373 case t of
adam@1479 3374 (L'.TFfi ("Basis", "bool"), _) =>
adam@1479 3375 let
adam@1479 3376 val s' = " " ^ lowercaseFirst x
adam@1479 3377 in
adam@1479 3378 ((L'.ECase (e,
adam@1479 3379 [((L'.PCon (L'.Enum,
adam@1479 3380 L'.PConFfi {mod = "Basis",
adam@1479 3381 datatyp = "bool",
adam@1479 3382 con = "True",
adam@1479 3383 arg = NONE},
adam@1479 3384 NONE), loc),
adam@1479 3385 (L'.EStrcat (s,
adam@2048 3386 strH s'), loc)),
adam@1479 3387 ((L'.PCon (L'.Enum,
adam@1479 3388 L'.PConFfi {mod = "Basis",
adam@1479 3389 datatyp = "bool",
adam@1479 3390 con = "False",
adam@1479 3391 arg = NONE},
adam@1479 3392 NONE), loc),
adam@1479 3393 s)],
adam@1479 3394 {disc = (L'.TFfi ("Basis", "bool"), loc),
adam@1479 3395 result = (L'.TFfi ("Basis", "string"), loc)}), loc),
adam@1479 3396 fm)
adam@1479 3397 end
adam@1479 3398 | (L'.TFun (dom, _), _) =>
adam@1479 3399 let
vshabanoff@1712 3400 val e =
adam@1479 3401 case #1 dom of
vshabanoff@1712 3402 L'.TRecord [] => (L'.EApp (e, (L'.ERecord [], loc)), loc)
adam@1783 3403 | _ =>
adam@1783 3404 if String.isPrefix "Onkey" x then
adam@1783 3405 (L'.EApp ((L'.EApp (e, (L'.EFfiApp ("Basis", "keyEvent", []), loc)),
adam@1783 3406 loc), (L'.ERecord [], loc)), loc)
adam@1783 3407 else
adam@1783 3408 (L'.EApp ((L'.EApp (e, (L'.EFfiApp ("Basis", "mouseEvent", []), loc)),
adam@1783 3409 loc), (L'.ERecord [], loc)), loc)
adam@1783 3410
vshabanoff@1712 3411 val s' = " " ^ lowercaseFirst x ^ "='uw_event=event;exec("
adam@1479 3412 in
adam@1479 3413 ((L'.EStrcat (s,
adam@1479 3414 (L'.EStrcat (
adam@2048 3415 strH s',
adam@1479 3416 (L'.EStrcat (
adam@1479 3417 (L'.EJavaScript (L'.Attribute, e), loc),
julian@2145 3418 strH ")'"), loc)),
adam@1479 3419 loc)), loc),
adam@1479 3420 fm)
adam@1479 3421 end
adam@1479 3422 | _ =>
adam@1479 3423 let
adam@1479 3424 val fooify =
adam@1479 3425 case x of
adam@1479 3426 "Link" => urlifyExp
adam@1479 3427 | "Action" => urlifyExp
adam@1479 3428 | _ => attrifyExp
adam@1479 3429
adam@1479 3430 val x =
adam@1479 3431 case x of
adam@1479 3432 "Typ" => "Type"
adam@1840 3433 | "Nam" => "Name"
adam@1479 3434 | "Link" => "Href"
adam@1479 3435 | _ => x
adam@1840 3436
adam@1840 3437 val x = String.translate (fn #"_" => "-"
adam@1840 3438 | ch => String.str ch) x
adam@1840 3439
adam@1479 3440 val xp = " " ^ lowercaseFirst x ^ "=\""
adam@1479 3441
adam@1479 3442 val (e, fm) = fooify env fm (e, t)
adam@1479 3443 val e = case (tag, x) of
adam@2048 3444 ("coption", "Value") => (L'.EStrcat (strH "x", e), loc)
adam@1479 3445 | _ => e
adam@1479 3446 in
adam@1479 3447 ((L'.EStrcat (s,
adam@2048 3448 (L'.EStrcat (strH xp,
adam@1479 3449 (L'.EStrcat (e,
adam@2048 3450 strH "\""),
adam@1479 3451 loc)),
adam@1479 3452 loc)), loc),
adam@1479 3453 fm)
adam@1479 3454 end)
adam@1479 3455 (s, fm) attrs
adamc@598 3456 in
adam@1479 3457 (if tag = "coption" andalso List.all (fn ("Value", _, _) => false | _ => true) attrs then
adam@1479 3458 (L'.EStrcat (s,
adam@2048 3459 strH " value=\"\""), loc)
adam@1479 3460 else
adam@1479 3461 s,
adam@1479 3462 fm)
adamc@598 3463 end
adamc@104 3464
adamc@143 3465 fun input typ =
adamc@143 3466 case targs of
adamc@155 3467 [_, (L.CName name, _)] =>
adamc@179 3468 let
adamc@179 3469 val (ts, fm) = tagStart "input"
adamc@179 3470 in
adamc@179 3471 ((L'.EStrcat (ts,
adam@2048 3472 strH (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\" />")), loc), fm)
adamc@179 3473 end
adamc@143 3474 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adamc@153 3475 raise Fail "No name passed to input tag")
adamc@104 3476
adam@1728 3477 fun normal (tag, extra) =
adamc@143 3478 let
adamc@179 3479 val (tagStart, fm) = tagStart tag
adamc@152 3480 val tagStart = case extra of
adamc@152 3481 NONE => tagStart
adamc@152 3482 | SOME extra => (L'.EStrcat (tagStart, extra), loc)
adamc@152 3483
adam@2090 3484 val firstWord = Substring.string o #1 o Substring.splitl (fn ch => not (Char.isSpace ch)) o Substring.full
adam@2090 3485
adamc@143 3486 fun normal () =
adamc@179 3487 let
adamc@179 3488 val (xml, fm) = monoExp (env, st, fm) xml
adam@2026 3489
adam@2026 3490 val xml = case extraString of
adam@2026 3491 NONE => xml
adam@2026 3492 | SOME extra => (L'.EStrcat (extra, xml), loc)
adamc@179 3493 in
adam@2048 3494 ((L'.EStrcat ((L'.EStrcat (tagStart, strH ">"), loc),
adamc@179 3495 (L'.EStrcat (xml,
adam@2090 3496 strH (String.concat ["</", firstWord tag, ">"])), loc)),
adamc@179 3497 loc),
adamc@179 3498 fm)
adamc@179 3499 end
adamc@984 3500
adamc@984 3501 fun isSingleton () =
adamc@984 3502 let
adamc@984 3503 val (bef, aft) = Substring.splitl (not o Char.isSpace) (Substring.full tag)
adamc@984 3504 in
adamc@984 3505 SS.member (singletons, if Substring.isEmpty aft then
adamc@984 3506 tag
adamc@984 3507 else
adamc@984 3508 Substring.string bef)
adamc@984 3509 end
adamc@143 3510 in
adam@2026 3511 case (xml, extraString) of
adam@2026 3512 ((L.EApp ((L.ECApp (
adam@2026 3513 (L.ECApp ((L.EFfi ("Basis", "cdata"), _),
adam@2026 3514 _), _),
adam@2026 3515 _), _),
adam@2048 3516 (L.EPrim (Prim.String (_, s)), _)), _), NONE) =>
adamc@984 3517 if CharVector.all Char.isSpace s andalso isSingleton () then
adam@2048 3518 ((L'.EStrcat (tagStart, strH " />"), loc), fm)
adamc@143 3519 else
adamc@143 3520 normal ()
adamc@143 3521 | _ => normal ()
adamc@143 3522 end
adamc@606 3523
adamc@606 3524 fun setAttrs jexp =
adamc@606 3525 let
adam@2048 3526 val s = strH (String.concat ["<", tag])
adamc@606 3527
adamc@606 3528 val assgns = List.mapPartial
adamc@606 3529 (fn ("Source", _, _) => NONE
adamc@800 3530 | ("Onchange", e, _) =>
adamc@970 3531 SOME (strcat [str "addOnChange(d,exec(",
adamc@815 3532 (L'.EJavaScript (L'.Script, e), loc),
adam@1398 3533 str "));"])
adam@1290 3534 | (x, e, (L'.TFun ((L'.TRecord [], _), _), _)) =>
adamc@970 3535 SOME (strcat [str ("d." ^ lowercaseFirst x ^ "=exec("),
adamc@815 3536 (L'.EJavaScript (L'.Script, e), loc),
adam@1290 3537 str ");"])
adam@1290 3538 | (x, e, _) =>
adam@1398 3539 if String.isPrefix "On" x then
adam@1398 3540 let
adam@1789 3541 val arg = if String.isPrefix "Onkey" x then
adam@1789 3542 SOME (L'.EFfiApp ("Basis", "keyEvent", []), loc)
adam@1789 3543 else if String.isSuffix "click" x orelse String.isPrefix "Onmouse" x then
adam@1789 3544 SOME (L'.EFfiApp ("Basis", "mouseEvent", []), loc)
adam@1789 3545 else
adam@1789 3546 NONE
adam@1789 3547
adam@1789 3548 val e = liftExpInExp 0 e
adam@1789 3549
adam@1789 3550 val e = case arg of
adam@1789 3551 NONE => e
adam@1789 3552 | SOME arg => (L'.EApp (e, arg), loc)
adam@1789 3553
adam@1398 3554 val e = (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
adam@1789 3555 (L'.EApp (e, (L'.ERecord [], loc)), loc)), loc)
adam@1398 3556 in
adam@1398 3557 case x of
adam@1398 3558 "Onkeyup" =>
adam@1680 3559 SOME (strcat [str ("((function(c){addOnKeyUp(d,function(ev){window.uw_event=ev?ev:window.event;return c();});})(exec("),
adam@1398 3560 (L'.EJavaScript (L'.Script, e), loc),
adam@1398 3561 str ")));"])
adam@1398 3562 | _ =>
adam@1680 3563 SOME (strcat [str ("((function(c){d." ^ lowercaseFirst x ^ "=function(ev){window.uw_event=ev?ev:window.event;return c();};})(exec("),
adam@1398 3564 (L'.EJavaScript (L'.Script, e), loc),
adam@1398 3565 str ")));"])
adam@1398 3566 end
adam@1398 3567 else
adam@1398 3568 SOME (strcat [str ("d." ^ lowercaseFirst x ^ "=exec("),
adam@1398 3569 (L'.EJavaScript (L'.Script, e), loc),
adam@1398 3570 str ");"]))
adamc@606 3571 attrs
adamc@1173 3572
adamc@1173 3573 val t = (L'.TFfi ("Basis", "string"), loc)
adamc@1173 3574 val setClass = (L'.ECase (class,
adam@2048 3575 [((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
adamc@1173 3576 str ""),
adam@1800 3577 ((L'.PVar ("x", t), loc),
adam@2048 3578 (L'.EStrcat (strH "d.className=\"",
adamc@1173 3579 (L'.EStrcat ((L'.ERel 0, loc),
adam@2048 3580 strH "\";"), loc)),
adamc@1173 3581 loc))],
adamc@1173 3582 {disc = (L'.TOption t, loc),
adamc@1173 3583 result = t}), loc)
adamc@606 3584 in
adamc@606 3585 case assgns of
adamc@1173 3586 [] => strcat [str "var d=",
adamc@1173 3587 jexp,
adamc@1173 3588 str ";",
adamc@1173 3589 setClass]
adamc@606 3590 | _ => strcat (str "var d="
adamc@606 3591 :: jexp
adamc@606 3592 :: str ";"
adamc@1173 3593 :: setClass
adamc@606 3594 :: assgns)
adamc@606 3595 end
adamc@1042 3596
adamc@1042 3597 fun execify e =
adamc@1042 3598 case e of
adam@2048 3599 NONE => strH ""
adamc@1042 3600 | SOME e =>
adamc@1042 3601 let
adamc@1042 3602 val e = (L'.EApp (e, (L'.ERecord [], loc)), loc)
adamc@1042 3603 in
adam@2048 3604 (L'.EStrcat (strH "exec(",
adamc@1042 3605 (L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc),
adam@2048 3606 strH ")"), loc)), loc)
adamc@1042 3607 end
adam@1643 3608
adam@2012 3609 fun inTag tag' = case ctxOuter of
adam@2012 3610 (L.CRecord (_, ctx), _) =>
adam@2012 3611 List.exists (fn ((L.CName tag'', _), _) => tag'' = tag'
adam@2012 3612 | _ => false) ctx
adam@2012 3613 | _ => false
adam@2012 3614
adam@2012 3615 fun pnode () = if inTag "Tr" then
adam@2012 3616 "tr"
adam@2012 3617 else if inTag "Table" then
adam@2012 3618 "table"
adam@2012 3619 else
adam@2012 3620 "span"
adam@2012 3621
adam@2079 3622 fun cinput (fallback, dynamic) =
adam@2079 3623 case List.find (fn ("Source", _, _) => true | _ => false) attrs of
adam@2079 3624 NONE =>
adam@2079 3625 let
adam@2079 3626 val (ts, fm) = tagStart "input"
adam@2079 3627 in
adam@2079 3628 ((L'.EStrcat (ts,
adam@2079 3629 strH (" type=\"" ^ fallback ^ "\" />")),
adam@2079 3630 loc), fm)
adam@2079 3631 end
adam@2079 3632 | SOME (_, src, _) =>
adam@2079 3633 let
adam@2079 3634 val sc = strcat [str (dynamic ^ "(exec("),
adam@2079 3635 (L'.EJavaScript (L'.Script, src), loc),
adam@2079 3636 str "))"]
adam@2079 3637 val sc = setAttrs sc
adam@2079 3638 in
adam@2079 3639 (strcat [str "<script type=\"text/javascript\">",
adam@2079 3640 sc,
adam@2079 3641 str "</script>"],
adam@2079 3642 fm)
adam@2079 3643 end
adam@2079 3644
adam@1643 3645 val baseAll as (base, fm) =
adam@1643 3646 case tag of
adam@1643 3647 "body" => let
adam@1643 3648 val onload = execify onload
adam@1643 3649 val onunload = execify onunload
adam@1663 3650 val s = (L'.TFfi ("Basis", "string"), loc)
adam@1643 3651 in
adam@1643 3652 normal ("body",
adam@1643 3653 SOME (L'.EStrcat ((L'.EFfiApp ("Basis", "maybe_onload",
adam@1663 3654 [((L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings",
adam@1663 3655 [((L'.ERecord [], loc),
adam@1663 3656 (L'.TRecord [], loc))]), loc),
adam@1663 3657 onload), loc),
adam@1663 3658 s)]),
adam@1643 3659 loc),
adam@1643 3660 (L'.EFfiApp ("Basis", "maybe_onunload",
adam@1663 3661 [(onunload, s)]),
adam@1728 3662 loc)), loc))
adam@1643 3663 end
adam@1643 3664
adam@1643 3665 | "dyn" =>
adam@1643 3666 let
adam@1643 3667 in
adam@1643 3668 case attrs of
adam@1643 3669 [("Signal", e, _)] =>
adam@1643 3670 ((L'.EStrcat
adam@2048 3671 (strH ("<script type=\"text/javascript\">dyn(\""
adam@2048 3672 ^ pnode () ^ "\", execD("),
adam@1643 3673 (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
adam@2048 3674 strH ("))</script>")), loc)), loc),
adam@1643 3675 fm)
adam@1786 3676 | _ => raise Fail "Monoize: Bad <dyn> attributes"
adam@1643 3677 end
adam@1682 3678
adam@1786 3679 | "active" =>
adam@1786 3680 (case attrs of
adam@1786 3681 [("Code", e, _)] =>
adam@1786 3682 ((L'.EStrcat
adam@2048 3683 (strH "<script type=\"text/javascript\">active(execD(",
adam@1786 3684 (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
adam@2048 3685 strH "))</script>"), loc)), loc),
adam@1786 3686 fm)
adam@1786 3687 | _ => raise Fail "Monoize: Bad <active> attributes")
adam@1786 3688
adam@1926 3689 | "script" =>
grrwlf@1924 3690 (case attrs of
grrwlf@1924 3691 [("Code", e, _)] =>
grrwlf@1924 3692 ((L'.EStrcat
adam@2048 3693 (strH "<script type=\"text/javascript\">execF(execD(",
grrwlf@1924 3694 (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
adam@2048 3695 strH "))</script>"), loc)), loc),
grrwlf@1924 3696 fm)
adam@1926 3697 | _ => raise Fail "Monoize: Bad <script> attributes")
grrwlf@1924 3698
adam@1728 3699 | "submit" => normal ("input type=\"submit\"", NONE)
adam@1728 3700 | "image" => normal ("input type=\"image\"", NONE)
adam@1643 3701 | "hidden" => input "hidden"
adam@1643 3702
adam@1643 3703 | "textbox" =>
adam@1643 3704 (case targs of
adam@1643 3705 [_, (L.CName name, _)] =>
adam@1643 3706 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
adam@1643 3707 NONE =>
adam@1643 3708 let
adam@1643 3709 val (ts, fm) = tagStart "input"
adam@1643 3710 in
adam@1643 3711 ((L'.EStrcat (ts,
adam@2048 3712 strH (" type=\"text\" name=\"" ^ name ^ "\" />")),
adam@2048 3713 loc), fm)
adam@1643 3714 end
adam@1643 3715 | SOME (_, src, _) =>
adam@1643 3716 (strcat [str "<script type=\"text/javascript\">inp(exec(",
adam@1643 3717 (L'.EJavaScript (L'.Script, src), loc),
adam@1643 3718 str "), \"",
adam@1643 3719 str name,
adam@1643 3720 str "\")</script>"],
adam@1643 3721 fm))
adam@1643 3722 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adam@1643 3723 raise Fail "No name passed to textbox tag"))
adam@1643 3724 | "password" => input "password"
grrwlf@2074 3725 | "email" => input "email"
adam@2077 3726 | "search" => input "search"
adam@2077 3727 | "url_" => input "url"
adam@2077 3728 | "tel" => input "tel"
adam@2078 3729 | "color" => input "color"
adam@2078 3730 | "number" => input "number"
adam@2078 3731 | "range" => input "range"
adam@2078 3732 | "date" => input "date"
adam@2078 3733 | "datetime" => input "datetime"
adam@2078 3734 | "datetime_local" => input "datetime-local"
adam@2078 3735 | "month" => input "month"
adam@2078 3736 | "week" => input "week"
adam@2078 3737 | "timeInput" => input "time"
adam@1643 3738 | "textarea" =>
adam@1643 3739 (case targs of
adam@1643 3740 [_, (L.CName name, _)] =>
adam@1643 3741 let
adam@1643 3742 val (ts, fm) = tagStart "textarea"
adam@1643 3743 val (xml, fm) = monoExp (env, st, fm) xml
adam@1643 3744 in
adam@1643 3745 ((L'.EStrcat ((L'.EStrcat (ts,
adam@2048 3746 strH (" name=\"" ^ name ^ "\">")), loc),
adam@1643 3747 (L'.EStrcat (xml,
adam@2048 3748 strH "</textarea>"), loc)),
adam@1643 3749 loc), fm)
adam@1643 3750 end
adam@1643 3751 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adam@1643 3752 raise Fail "No name passed to ltextarea tag"))
adam@1643 3753
adam@1643 3754 | "checkbox" => input "checkbox"
adam@1643 3755 | "upload" => input "file"
adam@1643 3756
adam@1643 3757 | "radio" =>
adam@1643 3758 (case targs of
adam@1643 3759 [_, (L.CName name, _)] =>
adam@1643 3760 monoExp (env, St.setRadioGroup (st, name), fm) xml
adam@1643 3761 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adam@1643 3762 raise Fail "No name passed to radio tag"))
adam@1643 3763 | "radioOption" =>
adam@1643 3764 (case St.radioGroup st of
adam@1643 3765 NONE => raise Fail "No name for radioGroup"
adam@1643 3766 | SOME name =>
adam@1643 3767 normal ("input",
adam@2048 3768 SOME (strH (" type=\"radio\" name=\"" ^ name ^ "\""))))
adam@1643 3769
adam@1643 3770 | "select" =>
adam@1643 3771 (case targs of
adam@1643 3772 [_, (L.CName name, _)] =>
adam@1643 3773 let
adam@1643 3774 val (ts, fm) = tagStart "select"
adam@1643 3775 val (xml, fm) = monoExp (env, st, fm) xml
adam@1643 3776 in
adam@1643 3777 ((L'.EStrcat ((L'.EStrcat (ts,
adam@2048 3778 strH (" name=\"" ^ name ^ "\">")), loc),
adam@1643 3779 (L'.EStrcat (xml,
adam@2048 3780 strH "</select>"),
adam@2048 3781 loc)),
adam@1643 3782 loc),
adam@1643 3783 fm)
adam@1643 3784 end
adam@1643 3785 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adam@1643 3786 raise Fail "No name passed to lselect tag"))
adam@1643 3787
adam@2079 3788 | "ctextbox" => cinput ("text", "inp")
adam@2079 3789 | "cpassword" => cinput ("password", "password")
adam@2079 3790 | "cemail" => cinput ("email", "email")
adam@2079 3791 | "csearch" => cinput ("search", "search")
adam@2079 3792 | "curl" => cinput ("url", "url")
adam@2079 3793 | "ctel" => cinput ("tel", "tel")
adam@2079 3794 | "ccolor" => cinput ("color", "color")
adam@2079 3795
adam@2080 3796 | "cnumber" => cinput ("number", "number")
adam@2080 3797 | "crange" => cinput ("range", "range")
adam@2080 3798 | "cdate" => cinput ("date", "date")
adam@2080 3799 | "cdatetime" => cinput ("datetime", "datetime")
adam@2080 3800 | "cdatetime_local" => cinput ("datetime-local", "datetime_local")
adam@2080 3801 | "cmonth" => cinput ("month", "month")
adam@2080 3802 | "cweek" => cinput ("week", "week")
adam@2080 3803 | "ctime" => cinput ("time", "time")
adam@2080 3804
adam@2079 3805 | "ccheckbox" => cinput ("checkbox", "chk")
adam@1643 3806 | "cselect" =>
adam@1643 3807 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
adam@1643 3808 NONE =>
adam@1643 3809 let
adam@1643 3810 val (xml, fm) = monoExp (env, st, fm) xml
adam@1643 3811 val (ts, fm) = tagStart "select"
adam@1643 3812 in
adam@1643 3813 (strcat [ts,
adam@1643 3814 str ">",
adam@1643 3815 xml,
adam@1643 3816 str "</select>"],
adam@1643 3817 fm)
adam@1643 3818 end
adam@1643 3819 | SOME (_, src, _) =>
adam@1643 3820 let
adam@1643 3821 val (xml, fm) = monoExp (env, st, fm) xml
adam@1643 3822
adam@1643 3823 val sc = strcat [str "sel(exec(",
adam@1643 3824 (L'.EJavaScript (L'.Script, src), loc),
adam@1643 3825 str "),exec(",
adam@1643 3826 (L'.EJavaScript (L'.Script, xml), loc),
adam@1643 3827 str "))"]
adam@1643 3828 val sc = setAttrs sc
adam@1643 3829 in
adam@1643 3830 (strcat [str "<script type=\"text/javascript\">",
adam@1643 3831 sc,
adam@1643 3832 str "</script>"],
adam@1643 3833 fm)
adam@1643 3834 end)
adam@1643 3835
adam@1728 3836 | "coption" => normal ("option", NONE)
adam@1643 3837
adam@1643 3838 | "ctextarea" =>
adam@1643 3839 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
adam@1643 3840 NONE =>
adam@1643 3841 let
adam@1643 3842 val (ts, fm) = tagStart "textarea"
adam@1643 3843 in
adam@1643 3844 ((L'.EStrcat (ts,
adam@2048 3845 strH " />"),
adam@1643 3846 loc), fm)
adam@1643 3847 end
adam@1643 3848 | SOME (_, src, _) =>
adam@1643 3849 let
adam@1643 3850 val sc = strcat [str "tbx(exec(",
adam@1643 3851 (L'.EJavaScript (L'.Script, src), loc),
adam@1643 3852 str "))"]
adam@1643 3853 val sc = setAttrs sc
adam@1643 3854 in
adam@1643 3855 (strcat [str "<script type=\"text/javascript\">",
adam@1643 3856 sc,
adam@1643 3857 str "</script>"],
adam@1643 3858 fm)
adam@1643 3859 end)
adam@1643 3860
adam@1728 3861 | "tabl" => normal ("table", NONE)
adam@1728 3862 | _ => normal (tag, NONE)
adam@2121 3863
adam@2121 3864 val (dynClass', dynStyle') =
adam@2121 3865 case tag of
adam@2121 3866 "body" => ((L'.ENone dummyTyp, ErrorMsg.dummySpan),
adam@2121 3867 (L'.ENone dummyTyp, ErrorMsg.dummySpan))
adam@2121 3868 | _ => (dynClass, dynStyle)
adam@1643 3869 in
adam@2121 3870 case #1 dynClass' of
adam@1751 3871 L'.ENone _ =>
adam@2121 3872 (case #1 dynStyle' of
adam@1751 3873 L'.ENone _ => baseAll
adam@2012 3874 | L'.ESome (_, ds) => (strcat [str "<script type=\"text/javascript\">dynClass(\"",
adam@2012 3875 str (pnode ()),
adam@2012 3876 str "\",execD(",
adam@1751 3877 (L'.EJavaScript (L'.Script, base), loc),
adam@1751 3878 str "),null,execD(",
adam@1751 3879 (L'.EJavaScript (L'.Script, ds), loc),
adam@1751 3880 str "))</script>"],
adam@1751 3881 fm)
adam@1751 3882 | _ => (E.errorAt loc "Absence/presence of 'dynStyle' unknown";
adam@1751 3883 baseAll))
adam@1751 3884 | L'.ESome (_, dc) =>
adam@1751 3885 let
adam@2121 3886 val e = case #1 dynStyle' of
adam@1751 3887 L'.ENone _ => str "null"
adam@1751 3888 | L'.ESome (_, ds) => strcat [str "execD(",
adam@1751 3889 (L'.EJavaScript (L'.Script, ds), loc),
adam@1751 3890 str ")"]
adam@1751 3891 | _ => (E.errorAt loc "Absence/presence of 'dynStyle' unknown";
adam@1751 3892 str "null")
adam@1751 3893 in
adam@2012 3894 (strcat [str "<script type=\"text/javascript\">dynClass(\"",
adam@2012 3895 str (pnode ()),
adam@2012 3896 str "\",execD(",
adam@1751 3897 (L'.EJavaScript (L'.Script, base), loc),
adam@1751 3898 str "),execD(",
adam@1751 3899 (L'.EJavaScript (L'.Script, dc), loc),
adam@1751 3900 str "),",
adam@1751 3901 e,
adam@1751 3902 str ")</script>"],
adam@1751 3903 fm)
adam@1751 3904 end
adam@1646 3905 | _ => (E.errorAt loc "Absence/presence of 'dynClass' unknown";
adam@1646 3906 baseAll)
adamc@95 3907 end
adamc@94 3908
adam@1412 3909 | L.EApp (
adam@1412 3910 (L.EApp ((L.ECApp (
adam@1412 3911 (L.ECApp ((L.EFfi ("Basis", "form"), _), _), _),
adam@1412 3912 (L.CRecord (_, fields), _)), _),
adam@1412 3913 class), _),
adam@1412 3914 xml) =>
adamc@143 3915 let
adamc@143 3916 fun findSubmit (e, _) =
adamc@143 3917 case e of
adamc@143 3918 L.EApp (
adamc@143 3919 (L.EApp (
adamc@143 3920 (L.ECApp (
adamc@143 3921 (L.ECApp (
adamc@143 3922 (L.ECApp (
adamc@143 3923 (L.ECApp (
adamc@143 3924 (L.EFfi ("Basis", "join"),
adamc@143 3925 _), _), _),
adamc@143 3926 _), _),
adamc@143 3927 _), _),
adamc@143 3928 _), _),
adamc@143 3929 xml1), _),
adamc@143 3930 xml2) => (case findSubmit xml1 of
adamc@143 3931 Error => Error
adamc@143 3932 | NotFound => findSubmit xml2
adamc@143 3933 | Found e =>
adamc@143 3934 case findSubmit xml2 of
adamc@143 3935 NotFound => Found e
adamc@143 3936 | _ => Error)
adamc@143 3937 | L.EApp (
adamc@143 3938 (L.EApp (
adamc@143 3939 (L.EApp (
adamc@730 3940 (L.EApp (
adam@1646 3941 (L.EApp (
adam@1754 3942 (L.EApp (
adam@1754 3943 (L.EApp (
adamc@143 3944 (L.ECApp (
adamc@143 3945 (L.ECApp (
adamc@143 3946 (L.ECApp (
adamc@143 3947 (L.ECApp (
adamc@730 3948 (L.ECApp (
adam@1646 3949 (L.ECApp (
adam@1754 3950 (L.ECApp (
adam@1754 3951 (L.ECApp (
adam@1754 3952 (L.EFfi ("Basis", "tag"),
adam@1754 3953 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
adam@1754 3954 _), _),
adam@1754 3955 _), _),
adam@1646 3956 _), _),
adamc@730 3957 _), _),
adamc@143 3958 attrs), _),
adamc@143 3959 _), _),
adamc@143 3960 xml) =>
adamc@143 3961 (case #1 attrs of
adamc@143 3962 L.ERecord xes =>
adamc@143 3963 (case ListUtil.search (fn ((L.CName "Action", _), e, t) => SOME (e, t)
adamc@143 3964 | _ => NONE) xes of
adamc@143 3965 NONE => findSubmit xml
adamc@143 3966 | SOME et =>
adamc@143 3967 case findSubmit xml of
adamc@143 3968 NotFound => Found et
adamc@143 3969 | _ => Error)
adamc@143 3970 | _ => findSubmit xml)
adamc@143 3971 | _ => NotFound
adamc@143 3972
adamc@735 3973 val (func, action, fm) = case findSubmit xml of
adam@2048 3974 NotFound => (0, strH "", fm)
adamc@143 3975 | Error => raise Fail "Not ready for multi-submit lforms yet"
adamc@598 3976 | Found (action, actionT) =>
adamc@598 3977 let
adamc@735 3978 val func = case #1 action of
adamc@735 3979 L.EClosure (n, _) => n
adamc@735 3980 | _ => raise Fail "Monoize: Action is not a closure"
adamc@598 3981 val actionT = monoType env actionT
adamc@598 3982 val (action, fm) = monoExp (env, st, fm) action
adamc@598 3983 val (action, fm) = urlifyExp env fm (action, actionT)
adamc@598 3984 in
adamc@735 3985 (func,
adam@2048 3986 (L'.EStrcat (strH " action=\"",
adamc@598 3987 (L'.EStrcat (action,
adam@2048 3988 strH "\""), loc)), loc),
adamc@598 3989 fm)
adamc@598 3990 end
adamc@734 3991
adamc@737 3992 val hasUpload = CoreUtil.Exp.exists {kind = fn _ => false,
adamc@737 3993 con = fn _ => false,
adamc@737 3994 exp = fn e =>
adamc@737 3995 case e of
adamc@737 3996 L.EFfi ("Basis", "upload") => true
adamc@737 3997 | _ => false} xml
adamc@737 3998
adamc@179 3999 val (xml, fm) = monoExp (env, st, fm) xml
adamc@735 4000
adamc@735 4001 val xml =
adamc@735 4002 if IS.member (!readCookie, func) then
adamc@735 4003 let
adamc@735 4004 fun inFields s = List.exists (fn ((L.CName s', _), _) => s' = s
adamc@735 4005 | _ => true) fields
adamc@735 4006
adamc@735 4007 fun getSigName () =
adamc@735 4008 let
adamc@735 4009 fun getSigName' n =
adamc@735 4010 let
adamc@735 4011 val s = "Sig" ^ Int.toString n
adamc@735 4012 in
adamc@735 4013 if inFields s then
adamc@735 4014 getSigName' (n + 1)
adamc@735 4015 else
adamc@735 4016 s
adamc@735 4017 end
adamc@735 4018 in
adamc@735 4019 if inFields "Sig" then
adamc@735 4020 getSigName' 0
adamc@735 4021 else
adamc@735 4022 "Sig"
adamc@735 4023 end
adamc@735 4024
adamc@735 4025 val sigName = getSigName ()
adam@1663 4026 val sigSet = (L'.EFfiApp ("Basis", "sigString", [((L'.ERecord [], loc), (L'.TRecord [], loc))]), loc)
adam@2048 4027 val sigSet = (L'.EStrcat (strH ("<input type=\"hidden\" name=\""
adam@2048 4028 ^ sigName
adam@2048 4029 ^ "\" value=\""),
adamc@735 4030 sigSet), loc)
adamc@735 4031 val sigSet = (L'.EStrcat (sigSet,
adam@2048 4032 strH "\" />"), loc)
adamc@735 4033 in
adamc@735 4034 (L'.EStrcat (sigSet, xml), loc)
adamc@735 4035 end
adamc@735 4036 else
adamc@735 4037 xml
adamc@737 4038
adamc@737 4039 val action = if hasUpload then
adamc@737 4040 (L'.EStrcat (action,
adam@2048 4041 strH " enctype=\"multipart/form-data\""), loc)
adamc@737 4042 else
adamc@737 4043 action
adamc@737 4044
adam@1412 4045 val stt = (L'.TFfi ("Basis", "string"), loc)
adam@1412 4046 val (class, fm) = monoExp (env, st, fm) class
adam@1412 4047 val action = (L'.EStrcat (action,
adam@1412 4048 (L'.ECase (class,
adam@1412 4049 [((L'.PNone stt, loc),
adam@2048 4050 strH ""),
adam@1412 4051 ((L'.PSome (stt, (L'.PVar ("x", stt), loc)), loc),
adam@2048 4052 (L'.EStrcat (strH " class=\"",
adam@1412 4053 (L'.EStrcat ((L'.ERel 0, loc),
adam@2048 4054 strH "\""), loc)), loc))],
adam@1412 4055 {disc = (L'.TOption stt, loc),
adam@1412 4056 result = stt}), loc)), loc)
adamc@143 4057 in
adam@2048 4058 ((L'.EStrcat ((L'.EStrcat (strH "<form method=\"post\"",
adamc@179 4059 (L'.EStrcat (action,
adam@2048 4060 strH ">"), loc)), loc),
adamc@179 4061 (L'.EStrcat (xml,
adam@2048 4062 strH "</form>"), loc)), loc),
adamc@179 4063 fm)
adamc@143 4064 end
adamc@141 4065
adamc@756 4066 | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp (
adamc@756 4067 (L.EFfi ("Basis", "subform"), _), _), _), _),
adamc@756 4068 _), _), _), (L.CName nm, loc)) =>
adamc@756 4069 let
adamc@756 4070 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@756 4071 in
adamc@756 4072 ((L'.EAbs ("xml", s, s,
adam@2048 4073 strcat [strH ("<input type=\"hidden\" name=\".b\" value=\""
adam@2048 4074 ^ nm ^ "\" />"),
adamc@756 4075 (L'.ERel 0, loc),
adam@2048 4076 strH ("<input type=\"hidden\" name=\".e\" value=\"1\" />")]),
adamc@756 4077 loc),
adamc@756 4078 fm)
adamc@756 4079 end
adamc@756 4080
adamc@758 4081 | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp (
adamc@758 4082 (L.EFfi ("Basis", "subforms"), _), _), _), _),
adamc@758 4083 _), _), _), (L.CName nm, loc)) =>
adamc@758 4084 let
adamc@758 4085 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@758 4086 in
adamc@758 4087 ((L'.EAbs ("xml", s, s,
adam@2048 4088 strcat [strH ("<input type=\"hidden\" name=\".s\" value=\""
adam@2048 4089 ^ nm ^ "\" />"),
adamc@758 4090 (L'.ERel 0, loc),
adam@2048 4091 strH ("<input type=\"hidden\" name=\".e\" value=\"1\" />")]),
adamc@758 4092 loc),
adamc@758 4093 fm)
adamc@758 4094 end
adamc@758 4095
adamc@758 4096 | L.ECApp ((L.ECApp (
adamc@758 4097 (L.EFfi ("Basis", "entry"), _), _), _), _) =>
adamc@758 4098 let
adamc@758 4099 val s = (L'.TFfi ("Basis", "string"), loc)
adamc@758 4100 in
adamc@758 4101 ((L'.EAbs ("xml", s, s,
adam@2048 4102 strcat [strH ("<input type=\"hidden\" name=\".i\" value=\"1\" />"),
adamc@758 4103 (L'.ERel 0, loc),
adam@2048 4104 strH ("<input type=\"hidden\" name=\".e\" value=\"1\" />")]),
adamc@758 4105 loc),
adamc@758 4106 fm)
adamc@758 4107 end
adamc@758 4108
adamc@148 4109 | L.EApp ((L.ECApp (
adamc@148 4110 (L.ECApp (
adamc@148 4111 (L.ECApp (
adamc@148 4112 (L.ECApp (
adamc@148 4113 (L.EFfi ("Basis", "useMore"), _), _), _),
adamc@148 4114 _), _),
adamc@148 4115 _), _),
adamc@148 4116 _), _),
adamc@179 4117 xml) => monoExp (env, st, fm) xml
adamc@148 4118
adamc@283 4119 | L.ECApp ((L.EFfi ("Basis", "error"), _), t) =>
adamc@283 4120 let
adamc@283 4121 val t = monoType env t
adamc@283 4122 in
adamc@283 4123 ((L'.EAbs ("s", (L'.TFfi ("Basis", "string"), loc), t,
adamc@283 4124 (L'.EError ((L'.ERel 0, loc), t), loc)), loc),
adamc@283 4125 fm)
adamc@283 4126 end
adam@1932 4127 | L.EApp (
adam@1932 4128 (L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t), _),
adam@1932 4129 (L.EFfiApp ("Basis", "textBlob", [(e, _)]), _)) =>
adam@1932 4130 let
adam@1932 4131 val t = monoType env t
adam@1932 4132 val un = (L'.TRecord [], loc)
adam@1932 4133 val (e, fm) = monoExp (env, st, fm) e
adam@1932 4134 in
adam@1932 4135 ((L'.EAbs ("mt", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
adam@1932 4136 (L'.EAbs ("_", un, t,
adam@1932 4137 (L'.ESeq ((L'.EFfiApp ("Basis", "clear_page", []), loc),
adam@1932 4138 (L'.ESeq ((L'.EWrite (liftExpInExp 0 (liftExpInExp 0 e)), loc),
adam@1932 4139 (L'.EReturnBlob {blob = NONE,
adam@1932 4140 mimeType = (L'.ERel 1, loc),
adam@1932 4141 t = t}, loc)), loc)), loc)), loc)),
adam@1932 4142 loc),
adam@1932 4143 fm)
adam@1932 4144 end
adamc@741 4145 | L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t) =>
adamc@741 4146 let
adamc@741 4147 val t = monoType env t
adamc@741 4148 val un = (L'.TRecord [], loc)
adamc@741 4149 in
adamc@741 4150 ((L'.EAbs ("b", (L'.TFfi ("Basis", "blob"), loc),
adamc@741 4151 (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc)), loc),
adamc@741 4152 (L'.EAbs ("mt", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
adamc@741 4153 (L'.EAbs ("_", un, t,
adam@1932 4154 (L'.EReturnBlob {blob = SOME (L'.ERel 2, loc),
adamc@741 4155 mimeType = (L'.ERel 1, loc),
adamc@741 4156 t = t}, loc)), loc)), loc)), loc),
adamc@741 4157 fm)
adamc@741 4158 end
adamc@1065 4159 | L.ECApp ((L.EFfi ("Basis", "redirect"), _), t) =>
adamc@1065 4160 let
adamc@1065 4161 val t = monoType env t
adamc@1065 4162 val un = (L'.TRecord [], loc)
adamc@1065 4163 in
adamc@1065 4164 ((L'.EAbs ("url", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
adamc@1065 4165 (L'.EAbs ("_", un, t,
adamc@1065 4166 (L'.ERedirect ((L'.ERel 1, loc), t), loc)), loc)), loc),
adamc@1065 4167 fm)
adamc@1065 4168 end
adamc@283 4169
adamc@1104 4170 | L.ECApp ((L.EFfi ("Basis", "serialize"), _), t) =>
adamc@1104 4171 let
adamc@1104 4172 val t = monoType env t
adamc@1104 4173 val (e, fm) = urlifyExp env fm ((L'.ERel 0, loc), t)
adamc@1104 4174 in
adamc@1104 4175 ((L'.EAbs ("v", t, (L'.TFfi ("Basis", "string"), loc), e), loc),
adamc@1104 4176 fm)
adamc@1104 4177 end
adamc@1104 4178 | L.ECApp ((L.EFfi ("Basis", "deserialize"), _), t) =>
adamc@1104 4179 let
adamc@1104 4180 val t = monoType env t
adamc@1104 4181 in
adamc@1112 4182 ((L'.EAbs ("v", (L'.TFfi ("Basis", "string"), loc), t, (L'.EUnurlify ((L'.ERel 0, loc), t, false),
adamc@1112 4183 loc)), loc),
adamc@1104 4184 fm)
adamc@1104 4185 end
adamc@1104 4186
adam@1663 4187 | L.EFfiApp ("Basis", "url", [(e, _)]) =>
adamc@1067 4188 let
adamc@1067 4189 val (e, fm) = monoExp (env, st, fm) e
adam@1370 4190 val (e, fm) = urlifyExp env fm (e, dummyTyp)
adamc@1067 4191 in
adam@2048 4192 ((L'.EStrcat (str (Settings.getUrlPrePrefix ()), e), loc), fm)
adamc@1067 4193 end
adamc@1067 4194
adamc@179 4195 | L.EApp (e1, e2) =>
adamc@179 4196 let
adamc@179 4197 val (e1, fm) = monoExp (env, st, fm) e1
adamc@179 4198 val (e2, fm) = monoExp (env, st, fm) e2
adamc@179 4199 in
adamc@179 4200 ((L'.EApp (e1, e2), loc), fm)
adamc@179 4201 end
adamc@26 4202 | L.EAbs (x, dom, ran, e) =>
adamc@179 4203 let
adamc@179 4204 val (e, fm) = monoExp (Env.pushERel env x dom, st, fm) e
adamc@179 4205 in
adamc@179 4206 ((L'.EAbs (x, monoType env dom, monoType env ran, e), loc), fm)
adamc@179 4207 end
adam@1836 4208
adam@1836 4209 | L.ECApp (e, _) =>
adam@1836 4210 let
adam@1836 4211 val (e, fm) = monoExp (env, st, fm) e
adam@1836 4212 in
adam@1836 4213 case #1 e of
adam@1836 4214 L'.EFfi _ => (e, fm)
adam@1836 4215 | _ => poly ()
adam@1836 4216 end
adamc@25 4217 | L.ECAbs _ => poly ()
adamc@25 4218
adamc@252 4219 | L.EFfi mx => ((L'.EFfi mx, loc), fm)
adamc@252 4220 | L.EFfiApp (m, x, es) =>
adamc@252 4221 let
adam@1663 4222 val (es, fm) = ListUtil.foldlMap (fn ((e, t), fm) =>
adam@1663 4223 let
adam@1663 4224 val (e, fm) = monoExp (env, st, fm) e
adam@1663 4225 in
adam@1663 4226 ((e, monoType env t), fm)
adam@1663 4227 end) fm es
adamc@252 4228 in
adamc@252 4229 ((L'.EFfiApp (m, x, es), loc), fm)
adamc@252 4230 end
adamc@252 4231
adamc@179 4232 | L.ERecord xes =>
adamc@179 4233 let
adamc@179 4234 val (xes, fm) = ListUtil.foldlMap
adamc@179 4235 (fn ((x, e, t), fm) =>
adamc@179 4236 let
adamc@179 4237 val (e, fm) = monoExp (env, st, fm) e
adamc@179 4238 in
adamc@179 4239 ((monoName env x,
adamc@179 4240 e,
adamc@179 4241 monoType env t), fm)
adamc@179 4242 end) fm xes
adamc@905 4243
adamc@905 4244 val xes = ListMergeSort.sort (fn ((x, _, _), (y, _, _)) => String.compare (x, y) = GREATER) xes
adamc@179 4245 in
adamc@179 4246 ((L'.ERecord xes, loc), fm)
adamc@179 4247 end
adamc@179 4248 | L.EField (e, x, _) =>
adamc@179 4249 let
adamc@179 4250 val (e, fm) = monoExp (env, st, fm) e
adamc@179 4251 in
adamc@179 4252 ((L'.EField (e, monoName env x), loc), fm)
adamc@179 4253 end
adamc@445 4254 | L.EConcat _ => poly ()
adamc@149 4255 | L.ECut _ => poly ()
adamc@493 4256 | L.ECutMulti _ => poly ()
adamc@177 4257
adamc@182 4258 | L.ECase (e, pes, {disc, result}) =>
adamc@179 4259 let
adamc@179 4260 val (e, fm) = monoExp (env, st, fm) e
adamc@179 4261 val (pes, fm) = ListUtil.foldlMap
adamc@179 4262 (fn ((p, e), fm) =>
adamc@179 4263 let
adamc@179 4264 val (e, fm) = monoExp (env, st, fm) e
adamc@179 4265 in
adamc@182 4266 ((monoPat env p, e), fm)
adamc@179 4267 end) fm pes
adamc@179 4268 in
adamc@182 4269 ((L'.ECase (e, pes, {disc = monoType env disc, result = monoType env result}), loc), fm)
adamc@179 4270 end
adamc@177 4271
adamc@179 4272 | L.EWrite e =>
adamc@179 4273 let
adamc@179 4274 val (e, fm) = monoExp (env, st, fm) e
adamc@179 4275 in
adamc@252 4276 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
adamc@252 4277 (L'.EWrite (liftExpInExp 0 e), loc)), loc), fm)
adamc@179 4278 end
adamc@110 4279
adamc@179 4280 | L.EClosure (n, es) =>
adamc@179 4281 let
adamc@179 4282 val (es, fm) = ListUtil.foldlMap (fn (e, fm) =>
adamc@179 4283 monoExp (env, st, fm) e)
adamc@1065 4284 fm es
adamc@1065 4285 val e = (L'.EClosure (n, es), loc)
adamc@179 4286 in
adamc@1067 4287 (e, fm)
adamc@179 4288 end
adamc@450 4289
adamc@450 4290 | L.ELet (x, t, e1, e2) =>
adamc@450 4291 let
adamc@450 4292 val t' = monoType env t
adamc@450 4293 val (e1, fm) = monoExp (env, st, fm) e1
adamc@450 4294 val (e2, fm) = monoExp (Env.pushERel env x t, st, fm) e2
adamc@450 4295 in
adamc@450 4296 ((L'.ELet (x, t', e1, e2), loc), fm)
adamc@450 4297 end
adamc@607 4298
adam@1848 4299 | L.EServerCall (n, es, t, fmode) =>
adamc@608 4300 let
adamc@609 4301 val t = monoType env t
adamc@614 4302 val (_, ft, _, name) = Env.lookupENamed env n
adamc@608 4303 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
adamc@614 4304
adamc@614 4305 fun encodeArgs (es, ft, acc, fm) =
adamc@614 4306 case (es, ft) of
adamc@614 4307 ([], _) => (rev acc, fm)
adamc@614 4308 | (e :: es, (L.TFun (dom, ran), _)) =>
adamc@614 4309 let
adamc@614 4310 val (e, fm) = urlifyExp env fm (e, monoType env dom)
adamc@614 4311 in
adamc@614 4312 encodeArgs (es, ran, e
adam@2048 4313 :: str "/"
adamc@614 4314 :: acc, fm)
adamc@614 4315 end
adamc@614 4316 | _ => raise Fail "Monoize: Not enough arguments visible in RPC function type"
adamc@614 4317
adamc@614 4318 val (call, fm) = encodeArgs (es, ft, [], fm)
adamc@614 4319 val call = foldl (fn (e, call) => (L'.EStrcat (call, e), loc))
adam@2048 4320 (str name) call
adamc@614 4321
adamc@905 4322 val unit = (L'.TRecord [], loc)
adamc@905 4323
adamc@736 4324 val eff = if IS.member (!readCookie, n) then
adamc@736 4325 L'.ReadCookieWrite
adamc@736 4326 else
adamc@736 4327 L'.ReadOnly
adamc@905 4328
adam@1848 4329 val e = (L'.EServerCall (call, t, eff, fmode), loc)
adamc@651 4330 val e = liftExpInExp 0 e
adamc@651 4331 val e = (L'.EAbs ("_", unit, unit, e), loc)
adamc@608 4332 in
adamc@651 4333 (e, fm)
adamc@608 4334 end
adamc@626 4335
adamc@626 4336 | L.EKAbs _ => poly ()
adamc@626 4337 | L.EKApp _ => poly ()
adamc@25 4338 end
adamc@25 4339
adamc@179 4340 fun monoDecl (env, fm) (all as (d, loc)) =
adamc@25 4341 let
adamc@25 4342 fun poly () =
adamc@25 4343 (E.errorAt loc "Unsupported declaration";
adamc@25 4344 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
adamc@25 4345 NONE)
adam@2048 4346
adam@2048 4347 fun str s = (L'.EPrim (Prim.String (Prim.Normal, s)), loc)
adam@2048 4348 fun strH s = (L'.EPrim (Prim.String (Prim.Html, s)), loc)
adamc@25 4349 in
adamc@25 4350 case d of
adamc@25 4351 L.DCon _ => NONE
adamc@808 4352 | L.DDatatype [("list", n, [_], [("Nil", _, NONE),
adamc@808 4353 ("Cons", _, SOME (L.TRecord (L.CRecord (_,
adamc@808 4354 [((L.CName "1", _),
adamc@808 4355 (L.CRel 0, _)),
adamc@808 4356 ((L.CName "2", _),
adamc@808 4357 (L.CApp ((L.CNamed n', _),
adamc@808 4358 (L.CRel 0, _)),
adamc@808 4359 _))]), _), _))])] =>
adamc@757 4360 if n = n' then
adamc@757 4361 NONE
adamc@757 4362 else
adamc@757 4363 poly ()
adamc@808 4364 | L.DDatatype dts =>
adamc@808 4365 let
adamc@808 4366 val env' = Env.declBinds env all
adamc@808 4367 val dts = map (fn (x, n, [], xncs) =>
adamc@808 4368 (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env') to)) xncs)
adamc@808 4369 | _ => (E.errorAt loc "Polymorphic datatype needed too late";
adamc@808 4370 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
adamc@808 4371 ("", 0, []))) dts
adamc@808 4372 val d = (L'.DDatatype dts, loc)
adamc@808 4373 in
adamc@808 4374 SOME (env', fm, [d])
adamc@808 4375 end
adamc@179 4376 | L.DVal (x, n, t, e, s) =>
adamc@179 4377 let
adamc@179 4378 val (e, fm) = monoExp (env, St.empty, fm) e
adamc@179 4379 in
adamc@179 4380 SOME (Env.pushENamed env x n t NONE s,
adamc@179 4381 fm,
adamc@273 4382 [(L'.DVal (x, n, monoType env t, e, s), loc)])
adamc@179 4383 end
adamc@128 4384 | L.DValRec vis =>
adamc@128 4385 let
adamc@1107 4386 val vis = map (fn (x, n, t, e, s) =>
adamc@1107 4387 let
adamc@1107 4388 fun maybeTransaction (t, e) =
adamc@1107 4389 case (#1 t, #1 e) of
adamc@1107 4390 (L.CApp ((L.CFfi ("Basis", "transaction"), _), _), _) =>
adamc@1107 4391 SOME (L.EAbs ("_",
adamc@1107 4392 (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc),
adamc@1107 4393 t,
adamc@1107 4394 (L.EApp (CoreEnv.liftExpInExp 0 e,
adamc@1107 4395 (L.ERecord [], loc)), loc)), loc)
adamc@1107 4396 | (L.TFun (dom, ran), L.EAbs (x, _, _, e)) =>
adamc@1107 4397 (case maybeTransaction (ran, e) of
adamc@1107 4398 NONE => NONE
adamc@1107 4399 | SOME e => SOME (L.EAbs (x, dom, ran, e), loc))
adamc@1107 4400 | _ => NONE
adamc@1107 4401 in
adamc@1107 4402 (x, n, t,
adamc@1107 4403 case maybeTransaction (t, e) of
adamc@1107 4404 NONE => e
adamc@1107 4405 | SOME e => e,
adamc@1107 4406 s)
adamc@1107 4407 end) vis
adamc@1107 4408
adamc@128 4409 val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis
adamc@179 4410
adamc@179 4411 val (vis, fm) = ListUtil.foldlMap
adamc@179 4412 (fn ((x, n, t, e, s), fm) =>
adamc@179 4413 let
adamc@179 4414 val (e, fm) = monoExp (env, St.empty, fm) e
adamc@179 4415 in
adamc@179 4416 ((x, n, monoType env t, e, s), fm)
adamc@179 4417 end)
adamc@179 4418 fm vis
adamc@128 4419 in
adamc@128 4420 SOME (env,
adamc@179 4421 fm,
adamc@273 4422 [(L'.DValRec vis, loc)])
adamc@128 4423 end
adamc@1104 4424 | L.DExport (ek, n, b) =>
adamc@115 4425 let
adamc@120 4426 val (_, t, _, s) = Env.lookupENamed env n
adamc@120 4427
adamc@609 4428 fun unwind (t, args) =
adamc@609 4429 case #1 t of
adamc@609 4430 L.TFun (dom, ran) => unwind (ran, dom :: args)
adamc@314 4431 | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
adamc@609 4432 unwind (t, (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) :: args)
adamc@609 4433 | _ => (rev args, t)
adamc@120 4434
adamc@609 4435 val (ts, ran) = unwind (t, [])
adamc@609 4436 val ts = map (monoType env) ts
adamc@609 4437 val ran = monoType env ran
adamc@115 4438 in
adamc@1104 4439 SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran, b), loc)])
adamc@115 4440 end
adamc@707 4441 | L.DTable (x, n, (L.CRecord (_, xts), _), s, pe, _, ce, _) =>
adamc@251 4442 let
adamc@251 4443 val t = (L.CFfi ("Basis", "string"), loc)
adamc@251 4444 val t' = (L'.TFfi ("Basis", "string"), loc)
adam@1953 4445 val s = Settings.mangleSqlTable s
adam@2048 4446 val e_name = str s
adamc@273 4447
adamc@273 4448 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
adamc@704 4449
adamc@707 4450 val (pe, fm) = monoExp (env, St.empty, fm) pe
adamc@707 4451 val (ce, fm) = monoExp (env, St.empty, fm) ce
adamc@251 4452 in
adamc@251 4453 SOME (Env.pushENamed env x n t NONE s,
adamc@251 4454 fm,
adamc@707 4455 [(L'.DTable (s, xts, pe, ce), loc),
adamc@704 4456 (L'.DVal (x, n, t', e_name, s), loc)])
adamc@251 4457 end
adamc@273 4458 | L.DTable _ => poly ()
adamc@754 4459 | L.DView (x, n, s, e, (L.CRecord (_, xts), _)) =>
adamc@754 4460 let
adamc@754 4461 val t = (L.CFfi ("Basis", "string"), loc)
adamc@754 4462 val t' = (L'.TFfi ("Basis", "string"), loc)
adam@1953 4463 val s = Settings.mangleSqlTable s
adam@2048 4464 val e_name = str s
adamc@754 4465
adamc@754 4466 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
adamc@754 4467
adamc@754 4468 val (e, fm) = monoExp (env, St.empty, fm) e
adam@1663 4469 val e = (L'.EFfiApp ("Basis", "viewify", [(e, t')]), loc)
adamc@754 4470 in
adamc@754 4471 SOME (Env.pushENamed env x n t NONE s,
adamc@754 4472 fm,
adamc@754 4473 [(L'.DView (s, xts, e), loc),
adamc@754 4474 (L'.DVal (x, n, t', e_name, s), loc)])
adamc@754 4475 end
adamc@754 4476 | L.DView _ => poly ()
adamc@338 4477 | L.DSequence (x, n, s) =>
adamc@338 4478 let
adamc@338 4479 val t = (L.CFfi ("Basis", "string"), loc)
adamc@338 4480 val t' = (L'.TFfi ("Basis", "string"), loc)
adam@1953 4481 val s = Settings.mangleSql s
adam@2048 4482 val e = str s
adamc@338 4483 in
adamc@338 4484 SOME (Env.pushENamed env x n t NONE s,
adamc@338 4485 fm,
adamc@338 4486 [(L'.DSequence s, loc),
adamc@338 4487 (L'.DVal (x, n, t', e, s), loc)])
adamc@338 4488 end
adamc@683 4489 | L.DDatabase _ => NONE
adamc@462 4490 | L.DCookie (x, n, t, s) =>
adamc@462 4491 let
adamc@462 4492 val t = (L.CFfi ("Basis", "string"), loc)
adamc@462 4493 val t' = (L'.TFfi ("Basis", "string"), loc)
adam@2048 4494 val e = str s
adamc@462 4495 in
adamc@462 4496 SOME (Env.pushENamed env x n t NONE s,
adamc@462 4497 fm,
adamc@725 4498 [(L'.DCookie s, loc),
adamc@725 4499 (L'.DVal (x, n, t', e, s), loc)])
adamc@462 4500 end
adamc@720 4501 | L.DStyle (x, n, s) =>
adamc@718 4502 let
adamc@718 4503 val t = (L.CFfi ("Basis", "string"), loc)
adamc@718 4504 val t' = (L'.TFfi ("Basis", "string"), loc)
adam@2048 4505 val e = strH s
adamc@718 4506 in
adamc@718 4507 SOME (Env.pushENamed env x n t NONE s,
adamc@718 4508 fm,
adamc@720 4509 [(L'.DStyle s, loc),
adamc@718 4510 (L'.DVal (x, n, t', e, s), loc)])
adamc@718 4511 end
adamc@1075 4512 | L.DTask (e1, e2) =>
adamc@1073 4513 let
adamc@1075 4514 val (e1, fm) = monoExp (env, St.empty, fm) e1
adamc@1075 4515 val (e2, fm) = monoExp (env, St.empty, fm) e2
adam@1690 4516
adam@1690 4517 val un = (L'.TRecord [], loc)
adam@1690 4518 val t = if MonoUtil.Exp.exists {typ = fn _ => false,
adam@1947 4519 exp = fn L'.EFfiApp ("Basis", "periodic", _) =>
adam@1947 4520 (if #persistent (Settings.currentProtocol ()) then
adam@1947 4521 ()
adam@1947 4522 else
adam@1947 4523 E.errorAt (#2 e1)
adam@1947 4524 ("Periodic tasks aren't allowed in the selected protocol (" ^ #name (Settings.currentProtocol ()) ^ ").");
adam@1947 4525 true)
adam@1690 4526 | _ => false} e1 then
adam@1690 4527 (L'.TFfi ("Basis", "int"), loc)
adam@1690 4528 else
adam@1690 4529 un
ziv@2055 4530
adam@1690 4531 val e2 = (L'.EAbs ("$x", t, (L'.TFun (un, un), loc),
adam@1690 4532 (L'.EAbs ("$y", un, un,
adam@1690 4533 (L'.EApp (
adam@1690 4534 (L'.EApp (e2, (L'.ERel 1, loc)), loc),
adam@1690 4535 (L'.ERel 0, loc)), loc)), loc)), loc)
adamc@1073 4536 in
adamc@1073 4537 SOME (env,
adamc@1073 4538 fm,
adamc@1075 4539 [(L'.DTask (e1, e2), loc)])
adamc@1073 4540 end
adamc@1199 4541 | L.DPolicy e =>
adamc@1199 4542 let
adamc@1240 4543 fun policies (e, fm) =
adamc@1199 4544 case #1 e of
adam@1663 4545 L.EFfiApp ("Basis", "also", [(e1, _), (e2, _)]) =>
adamc@1240 4546 let
adamc@1240 4547 val (ps1, fm) = policies (e1, fm)
adamc@1240 4548 val (ps2, fm) = policies (e2, fm)
adamc@1240 4549 in
adamc@1240 4550 (ps1 @ ps2, fm)
adamc@1240 4551 end
adamc@1240 4552 | _ =>
adamc@1240 4553 let
adamc@1240 4554 val (e, make) =
adamc@1240 4555 case #1 e of
adamc@1240 4556 L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sendClient"), _), _), _), _), _), e) =>
adamc@1240 4557 (e, L'.PolClient)
adamc@1240 4558 | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayInsert"), _), _), _), _), _), e) =>
adamc@1240 4559 (e, L'.PolInsert)
adamc@1240 4560 | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayDelete"), _), _), _), _), _), e) =>
adamc@1240 4561 (e, L'.PolDelete)
adamc@1240 4562 | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayUpdate"), _), _), _), _), _), e) =>
adamc@1240 4563 (e, L'.PolUpdate)
adam@1663 4564 | L.EFfiApp ("Basis", "sendOwnIds", [(e, _)]) =>
adamc@1240 4565 (e, L'.PolSequence)
adamc@1240 4566 | _ => (poly (); (e, L'.PolClient))
adamc@1199 4567
adamc@1240 4568 val (e, fm) = monoExp (env, St.empty, fm) e
adamc@1240 4569 in
adamc@1240 4570 ([(L'.DPolicy (make e), loc)], fm)
adamc@1240 4571 end
adamc@1240 4572
adamc@1240 4573 val (ps, fm) = policies (e, fm)
adamc@1199 4574 in
adamc@1240 4575 SOME (env, fm, ps)
adamc@1199 4576 end
adam@1294 4577 | L.DOnError n => SOME (env,
adam@1294 4578 fm,
adam@1294 4579 [(L'.DOnError n, loc)])
adamc@25 4580 end
adamc@25 4581
adamc@683 4582 datatype expungable = Client | Channel
adamc@683 4583
adamc@683 4584 fun monoize env file =
adamc@25 4585 let
adam@1287 4586 val () = pvars := RM.empty
adam@1287 4587
adamc@735 4588 (* Calculate which exported functions need cookie signature protection *)
adamc@735 4589 val rcook = foldl (fn ((d, _), rcook) =>
adamc@735 4590 case d of
adamc@1104 4591 L.DExport (L.Action L.ReadCookieWrite, n, _) => IS.add (rcook, n)
adamc@1104 4592 | L.DExport (L.Rpc L.ReadCookieWrite, n, _) => IS.add (rcook, n)
adamc@735 4593 | _ => rcook)
adamc@735 4594 IS.empty file
adamc@735 4595 val () = readCookie := rcook
adamc@735 4596
adamc@683 4597 val loc = E.dummySpan
adamc@683 4598 val client = (L'.TFfi ("Basis", "client"), loc)
adamc@683 4599 val unit = (L'.TRecord [], loc)
adamc@687 4600
adam@2048 4601 fun str s = (L'.EPrim (Prim.String (Prim.Normal, s)), loc)
adam@2048 4602 fun strH s = (L'.EPrim (Prim.String (Prim.Html, s)), loc)
adam@2048 4603
adamc@687 4604 fun calcClientish xts =
adamc@687 4605 foldl (fn ((x : L.con, t : L.con), st as (nullable, notNullable)) =>
adamc@687 4606 case #1 x of
adamc@687 4607 L.CName x =>
adamc@687 4608 (case #1 t of
adamc@687 4609 L.CFfi ("Basis", "client") =>
adamc@687 4610 (nullable, (x, Client) :: notNullable)
adamc@687 4611 | L.CApp ((L.CFfi ("Basis", "option"), _),
adamc@687 4612 (L.CFfi ("Basis", "client"), _)) =>
adamc@687 4613 ((x, Client) :: nullable, notNullable)
adamc@687 4614 | L.CApp ((L.CFfi ("Basis", "channel"), _), _) =>
adamc@687 4615 (nullable, (x, Channel) :: notNullable)
adamc@687 4616 | L.CApp ((L.CFfi ("Basis", "option"), _),
adamc@687 4617 (L.CApp ((L.CFfi ("Basis", "channel"), _), _), _)) =>
adamc@687 4618 ((x, Channel) :: nullable, notNullable)
adamc@687 4619 | _ => st)
adamc@687 4620 | _ => st) ([], []) xts
adamc@687 4621
adamc@683 4622 fun expunger () =
adamc@683 4623 let
adam@1663 4624 val target = (L'.EFfiApp ("Basis", "sqlifyClient", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "client"), loc))]), loc)
adamc@683 4625
adamc@683 4626 fun doTable (tab, xts, e) =
adamc@683 4627 case xts of
adamc@683 4628 L.CRecord (_, xts) =>
adamc@683 4629 let
adamc@687 4630 val (nullable, notNullable) = calcClientish xts
adamc@683 4631
adamc@684 4632 fun cond (x, v) =
adam@2048 4633 (L'.EStrcat (str (Settings.mangleSql x
adam@2048 4634 ^ (case v of
adam@2048 4635 Client => ""
adam@2048 4636 | Channel => " >> 32")
adam@2048 4637 ^ " = "),
adamc@684 4638 target), loc)
adamc@684 4639
adamc@684 4640 val e =
adamc@684 4641 foldl (fn ((x, v), e) =>
adamc@684 4642 (L'.ESeq (
adam@1293 4643 (L'.EDml ((L'.EStrcat (
adam@2048 4644 str ("UPDATE "
adam@2048 4645 ^ Settings.mangleSql tab
adam@2048 4646 ^ " SET "
adam@2048 4647 ^ Settings.mangleSql x
adam@2048 4648 ^ " = NULL WHERE "),
adam@1293 4649 cond (x, v)), loc), L'.Error), loc),
adamc@684 4650 e), loc))
adamc@684 4651 e nullable
adamc@684 4652
adamc@683 4653 val e =
adamc@683 4654 case notNullable of
adamc@683 4655 [] => e
adamc@683 4656 | eb :: ebs =>
adamc@684 4657 (L'.ESeq (
adamc@684 4658 (L'.EDml (foldl
adamc@684 4659 (fn (eb, s) =>
adamc@684 4660 (L'.EStrcat (s,
adam@2048 4661 (L'.EStrcat (str " OR ",
adamc@684 4662 cond eb), loc)), loc))
adam@2048 4663 (L'.EStrcat (str ("DELETE FROM "
adam@2048 4664 ^ Settings.mangleSql tab
adam@2048 4665 ^ " WHERE "),
adamc@684 4666 cond eb), loc)
adam@1293 4667 ebs, L'.Error), loc),
adamc@684 4668 e), loc)
adamc@683 4669 in
adamc@683 4670 e
adamc@683 4671 end
adamc@683 4672 | _ => e
adamc@683 4673
adamc@683 4674 val e = (L'.ERecord [], loc)
adamc@683 4675 in
adamc@683 4676 foldl (fn ((d, _), e) =>
adamc@683 4677 case d of
adamc@707 4678 L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e)
adamc@683 4679 | _ => e) e file
adamc@683 4680 end
adamc@683 4681
adamc@687 4682 fun initializer () =
adamc@687 4683 let
adamc@687 4684 fun doTable (tab, xts, e) =
adamc@687 4685 case xts of
adamc@687 4686 L.CRecord (_, xts) =>
adamc@687 4687 let
adamc@687 4688 val (nullable, notNullable) = calcClientish xts
adamc@687 4689
adamc@687 4690 val e =
adamc@687 4691 case nullable of
adamc@687 4692 [] => e
adamc@687 4693 | (x, _) :: ebs =>
adamc@687 4694 (L'.ESeq (
adam@2048 4695 (L'.EDml (str
adam@2048 4696 (foldl (fn ((x, _), s) =>
adam@2048 4697 s ^ ", " ^ Settings.mangleSql x ^ " = NULL")
istvan@2133 4698 ("UPDATE "
istvan@2133 4699 ^ Settings.mangleSql tab
adam@2048 4700 ^ " SET "
adam@2048 4701 ^ Settings.mangleSql x
adam@1293 4702 ^ " = NULL")
adam@2048 4703 ebs), L'.Error), loc),
adamc@687 4704 e), loc)
adamc@687 4705
adamc@687 4706 val e =
adamc@687 4707 case notNullable of
adamc@687 4708 [] => e
adamc@687 4709 | eb :: ebs =>
adamc@687 4710 (L'.ESeq (
adam@2048 4711 (L'.EDml (str ("DELETE FROM "
adam@2048 4712 ^ Settings.mangleSql tab), L'.Error), loc),
adamc@687 4713 e), loc)
adamc@687 4714 in
adamc@687 4715 e
adamc@687 4716 end
adamc@687 4717 | _ => e
adamc@687 4718
adamc@687 4719 val e = (L'.ERecord [], loc)
adamc@687 4720 in
adamc@687 4721 foldl (fn ((d, _), e) =>
adamc@687 4722 case d of
adamc@707 4723 L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e)
adamc@687 4724 | _ => e) e file
adamc@687 4725 end
adamc@687 4726
adam@1287 4727 val mname = CoreUtil.File.maxName file + 1
adam@1287 4728 val () = nextPvar := mname
adam@1287 4729
adamc@179 4730 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
adamc@683 4731 case #1 d of
adamc@683 4732 L.DDatabase s =>
adamc@683 4733 let
adamc@687 4734 val (nExp, fm) = Fm.freshName fm
adamc@687 4735 val (nIni, fm) = Fm.freshName fm
adam@1682 4736
adamc@687 4737 val dExp = L'.DVal ("expunger",
adamc@687 4738 nExp,
adamc@687 4739 (L'.TFun (client, unit), loc),
adamc@687 4740 (L'.EAbs ("cli", client, unit, expunger ()), loc),
adamc@687 4741 "expunger")
adamc@687 4742 val dIni = L'.DVal ("initializer",
adamc@687 4743 nIni,
adamc@687 4744 (L'.TFun (unit, unit), loc),
adamc@687 4745 (L'.EAbs ("_", unit, unit, initializer ()), loc),
adamc@687 4746 "initializer")
adamc@683 4747 in
adamc@687 4748 (env, Fm.enter fm, (L'.DDatabase {name = s,
adamc@687 4749 expunge = nExp,
adamc@687 4750 initialize = nIni}, loc)
adamc@687 4751 :: (dExp, loc)
adamc@687 4752 :: (dIni, loc)
adamc@683 4753 :: ds)
adamc@683 4754 end
adamc@683 4755 | _ =>
adam@1287 4756 (pvarDefs := [];
adam@1288 4757 pvarOldDefs := [];
adam@1287 4758 case monoDecl (env, fm) d of
adam@1287 4759 NONE => (env, fm, ds)
adam@1287 4760 | SOME (env, fm, ds') =>
adam@1288 4761 (foldr (fn ((n, cs), env) =>
adam@1288 4762 Env.declBinds env (L.DDatatype [("$poly" ^ Int.toString n,
adam@1288 4763 n,
adam@1288 4764 [],
adam@1288 4765 cs)], loc))
adam@1288 4766 env (!pvarOldDefs),
adam@1287 4767 Fm.enter fm,
adam@1713 4768 case ds' of
adam@1713 4769 [(L'.DDatatype dts, loc)] =>
adam@1713 4770 (L'.DDatatype (dts @ !pvarDefs), loc) :: Fm.decls fm @ ds
adam@1713 4771 | _ =>
adam@1713 4772 ds' @ Fm.decls fm @ (L'.DDatatype (!pvarDefs), loc) :: ds)))
adam@1287 4773 (env, Fm.empty mname, []) file
adamc@25 4774 in
adam@1287 4775 pvars := RM.empty;
adam@1287 4776 pvarDefs := [];
adam@1288 4777 pvarOldDefs := [];
adam@1845 4778 (rev ds, [])
adamc@25 4779 end
adamc@25 4780
adamc@25 4781 end