Mercurial > urweb

annotate src/jscomp.sml @ 1260:25ebd8c4fafb

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Thunking recursive JavaScripted function ASTs, to reduce page load time dramatically
author Adam Chlipala <adamc@hcoop.net>
date Sat, 22 May 2010 14:09:06 -0400
parents 78b36c50daf9
children 003df929ee08
rev   line source
adamc@1177 1 (* Copyright (c) 2008-2010, Adam Chlipala
adamc@567 2 * All rights reserved.
adamc@567 3 *
adamc@567 4 * Redistribution and use in source and binary forms, with or without
adamc@567 5 * modification, are permitted provided that the following conditions are met:
adamc@567 6 *
adamc@567 7 * - Redistributions of source code must retain the above copyright notice,
adamc@567 8 * this list of conditions and the following disclaimer.
adamc@567 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@567 10 * this list of conditions and the following disclaimer in the documentation
adamc@567 11 * and/or other materials provided with the distribution.
adamc@567 12 * - The names of contributors may not be used to endorse or promote products
adamc@567 13 * derived from this software without specific prior written permission.
adamc@567 14 *
adamc@567 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@567 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@567 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@567 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@567 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@567 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@567 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@567 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@567 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@567 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@567 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@567 26 *)
adamc@567 27
adamc@567 28 structure JsComp :> JSCOMP = struct
adamc@567 29
adamc@567 30 open Mono
adamc@567 31
adamc@567 32 structure EM = ErrorMsg
adamc@567 33 structure E = MonoEnv
adamc@567 34 structure U = MonoUtil
adamc@567 35
adamc@589 36 structure IS = IntBinarySet
adamc@589 37 structure IM = IntBinaryMap
adamc@589 38
adamc@800 39 structure TM = BinaryMapFn(struct
adamc@800 40 type ord_key = typ
adamc@800 41 val compare = U.Typ.compare
adamc@800 42 end)
adamc@800 43
adamc@567 44 type state = {
adamc@840 45 decls : (string * int * (string * int * typ option) list) list,
adamc@589 46 script : string list,
adamc@595 47 included : IS.set,
adamc@595 48 injectors : int IM.map,
adamc@800 49 listInjectors : int TM.map,
adamc@638 50 decoders : int IM.map,
adamc@595 51 maxName : int
adamc@567 52 }
adamc@567 53
adamc@568 54 fun strcat loc es =
adamc@568 55 case es of
adamc@568 56 [] => (EPrim (Prim.String ""), loc)
adamc@568 57 | [x] => x
adamc@568 58 | x :: es' => (EStrcat (x, strcat loc es'), loc)
adamc@568 59
adamc@815 60 exception CantEmbed of typ
adamc@815 61
adamc@970 62 fun inString {needle, haystack} = String.isSubstring needle haystack
adamc@847 63
adamc@589 64 fun process file =
adamc@567 65 let
adamc@596 66 val (someTs, nameds) =
adamc@596 67 foldl (fn ((DVal (_, n, t, e, _), _), (someTs, nameds)) => (someTs, IM.insert (nameds, n, e))
adamc@596 68 | ((DValRec vis, _), (someTs, nameds)) =>
adamc@596 69 (someTs, foldl (fn ((_, n, _, e, _), nameds) => IM.insert (nameds, n, e))
adamc@596 70 nameds vis)
adamc@808 71 | ((DDatatype dts, _), state as (someTs, nameds)) =>
adamc@808 72 (foldl (fn ((_, _, cs), someTs) =>
adamc@808 73 if ElabUtil.classifyDatatype cs = Option then
adamc@808 74 foldl (fn ((_, n, SOME t), someTs) => IM.insert (someTs, n, t)
adamc@808 75 | (_, someTs) => someTs) someTs cs
adamc@808 76 else
adamc@808 77 someTs) someTs dts,
adamc@808 78 nameds)
adamc@595 79 | (_, state) => state)
adamc@596 80 (IM.empty, IM.empty) file
adamc@567 81
adamc@590 82 fun str loc s = (EPrim (Prim.String s), loc)
adamc@590 83
adamc@594 84 fun isNullable (t, _) =
adamc@594 85 case t of
adamc@594 86 TOption _ => true
adamc@841 87 | TList _ => true
adamc@841 88 | TDatatype (_, ref (Option, _)) => true
adamc@594 89 | TRecord [] => true
adamc@594 90 | _ => false
adamc@594 91
adamc@593 92 fun quoteExp loc (t : typ) (e, st) =
adamc@590 93 case #1 t of
adamc@593 94 TSource => (strcat loc [str loc "s",
adamc@593 95 (EFfiApp ("Basis", "htmlifyInt", [e]), loc)], st)
adamc@590 96
adamc@593 97 | TRecord [] => (str loc "null", st)
adamc@593 98 | TRecord [(x, t)] =>
adamc@593 99 let
adamc@593 100 val (e, st) = quoteExp loc t ((EField (e, x), loc), st)
adamc@593 101 in
adamc@593 102 (strcat loc [str loc ("{_" ^ x ^ ":"),
adamc@593 103 e,
adamc@593 104 str loc "}"], st)
adamc@593 105 end
adamc@593 106 | TRecord ((x, t) :: xts) =>
adamc@593 107 let
adamc@593 108 val (e', st) = quoteExp loc t ((EField (e, x), loc), st)
adamc@593 109 val (es, st) = ListUtil.foldlMap
adamc@593 110 (fn ((x, t), st) =>
adamc@593 111 let
adamc@593 112 val (e, st) = quoteExp loc t ((EField (e, x), loc), st)
adamc@593 113 in
adamc@593 114 (strcat loc [str loc (",_" ^ x ^ ":"), e], st)
adamc@593 115 end)
adamc@593 116 st xts
adamc@593 117 in
adamc@593 118 (strcat loc (str loc ("{_" ^ x ^ ":")
adamc@593 119 :: e'
adamc@593 120 :: es
adamc@593 121 @ [str loc "}"]), st)
adamc@593 122 end
adamc@590 123
adamc@593 124 | TFfi ("Basis", "string") => ((EFfiApp ("Basis", "jsifyString", [e]), loc), st)
adamc@1025 125 | TFfi ("Basis", "char") => ((EFfiApp ("Basis", "jsifyChar", [e]), loc), st)
adamc@593 126 | TFfi ("Basis", "int") => ((EFfiApp ("Basis", "htmlifyInt", [e]), loc), st)
adamc@593 127 | TFfi ("Basis", "float") => ((EFfiApp ("Basis", "htmlifyFloat", [e]), loc), st)
adamc@682 128 | TFfi ("Basis", "channel") => ((EFfiApp ("Basis", "jsifyChannel", [e]), loc), st)
adamc@593 129
adamc@593 130 | TFfi ("Basis", "bool") => ((ECase (e,
adamc@593 131 [((PCon (Enum, PConFfi {mod = "Basis",
adamc@593 132 datatyp = "bool",
adamc@593 133 con = "True",
adamc@593 134 arg = NONE}, NONE), loc),
adamc@593 135 str loc "true"),
adamc@593 136 ((PCon (Enum, PConFfi {mod = "Basis",
adamc@593 137 datatyp = "bool",
adamc@593 138 con = "False",
adamc@593 139 arg = NONE}, NONE), loc),
adamc@593 140 str loc "false")],
adamc@593 141 {disc = (TFfi ("Basis", "bool"), loc),
adamc@593 142 result = (TFfi ("Basis", "string"), loc)}), loc),
adamc@593 143 st)
adamc@592 144
adamc@594 145 | TOption t =>
adamc@594 146 let
adamc@594 147 val (e', st) = quoteExp loc t ((ERel 0, loc), st)
adamc@594 148 in
adamc@813 149 (case #1 e' of
adamc@813 150 EPrim (Prim.String "ERROR") => raise Fail "UHOH"
adamc@813 151 | _ =>
adamc@813 152 (ECase (e,
adamc@813 153 [((PNone t, loc),
adamc@813 154 str loc "null"),
adamc@813 155 ((PSome (t, (PVar ("x", t), loc)), loc),
adamc@813 156 if isNullable t then
adamc@813 157 strcat loc [str loc "{v:", e', str loc "}"]
adamc@813 158 else
adamc@813 159 e')],
adamc@813 160 {disc = (TOption t, loc),
adamc@813 161 result = (TFfi ("Basis", "string"), loc)}), loc),
adamc@594 162 st)
adamc@594 163 end
adamc@594 164
adamc@800 165 | TList t' =>
adamc@800 166 (case TM.find (#listInjectors st, t') of
adamc@800 167 SOME n' => ((EApp ((ENamed n', loc), e), loc), st)
adamc@800 168 | NONE =>
adamc@800 169 let
adamc@800 170 val rt = (TRecord [("1", t'), ("2", t)], loc)
adamc@800 171
adamc@800 172 val n' = #maxName st
adamc@800 173 val st = {decls = #decls st,
adamc@800 174 script = #script st,
adamc@800 175 included = #included st,
adamc@800 176 injectors = #injectors st,
adamc@800 177 listInjectors = TM.insert (#listInjectors st, t', n'),
adamc@800 178 decoders = #decoders st,
adamc@800 179 maxName = n' + 1}
adamc@800 180
adamc@800 181 val s = (TFfi ("Basis", "string"), loc)
adamc@801 182 val (e', st) = quoteExp loc t' ((EField ((ERel 0, loc), "1"), loc), st)
adamc@800 183
adamc@800 184 val body = (ECase ((ERel 0, loc),
adamc@800 185 [((PNone rt, loc),
adamc@800 186 str loc "null"),
adamc@800 187 ((PSome (rt, (PVar ("x", rt), loc)), loc),
adamc@911 188 strcat loc [str loc ((if isNullable t' then
adamc@911 189 "{v:"
adamc@911 190 else
adamc@911 191 "") ^ "{_1:"),
adamc@800 192 e',
adamc@800 193 str loc ",_2:",
adamc@800 194 (EApp ((ENamed n', loc),
adamc@800 195 (EField ((ERel 0, loc), "2"), loc)), loc),
adamc@911 196 str loc ((if isNullable t' then
adamc@911 197 "}"
adamc@911 198 else
adamc@911 199 "") ^ "}")])],
adamc@800 200 {disc = t, result = s}), loc)
adamc@800 201 val body = (EAbs ("x", t, s, body), loc)
adamc@800 202
adamc@840 203 val st = {decls = ("jsify", n', (TFun (t, s), loc),
adamc@840 204 body, "jsify") :: #decls st,
adamc@800 205 script = #script st,
adamc@800 206 included = #included st,
adamc@800 207 injectors = #injectors st,
adamc@800 208 listInjectors = #listInjectors st,
adamc@800 209 decoders= #decoders st,
adamc@800 210 maxName = #maxName st}
adamc@800 211
adamc@800 212
adamc@800 213 in
adamc@800 214 ((EApp ((ENamed n', loc), e), loc), st)
adamc@800 215 end)
adamc@800 216
adamc@595 217 | TDatatype (n, ref (dk, cs)) =>
adamc@595 218 (case IM.find (#injectors st, n) of
adamc@595 219 SOME n' => ((EApp ((ENamed n', loc), e), loc), st)
adamc@595 220 | NONE =>
adamc@595 221 let
adamc@595 222 val n' = #maxName st
adamc@595 223 val st = {decls = #decls st,
adamc@595 224 script = #script st,
adamc@595 225 included = #included st,
adamc@595 226 injectors = IM.insert (#injectors st, n, n'),
adamc@800 227 listInjectors = #listInjectors st,
adamc@638 228 decoders = #decoders st,
adamc@595 229 maxName = n' + 1}
adamc@595 230
adamc@595 231 val (pes, st) = ListUtil.foldlMap
adamc@595 232 (fn ((_, cn, NONE), st) =>
adamc@595 233 (((PCon (dk, PConVar cn, NONE), loc),
adamc@596 234 case dk of
adamc@596 235 Option => str loc "null"
adamc@596 236 | _ => str loc (Int.toString cn)),
adamc@595 237 st)
adamc@595 238 | ((_, cn, SOME t), st) =>
adamc@595 239 let
adamc@595 240 val (e, st) = quoteExp loc t ((ERel 0, loc), st)
adamc@595 241 in
adamc@595 242 (((PCon (dk, PConVar cn, SOME (PVar ("x", t), loc)), loc),
adamc@596 243 case dk of
adamc@596 244 Option =>
adamc@596 245 if isNullable t then
adamc@638 246 strcat loc [str loc "{v:",
adamc@596 247 e,
adamc@596 248 str loc "}"]
adamc@596 249 else
adamc@596 250 e
adamc@597 251 | _ => strcat loc [str loc ("{n:" ^ Int.toString cn
adamc@597 252 ^ ",v:"),
adamc@597 253 e,
adamc@597 254 str loc "}"]),
adamc@595 255 st)
adamc@595 256 end)
adamc@595 257 st cs
adamc@595 258
adamc@595 259 val s = (TFfi ("Basis", "string"), loc)
adamc@595 260 val body = (ECase ((ERel 0, loc), pes,
adamc@595 261 {disc = t, result = s}), loc)
adamc@595 262 val body = (EAbs ("x", t, s, body), loc)
adamc@595 263
adamc@840 264 val st = {decls = ("jsify", n', (TFun (t, s), loc),
adamc@840 265 body, "jsify") :: #decls st,
adamc@595 266 script = #script st,
adamc@595 267 included = #included st,
adamc@595 268 injectors = #injectors st,
adamc@800 269 listInjectors = #listInjectors st,
adamc@638 270 decoders= #decoders st,
adamc@595 271 maxName = #maxName st}
adamc@595 272 in
adamc@595 273 ((EApp ((ENamed n', loc), e), loc), st)
adamc@595 274 end)
adamc@595 275
adamc@834 276 | _ => ((*Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];*)
adamc@834 277 raise CantEmbed t)
adamc@590 278
adamc@613 279 fun unurlifyExp loc (t : typ, st) =
adamc@613 280 case #1 t of
adamc@613 281 TRecord [] => ("null", st)
adamc@910 282 | TFfi ("Basis", "unit") => ("null", st)
adamc@613 283 | TRecord [(x, t)] =>
adamc@613 284 let
adamc@613 285 val (e, st) = unurlifyExp loc (t, st)
adamc@613 286 in
adamc@613 287 ("{_" ^ x ^ ":" ^ e ^ "}",
adamc@613 288 st)
adamc@613 289 end
adamc@613 290 | TRecord ((x, t) :: xts) =>
adamc@613 291 let
adamc@613 292 val (e', st) = unurlifyExp loc (t, st)
adamc@613 293 val (es, st) = ListUtil.foldlMap
adamc@638 294 (fn ((x, t), st) =>
adamc@638 295 let
adamc@638 296 val (e, st) = unurlifyExp loc (t, st)
adamc@638 297 in
adamc@638 298 (",_" ^ x ^ ":" ^ e, st)
adamc@638 299 end)
adamc@638 300 st xts
adamc@613 301 in
adamc@613 302 (String.concat ("{_"
adamc@613 303 :: x
adamc@613 304 :: ":"
adamc@613 305 :: e'
adamc@613 306 :: es
adamc@613 307 @ ["}"]), st)
adamc@613 308 end
adamc@613 309
adamc@679 310 | TFfi ("Basis", "string") => ("uu(t[i++])", st)
adamc@1025 311 | TFfi ("Basis", "char") => ("uu(t[i++])", st)
adamc@613 312 | TFfi ("Basis", "int") => ("parseInt(t[i++])", st)
adamc@613 313 | TFfi ("Basis", "float") => ("parseFloat(t[i++])", st)
adamc@682 314 | TFfi ("Basis", "channel") => ("(t[i++].length > 0 ? parseInt(t[i]) : null)", st)
adamc@613 315
adamc@912 316 | TFfi ("Basis", "bool") => ("t[i++] == \"1\"", st)
adamc@613 317
adamc@638 318 | TOption t =>
adamc@613 319 let
adamc@638 320 val (e, st) = unurlifyExp loc (t, st)
adamc@638 321 val e = if isNullable t then
adamc@638 322 "{v:" ^ e ^ "}"
adamc@638 323 else
adamc@638 324 e
adamc@613 325 in
adamc@703 326 ("(t[i++]==\"Some\"?" ^ e ^ ":null)", st)
adamc@638 327 end
adamc@613 328
adamc@905 329 | TList t =>
adamc@905 330 let
adamc@905 331 val (e, st) = unurlifyExp loc (t, st)
adamc@905 332 in
adamc@905 333 ("uul(function(){return t[i++];},function(){return " ^ e ^ "})", st)
adamc@905 334 end
adamc@905 335
adamc@638 336 | TDatatype (n, ref (dk, cs)) =>
adamc@638 337 (case IM.find (#decoders st, n) of
adamc@638 338 SOME n' => ("(tmp=_n" ^ Int.toString n' ^ "(t,i),i=tmp._1,tmp._2)", st)
adamc@613 339 | NONE =>
adamc@613 340 let
adamc@613 341 val n' = #maxName st
adamc@613 342 val st = {decls = #decls st,
adamc@613 343 script = #script st,
adamc@613 344 included = #included st,
adamc@638 345 injectors = #injectors st,
adamc@800 346 listInjectors = #listInjectors st,
adamc@638 347 decoders = IM.insert (#decoders st, n, n'),
adamc@613 348 maxName = n' + 1}
adamc@613 349
adamc@638 350 val (e, st) = foldl (fn ((x, cn, NONE), (e, st)) =>
adamc@638 351 ("x==\"" ^ x ^ "\"?"
adamc@638 352 ^ (case dk of
adamc@638 353 Option => "null"
adamc@638 354 | _ => Int.toString cn)
adamc@638 355 ^ ":" ^ e,
adamc@613 356 st)
adamc@638 357 | ((x, cn, SOME t), (e, st)) =>
adamc@613 358 let
adamc@638 359 val (e', st) = unurlifyExp loc (t, st)
adamc@613 360 in
adamc@638 361 ("x==\"" ^ x ^ "\"?"
adamc@638 362 ^ (case dk of
adamc@638 363 Option =>
adamc@638 364 if isNullable t then
adamc@638 365 "{v:" ^ e' ^ "}"
adamc@638 366 else
adamc@638 367 e'
adamc@638 368 | _ => "{n:" ^ Int.toString cn ^ ",v:" ^ e' ^ "}")
adamc@638 369 ^ ":" ^ e,
adamc@613 370 st)
adamc@613 371 end)
adamc@810 372 ("pf(\"" ^ ErrorMsg.spanToString loc ^ "\")", st) cs
adamc@613 373
adamc@638 374 val body = "function _n" ^ Int.toString n' ^ "(t,i){var x=t[i++];var r="
adamc@638 375 ^ e ^ ";return {_1:i,_2:r}}\n\n"
adamc@613 376
adamc@638 377 val st = {decls = #decls st,
adamc@638 378 script = body :: #script st,
adamc@613 379 included = #included st,
adamc@613 380 injectors = #injectors st,
adamc@800 381 listInjectors = #listInjectors st,
adamc@638 382 decoders = #decoders st,
adamc@613 383 maxName = #maxName st}
adamc@613 384 in
adamc@638 385 ("(tmp=_n" ^ Int.toString n' ^ "(t,i),i=tmp._1,tmp._2)", st)
adamc@638 386 end)
adamc@613 387
adamc@613 388 | _ => (EM.errorAt loc "Don't know how to unurlify type in JavaScript";
adamc@613 389 Print.prefaces "Can't unurlify" [("t", MonoPrint.p_typ MonoEnv.empty t)];
adamc@613 390 ("ERROR", st))
adamc@613 391
adamc@646 392 fun padWith (ch, s, len) =
adamc@646 393 if size s < len then
adamc@646 394 padWith (ch, String.str ch ^ s, len - 1)
adamc@646 395 else
adamc@646 396 s
adamc@646 397
adamc@794 398 val foundJavaScript = ref false
adamc@794 399
adamc@800 400 fun jsExp mode outer =
adamc@567 401 let
adamc@589 402 val len = length outer
adamc@567 403
adamc@589 404 fun jsE inner (e as (_, loc), st) =
adamc@589 405 let
adamc@590 406 val str = str loc
adamc@567 407
adamc@589 408 fun patCon pc =
adamc@589 409 case pc of
adamc@589 410 PConVar n => str (Int.toString n)
adamc@589 411 | PConFfi {mod = "Basis", con = "True", ...} => str "true"
adamc@589 412 | PConFfi {mod = "Basis", con = "False", ...} => str "false"
adamc@970 413 | PConFfi {con, ...} => str ("\"" ^ con ^ "\"")
adamc@567 414
adamc@591 415 fun unsupported s =
adamc@591 416 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript[2]");
adamc@910 417 Print.preface ("Code", MonoPrint.p_exp MonoEnv.empty e);
adamc@591 418 (str "ERROR", st))
adamc@577 419
adamc@589 420 val strcat = strcat loc
adamc@584 421
adamc@589 422 fun jsPrim p =
adamc@943 423 let
adamc@943 424 fun jsChar ch =
adamc@943 425 case ch of
adamc@943 426 #"'" =>
adamc@943 427 if mode = Attribute then
adamc@943 428 "\\047"
adamc@943 429 else
adamc@943 430 "'"
adamc@943 431 | #"\"" => "\\\""
adamc@943 432 | #"<" => "\\074"
adamc@943 433 | #"\\" => "\\\\"
adamc@943 434 | #"\n" => "\\n"
adamc@943 435 | #"\r" => "\\r"
adamc@943 436 | #"\t" => "\\t"
adamc@943 437 | ch =>
adamc@943 438 if Char.isPrint ch then
adamc@943 439 String.str ch
adamc@943 440 else
adamc@943 441 "\\" ^ padWith (#"0",
adamc@943 442 Int.fmt StringCvt.OCT (ord ch),
adamc@943 443 3)
adamc@943 444 in
adamc@943 445 case p of
adamc@943 446 Prim.String s =>
adamc@943 447 str ("\"" ^ String.translate jsChar s ^ "\"")
adamc@1176 448 | Prim.Char ch => str ("\"" ^ jsChar ch ^ "\"")
adamc@943 449 | _ => str (Prim.toString p)
adamc@943 450 end
adamc@589 451
adamc@970 452 fun jsPat (p, _) =
adamc@589 453 case p of
adamc@970 454 PWild => str "{c:\"w\"}"
adamc@970 455 | PVar _ => str "{c:\"v\"}"
adamc@970 456 | PPrim p => strcat [str "{c:\"c\",v:",
adamc@589 457 jsPrim p,
adamc@970 458 str "}"]
adamc@589 459 | PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE) =>
adamc@970 460 str "{c:\"c\",v:true}"
adamc@589 461 | PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE) =>
adamc@970 462 str "{c:\"c\",v:false}"
adamc@596 463 | PCon (Option, _, NONE) =>
adamc@970 464 str "{c:\"c\",v:null}"
adamc@596 465 | PCon (Option, PConVar n, SOME p) =>
adamc@596 466 (case IM.find (someTs, n) of
adamc@596 467 NONE => raise Fail "Jscomp: Not in someTs"
adamc@974 468 | SOME t =>
adamc@974 469 strcat [str ("{c:\"s\",n:"
adamc@974 470 ^ (if isNullable t then
adamc@974 471 "true"
adamc@974 472 else
adamc@974 473 "false")
adamc@974 474 ^ ",p:"),
adamc@974 475 jsPat p,
adamc@974 476 str "}"])
adamc@974 477 | PCon (_, pc, NONE) => strcat [str "{c:\"c\",v:",
adamc@970 478 patCon pc,
adamc@970 479 str "}"]
adamc@970 480 | PCon (_, pc, SOME p) => strcat [str "{c:\"1\",n:",
adamc@970 481 patCon pc,
adamc@970 482 str ",p:",
adamc@970 483 jsPat p,
adamc@970 484 str "}"]
adamc@970 485 | PRecord xps => strcat [str "{c:\"r\",l:",
adamc@970 486 foldr (fn ((x, p, _), e) =>
adamc@970 487 strcat [str ("cons({n:\"" ^ x ^ "\",p:"),
adamc@970 488 jsPat p,
adamc@970 489 str "},",
adamc@970 490 e,
adamc@970 491 str ")"])
adamc@970 492 (str "null") xps,
adamc@970 493 str "}"]
adamc@970 494 | PNone _ => str "{c:\"c\",v:null}"
adamc@970 495 | PSome (t, p) => strcat [str ("{c:\"s\",n:"
adamc@829 496 ^ (if isNullable t then
adamc@970 497 "true"
adamc@829 498 else
adamc@970 499 "false")
adamc@970 500 ^ ",p:"),
adamc@970 501 jsPat p,
adamc@970 502 str "}"]
adamc@589 503
adamc@601 504 val jsifyString = String.translate (fn #"\"" => "\\\""
adamc@601 505 | #"\\" => "\\\\"
adamc@601 506 | ch => String.str ch)
adamc@601 507
adamc@601 508 fun jsifyStringMulti (n, s) =
adamc@601 509 case n of
adamc@601 510 0 => s
adamc@601 511 | _ => jsifyStringMulti (n - 1, jsifyString s)
adamc@601 512
adamc@601 513 fun deStrcat level (all as (e, _)) =
adamc@589 514 case e of
adamc@601 515 EPrim (Prim.String s) => jsifyStringMulti (level, s)
adamc@601 516 | EStrcat (e1, e2) => deStrcat level e1 ^ deStrcat level e2
adamc@601 517 | EFfiApp ("Basis", "jsifyString", [e]) => "\"" ^ deStrcat (level + 1) e ^ "\""
adamc@601 518 | _ => (Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)];
adamc@601 519 raise Fail "Jscomp: deStrcat")
adamc@590 520
adamc@590 521 val quoteExp = quoteExp loc
adamc@567 522 in
adamc@801 523 (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e),
adamc@801 524 ("inner", Print.PD.string (Int.toString inner))];*)
adamc@590 525
adamc@589 526 case #1 e of
adamc@970 527 EPrim p => (strcat [str "{c:\"c\",v:",
adamc@970 528 jsPrim p,
adamc@970 529 str "}"],
adamc@970 530 st)
adamc@589 531 | ERel n =>
adamc@589 532 if n < inner then
adamc@970 533 (str ("{c:\"v\",n:" ^ Int.toString n ^ "}"), st)
adamc@589 534 else
adamc@589 535 let
adamc@589 536 val n = n - inner
adamc@813 537 (*val () = Print.prefaces "quote" [("t", MonoPrint.p_typ MonoEnv.empty
adamc@813 538 (List.nth (outer, n)))]*)
adamc@970 539 val (e, st) = quoteExp (List.nth (outer, n)) ((ERel n, loc), st)
adamc@589 540 in
adamc@970 541 (strcat [str "{c:\"c\",v:",
adamc@970 542 e,
adamc@970 543 str "}"], st)
adamc@589 544 end
adamc@567 545
adamc@589 546 | ENamed n =>
adamc@589 547 let
adamc@589 548 val st =
adamc@589 549 if IS.member (#included st, n) then
adamc@589 550 st
adamc@589 551 else
adamc@589 552 case IM.find (nameds, n) of
adamc@589 553 NONE => raise Fail "Jscomp: Unbound ENamed"
adamc@589 554 | SOME e =>
adamc@589 555 let
adamc@589 556 val st = {decls = #decls st,
adamc@589 557 script = #script st,
adamc@595 558 included = IS.add (#included st, n),
adamc@595 559 injectors = #injectors st,
adamc@800 560 listInjectors = #listInjectors st,
adamc@638 561 decoders = #decoders st,
adamc@595 562 maxName = #maxName st}
adamc@578 563
adamc@801 564 val old = e
adamc@970 565 val (e, st) = jsExp mode [] (e, st)
adamc@601 566 val e = deStrcat 0 e
adamc@589 567
adamc@1260 568 val sc = "urfuncs[" ^ Int.toString n ^ "] = {c:\"t\",f:function(){return "
adamc@1260 569 ^ e ^ "}};\n"
adamc@589 570 in
adamc@801 571 (*Print.prefaces "jsify'" [("old", MonoPrint.p_exp MonoEnv.empty old),
adamc@801 572 ("new", MonoPrint.p_exp MonoEnv.empty new)];*)
adamc@589 573 {decls = #decls st,
adamc@589 574 script = sc :: #script st,
adamc@595 575 included = #included st,
adamc@595 576 injectors = #injectors st,
adamc@800 577 listInjectors = #listInjectors st,
adamc@638 578 decoders= #decoders st,
adamc@595 579 maxName = #maxName st}
adamc@589 580 end
adamc@589 581 in
adamc@970 582 (str ("{c:\"n\",n:" ^ Int.toString n ^ "}"), st)
adamc@589 583 end
adamc@589 584
adamc@970 585 | ECon (Option, _, NONE) => (str "{c:\"c\",v:null}", st)
adamc@596 586 | ECon (Option, PConVar n, SOME e) =>
adamc@596 587 let
adamc@596 588 val (e, st) = jsE inner (e, st)
adamc@596 589 in
adamc@596 590 case IM.find (someTs, n) of
adamc@596 591 NONE => raise Fail "Jscomp: Not in someTs [2]"
adamc@596 592 | SOME t =>
adamc@596 593 (if isNullable t then
adamc@970 594 strcat [str "{c:\"s\",v:",
adamc@596 595 e,
adamc@596 596 str "}"]
adamc@596 597 else
adamc@596 598 e, st)
adamc@596 599 end
adamc@596 600
adamc@970 601 | ECon (_, pc, NONE) => (strcat [str "{c:\"c\",v:",
adamc@970 602 patCon pc,
adamc@970 603 str "}"],
adamc@970 604 st)
adamc@589 605 | ECon (_, pc, SOME e) =>
adamc@589 606 let
adamc@589 607 val (s, st) = jsE inner (e, st)
adamc@589 608 in
adamc@970 609 (strcat [str "{c:\"1\",n:",
adamc@589 610 patCon pc,
adamc@589 611 str ",v:",
adamc@589 612 s,
adamc@589 613 str "}"], st)
adamc@589 614 end
adamc@596 615
adamc@970 616 | ENone _ => (str "{c:\"c\",v:null}", st)
adamc@589 617 | ESome (t, e) =>
adamc@572 618 let
adamc@572 619 val (e, st) = jsE inner (e, st)
adamc@572 620 in
adamc@589 621 (if isNullable t then
adamc@970 622 strcat [str "{c:\"s\",v:", e, str "}"]
adamc@589 623 else
adamc@589 624 e, st)
adamc@589 625 end
adamc@589 626
adamc@589 627 | EFfi k =>
adamc@589 628 let
adamc@765 629 val name = case Settings.jsFunc k of
adamc@589 630 NONE => (EM.errorAt loc ("Unsupported FFI identifier " ^ #2 k
adamc@589 631 ^ " in JavaScript");
adamc@589 632 "ERROR")
adamc@589 633 | SOME s => s
adamc@589 634 in
adamc@970 635 (str ("{c:\"c\",v:" ^ name ^ "}"), st)
adamc@589 636 end
adamc@970 637 | EFfiApp ("Basis", "sigString", [_]) => (strcat [str "{c:\"c\",v:\"",
adamc@970 638 e,
adamc@970 639 str "\"}"], st)
adamc@589 640 | EFfiApp (m, x, args) =>
adamc@589 641 let
adamc@765 642 val name = case Settings.jsFunc (m, x) of
adamc@589 643 NONE => (EM.errorAt loc ("Unsupported FFI function "
adamc@589 644 ^ x ^ " in JavaScript");
adamc@589 645 "ERROR")
adamc@589 646 | SOME s => s
adamc@970 647
adamc@970 648 val (e, st) = foldr (fn (e, (acc, st)) =>
adamc@970 649 let
adamc@970 650 val (e, st) = jsE inner (e, st)
adamc@970 651 in
adamc@970 652 (strcat [str "cons(",
adamc@970 653 e,
adamc@970 654 str ",",
adamc@970 655 acc,
adamc@970 656 str ")"],
adamc@970 657 st)
adamc@970 658 end)
adamc@970 659 (str "null", st) args
adamc@589 660 in
adamc@1057 661 (strcat [str ("{c:\"f\",f:\"" ^ name ^ "\",a:"),
adamc@970 662 e,
adamc@970 663 str "}"],
adamc@970 664 st)
adamc@589 665 end
adamc@589 666
adamc@589 667 | EApp (e1, e2) =>
adamc@589 668 let
adamc@589 669 val (e1, st) = jsE inner (e1, st)
adamc@589 670 val (e2, st) = jsE inner (e2, st)
adamc@589 671 in
adamc@970 672 (strcat [str "{c:\"a\",f:",
adamc@970 673 e1,
adamc@970 674 str ",x:",
adamc@970 675 e2,
adamc@970 676 str "}"], st)
adamc@589 677 end
adamc@589 678 | EAbs (_, _, _, e) =>
adamc@589 679 let
adamc@589 680 val (e, st) = jsE (inner + 1) (e, st)
adamc@589 681 in
adamc@970 682 (strcat [str "{c:\"l\",b:",
adamc@970 683 e,
adamc@970 684 str "}"], st)
adamc@589 685 end
adamc@589 686
adamc@589 687 | EUnop (s, e) =>
adamc@589 688 let
adamc@970 689 val name = case s of
adamc@970 690 "!" => "not"
adamc@970 691 | "-" => "neg"
adamc@980 692 | _ => raise Fail ("Jscomp: Unknown unary operator " ^ s)
adamc@970 693
adamc@589 694 val (e, st) = jsE inner (e, st)
adamc@589 695 in
adamc@1057 696 (strcat [str ("{c:\"f\",f:\"" ^ name ^ "\",a:cons("),
adamc@572 697 e,
adamc@970 698 str ",null)}"],
adamc@589 699 st)
adamc@589 700 end
adamc@589 701 | EBinop (s, e1, e2) =>
adamc@589 702 let
adamc@970 703 val name = case s of
adamc@970 704 "==" => "eq"
adamc@970 705 | "!strcmp" => "eq"
adamc@970 706 | "+" => "plus"
adamc@970 707 | "-" => "minus"
adamc@970 708 | "*" => "times"
adamc@970 709 | "/" => "div"
adamc@970 710 | "%" => "mod"
adamc@970 711 | "<" => "lt"
adamc@970 712 | "<=" => "le"
adamc@980 713 | "strcmp" => "strcmp"
adamc@980 714 | _ => raise Fail ("Jscomp: Unknown binary operator " ^ s)
adamc@729 715
adamc@589 716 val (e1, st) = jsE inner (e1, st)
adamc@589 717 val (e2, st) = jsE inner (e2, st)
adamc@589 718 in
adamc@1057 719 (strcat [str ("{c:\"f\",f:\"" ^ name ^ "\",a:cons("),
adamc@589 720 e1,
adamc@970 721 str ",cons(",
adamc@589 722 e2,
adamc@970 723 str ",null))}"],
adamc@589 724 st)
adamc@589 725 end
adamc@589 726
adamc@970 727 | ERecord [] => (str "{c:\"c\",v:null}", st)
adamc@970 728 | ERecord xes =>
adamc@589 729 let
adamc@589 730 val (es, st) =
adamc@589 731 foldr (fn ((x, e, _), (es, st)) =>
adamc@589 732 let
adamc@589 733 val (e, st) = jsE inner (e, st)
adamc@589 734 in
adamc@973 735 (strcat [str ("cons({n:\"" ^ x ^ "\",v:"),
adamc@970 736 e,
adamc@970 737 str "},",
adamc@970 738 es,
adamc@970 739 str ")"],
adamc@589 740 st)
adamc@589 741 end)
adamc@970 742 (str "null", st) xes
adamc@589 743 in
adamc@970 744 (strcat [str "{c:\"r\",l:",
adamc@970 745 es,
adamc@970 746 str "}"],
adamc@589 747 st)
adamc@589 748 end
adamc@934 749 | EField (e', x) =>
adamc@589 750 let
adamc@934 751 fun default () =
adamc@934 752 let
adamc@934 753 val (e', st) = jsE inner (e', st)
adamc@934 754 in
adamc@970 755 (strcat [str "{c:\".\",r:",
adamc@970 756 e',
adamc@970 757 str (",f:\"" ^ x ^ "\"}")], st)
adamc@934 758 end
adamc@934 759
adamc@934 760 fun seek (e, xs) =
adamc@934 761 case #1 e of
adamc@934 762 ERel n =>
adamc@934 763 if n < inner then
adamc@934 764 default ()
adamc@934 765 else
adamc@934 766 let
adamc@934 767 val n = n - inner
adamc@934 768 val t = List.nth (outer, n)
adamc@934 769 val t = foldl (fn (x, (TRecord xts, _)) =>
adamc@934 770 (case List.find (fn (x', _) => x' = x) xts of
adamc@934 771 NONE => raise Fail "Jscomp: Bad seek [1]"
adamc@934 772 | SOME (_, t) => t)
adamc@934 773 | _ => raise Fail "Jscomp: Bad seek [2]")
adamc@934 774 t xs
adamc@934 775
adamc@934 776 val e = (ERel n, loc)
adamc@934 777 val e = foldl (fn (x, e) => (EField (e, x), loc)) e xs
adamc@970 778 val (e, st) = quoteExp t (e, st)
adamc@934 779 in
adamc@970 780 (strcat [str "{c:\"c\",v:",
adamc@970 781 e,
adamc@970 782 str "}"],
adamc@970 783 st)
adamc@934 784 end
adamc@934 785 | EField (e', x) => seek (e', x :: xs)
adamc@934 786 | _ => default ()
adamc@589 787 in
adamc@934 788 seek (e', [x])
adamc@934 789 end
adamc@589 790
adamc@970 791 | ECase (e', pes, _) =>
adamc@801 792 let
adamc@970 793 val (e', st) = jsE inner (e', st)
adamc@589 794
adamc@970 795 val (ps, st) =
adamc@970 796 foldr (fn ((p, e), (ps, st)) =>
adamc@970 797 let
adamc@974 798 val (e, st) = jsE (inner + E.patBindsN p) (e, st)
adamc@970 799 in
adamc@970 800 (strcat [str "cons({p:",
adamc@970 801 jsPat p,
adamc@970 802 str ",b:",
adamc@970 803 e,
adamc@970 804 str "},",
adamc@970 805 ps,
adamc@970 806 str ")"],
adamc@970 807 st)
adamc@970 808 end)
adamc@970 809 (str "null", st) pes
adamc@801 810 in
adamc@970 811 (strcat [str "{c:\"m\",e:",
adamc@974 812 e',
adamc@970 813 str ",p:",
adamc@970 814 ps,
adamc@970 815 str "}"], st)
adamc@801 816 end
adamc@589 817
adamc@589 818 | EStrcat (e1, e2) =>
adamc@589 819 let
adamc@589 820 val (e1, st) = jsE inner (e1, st)
adamc@589 821 val (e2, st) = jsE inner (e2, st)
adamc@589 822 in
adamc@1057 823 (strcat [str "{c:\"f\",f:\"cat\",a:cons(", e1, str ",cons(", e2, str ",null))}"], st)
adamc@589 824 end
adamc@589 825
adamc@589 826 | EError (e, _) =>
adamc@589 827 let
adamc@589 828 val (e, st) = jsE inner (e, st)
adamc@589 829 in
adamc@1057 830 (strcat [str "{c:\"f\",f:\"er\",a:cons(", e, str ",null)}"],
adamc@589 831 st)
adamc@589 832 end
adamc@589 833
adamc@589 834 | ESeq (e1, e2) =>
adamc@589 835 let
adamc@589 836 val (e1, st) = jsE inner (e1, st)
adamc@589 837 val (e2, st) = jsE inner (e2, st)
adamc@589 838 in
adamc@970 839 (strcat [str "{c:\";\",e1:", e1, str ",e2:", e2, str "}"], st)
adamc@589 840 end
adamc@589 841 | ELet (_, _, e1, e2) =>
adamc@589 842 let
adamc@589 843 val (e1, st) = jsE inner (e1, st)
adamc@589 844 val (e2, st) = jsE (inner + 1) (e2, st)
adamc@589 845 in
adamc@970 846 (strcat [str "{c:\"=\",e1:",
adamc@589 847 e1,
adamc@970 848 str ",e2:",
adamc@589 849 e2,
adamc@970 850 str "}"], st)
adamc@572 851 end
adamc@589 852
adamc@815 853 | EJavaScript (Source _, e) =>
adamc@794 854 (foundJavaScript := true;
adamc@815 855 jsE inner (e, st))
adamc@815 856 | EJavaScript (_, e) =>
adamc@815 857 let
adamc@815 858 val (e, st) = jsE inner (e, st)
adamc@815 859 in
adamc@815 860 foundJavaScript := true;
adamc@970 861 (strcat [str "{c:\"e\",e:",
adamc@970 862 e,
adamc@970 863 str "}"],
adamc@815 864 st)
adamc@815 865 end
adamc@590 866
adamc@970 867 | EWrite _ => unsupported "EWrite"
adamc@589 868 | EClosure _ => unsupported "EClosure"
adamc@589 869 | EQuery _ => unsupported "Query"
adamc@589 870 | EDml _ => unsupported "DML"
adamc@589 871 | ENextval _ => unsupported "Nextval"
adamc@1073 872 | ESetval _ => unsupported "Nextval"
adamc@1112 873 | EReturnBlob _ => unsupported "EReturnBlob"
adamc@1065 874 | ERedirect _ => unsupported "ERedirect"
adamc@1112 875 | EUnurlify (_, _, true) => unsupported "EUnurlify"
adamc@590 876
adamc@1112 877 | EUnurlify (e, t, false) =>
adamc@1111 878 let
adamc@1111 879 val (e, st) = jsE inner (e, st)
adamc@1111 880 val (e', st) = unurlifyExp loc (t, st)
adamc@1111 881 in
adamc@1111 882 (strcat [str ("{c:\"f\",f:\"unurlify\",a:cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return "
adamc@1111 883 ^ e' ^ "}},cons("),
adamc@1111 884 e,
adamc@1111 885 str ",null))}"],
adamc@1111 886 st)
adamc@1111 887 end
adamc@1111 888
adamc@589 889 | ESignalReturn e =>
adamc@572 890 let
adamc@572 891 val (e, st) = jsE inner (e, st)
adamc@572 892 in
adamc@1057 893 (strcat [str "{c:\"f\",f:\"sr\",a:cons(",
adamc@589 894 e,
adamc@970 895 str ",null)}"],
adamc@589 896 st)
adamc@589 897 end
adamc@589 898 | ESignalBind (e1, e2) =>
adamc@589 899 let
adamc@589 900 val (e1, st) = jsE inner (e1, st)
adamc@589 901 val (e2, st) = jsE inner (e2, st)
adamc@589 902 in
adamc@1057 903 (strcat [str "{c:\"f\",f:\"sb\",a:cons(",
adamc@589 904 e1,
adamc@976 905 str ",cons(",
adamc@589 906 e2,
adamc@976 907 str ",null))}"],
adamc@589 908 st)
adamc@589 909 end
adamc@589 910 | ESignalSource e =>
adamc@589 911 let
adamc@589 912 val (e, st) = jsE inner (e, st)
adamc@589 913 in
adamc@1057 914 (strcat [str "{c:\"f\",f:\"ss\",a:cons(",
adamc@589 915 e,
adamc@970 916 str ",null)}"],
adamc@589 917 st)
adamc@572 918 end
adamc@608 919
adamc@1020 920 | EServerCall (e, t, eff) =>
adamc@609 921 let
adamc@614 922 val (e, st) = jsE inner (e, st)
adamc@613 923 val (unurl, st) = unurlifyExp loc (t, st)
adamc@609 924 in
adamc@1057 925 (strcat [str ("{c:\"f\",f:\"rc\",a:cons({c:\"c\",v:\""
adamc@970 926 ^ Settings.getUrlPrefix ()
adamc@970 927 ^ "\"},cons("),
adamc@614 928 e,
adamc@970 929 str (",cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return "
adamc@1020 930 ^ unurl ^ "}},cons({c:\"K\"},cons({c:\"c\",v:"
adamc@736 931 ^ (case eff of
adamc@736 932 ReadCookieWrite => "true"
adamc@736 933 | _ => "false")
adamc@978 934 ^ "},null)))))}")],
adamc@609 935 st)
adamc@609 936 end
adamc@670 937
adamc@1021 938 | ERecv (e, t) =>
adamc@670 939 let
adamc@670 940 val (e, st) = jsE inner (e, st)
adamc@670 941 val (unurl, st) = unurlifyExp loc (t, st)
adamc@670 942 in
adamc@1057 943 (strcat [str ("{c:\"f\",f:\"rv\",a:cons("),
adamc@670 944 e,
adamc@970 945 str (",cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return "
adamc@1021 946 ^ unurl ^ "}},cons({c:\"K\"},null)))}")],
adamc@670 947 st)
adamc@670 948 end
adamc@695 949
adamc@1021 950 | ESleep e =>
adamc@695 951 let
adamc@695 952 val (e, st) = jsE inner (e, st)
adamc@695 953 in
adamc@1057 954 (strcat [str "{c:\"f\",f:\"sl\",a:cons(",
adamc@978 955 e,
adamc@1021 956 str ",cons({c:\"K\"},null))}"],
adamc@1021 957 st)
adamc@1021 958 end
adamc@1021 959
adamc@1021 960 | ESpawn e =>
adamc@1021 961 let
adamc@1021 962 val (e, st) = jsE inner (e, st)
adamc@1021 963 in
adamc@1057 964 (strcat [str "{c:\"f\",f:\"sp\",a:cons(",
adamc@1021 965 e,
adamc@1021 966 str ",null)}"],
adamc@695 967 st)
adamc@695 968 end
adamc@567 969 end
adamc@589 970 in
adamc@970 971 jsE 0
adamc@589 972 end
adamc@567 973
adamc@815 974 fun patBinds ((p, _), env) =
adamc@815 975 case p of
adamc@815 976 PWild => env
adamc@815 977 | PVar (_, t) => t :: env
adamc@815 978 | PPrim _ => env
adamc@815 979 | PCon (_, _, NONE) => env
adamc@815 980 | PCon (_, _, SOME p) => patBinds (p, env)
adamc@815 981 | PRecord xpts => foldl (fn ((_, p, _), env) => patBinds (p, env)) env xpts
adamc@815 982 | PNone _ => env
adamc@815 983 | PSome (_, p) => patBinds (p, env)
adamc@815 984
adamc@815 985 fun exp outer (e as (_, loc), st) =
adamc@815 986 ((*Print.preface ("exp", MonoPrint.p_exp MonoEnv.empty e);*)
adamc@815 987 case #1 e of
adamc@847 988 EPrim p =>
adamc@847 989 (case p of
adamc@847 990 Prim.String s => if inString {needle = "<script", haystack = s} then
adamc@847 991 foundJavaScript := true
adamc@847 992 else
adamc@847 993 ()
adamc@847 994 | _ => ();
adamc@847 995 (e, st))
adamc@815 996 | ERel _ => (e, st)
adamc@815 997 | ENamed _ => (e, st)
adamc@815 998 | ECon (_, _, NONE) => (e, st)
adamc@815 999 | ECon (dk, pc, SOME e) =>
adamc@815 1000 let
adamc@815 1001 val (e, st) = exp outer (e, st)
adamc@815 1002 in
adamc@815 1003 ((ECon (dk, pc, SOME e), loc), st)
adamc@815 1004 end
adamc@815 1005 | ENone _ => (e, st)
adamc@815 1006 | ESome (t, e) =>
adamc@815 1007 let
adamc@815 1008 val (e, st) = exp outer (e, st)
adamc@815 1009 in
adamc@815 1010 ((ESome (t, e), loc), st)
adamc@815 1011 end
adamc@815 1012 | EFfi _ => (e, st)
adamc@815 1013 | EFfiApp (m, x, es) =>
adamc@815 1014 let
adamc@815 1015 val (es, st) = ListUtil.foldlMap (exp outer) st es
adamc@815 1016 in
adamc@815 1017 ((EFfiApp (m, x, es), loc), st)
adamc@815 1018 end
adamc@815 1019 | EApp (e1, e2) =>
adamc@815 1020 let
adamc@815 1021 val (e1, st) = exp outer (e1, st)
adamc@815 1022 val (e2, st) = exp outer (e2, st)
adamc@815 1023 in
adamc@815 1024 ((EApp (e1, e2), loc), st)
adamc@815 1025 end
adamc@815 1026 | EAbs (x, dom, ran, e) =>
adamc@815 1027 let
adamc@815 1028 val (e, st) = exp (dom :: outer) (e, st)
adamc@815 1029 in
adamc@815 1030 ((EAbs (x, dom, ran, e), loc), st)
adamc@815 1031 end
adamc@815 1032
adamc@815 1033 | EUnop (s, e) =>
adamc@815 1034 let
adamc@815 1035 val (e, st) = exp outer (e, st)
adamc@815 1036 in
adamc@815 1037 ((EUnop (s, e), loc), st)
adamc@815 1038 end
adamc@815 1039 | EBinop (s, e1, e2) =>
adamc@815 1040 let
adamc@815 1041 val (e1, st) = exp outer (e1, st)
adamc@815 1042 val (e2, st) = exp outer (e2, st)
adamc@815 1043 in
adamc@815 1044 ((EBinop (s, e1, e2), loc), st)
adamc@815 1045 end
adamc@815 1046
adamc@815 1047 | ERecord xets =>
adamc@815 1048 let
adamc@815 1049 val (xets, st) = ListUtil.foldlMap (fn ((x, e, t), st) =>
adamc@815 1050 let
adamc@815 1051 val (e, st) = exp outer (e, st)
adamc@815 1052 in
adamc@815 1053 ((x, e, t), st)
adamc@815 1054 end) st xets
adamc@815 1055 in
adamc@815 1056 ((ERecord xets, loc), st)
adamc@815 1057 end
adamc@815 1058 | EField (e, s) =>
adamc@815 1059 let
adamc@815 1060 val (e, st) = exp outer (e, st)
adamc@815 1061 in
adamc@815 1062 ((EField (e, s), loc), st)
adamc@815 1063 end
adamc@815 1064
adamc@815 1065 | ECase (e, pes, ts) =>
adamc@815 1066 let
adamc@815 1067 val (e, st) = exp outer (e, st)
adamc@815 1068 val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
adamc@815 1069 let
adamc@815 1070 val (e, st) = exp (patBinds (p, outer)) (e, st)
adamc@815 1071 in
adamc@815 1072 ((p, e), st)
adamc@815 1073 end) st pes
adamc@815 1074 in
adamc@815 1075 ((ECase (e, pes, ts), loc), st)
adamc@815 1076 end
adamc@815 1077
adamc@815 1078 | EStrcat (e1, e2) =>
adamc@815 1079 let
adamc@815 1080 val (e1, st) = exp outer (e1, st)
adamc@815 1081 val (e2, st) = exp outer (e2, st)
adamc@815 1082 in
adamc@815 1083 ((EStrcat (e1, e2), loc), st)
adamc@815 1084 end
adamc@815 1085
adamc@815 1086 | EError (e, t) =>
adamc@815 1087 let
adamc@815 1088 val (e, st) = exp outer (e, st)
adamc@815 1089 in
adamc@815 1090 ((EError (e, t), loc), st)
adamc@815 1091 end
adamc@815 1092 | EReturnBlob {blob, mimeType, t} =>
adamc@815 1093 let
adamc@815 1094 val (blob, st) = exp outer (blob, st)
adamc@815 1095 val (mimeType, st) = exp outer (mimeType, st)
adamc@815 1096 in
adamc@815 1097 ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st)
adamc@815 1098 end
adamc@1065 1099 | ERedirect (e, t) =>
adamc@1065 1100 let
adamc@1065 1101 val (e, st) = exp outer (e, st)
adamc@1065 1102 in
adamc@1065 1103 ((ERedirect (e, t), loc), st)
adamc@1065 1104 end
adamc@815 1105
adamc@815 1106 | EWrite e =>
adamc@815 1107 let
adamc@815 1108 val (e, st) = exp outer (e, st)
adamc@815 1109 in
adamc@815 1110 ((EWrite e, loc), st)
adamc@815 1111 end
adamc@815 1112 | ESeq (e1, e2) =>
adamc@815 1113 let
adamc@815 1114 val (e1, st) = exp outer (e1, st)
adamc@815 1115 val (e2, st) = exp outer (e2, st)
adamc@815 1116 in
adamc@815 1117 ((ESeq (e1, e2), loc), st)
adamc@815 1118 end
adamc@815 1119 | ELet (x, t, e1, e2) =>
adamc@815 1120 let
adamc@815 1121 val (e1, st) = exp outer (e1, st)
adamc@815 1122 val (e2, st) = exp (t :: outer) (e2, st)
adamc@815 1123 in
adamc@815 1124 ((ELet (x, t, e1, e2), loc), st)
adamc@815 1125 end
adamc@815 1126
adamc@815 1127 | EClosure (n, es) =>
adamc@815 1128 let
adamc@815 1129 val (es, st) = ListUtil.foldlMap (exp outer) st es
adamc@815 1130 in
adamc@815 1131 ((EClosure (n, es), loc), st)
adamc@815 1132 end
adamc@815 1133
adamc@815 1134 | EQuery {exps, tables, state, query, body, initial} =>
adamc@815 1135 let
adamc@934 1136 val row = exps @ map (fn (x, xts) => (x, (TRecord xts, loc))) tables
adamc@934 1137 val row = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row
adamc@934 1138 val row = (TRecord row, loc)
adamc@934 1139
adamc@815 1140 val (query, st) = exp outer (query, st)
adamc@934 1141 val (body, st) = exp (state :: row :: outer) (body, st)
adamc@815 1142 val (initial, st) = exp outer (initial, st)
adamc@815 1143 in
adamc@815 1144 ((EQuery {exps = exps, tables = tables, state = state,
adamc@815 1145 query = query, body = body, initial = initial}, loc), st)
adamc@815 1146 end
adamc@815 1147 | EDml e =>
adamc@815 1148 let
adamc@815 1149 val (e, st) = exp outer (e, st)
adamc@815 1150 in
adamc@815 1151 ((EDml e, loc), st)
adamc@815 1152 end
adamc@815 1153 | ENextval e =>
adamc@815 1154 let
adamc@815 1155 val (e, st) = exp outer (e, st)
adamc@815 1156 in
adamc@815 1157 ((ENextval e, loc), st)
adamc@815 1158 end
adamc@1073 1159 | ESetval (e1, e2) =>
adamc@1073 1160 let
adamc@1073 1161 val (e1, st) = exp outer (e1, st)
adamc@1073 1162 val (e2, st) = exp outer (e2, st)
adamc@1073 1163 in
adamc@1073 1164 ((ESetval (e1, e2), loc), st)
adamc@1073 1165 end
adamc@815 1166
adamc@1112 1167 | EUnurlify (e, t, b) =>
adamc@815 1168 let
adamc@815 1169 val (e, st) = exp outer (e, st)
adamc@815 1170 in
adamc@1112 1171 ((EUnurlify (e, t, b), loc), st)
adamc@815 1172 end
adamc@815 1173
adamc@815 1174 | EJavaScript (m, e') =>
adamc@970 1175 (foundJavaScript := true;
adamc@970 1176 jsExp m outer (e', st)
adamc@1258 1177 handle CantEmbed t => ((*ErrorMsg.errorAt loc "Unable to embed type in JavaScript";
adamc@1258 1178 Print.preface ("Type",
adamc@1258 1179 MonoPrint.p_typ MonoEnv.empty t);*)
adamc@1176 1180 (e, st)))
adamc@815 1181
adamc@815 1182 | ESignalReturn e =>
adamc@815 1183 let
adamc@815 1184 val (e, st) = exp outer (e, st)
adamc@815 1185 in
adamc@815 1186 ((ESignalReturn e, loc), st)
adamc@815 1187 end
adamc@815 1188 | ESignalBind (e1, e2) =>
adamc@815 1189 let
adamc@815 1190 val (e1, st) = exp outer (e1, st)
adamc@815 1191 val (e2, st) = exp outer (e2, st)
adamc@815 1192 in
adamc@815 1193 ((ESignalBind (e1, e2), loc), st)
adamc@815 1194 end
adamc@815 1195 | ESignalSource e =>
adamc@815 1196 let
adamc@815 1197 val (e, st) = exp outer (e, st)
adamc@815 1198 in
adamc@815 1199 ((ESignalSource e, loc), st)
adamc@815 1200 end
adamc@815 1201
adamc@1020 1202 | EServerCall (e1, t, ef) =>
adamc@815 1203 let
adamc@815 1204 val (e1, st) = exp outer (e1, st)
adamc@815 1205 in
adamc@1020 1206 ((EServerCall (e1, t, ef), loc), st)
adamc@815 1207 end
adamc@1021 1208 | ERecv (e1, t) =>
adamc@815 1209 let
adamc@815 1210 val (e1, st) = exp outer (e1, st)
adamc@815 1211 in
adamc@1021 1212 ((ERecv (e1, t), loc), st)
adamc@815 1213 end
adamc@1021 1214 | ESleep e1 =>
adamc@815 1215 let
adamc@815 1216 val (e1, st) = exp outer (e1, st)
adamc@815 1217 in
adamc@1021 1218 ((ESleep e1, loc), st)
adamc@1021 1219 end
adamc@1021 1220 | ESpawn e1 =>
adamc@1021 1221 let
adamc@1021 1222 val (e1, st) = exp outer (e1, st)
adamc@1021 1223 in
adamc@1021 1224 ((ESpawn e1, loc), st)
adamc@815 1225 end)
adamc@815 1226
adamc@815 1227 fun decl (d as (_, loc), st) =
adamc@815 1228 case #1 d of
adamc@815 1229 DVal (x, n, t, e, s) =>
adamc@815 1230 let
adamc@815 1231 val (e, st) = exp [] (e, st)
adamc@815 1232 in
adamc@815 1233 ((DVal (x, n, t, e, s), loc), st)
adamc@815 1234 end
adamc@815 1235 | DValRec vis =>
adamc@815 1236 let
adamc@815 1237 val (vis, st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) =>
adamc@815 1238 let
adamc@815 1239 val (e, st) = exp [] (e, st)
adamc@815 1240 in
adamc@815 1241 ((x, n, t, e, s), st)
adamc@815 1242 end) st vis
adamc@815 1243 in
adamc@815 1244 ((DValRec vis, loc), st)
adamc@815 1245 end
adamc@815 1246 | _ => (d, st)
adamc@567 1247
adamc@567 1248 fun doDecl (d, st) =
adamc@567 1249 let
adamc@815 1250 (*val () = Print.preface ("doDecl", MonoPrint.p_decl MonoEnv.empty d)*)
adamc@815 1251 val (d, st) = decl (d, st)
adamc@840 1252
adamc@840 1253 val ds =
adamc@840 1254 case #decls st of
adamc@840 1255 [] => [d]
adamc@840 1256 | vis => [(DValRec vis, #2 d), d]
adamc@567 1257 in
adamc@840 1258 (ds,
adamc@567 1259 {decls = [],
adamc@589 1260 script = #script st,
adamc@595 1261 included = #included st,
adamc@595 1262 injectors = #injectors st,
adamc@800 1263 listInjectors = #listInjectors st,
adamc@638 1264 decoders = #decoders st,
adamc@595 1265 maxName = #maxName st})
adamc@567 1266 end
adamc@567 1267
adamc@567 1268 val (ds, st) = ListUtil.foldlMapConcat doDecl
adamc@567 1269 {decls = [],
adamc@589 1270 script = [],
adamc@595 1271 included = IS.empty,
adamc@595 1272 injectors = IM.empty,
adamc@800 1273 listInjectors = TM.empty,
adamc@638 1274 decoders = IM.empty,
adamc@595 1275 maxName = U.File.maxName file + 1}
adamc@815 1276 file
adamc@569 1277
adamc@569 1278 val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.libJs, file = "urweb.js"})
adamc@569 1279 fun lines acc =
adamc@569 1280 case TextIO.inputLine inf of
adamc@569 1281 NONE => String.concat (rev acc)
adamc@569 1282 | SOME line => lines (line :: acc)
adamc@569 1283 val lines = lines []
adamc@794 1284
adamc@794 1285 val script =
adamc@794 1286 if !foundJavaScript then
adamc@794 1287 lines ^ String.concat (rev (#script st))
adamc@794 1288 else
adamc@794 1289 ""
adamc@567 1290 in
adamc@569 1291 TextIO.closeIn inf;
adamc@794 1292 (DJavaScript script, ErrorMsg.dummySpan) :: ds
adamc@567 1293 end
adamc@567 1294
adamc@567 1295 end