Mercurial > urweb

annotate src/monoize.sml @ 2307:6ae9a2784a45

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