Mercurial > urweb

annotate src/jscomp.sml @ 1380:ede95ecb4000

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