Mercurial > urweb

annotate src/monoize.sml @ 1775:6bc2a8cb3a67

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