Mercurial > urweb

annotate src/jscomp.sml @ 2057:f4a6ccb7937f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Allow Body tags inside cformTags This is required by Bootstrap. For example, see http://getbootstrap.com/components/#alerts-dismissible
author Sergey Mironov <grrwlf@gmail.com>
date Sun, 17 Aug 2014 18:28:37 +0000
parents 4d64af730e35
children 9e9c915f554c 278e10629ba1
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"
adamc@980 727 | _ => raise Fail ("Jscomp: Unknown binary operator " ^ s)
adamc@729 728
adamc@589 729 val (e1, st) = jsE inner (e1, st)
adamc@589 730 val (e2, st) = jsE inner (e2, st)
adamc@589 731 in
adam@1798 732 (strcat [str ("{c:\"f\",f:" ^ name ^ ",a:cons("),
adamc@589 733 e1,
adamc@970 734 str ",cons(",
adamc@589 735 e2,
adamc@970 736 str ",null))}"],
adamc@589 737 st)
adamc@589 738 end
adamc@589 739
adamc@970 740 | ERecord [] => (str "{c:\"c\",v:null}", st)
adamc@970 741 | ERecord xes =>
adamc@589 742 let
adamc@589 743 val (es, st) =
adamc@589 744 foldr (fn ((x, e, _), (es, st)) =>
adamc@589 745 let
adamc@589 746 val (e, st) = jsE inner (e, st)
adamc@589 747 in
adamc@973 748 (strcat [str ("cons({n:\"" ^ x ^ "\",v:"),
adamc@970 749 e,
adamc@970 750 str "},",
adamc@970 751 es,
adamc@970 752 str ")"],
adamc@589 753 st)
adamc@589 754 end)
adamc@970 755 (str "null", st) xes
adamc@589 756 in
adamc@970 757 (strcat [str "{c:\"r\",l:",
adamc@970 758 es,
adamc@970 759 str "}"],
adamc@589 760 st)
adamc@589 761 end
adamc@934 762 | EField (e', x) =>
adamc@589 763 let
adamc@934 764 fun default () =
adamc@934 765 let
adamc@934 766 val (e', st) = jsE inner (e', st)
adamc@934 767 in
adamc@970 768 (strcat [str "{c:\".\",r:",
adamc@970 769 e',
adamc@970 770 str (",f:\"" ^ x ^ "\"}")], st)
adamc@934 771 end
adamc@934 772
adamc@934 773 fun seek (e, xs) =
adamc@934 774 case #1 e of
adamc@934 775 ERel n =>
adamc@934 776 if n < inner then
adamc@934 777 default ()
adamc@934 778 else
adamc@934 779 let
adamc@934 780 val n = n - inner
adamc@934 781 val t = List.nth (outer, n)
adamc@934 782 val t = foldl (fn (x, (TRecord xts, _)) =>
adamc@934 783 (case List.find (fn (x', _) => x' = x) xts of
adamc@934 784 NONE => raise Fail "Jscomp: Bad seek [1]"
adamc@934 785 | SOME (_, t) => t)
adamc@934 786 | _ => raise Fail "Jscomp: Bad seek [2]")
adamc@934 787 t xs
adamc@934 788
adamc@934 789 val e = (ERel n, loc)
adamc@934 790 val e = foldl (fn (x, e) => (EField (e, x), loc)) e xs
adamc@970 791 val (e, st) = quoteExp t (e, st)
adamc@934 792 in
adamc@970 793 (strcat [str "{c:\"c\",v:",
adamc@970 794 e,
adamc@970 795 str "}"],
adamc@970 796 st)
adamc@934 797 end
adamc@934 798 | EField (e', x) => seek (e', x :: xs)
adamc@934 799 | _ => default ()
adamc@589 800 in
adamc@934 801 seek (e', [x])
adamc@934 802 end
adamc@589 803
adamc@970 804 | ECase (e', pes, _) =>
adamc@801 805 let
adamc@970 806 val (e', st) = jsE inner (e', st)
adamc@589 807
adamc@970 808 val (ps, st) =
adamc@970 809 foldr (fn ((p, e), (ps, st)) =>
adamc@970 810 let
adamc@974 811 val (e, st) = jsE (inner + E.patBindsN p) (e, st)
adamc@970 812 in
adamc@970 813 (strcat [str "cons({p:",
adamc@970 814 jsPat p,
adamc@970 815 str ",b:",
adamc@970 816 e,
adamc@970 817 str "},",
adamc@970 818 ps,
adamc@970 819 str ")"],
adamc@970 820 st)
adamc@970 821 end)
adamc@970 822 (str "null", st) pes
adamc@801 823 in
adamc@970 824 (strcat [str "{c:\"m\",e:",
adamc@974 825 e',
adamc@970 826 str ",p:",
adamc@970 827 ps,
adamc@970 828 str "}"], st)
adamc@801 829 end
adamc@589 830
adamc@589 831 | EStrcat (e1, e2) =>
adamc@589 832 let
adamc@589 833 val (e1, st) = jsE inner (e1, st)
adamc@589 834 val (e2, st) = jsE inner (e2, st)
adamc@589 835 in
adam@1798 836 (strcat [str "{c:\"f\",f:cat,a:cons(", e1, str ",cons(", e2, str ",null))}"], st)
adamc@589 837 end
adamc@589 838
adamc@589 839 | EError (e, _) =>
adamc@589 840 let
adamc@589 841 val (e, st) = jsE inner (e, st)
adamc@589 842 in
adam@1798 843 (strcat [str "{c:\"f\",f:er,a:cons(", e, str ",null)}"],
adamc@589 844 st)
adamc@589 845 end
adamc@589 846
adamc@589 847 | ESeq (e1, e2) =>
adamc@589 848 let
adamc@589 849 val (e1, st) = jsE inner (e1, st)
adamc@589 850 val (e2, st) = jsE inner (e2, st)
adamc@589 851 in
adamc@970 852 (strcat [str "{c:\";\",e1:", e1, str ",e2:", e2, str "}"], st)
adamc@589 853 end
adamc@589 854 | ELet (_, _, e1, e2) =>
adamc@589 855 let
adamc@589 856 val (e1, st) = jsE inner (e1, st)
adamc@589 857 val (e2, st) = jsE (inner + 1) (e2, st)
adamc@589 858 in
adamc@970 859 (strcat [str "{c:\"=\",e1:",
adamc@589 860 e1,
adamc@970 861 str ",e2:",
adamc@589 862 e2,
adamc@970 863 str "}"], st)
adamc@572 864 end
adamc@589 865
adamc@815 866 | EJavaScript (Source _, e) =>
adamc@794 867 (foundJavaScript := true;
adamc@815 868 jsE inner (e, st))
adamc@815 869 | EJavaScript (_, e) =>
adamc@815 870 let
adamc@815 871 val (e, st) = jsE inner (e, st)
adamc@815 872 in
adamc@815 873 foundJavaScript := true;
adamc@970 874 (strcat [str "{c:\"e\",e:",
adamc@970 875 e,
adamc@970 876 str "}"],
adamc@815 877 st)
adamc@815 878 end
adamc@590 879
adamc@970 880 | EWrite _ => unsupported "EWrite"
adamc@589 881 | EClosure _ => unsupported "EClosure"
adamc@589 882 | EQuery _ => unsupported "Query"
adamc@589 883 | EDml _ => unsupported "DML"
adamc@589 884 | ENextval _ => unsupported "Nextval"
adamc@1073 885 | ESetval _ => unsupported "Nextval"
adamc@1112 886 | EReturnBlob _ => unsupported "EReturnBlob"
adam@1385 887
adam@1385 888 | ERedirect (e, _) =>
adam@1385 889 let
adam@1385 890 val (e, st) = jsE inner (e, st)
adam@1385 891 in
adam@1798 892 (strcat [str "{c:\"f\",f:redirect,a:cons(",
adam@1385 893 e,
adam@1385 894 str ",null)}"],
adam@1385 895 st)
adam@1385 896 end
adam@1385 897
adamc@1112 898 | EUnurlify (_, _, true) => unsupported "EUnurlify"
adamc@590 899
adamc@1112 900 | EUnurlify (e, t, false) =>
adamc@1111 901 let
adamc@1111 902 val (e, st) = jsE inner (e, st)
adamc@1111 903 val (e', st) = unurlifyExp loc (t, st)
adamc@1111 904 in
adam@1798 905 (strcat [str ("{c:\"f\",f:unurlify,a:cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return "
adamc@1111 906 ^ e' ^ "}},cons("),
adamc@1111 907 e,
adamc@1111 908 str ",null))}"],
adamc@1111 909 st)
adamc@1111 910 end
adamc@1111 911
adamc@589 912 | ESignalReturn e =>
adamc@572 913 let
adamc@572 914 val (e, st) = jsE inner (e, st)
adamc@572 915 in
adam@1798 916 (strcat [str "{c:\"f\",f:sr,a:cons(",
adamc@589 917 e,
adamc@970 918 str ",null)}"],
adamc@589 919 st)
adamc@589 920 end
adamc@589 921 | ESignalBind (e1, e2) =>
adamc@589 922 let
adamc@589 923 val (e1, st) = jsE inner (e1, st)
adamc@589 924 val (e2, st) = jsE inner (e2, st)
adamc@589 925 in
adam@1798 926 (strcat [str "{c:\"f\",f:sb,a:cons(",
adamc@589 927 e1,
adamc@976 928 str ",cons(",
adamc@589 929 e2,
adamc@976 930 str ",null))}"],
adamc@589 931 st)
adamc@589 932 end
adamc@589 933 | ESignalSource e =>
adamc@589 934 let
adamc@589 935 val (e, st) = jsE inner (e, st)
adamc@589 936 in
adam@1798 937 (strcat [str "{c:\"f\",f:ss,a:cons(",
adamc@589 938 e,
adamc@970 939 str ",null)}"],
adamc@589 940 st)
adamc@572 941 end
adamc@608 942
adam@1848 943 | EServerCall (e, t, eff, fm) =>
adamc@609 944 let
adamc@614 945 val (e, st) = jsE inner (e, st)
adamc@613 946 val (unurl, st) = unurlifyExp loc (t, st)
adam@1848 947 val lastArg = case fm of
adam@1848 948 None => "null"
adam@1848 949 | Error =>
adam@1848 950 let
adam@1848 951 val isN = if isNullable t then
adam@1848 952 "true"
adam@1848 953 else
adam@1848 954 "false"
adam@1848 955 in
adam@1848 956 "cons({c:\"c\",v:" ^ isN ^ "},null)"
adam@1848 957 end
adamc@609 958 in
adam@1798 959 (strcat [str ("{c:\"f\",f:rc,a:cons({c:\"c\",v:\""
adamc@970 960 ^ Settings.getUrlPrefix ()
adamc@970 961 ^ "\"},cons("),
adamc@614 962 e,
adamc@970 963 str (",cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return "
adamc@1020 964 ^ unurl ^ "}},cons({c:\"K\"},cons({c:\"c\",v:"
adamc@736 965 ^ (case eff of
adamc@736 966 ReadCookieWrite => "true"
adamc@736 967 | _ => "false")
adam@1848 968 ^ "}," ^ lastArg ^ ")))))}")],
adamc@609 969 st)
adamc@609 970 end
adamc@670 971
adamc@1021 972 | ERecv (e, t) =>
adamc@670 973 let
adamc@670 974 val (e, st) = jsE inner (e, st)
adamc@670 975 val (unurl, st) = unurlifyExp loc (t, st)
adamc@670 976 in
adam@1798 977 (strcat [str ("{c:\"f\",f:rv,a:cons("),
adamc@670 978 e,
adamc@970 979 str (",cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return "
adamc@1021 980 ^ unurl ^ "}},cons({c:\"K\"},null)))}")],
adamc@670 981 st)
adamc@670 982 end
adamc@695 983
adamc@1021 984 | ESleep e =>
adamc@695 985 let
adamc@695 986 val (e, st) = jsE inner (e, st)
adamc@695 987 in
adam@1798 988 (strcat [str "{c:\"f\",f:sl,a:cons(",
adamc@978 989 e,
adamc@1021 990 str ",cons({c:\"K\"},null))}"],
adamc@1021 991 st)
adamc@1021 992 end
adamc@1021 993
adamc@1021 994 | ESpawn e =>
adamc@1021 995 let
adamc@1021 996 val (e, st) = jsE inner (e, st)
adamc@1021 997 in
adam@1798 998 (strcat [str "{c:\"f\",f:sp,a:cons(",
adamc@1021 999 e,
adamc@1021 1000 str ",null)}"],
adamc@695 1001 st)
adamc@695 1002 end
adamc@567 1003 end
adamc@589 1004 in
adamc@970 1005 jsE 0
adamc@589 1006 end
adamc@567 1007
adamc@815 1008 fun patBinds ((p, _), env) =
adamc@815 1009 case p of
adamc@815 1010 PWild => env
adamc@815 1011 | PVar (_, t) => t :: env
adamc@815 1012 | PPrim _ => env
adamc@815 1013 | PCon (_, _, NONE) => env
adamc@815 1014 | PCon (_, _, SOME p) => patBinds (p, env)
adamc@815 1015 | PRecord xpts => foldl (fn ((_, p, _), env) => patBinds (p, env)) env xpts
adamc@815 1016 | PNone _ => env
adamc@815 1017 | PSome (_, p) => patBinds (p, env)
adamc@815 1018
adamc@815 1019 fun exp outer (e as (_, loc), st) =
adamc@815 1020 ((*Print.preface ("exp", MonoPrint.p_exp MonoEnv.empty e);*)
adamc@815 1021 case #1 e of
adamc@847 1022 EPrim p =>
adamc@847 1023 (case p of
adam@2048 1024 Prim.String (_, s) => if inString {needle = "<script", haystack = s} then
adam@2048 1025 foundJavaScript := true
adam@2048 1026 else
adam@2048 1027 ()
adamc@847 1028 | _ => ();
adamc@847 1029 (e, st))
adamc@815 1030 | ERel _ => (e, st)
adamc@815 1031 | ENamed _ => (e, st)
adamc@815 1032 | ECon (_, _, NONE) => (e, st)
adamc@815 1033 | ECon (dk, pc, SOME e) =>
adamc@815 1034 let
adamc@815 1035 val (e, st) = exp outer (e, st)
adamc@815 1036 in
adamc@815 1037 ((ECon (dk, pc, SOME e), loc), st)
adamc@815 1038 end
adamc@815 1039 | ENone _ => (e, st)
adamc@815 1040 | ESome (t, e) =>
adamc@815 1041 let
adamc@815 1042 val (e, st) = exp outer (e, st)
adamc@815 1043 in
adamc@815 1044 ((ESome (t, e), loc), st)
adamc@815 1045 end
adamc@815 1046 | EFfi _ => (e, st)
adamc@815 1047 | EFfiApp (m, x, es) =>
adamc@815 1048 let
adam@1663 1049 val (es, st) = ListUtil.foldlMap (fn ((e, t), st) =>
adam@1663 1050 let
adam@1663 1051 val (e, st) = exp outer (e, st)
adam@1663 1052 in
adam@1663 1053 ((e, t), st)
adam@1663 1054 end) st es
adamc@815 1055 in
adamc@815 1056 ((EFfiApp (m, x, es), loc), st)
adamc@815 1057 end
adamc@815 1058 | EApp (e1, e2) =>
adamc@815 1059 let
adamc@815 1060 val (e1, st) = exp outer (e1, st)
adamc@815 1061 val (e2, st) = exp outer (e2, st)
adamc@815 1062 in
adamc@815 1063 ((EApp (e1, e2), loc), st)
adamc@815 1064 end
adamc@815 1065 | EAbs (x, dom, ran, e) =>
adamc@815 1066 let
adamc@815 1067 val (e, st) = exp (dom :: outer) (e, st)
adamc@815 1068 in
adamc@815 1069 ((EAbs (x, dom, ran, e), loc), st)
adamc@815 1070 end
adamc@815 1071
adamc@815 1072 | EUnop (s, e) =>
adamc@815 1073 let
adamc@815 1074 val (e, st) = exp outer (e, st)
adamc@815 1075 in
adamc@815 1076 ((EUnop (s, e), loc), st)
adamc@815 1077 end
adam@1360 1078 | EBinop (bi, s, e1, e2) =>
adamc@815 1079 let
adamc@815 1080 val (e1, st) = exp outer (e1, st)
adamc@815 1081 val (e2, st) = exp outer (e2, st)
adamc@815 1082 in
adam@1360 1083 ((EBinop (bi, s, e1, e2), loc), st)
adamc@815 1084 end
adamc@815 1085
adamc@815 1086 | ERecord xets =>
adamc@815 1087 let
adamc@815 1088 val (xets, st) = ListUtil.foldlMap (fn ((x, e, t), st) =>
adamc@815 1089 let
adamc@815 1090 val (e, st) = exp outer (e, st)
adamc@815 1091 in
adamc@815 1092 ((x, e, t), st)
adamc@815 1093 end) st xets
adamc@815 1094 in
adamc@815 1095 ((ERecord xets, loc), st)
adamc@815 1096 end
adamc@815 1097 | EField (e, s) =>
adamc@815 1098 let
adamc@815 1099 val (e, st) = exp outer (e, st)
adamc@815 1100 in
adamc@815 1101 ((EField (e, s), loc), st)
adamc@815 1102 end
adamc@815 1103
adamc@815 1104 | ECase (e, pes, ts) =>
adamc@815 1105 let
adamc@815 1106 val (e, st) = exp outer (e, st)
adamc@815 1107 val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
adamc@815 1108 let
adamc@815 1109 val (e, st) = exp (patBinds (p, outer)) (e, st)
adamc@815 1110 in
adamc@815 1111 ((p, e), st)
adamc@815 1112 end) st pes
adamc@815 1113 in
adamc@815 1114 ((ECase (e, pes, ts), loc), st)
adamc@815 1115 end
adamc@815 1116
adamc@815 1117 | EStrcat (e1, e2) =>
adamc@815 1118 let
adamc@815 1119 val (e1, st) = exp outer (e1, st)
adamc@815 1120 val (e2, st) = exp outer (e2, st)
adamc@815 1121 in
adamc@815 1122 ((EStrcat (e1, e2), loc), st)
adamc@815 1123 end
adamc@815 1124
adamc@815 1125 | EError (e, t) =>
adamc@815 1126 let
adamc@815 1127 val (e, st) = exp outer (e, st)
adamc@815 1128 in
adamc@815 1129 ((EError (e, t), loc), st)
adamc@815 1130 end
adam@1932 1131 | EReturnBlob {blob = NONE, mimeType, t} =>
adam@1932 1132 let
adam@1932 1133 val (mimeType, st) = exp outer (mimeType, st)
adam@1932 1134 in
adam@1932 1135 ((EReturnBlob {blob = NONE, mimeType = mimeType, t = t}, loc), st)
adam@1932 1136 end
adam@1932 1137 | EReturnBlob {blob = SOME blob, mimeType, t} =>
adamc@815 1138 let
adamc@815 1139 val (blob, st) = exp outer (blob, st)
adamc@815 1140 val (mimeType, st) = exp outer (mimeType, st)
adamc@815 1141 in
adam@1932 1142 ((EReturnBlob {blob = SOME blob, mimeType = mimeType, t = t}, loc), st)
adamc@815 1143 end
adamc@1065 1144 | ERedirect (e, t) =>
adamc@1065 1145 let
adamc@1065 1146 val (e, st) = exp outer (e, st)
adamc@1065 1147 in
adamc@1065 1148 ((ERedirect (e, t), loc), st)
adamc@1065 1149 end
adamc@815 1150
adamc@815 1151 | EWrite e =>
adamc@815 1152 let
adamc@815 1153 val (e, st) = exp outer (e, st)
adamc@815 1154 in
adamc@815 1155 ((EWrite e, loc), st)
adamc@815 1156 end
adamc@815 1157 | ESeq (e1, e2) =>
adamc@815 1158 let
adamc@815 1159 val (e1, st) = exp outer (e1, st)
adamc@815 1160 val (e2, st) = exp outer (e2, st)
adamc@815 1161 in
adamc@815 1162 ((ESeq (e1, e2), loc), st)
adamc@815 1163 end
adamc@815 1164 | ELet (x, t, e1, e2) =>
adamc@815 1165 let
adamc@815 1166 val (e1, st) = exp outer (e1, st)
adamc@815 1167 val (e2, st) = exp (t :: outer) (e2, st)
adamc@815 1168 in
adamc@815 1169 ((ELet (x, t, e1, e2), loc), st)
adamc@815 1170 end
adamc@815 1171
adamc@815 1172 | EClosure (n, es) =>
adamc@815 1173 let
adamc@815 1174 val (es, st) = ListUtil.foldlMap (exp outer) st es
adamc@815 1175 in
adamc@815 1176 ((EClosure (n, es), loc), st)
adamc@815 1177 end
adamc@815 1178
adamc@815 1179 | EQuery {exps, tables, state, query, body, initial} =>
adamc@815 1180 let
adamc@934 1181 val row = exps @ map (fn (x, xts) => (x, (TRecord xts, loc))) tables
adamc@934 1182 val row = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row
adamc@934 1183 val row = (TRecord row, loc)
adamc@934 1184
adamc@815 1185 val (query, st) = exp outer (query, st)
adamc@934 1186 val (body, st) = exp (state :: row :: outer) (body, st)
adamc@815 1187 val (initial, st) = exp outer (initial, st)
adamc@815 1188 in
adamc@815 1189 ((EQuery {exps = exps, tables = tables, state = state,
adamc@815 1190 query = query, body = body, initial = initial}, loc), st)
adamc@815 1191 end
adam@1293 1192 | EDml (e, mode) =>
adamc@815 1193 let
adamc@815 1194 val (e, st) = exp outer (e, st)
adamc@815 1195 in
adam@1293 1196 ((EDml (e, mode), loc), st)
adamc@815 1197 end
adamc@815 1198 | ENextval e =>
adamc@815 1199 let
adamc@815 1200 val (e, st) = exp outer (e, st)
adamc@815 1201 in
adamc@815 1202 ((ENextval e, loc), st)
adamc@815 1203 end
adamc@1073 1204 | ESetval (e1, e2) =>
adamc@1073 1205 let
adamc@1073 1206 val (e1, st) = exp outer (e1, st)
adamc@1073 1207 val (e2, st) = exp outer (e2, st)
adamc@1073 1208 in
adamc@1073 1209 ((ESetval (e1, e2), loc), st)
adamc@1073 1210 end
adamc@815 1211
adamc@1112 1212 | EUnurlify (e, t, b) =>
adamc@815 1213 let
adamc@815 1214 val (e, st) = exp outer (e, st)
adamc@815 1215 in
adamc@1112 1216 ((EUnurlify (e, t, b), loc), st)
adamc@815 1217 end
adamc@815 1218
adam@1422 1219 | EJavaScript (m as Source t, e') =>
adam@1422 1220 (foundJavaScript := true;
adam@1422 1221 let
adam@1422 1222 val (x', st) = jsExp m (t :: outer) ((ERel 0, loc), st)
adam@1422 1223 in
adam@1422 1224 ((ELet ("x", t, e', x'), loc), st)
adam@1422 1225 end
adam@1445 1226 handle CantEmbed _ =>
adam@1445 1227 (jsExp m outer (e', st)
adam@1445 1228 handle CantEmbed t => ((*ErrorMsg.errorAt loc "Unable to embed type in JavaScript";
adam@1445 1229 Print.preface ("Type",
adam@1445 1230 MonoPrint.p_typ MonoEnv.empty t);*)
adam@1445 1231 (e, st))))
adam@1422 1232
adamc@815 1233 | EJavaScript (m, e') =>
adamc@970 1234 (foundJavaScript := true;
adamc@970 1235 jsExp m outer (e', st)
adamc@1258 1236 handle CantEmbed t => ((*ErrorMsg.errorAt loc "Unable to embed type in JavaScript";
adamc@1258 1237 Print.preface ("Type",
adamc@1258 1238 MonoPrint.p_typ MonoEnv.empty t);*)
adamc@1176 1239 (e, st)))
adamc@815 1240
adamc@815 1241 | ESignalReturn e =>
adamc@815 1242 let
adamc@815 1243 val (e, st) = exp outer (e, st)
adamc@815 1244 in
adamc@815 1245 ((ESignalReturn e, loc), st)
adamc@815 1246 end
adamc@815 1247 | ESignalBind (e1, e2) =>
adamc@815 1248 let
adamc@815 1249 val (e1, st) = exp outer (e1, st)
adamc@815 1250 val (e2, st) = exp outer (e2, st)
adamc@815 1251 in
adamc@815 1252 ((ESignalBind (e1, e2), loc), st)
adamc@815 1253 end
adamc@815 1254 | ESignalSource e =>
adamc@815 1255 let
adamc@815 1256 val (e, st) = exp outer (e, st)
adamc@815 1257 in
adamc@815 1258 ((ESignalSource e, loc), st)
adamc@815 1259 end
adamc@815 1260
adam@1848 1261 | EServerCall (e1, t, ef, fm) =>
adamc@815 1262 let
adamc@815 1263 val (e1, st) = exp outer (e1, st)
adamc@815 1264 in
adam@1848 1265 ((EServerCall (e1, t, ef, fm), loc), st)
adamc@815 1266 end
adamc@1021 1267 | ERecv (e1, t) =>
adamc@815 1268 let
adamc@815 1269 val (e1, st) = exp outer (e1, st)
adamc@815 1270 in
adamc@1021 1271 ((ERecv (e1, t), loc), st)
adamc@815 1272 end
adamc@1021 1273 | ESleep e1 =>
adamc@815 1274 let
adamc@815 1275 val (e1, st) = exp outer (e1, st)
adamc@815 1276 in
adamc@1021 1277 ((ESleep e1, loc), st)
adamc@1021 1278 end
adamc@1021 1279 | ESpawn e1 =>
adamc@1021 1280 let
adamc@1021 1281 val (e1, st) = exp outer (e1, st)
adamc@1021 1282 in
adamc@1021 1283 ((ESpawn e1, loc), st)
adamc@815 1284 end)
adamc@815 1285
adamc@815 1286 fun decl (d as (_, loc), st) =
adamc@815 1287 case #1 d of
adamc@815 1288 DVal (x, n, t, e, s) =>
adamc@815 1289 let
adamc@815 1290 val (e, st) = exp [] (e, st)
adamc@815 1291 in
adamc@815 1292 ((DVal (x, n, t, e, s), loc), st)
adamc@815 1293 end
adamc@815 1294 | DValRec vis =>
adamc@815 1295 let
adamc@815 1296 val (vis, st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) =>
adamc@815 1297 let
adamc@815 1298 val (e, st) = exp [] (e, st)
adamc@815 1299 in
adamc@815 1300 ((x, n, t, e, s), st)
adamc@815 1301 end) st vis
adamc@815 1302 in
adamc@815 1303 ((DValRec vis, loc), st)
adamc@815 1304 end
adamc@815 1305 | _ => (d, st)
adamc@567 1306
adamc@567 1307 fun doDecl (d, st) =
adamc@567 1308 let
adamc@815 1309 (*val () = Print.preface ("doDecl", MonoPrint.p_decl MonoEnv.empty d)*)
adamc@815 1310 val (d, st) = decl (d, st)
adamc@840 1311
adamc@840 1312 val ds =
adamc@840 1313 case #decls st of
adamc@840 1314 [] => [d]
adamc@840 1315 | vis => [(DValRec vis, #2 d), d]
adamc@567 1316 in
adamc@840 1317 (ds,
adamc@567 1318 {decls = [],
adamc@589 1319 script = #script st,
adamc@595 1320 included = #included st,
adamc@595 1321 injectors = #injectors st,
adamc@800 1322 listInjectors = #listInjectors st,
adamc@638 1323 decoders = #decoders st,
adamc@595 1324 maxName = #maxName st})
adamc@567 1325 end
adamc@567 1326
adamc@567 1327 val (ds, st) = ListUtil.foldlMapConcat doDecl
adamc@567 1328 {decls = [],
adamc@589 1329 script = [],
adamc@595 1330 included = IS.empty,
adamc@595 1331 injectors = IM.empty,
adamc@800 1332 listInjectors = TM.empty,
adamc@638 1333 decoders = IM.empty,
adamc@595 1334 maxName = U.File.maxName file + 1}
adam@1845 1335 (#1 file)
adamc@569 1336
ezyang@1739 1337 val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Settings.libJs (), file = "urweb.js"})
adamc@569 1338 fun lines acc =
adamc@569 1339 case TextIO.inputLine inf of
adamc@569 1340 NONE => String.concat (rev acc)
adamc@569 1341 | SOME line => lines (line :: acc)
adamc@569 1342 val lines = lines []
adamc@794 1343
adamc@1323 1344 val urlRules = foldr (fn (r, s) =>
adamc@1323 1345 "cons({allow:"
adamc@1323 1346 ^ (if #action r = Settings.Allow then "true" else "false")
adamc@1323 1347 ^ ",prefix:"
adamc@1323 1348 ^ (if #kind r = Settings.Prefix then "true" else "false")
adamc@1323 1349 ^ ",pattern:\""
adamc@1323 1350 ^ #pattern r
adamc@1323 1351 ^ "\"},"
adamc@1323 1352 ^ s
adamc@1323 1353 ^ ")") "null" (Settings.getUrlRules ())
adamc@1323 1354
adamc@1323 1355 val urlRules = "urlRules = " ^ urlRules ^ ";\n\n"
adamc@1323 1356
adamc@794 1357 val script =
adamc@794 1358 if !foundJavaScript then
adamc@1323 1359 lines ^ urlRules ^ String.concat (rev (#script st))
adam@1656 1360 ^ "\ntime_format = \"" ^ Prim.toCString (Settings.getTimeFormat ()) ^ "\";\n"
adamc@794 1361 else
adamc@794 1362 ""
adamc@567 1363 in
adamc@569 1364 TextIO.closeIn inf;
adam@1845 1365 ((DJavaScript script, ErrorMsg.dummySpan) :: ds, #2 file)
adamc@567 1366 end
adamc@567 1367
adamc@567 1368 end