Mercurial > urweb

annotate src/jscomp.sml @ 2164:728aaeea12fd

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