Mercurial > urweb

annotate src/jscomp.sml @ 1549:355a928871ff

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