Mercurial > urweb

annotate src/jscomp.sml @ 1344:660a2715e2bd

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