Mercurial > urweb

annotate src/jscomp.sml @ 2258:b1ba35ce2613

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