Mercurial > urweb

annotate src/jscomp.sml @ 1404:82b204f20026

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