Mercurial > urweb

annotate src/jscomp.sml @ 1739:c414850f206f

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