Mercurial > urweb

annotate src/jscomp.sml @ 800:e92cfac1608f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Proper lifting of MonoEnv stored expressions; avoidance of onchange clobbering
author Adam Chlipala <adamc@hcoop.net>
date Thu, 14 May 2009 13:18:31 -0400
parents 83875a9eb9b8
children 5f49a6b759cb
rev   line source
adamc@567 1 (* Copyright (c) 2008, 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@567 45 decls : decl 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@567 54 fun varDepth (e, _) =
adamc@567 55 case e of
adamc@567 56 EPrim _ => 0
adamc@567 57 | ERel _ => 0
adamc@567 58 | ENamed _ => 0
adamc@567 59 | ECon (_, _, NONE) => 0
adamc@567 60 | ECon (_, _, SOME e) => varDepth e
adamc@567 61 | ENone _ => 0
adamc@567 62 | ESome (_, e) => varDepth e
adamc@567 63 | EFfi _ => 0
adamc@567 64 | EFfiApp (_, _, es) => foldl Int.max 0 (map varDepth es)
adamc@567 65 | EApp (e1, e2) => Int.max (varDepth e1, varDepth e2)
adamc@567 66 | EAbs _ => 0
adamc@567 67 | EUnop (_, e) => varDepth e
adamc@567 68 | EBinop (_, e1, e2) => Int.max (varDepth e1, varDepth e2)
adamc@567 69 | ERecord xes => foldl Int.max 0 (map (fn (_, e, _) => varDepth e) xes)
adamc@567 70 | EField (e, _) => varDepth e
adamc@567 71 | ECase (e, pes, _) =>
adamc@567 72 foldl Int.max (varDepth e)
adamc@567 73 (map (fn (p, e) => E.patBindsN p + varDepth e) pes)
adamc@567 74 | EStrcat (e1, e2) => Int.max (varDepth e1, varDepth e2)
adamc@567 75 | EError (e, _) => varDepth e
adamc@741 76 | EReturnBlob {blob = e1, mimeType = e2, ...} => Int.max (varDepth e1, varDepth e2)
adamc@567 77 | EWrite e => varDepth e
adamc@567 78 | ESeq (e1, e2) => Int.max (varDepth e1, varDepth e2)
adamc@567 79 | ELet (_, _, e1, e2) => Int.max (varDepth e1, 1 + varDepth e2)
adamc@567 80 | EClosure _ => 0
adamc@567 81 | EQuery _ => 0
adamc@567 82 | EDml _ => 0
adamc@567 83 | ENextval _ => 0
adamc@567 84 | EUnurlify _ => 0
adamc@567 85 | EJavaScript _ => 0
adamc@568 86 | ESignalReturn e => varDepth e
adamc@572 87 | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2)
adamc@574 88 | ESignalSource e => varDepth e
adamc@736 89 | EServerCall (e, ek, _, _) => Int.max (varDepth e, varDepth ek)
adamc@670 90 | ERecv (e, ek, _) => Int.max (varDepth e, varDepth ek)
adamc@695 91 | ESleep (e, ek) => Int.max (varDepth e, varDepth ek)
adamc@567 92
adamc@591 93 fun closedUpto d =
adamc@591 94 let
adamc@591 95 fun cu inner (e, _) =
adamc@591 96 case e of
adamc@591 97 EPrim _ => true
adamc@591 98 | ERel n => n < inner orelse n - inner >= d
adamc@591 99 | ENamed _ => true
adamc@591 100 | ECon (_, _, NONE) => true
adamc@591 101 | ECon (_, _, SOME e) => cu inner e
adamc@591 102 | ENone _ => true
adamc@591 103 | ESome (_, e) => cu inner e
adamc@591 104 | EFfi _ => true
adamc@591 105 | EFfiApp (_, _, es) => List.all (cu inner) es
adamc@591 106 | EApp (e1, e2) => cu inner e1 andalso cu inner e2
adamc@591 107 | EAbs (_, _, _, e) => cu (inner + 1) e
adamc@591 108 | EUnop (_, e) => cu inner e
adamc@591 109 | EBinop (_, e1, e2) => cu inner e1 andalso cu inner e2
adamc@591 110 | ERecord xes => List.all (fn (_, e, _) => cu inner e) xes
adamc@591 111 | EField (e, _) => cu inner e
adamc@591 112 | ECase (e, pes, _) =>
adamc@591 113 cu inner e
adamc@591 114 andalso List.all (fn (p, e) => cu (inner + E.patBindsN p) e) pes
adamc@591 115 | EStrcat (e1, e2) => cu inner e1 andalso cu inner e2
adamc@591 116 | EError (e, _) => cu inner e
adamc@741 117 | EReturnBlob {blob = e1, mimeType = e2, ...} => cu inner e1 andalso cu inner e2
adamc@591 118 | EWrite e => cu inner e
adamc@591 119 | ESeq (e1, e2) => cu inner e1 andalso cu inner e2
adamc@591 120 | ELet (_, _, e1, e2) => cu inner e1 andalso cu (inner + 1) e2
adamc@591 121 | EClosure (_, es) => List.all (cu inner) es
adamc@591 122 | EQuery {query, body, initial, ...} =>
adamc@591 123 cu inner query
adamc@591 124 andalso cu (inner + 2) body
adamc@591 125 andalso cu inner initial
adamc@591 126 | EDml e => cu inner e
adamc@591 127 | ENextval e => cu inner e
adamc@591 128 | EUnurlify (e, _) => cu inner e
adamc@591 129 | EJavaScript (_, e, _) => cu inner e
adamc@591 130 | ESignalReturn e => cu inner e
adamc@591 131 | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2
adamc@591 132 | ESignalSource e => cu inner e
adamc@736 133 | EServerCall (e, ek, _, _) => cu inner e andalso cu inner ek
adamc@670 134 | ERecv (e, ek, _) => cu inner e andalso cu inner ek
adamc@695 135 | ESleep (e, ek) => cu inner e andalso cu inner ek
adamc@591 136 in
adamc@591 137 cu 0
adamc@591 138 end
adamc@591 139
adamc@568 140 fun strcat loc es =
adamc@568 141 case es of
adamc@568 142 [] => (EPrim (Prim.String ""), loc)
adamc@568 143 | [x] => x
adamc@568 144 | x :: es' => (EStrcat (x, strcat loc es'), loc)
adamc@568 145
adamc@589 146 fun process file =
adamc@567 147 let
adamc@596 148 val (someTs, nameds) =
adamc@596 149 foldl (fn ((DVal (_, n, t, e, _), _), (someTs, nameds)) => (someTs, IM.insert (nameds, n, e))
adamc@596 150 | ((DValRec vis, _), (someTs, nameds)) =>
adamc@596 151 (someTs, foldl (fn ((_, n, _, e, _), nameds) => IM.insert (nameds, n, e))
adamc@596 152 nameds vis)
adamc@596 153 | ((DDatatype (_, _, cs), _), state as (someTs, nameds)) =>
adamc@596 154 if ElabUtil.classifyDatatype cs = Option then
adamc@596 155 (foldl (fn ((_, n, SOME t), someTs) => IM.insert (someTs, n, t)
adamc@596 156 | (_, someTs) => someTs) someTs cs,
adamc@596 157 nameds)
adamc@596 158 else
adamc@596 159 state
adamc@595 160 | (_, state) => state)
adamc@596 161 (IM.empty, IM.empty) file
adamc@567 162
adamc@590 163 fun str loc s = (EPrim (Prim.String s), loc)
adamc@590 164
adamc@594 165 fun isNullable (t, _) =
adamc@594 166 case t of
adamc@594 167 TOption _ => true
adamc@594 168 | TRecord [] => true
adamc@594 169 | _ => false
adamc@594 170
adamc@593 171 fun quoteExp loc (t : typ) (e, st) =
adamc@590 172 case #1 t of
adamc@593 173 TSource => (strcat loc [str loc "s",
adamc@593 174 (EFfiApp ("Basis", "htmlifyInt", [e]), loc)], st)
adamc@590 175
adamc@593 176 | TRecord [] => (str loc "null", st)
adamc@593 177 | TRecord [(x, t)] =>
adamc@593 178 let
adamc@593 179 val (e, st) = quoteExp loc t ((EField (e, x), loc), st)
adamc@593 180 in
adamc@593 181 (strcat loc [str loc ("{_" ^ x ^ ":"),
adamc@593 182 e,
adamc@593 183 str loc "}"], st)
adamc@593 184 end
adamc@593 185 | TRecord ((x, t) :: xts) =>
adamc@593 186 let
adamc@593 187 val (e', st) = quoteExp loc t ((EField (e, x), loc), st)
adamc@593 188 val (es, st) = ListUtil.foldlMap
adamc@593 189 (fn ((x, t), st) =>
adamc@593 190 let
adamc@593 191 val (e, st) = quoteExp loc t ((EField (e, x), loc), st)
adamc@593 192 in
adamc@593 193 (strcat loc [str loc (",_" ^ x ^ ":"), e], st)
adamc@593 194 end)
adamc@593 195 st xts
adamc@593 196 in
adamc@593 197 (strcat loc (str loc ("{_" ^ x ^ ":")
adamc@593 198 :: e'
adamc@593 199 :: es
adamc@593 200 @ [str loc "}"]), st)
adamc@593 201 end
adamc@590 202
adamc@593 203 | TFfi ("Basis", "string") => ((EFfiApp ("Basis", "jsifyString", [e]), loc), st)
adamc@593 204 | TFfi ("Basis", "int") => ((EFfiApp ("Basis", "htmlifyInt", [e]), loc), st)
adamc@593 205 | TFfi ("Basis", "float") => ((EFfiApp ("Basis", "htmlifyFloat", [e]), loc), st)
adamc@682 206 | TFfi ("Basis", "channel") => ((EFfiApp ("Basis", "jsifyChannel", [e]), loc), st)
adamc@593 207
adamc@593 208 | TFfi ("Basis", "bool") => ((ECase (e,
adamc@593 209 [((PCon (Enum, PConFfi {mod = "Basis",
adamc@593 210 datatyp = "bool",
adamc@593 211 con = "True",
adamc@593 212 arg = NONE}, NONE), loc),
adamc@593 213 str loc "true"),
adamc@593 214 ((PCon (Enum, PConFfi {mod = "Basis",
adamc@593 215 datatyp = "bool",
adamc@593 216 con = "False",
adamc@593 217 arg = NONE}, NONE), loc),
adamc@593 218 str loc "false")],
adamc@593 219 {disc = (TFfi ("Basis", "bool"), loc),
adamc@593 220 result = (TFfi ("Basis", "string"), loc)}), loc),
adamc@593 221 st)
adamc@592 222
adamc@594 223 | TOption t =>
adamc@594 224 let
adamc@594 225 val (e', st) = quoteExp loc t ((ERel 0, loc), st)
adamc@594 226 in
adamc@594 227 ((ECase (e,
adamc@594 228 [((PNone t, loc),
adamc@594 229 str loc "null"),
adamc@594 230 ((PSome (t, (PVar ("x", t), loc)), loc),
adamc@594 231 if isNullable t then
adamc@594 232 strcat loc [str loc "{v:", e', str loc "}"]
adamc@594 233 else
adamc@594 234 e')],
adamc@594 235 {disc = (TOption t, loc),
adamc@594 236 result = (TFfi ("Basis", "string"), loc)}), loc),
adamc@594 237 st)
adamc@594 238 end
adamc@594 239
adamc@800 240 | TList t' =>
adamc@800 241 (case TM.find (#listInjectors st, t') of
adamc@800 242 SOME n' => ((EApp ((ENamed n', loc), e), loc), st)
adamc@800 243 | NONE =>
adamc@800 244 let
adamc@800 245 val rt = (TRecord [("1", t'), ("2", t)], loc)
adamc@800 246
adamc@800 247 val n' = #maxName st
adamc@800 248 val st = {decls = #decls st,
adamc@800 249 script = #script st,
adamc@800 250 included = #included st,
adamc@800 251 injectors = #injectors st,
adamc@800 252 listInjectors = TM.insert (#listInjectors st, t', n'),
adamc@800 253 decoders = #decoders st,
adamc@800 254 maxName = n' + 1}
adamc@800 255
adamc@800 256 val s = (TFfi ("Basis", "string"), loc)
adamc@800 257 val (e', st) = quoteExp loc t ((EField ((ERel 0, loc), "1"), loc), st)
adamc@800 258
adamc@800 259 val body = (ECase ((ERel 0, loc),
adamc@800 260 [((PNone rt, loc),
adamc@800 261 str loc "null"),
adamc@800 262 ((PSome (rt, (PVar ("x", rt), loc)), loc),
adamc@800 263 strcat loc [str loc "{v:{_1:",
adamc@800 264 e',
adamc@800 265 str loc ",_2:",
adamc@800 266 (EApp ((ENamed n', loc),
adamc@800 267 (EField ((ERel 0, loc), "2"), loc)), loc),
adamc@800 268 str loc "}}"])],
adamc@800 269 {disc = t, result = s}), loc)
adamc@800 270 val body = (EAbs ("x", t, s, body), loc)
adamc@800 271
adamc@800 272 val st = {decls = (DValRec [("jsify", n', (TFun (t, s), loc),
adamc@800 273 body, "jsify")], loc) :: #decls st,
adamc@800 274 script = #script st,
adamc@800 275 included = #included st,
adamc@800 276 injectors = #injectors st,
adamc@800 277 listInjectors = #listInjectors st,
adamc@800 278 decoders= #decoders st,
adamc@800 279 maxName = #maxName st}
adamc@800 280
adamc@800 281
adamc@800 282 in
adamc@800 283 ((EApp ((ENamed n', loc), e), loc), st)
adamc@800 284 end)
adamc@800 285
adamc@595 286 | TDatatype (n, ref (dk, cs)) =>
adamc@595 287 (case IM.find (#injectors st, n) of
adamc@595 288 SOME n' => ((EApp ((ENamed n', loc), e), loc), st)
adamc@595 289 | NONE =>
adamc@595 290 let
adamc@595 291 val n' = #maxName st
adamc@595 292 val st = {decls = #decls st,
adamc@595 293 script = #script st,
adamc@595 294 included = #included st,
adamc@595 295 injectors = IM.insert (#injectors st, n, n'),
adamc@800 296 listInjectors = #listInjectors st,
adamc@638 297 decoders = #decoders st,
adamc@595 298 maxName = n' + 1}
adamc@595 299
adamc@595 300 val (pes, st) = ListUtil.foldlMap
adamc@595 301 (fn ((_, cn, NONE), st) =>
adamc@595 302 (((PCon (dk, PConVar cn, NONE), loc),
adamc@596 303 case dk of
adamc@596 304 Option => str loc "null"
adamc@596 305 | _ => str loc (Int.toString cn)),
adamc@595 306 st)
adamc@595 307 | ((_, cn, SOME t), st) =>
adamc@595 308 let
adamc@595 309 val (e, st) = quoteExp loc t ((ERel 0, loc), st)
adamc@595 310 in
adamc@595 311 (((PCon (dk, PConVar cn, SOME (PVar ("x", t), loc)), loc),
adamc@596 312 case dk of
adamc@596 313 Option =>
adamc@596 314 if isNullable t then
adamc@638 315 strcat loc [str loc "{v:",
adamc@596 316 e,
adamc@596 317 str loc "}"]
adamc@596 318 else
adamc@596 319 e
adamc@597 320 | _ => strcat loc [str loc ("{n:" ^ Int.toString cn
adamc@597 321 ^ ",v:"),
adamc@597 322 e,
adamc@597 323 str loc "}"]),
adamc@595 324 st)
adamc@595 325 end)
adamc@595 326 st cs
adamc@595 327
adamc@595 328 val s = (TFfi ("Basis", "string"), loc)
adamc@595 329 val body = (ECase ((ERel 0, loc), pes,
adamc@595 330 {disc = t, result = s}), loc)
adamc@595 331 val body = (EAbs ("x", t, s, body), loc)
adamc@595 332
adamc@595 333 val st = {decls = (DValRec [("jsify", n', (TFun (t, s), loc),
adamc@595 334 body, "jsify")], loc) :: #decls st,
adamc@595 335 script = #script st,
adamc@595 336 included = #included st,
adamc@595 337 injectors = #injectors st,
adamc@800 338 listInjectors = #listInjectors st,
adamc@638 339 decoders= #decoders st,
adamc@595 340 maxName = #maxName st}
adamc@595 341 in
adamc@595 342 ((EApp ((ENamed n', loc), e), loc), st)
adamc@595 343 end)
adamc@595 344
adamc@590 345 | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript";
adamc@590 346 Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];
adamc@593 347 (str loc "ERROR", st))
adamc@590 348
adamc@613 349 fun unurlifyExp loc (t : typ, st) =
adamc@613 350 case #1 t of
adamc@613 351 TRecord [] => ("null", st)
adamc@613 352 | TRecord [(x, t)] =>
adamc@613 353 let
adamc@613 354 val (e, st) = unurlifyExp loc (t, st)
adamc@613 355 in
adamc@613 356 ("{_" ^ x ^ ":" ^ e ^ "}",
adamc@613 357 st)
adamc@613 358 end
adamc@613 359 | TRecord ((x, t) :: xts) =>
adamc@613 360 let
adamc@613 361 val (e', st) = unurlifyExp loc (t, st)
adamc@613 362 val (es, st) = ListUtil.foldlMap
adamc@638 363 (fn ((x, t), st) =>
adamc@638 364 let
adamc@638 365 val (e, st) = unurlifyExp loc (t, st)
adamc@638 366 in
adamc@638 367 (",_" ^ x ^ ":" ^ e, st)
adamc@638 368 end)
adamc@638 369 st xts
adamc@613 370 in
adamc@613 371 (String.concat ("{_"
adamc@613 372 :: x
adamc@613 373 :: ":"
adamc@613 374 :: e'
adamc@613 375 :: es
adamc@613 376 @ ["}"]), st)
adamc@613 377 end
adamc@613 378
adamc@679 379 | TFfi ("Basis", "string") => ("uu(t[i++])", st)
adamc@613 380 | TFfi ("Basis", "int") => ("parseInt(t[i++])", st)
adamc@613 381 | TFfi ("Basis", "float") => ("parseFloat(t[i++])", st)
adamc@682 382 | TFfi ("Basis", "channel") => ("(t[i++].length > 0 ? parseInt(t[i]) : null)", st)
adamc@613 383
adamc@613 384 | TFfi ("Basis", "bool") => ("t[i++] == \"True\"", st)
adamc@613 385
adamc@638 386 | TOption t =>
adamc@613 387 let
adamc@638 388 val (e, st) = unurlifyExp loc (t, st)
adamc@638 389 val e = if isNullable t then
adamc@638 390 "{v:" ^ e ^ "}"
adamc@638 391 else
adamc@638 392 e
adamc@613 393 in
adamc@703 394 ("(t[i++]==\"Some\"?" ^ e ^ ":null)", st)
adamc@638 395 end
adamc@613 396
adamc@638 397 | TDatatype (n, ref (dk, cs)) =>
adamc@638 398 (case IM.find (#decoders st, n) of
adamc@638 399 SOME n' => ("(tmp=_n" ^ Int.toString n' ^ "(t,i),i=tmp._1,tmp._2)", st)
adamc@613 400 | NONE =>
adamc@613 401 let
adamc@613 402 val n' = #maxName st
adamc@613 403 val st = {decls = #decls st,
adamc@613 404 script = #script st,
adamc@613 405 included = #included st,
adamc@638 406 injectors = #injectors st,
adamc@800 407 listInjectors = #listInjectors st,
adamc@638 408 decoders = IM.insert (#decoders st, n, n'),
adamc@613 409 maxName = n' + 1}
adamc@613 410
adamc@638 411 val (e, st) = foldl (fn ((x, cn, NONE), (e, st)) =>
adamc@638 412 ("x==\"" ^ x ^ "\"?"
adamc@638 413 ^ (case dk of
adamc@638 414 Option => "null"
adamc@638 415 | _ => Int.toString cn)
adamc@638 416 ^ ":" ^ e,
adamc@613 417 st)
adamc@638 418 | ((x, cn, SOME t), (e, st)) =>
adamc@613 419 let
adamc@638 420 val (e', st) = unurlifyExp loc (t, st)
adamc@613 421 in
adamc@638 422 ("x==\"" ^ x ^ "\"?"
adamc@638 423 ^ (case dk of
adamc@638 424 Option =>
adamc@638 425 if isNullable t then
adamc@638 426 "{v:" ^ e' ^ "}"
adamc@638 427 else
adamc@638 428 e'
adamc@638 429 | _ => "{n:" ^ Int.toString cn ^ ",v:" ^ e' ^ "}")
adamc@638 430 ^ ":" ^ e,
adamc@613 431 st)
adamc@613 432 end)
adamc@638 433 ("pf()", st) cs
adamc@613 434
adamc@638 435 val body = "function _n" ^ Int.toString n' ^ "(t,i){var x=t[i++];var r="
adamc@638 436 ^ e ^ ";return {_1:i,_2:r}}\n\n"
adamc@613 437
adamc@638 438 val st = {decls = #decls st,
adamc@638 439 script = body :: #script st,
adamc@613 440 included = #included st,
adamc@613 441 injectors = #injectors st,
adamc@800 442 listInjectors = #listInjectors st,
adamc@638 443 decoders = #decoders st,
adamc@613 444 maxName = #maxName st}
adamc@613 445 in
adamc@638 446 ("(tmp=_n" ^ Int.toString n' ^ "(t,i),i=tmp._1,tmp._2)", st)
adamc@638 447 end)
adamc@613 448
adamc@613 449 | _ => (EM.errorAt loc "Don't know how to unurlify type in JavaScript";
adamc@613 450 Print.prefaces "Can't unurlify" [("t", MonoPrint.p_typ MonoEnv.empty t)];
adamc@613 451 ("ERROR", st))
adamc@613 452
adamc@646 453 fun padWith (ch, s, len) =
adamc@646 454 if size s < len then
adamc@646 455 padWith (ch, String.str ch ^ s, len - 1)
adamc@646 456 else
adamc@646 457 s
adamc@646 458
adamc@794 459 val foundJavaScript = ref false
adamc@794 460
adamc@800 461 fun jsExp mode outer =
adamc@567 462 let
adamc@589 463 val len = length outer
adamc@567 464
adamc@589 465 fun jsE inner (e as (_, loc), st) =
adamc@589 466 let
adamc@590 467 val str = str loc
adamc@567 468
adamc@589 469 fun var n = Int.toString (len + inner - n - 1)
adamc@567 470
adamc@589 471 fun patCon pc =
adamc@589 472 case pc of
adamc@589 473 PConVar n => str (Int.toString n)
adamc@589 474 | PConFfi {mod = "Basis", con = "True", ...} => str "true"
adamc@589 475 | PConFfi {mod = "Basis", con = "False", ...} => str "false"
adamc@589 476 | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"")
adamc@567 477
adamc@591 478 fun unsupported s =
adamc@591 479 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript[2]");
adamc@591 480 (str "ERROR", st))
adamc@577 481
adamc@589 482 val strcat = strcat loc
adamc@584 483
adamc@589 484 fun jsPrim p =
adamc@589 485 case p of
adamc@589 486 Prim.String s =>
adamc@589 487 str ("\""
adamc@589 488 ^ String.translate (fn #"'" =>
adamc@589 489 if mode = Attribute then
adamc@589 490 "\\047"
adamc@589 491 else
adamc@589 492 "'"
adamc@589 493 | #"\"" => "\\\""
adamc@589 494 | #"<" =>
adamc@589 495 if mode = Script then
adamc@589 496 "<"
adamc@589 497 else
adamc@589 498 "\\074"
adamc@589 499 | #"\\" => "\\\\"
adamc@646 500 | #"\n" => "\\n"
adamc@646 501 | #"\r" => "\\r"
adamc@646 502 | #"\t" => "\\t"
adamc@646 503 | ch =>
adamc@646 504 if Char.isPrint ch then
adamc@646 505 String.str ch
adamc@646 506 else
adamc@646 507 "\\" ^ padWith (#"0",
adamc@646 508 Int.fmt StringCvt.OCT (ord ch),
adamc@646 509 3)) s
adamc@589 510 ^ "\"")
adamc@589 511 | _ => str (Prim.toString p)
adamc@589 512
adamc@589 513 fun jsPat depth inner (p, _) succ fail =
adamc@589 514 case p of
adamc@589 515 PWild => succ
adamc@589 516 | PVar _ => strcat [str ("(_" ^ Int.toString (len + inner) ^ "=d"
adamc@589 517 ^ Int.toString depth ^ ","),
adamc@589 518 succ,
adamc@589 519 str ")"]
adamc@589 520 | PPrim p => strcat [str ("(d" ^ Int.toString depth ^ "=="),
adamc@589 521 jsPrim p,
adamc@589 522 str "?",
adamc@589 523 succ,
adamc@589 524 str ":",
adamc@589 525 fail,
adamc@589 526 str ")"]
adamc@589 527 | PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE) =>
adamc@589 528 strcat [str ("(d" ^ Int.toString depth ^ "?"),
adamc@589 529 succ,
adamc@589 530 str ":",
adamc@589 531 fail,
adamc@589 532 str ")"]
adamc@589 533 | PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE) =>
adamc@589 534 strcat [str ("(d" ^ Int.toString depth ^ "?"),
adamc@589 535 fail,
adamc@589 536 str ":",
adamc@589 537 succ,
adamc@589 538 str ")"]
adamc@596 539 | PCon (Option, _, NONE) =>
adamc@596 540 strcat [str ("(d" ^ Int.toString depth ^ "?"),
adamc@596 541 fail,
adamc@596 542 str ":",
adamc@596 543 succ,
adamc@596 544 str ")"]
adamc@596 545 | PCon (Option, PConVar n, SOME p) =>
adamc@596 546 (case IM.find (someTs, n) of
adamc@596 547 NONE => raise Fail "Jscomp: Not in someTs"
adamc@596 548 | SOME t =>
adamc@596 549 strcat [str ("(d" ^ Int.toString depth ^ "?("
adamc@596 550 ^ (if isNullable t then
adamc@596 551 "d" ^ Int.toString depth ^ "=d"
adamc@596 552 ^ Int.toString depth ^ ".v,"
adamc@596 553 else
adamc@596 554 "")),
adamc@596 555 jsPat depth inner p succ fail,
adamc@596 556 str "):",
adamc@596 557 fail,
adamc@596 558 str ")"])
adamc@589 559 | PCon (_, pc, NONE) =>
adamc@589 560 strcat [str ("(d" ^ Int.toString depth ^ "=="),
adamc@589 561 patCon pc,
adamc@589 562 str "?",
adamc@589 563 succ,
adamc@589 564 str ":",
adamc@589 565 fail,
adamc@589 566 str ")"]
adamc@589 567 | PCon (_, pc, SOME p) =>
adamc@589 568 strcat [str ("(d" ^ Int.toString depth ^ ".n=="),
adamc@589 569 patCon pc,
adamc@589 570 str ("?(d" ^ Int.toString depth ^ "=d" ^ Int.toString depth ^ ".v,"),
adamc@589 571 jsPat depth inner p succ fail,
adamc@589 572 str "):",
adamc@589 573 fail,
adamc@589 574 str ")"]
adamc@589 575 | PRecord xps =>
adamc@589 576 let
adamc@589 577 val (_, succ) = foldl
adamc@589 578 (fn ((x, p, _), (inner, succ)) =>
adamc@589 579 (inner + E.patBindsN p,
adamc@589 580 strcat [str ("(d" ^ Int.toString (depth+1) ^ "=d"
adamc@589 581 ^ Int.toString depth ^ "._" ^ x ^ ","),
adamc@589 582 jsPat (depth+1) inner p succ fail,
adamc@589 583 str ")"]))
adamc@589 584 (inner, succ) xps
adamc@589 585 in
adamc@589 586 succ
adamc@589 587 end
adamc@589 588 | PNone _ => strcat [str ("(d" ^ Int.toString depth ^ "?"),
adamc@589 589 fail,
adamc@589 590 str ":",
adamc@589 591 succ,
adamc@589 592 str ")"]
adamc@594 593 | PSome (t, p) => strcat (str ("(d" ^ Int.toString depth ^ "?")
adamc@594 594 :: (if isNullable t then
adamc@594 595 [str ("d" ^ Int.toString depth
adamc@594 596 ^ "=d" ^ Int.toString depth ^ ".v")]
adamc@594 597 else
adamc@594 598 [])
adamc@594 599 @ [jsPat depth inner p succ fail,
adamc@594 600 str ":",
adamc@594 601 fail,
adamc@594 602 str ")"])
adamc@589 603
adamc@601 604 val jsifyString = String.translate (fn #"\"" => "\\\""
adamc@601 605 | #"\\" => "\\\\"
adamc@601 606 | ch => String.str ch)
adamc@601 607
adamc@601 608 fun jsifyStringMulti (n, s) =
adamc@601 609 case n of
adamc@601 610 0 => s
adamc@601 611 | _ => jsifyStringMulti (n - 1, jsifyString s)
adamc@601 612
adamc@601 613 fun deStrcat level (all as (e, _)) =
adamc@589 614 case e of
adamc@601 615 EPrim (Prim.String s) => jsifyStringMulti (level, s)
adamc@601 616 | EStrcat (e1, e2) => deStrcat level e1 ^ deStrcat level e2
adamc@601 617 | EFfiApp ("Basis", "jsifyString", [e]) => "\"" ^ deStrcat (level + 1) e ^ "\""
adamc@601 618 | _ => (Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)];
adamc@601 619 raise Fail "Jscomp: deStrcat")
adamc@590 620
adamc@590 621 val quoteExp = quoteExp loc
adamc@567 622 in
adamc@590 623 (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e)];*)
adamc@590 624
adamc@589 625 case #1 e of
adamc@589 626 EPrim p => (jsPrim p, st)
adamc@589 627 | ERel n =>
adamc@589 628 if n < inner then
adamc@589 629 (str ("_" ^ var n), st)
adamc@589 630 else
adamc@589 631 let
adamc@589 632 val n = n - inner
adamc@589 633 in
adamc@800 634 quoteExp (List.nth (outer, n)) ((ERel n, loc), st)
adamc@589 635 end
adamc@567 636
adamc@589 637 | ENamed n =>
adamc@589 638 let
adamc@589 639 val st =
adamc@589 640 if IS.member (#included st, n) then
adamc@589 641 st
adamc@589 642 else
adamc@589 643 case IM.find (nameds, n) of
adamc@589 644 NONE => raise Fail "Jscomp: Unbound ENamed"
adamc@589 645 | SOME e =>
adamc@589 646 let
adamc@589 647 val st = {decls = #decls st,
adamc@589 648 script = #script st,
adamc@595 649 included = IS.add (#included st, n),
adamc@595 650 injectors = #injectors st,
adamc@800 651 listInjectors = #listInjectors st,
adamc@638 652 decoders = #decoders st,
adamc@595 653 maxName = #maxName st}
adamc@578 654
adamc@800 655 val (e, st) = jsExp mode [] 0 (e, st)
adamc@601 656 val e = deStrcat 0 e
adamc@589 657
adamc@589 658 val sc = "_n" ^ Int.toString n ^ "=" ^ e ^ ";\n"
adamc@589 659 in
adamc@589 660 {decls = #decls st,
adamc@589 661 script = sc :: #script st,
adamc@595 662 included = #included st,
adamc@595 663 injectors = #injectors st,
adamc@800 664 listInjectors = #listInjectors st,
adamc@638 665 decoders= #decoders st,
adamc@595 666 maxName = #maxName st}
adamc@589 667 end
adamc@589 668 in
adamc@589 669 (str ("_n" ^ Int.toString n), st)
adamc@589 670 end
adamc@589 671
adamc@596 672 | ECon (Option, _, NONE) => (str "null", st)
adamc@596 673 | ECon (Option, PConVar n, SOME e) =>
adamc@596 674 let
adamc@596 675 val (e, st) = jsE inner (e, st)
adamc@596 676 in
adamc@596 677 case IM.find (someTs, n) of
adamc@596 678 NONE => raise Fail "Jscomp: Not in someTs [2]"
adamc@596 679 | SOME t =>
adamc@596 680 (if isNullable t then
adamc@596 681 strcat [str "{v:",
adamc@596 682 e,
adamc@596 683 str "}"]
adamc@596 684 else
adamc@596 685 e, st)
adamc@596 686 end
adamc@596 687
adamc@589 688 | ECon (_, pc, NONE) => (patCon pc, st)
adamc@589 689 | ECon (_, pc, SOME e) =>
adamc@589 690 let
adamc@589 691 val (s, st) = jsE inner (e, st)
adamc@589 692 in
adamc@589 693 (strcat [str "{n:",
adamc@589 694 patCon pc,
adamc@589 695 str ",v:",
adamc@589 696 s,
adamc@589 697 str "}"], st)
adamc@589 698 end
adamc@596 699
adamc@589 700 | ENone _ => (str "null", st)
adamc@589 701 | ESome (t, e) =>
adamc@572 702 let
adamc@572 703 val (e, st) = jsE inner (e, st)
adamc@572 704 in
adamc@589 705 (if isNullable t then
adamc@589 706 strcat [str "{v:", e, str "}"]
adamc@589 707 else
adamc@589 708 e, st)
adamc@589 709 end
adamc@589 710
adamc@589 711 | EFfi k =>
adamc@589 712 let
adamc@765 713 val name = case Settings.jsFunc k of
adamc@589 714 NONE => (EM.errorAt loc ("Unsupported FFI identifier " ^ #2 k
adamc@589 715 ^ " in JavaScript");
adamc@589 716 "ERROR")
adamc@589 717 | SOME s => s
adamc@589 718 in
adamc@589 719 (str name, st)
adamc@589 720 end
adamc@589 721 | EFfiApp (m, x, args) =>
adamc@589 722 let
adamc@589 723 val args =
adamc@589 724 case (m, x, args) of
adamc@794 725 ("Basis", "new_client_source", [(EJavaScript (_, e, _), _)]) =>
adamc@794 726 (foundJavaScript := true; [e])
adamc@794 727 | ("Basis", "set_client_source", [e1, (EJavaScript (_, e2, _), _)]) =>
adamc@794 728 (foundJavaScript := true; [e1, e2])
adamc@589 729 | _ => args
adamc@589 730
adamc@765 731 val name = case Settings.jsFunc (m, x) of
adamc@589 732 NONE => (EM.errorAt loc ("Unsupported FFI function "
adamc@589 733 ^ x ^ " in JavaScript");
adamc@589 734 "ERROR")
adamc@589 735 | SOME s => s
adamc@589 736 in
adamc@589 737 case args of
adamc@589 738 [] => (str (name ^ "()"), st)
adamc@589 739 | [e] =>
adamc@589 740 let
adamc@589 741 val (e, st) = jsE inner (e, st)
adamc@589 742 in
adamc@589 743 (strcat [str (name ^ "("),
adamc@589 744 e,
adamc@589 745 str ")"], st)
adamc@589 746 end
adamc@589 747 | e :: es =>
adamc@589 748 let
adamc@589 749 val (e, st) = jsE inner (e, st)
adamc@589 750 val (es, st) = ListUtil.foldlMapConcat
adamc@589 751 (fn (e, st) =>
adamc@589 752 let
adamc@589 753 val (e, st) = jsE inner (e, st)
adamc@589 754 in
adamc@589 755 ([str ",", e], st)
adamc@589 756 end)
adamc@589 757 st es
adamc@589 758 in
adamc@589 759 (strcat (str (name ^ "(")
adamc@589 760 :: e
adamc@589 761 :: es
adamc@589 762 @ [str ")"]), st)
adamc@589 763 end
adamc@589 764 end
adamc@589 765
adamc@589 766 | EApp (e1, e2) =>
adamc@589 767 let
adamc@589 768 val (e1, st) = jsE inner (e1, st)
adamc@589 769 val (e2, st) = jsE inner (e2, st)
adamc@589 770 in
adamc@589 771 (strcat [e1, str "(", e2, str ")"], st)
adamc@589 772 end
adamc@589 773 | EAbs (_, _, _, e) =>
adamc@589 774 let
adamc@589 775 val locals = List.tabulate
adamc@589 776 (varDepth e,
adamc@589 777 fn i => str ("var _" ^ Int.toString (len + inner + i + 1) ^ ";"))
adamc@589 778 val (e, st) = jsE (inner + 1) (e, st)
adamc@589 779 in
adamc@589 780 (strcat (str ("function(_"
adamc@589 781 ^ Int.toString (len + inner)
adamc@589 782 ^ "){")
adamc@589 783 :: locals
adamc@589 784 @ [str "return ",
adamc@589 785 e,
adamc@589 786 str "}"]),
adamc@589 787 st)
adamc@589 788 end
adamc@589 789
adamc@589 790 | EUnop (s, e) =>
adamc@589 791 let
adamc@589 792 val (e, st) = jsE inner (e, st)
adamc@589 793 in
adamc@589 794 (strcat [str ("(" ^ s),
adamc@572 795 e,
adamc@589 796 str ")"],
adamc@589 797 st)
adamc@589 798 end
adamc@589 799 | EBinop (s, e1, e2) =>
adamc@589 800 let
adamc@729 801 val s =
adamc@729 802 case s of
adamc@729 803 "!strcmp" => "=="
adamc@729 804 | _ => s
adamc@729 805
adamc@589 806 val (e1, st) = jsE inner (e1, st)
adamc@589 807 val (e2, st) = jsE inner (e2, st)
adamc@589 808 in
adamc@589 809 (strcat [str "(",
adamc@589 810 e1,
adamc@589 811 str s,
adamc@589 812 e2,
adamc@589 813 str ")"],
adamc@589 814 st)
adamc@589 815 end
adamc@589 816
adamc@589 817 | ERecord [] => (str "null", st)
adamc@589 818 | ERecord [(x, e, _)] =>
adamc@589 819 let
adamc@589 820 val (e, st) = jsE inner (e, st)
adamc@589 821 in
adamc@589 822 (strcat [str "{_x:", e, str "}"], st)
adamc@589 823 end
adamc@589 824 | ERecord ((x, e, _) :: xes) =>
adamc@589 825 let
adamc@589 826 val (e, st) = jsE inner (e, st)
adamc@589 827
adamc@589 828 val (es, st) =
adamc@589 829 foldr (fn ((x, e, _), (es, st)) =>
adamc@589 830 let
adamc@589 831 val (e, st) = jsE inner (e, st)
adamc@589 832 in
adamc@589 833 (str (",_" ^ x ^ ":")
adamc@589 834 :: e
adamc@589 835 :: es,
adamc@589 836 st)
adamc@589 837 end)
adamc@589 838 ([str "}"], st) xes
adamc@589 839 in
adamc@589 840 (strcat (str ("{_" ^ x ^ ":")
adamc@589 841 :: e
adamc@589 842 :: es),
adamc@589 843 st)
adamc@589 844 end
adamc@589 845 | EField (e, x) =>
adamc@589 846 let
adamc@589 847 val (e, st) = jsE inner (e, st)
adamc@589 848 in
adamc@589 849 (strcat [e,
adamc@589 850 str ("._" ^ x)], st)
adamc@589 851 end
adamc@589 852
adamc@591 853 | ECase (e', pes, {result, ...}) =>
adamc@679 854 (*if closedUpto inner e andalso List.all (fn (_, e) => closedUpto inner e) pes then
adamc@593 855 let
adamc@593 856 val (e', st) = quoteExp result ((ERel 0, loc), st)
adamc@593 857 in
adamc@593 858 ((ELet ("js", result, e, e'), loc),
adamc@593 859 st)
adamc@593 860 end
adamc@679 861 else*)
adamc@591 862 let
adamc@591 863 val plen = length pes
adamc@589 864
adamc@591 865 val (cases, st) = ListUtil.foldliMap
adamc@591 866 (fn (i, (p, e), st) =>
adamc@591 867 let
adamc@591 868 val (e, st) = jsE (inner + E.patBindsN p) (e, st)
adamc@591 869 val fail =
adamc@591 870 if i = plen - 1 then
adamc@591 871 str "pf()"
adamc@591 872 else
adamc@591 873 str ("c" ^ Int.toString (i+1) ^ "()")
adamc@591 874 val c = jsPat 0 inner p e fail
adamc@591 875 in
adamc@591 876 (strcat [str ("c" ^ Int.toString i ^ "=function(){return "),
adamc@591 877 c,
adamc@591 878 str "},"],
adamc@591 879 st)
adamc@591 880 end)
adamc@591 881 st pes
adamc@589 882
adamc@591 883 val (e, st) = jsE inner (e', st)
adamc@591 884 in
adamc@798 885 (strcat (str "(d0="
adamc@798 886 :: e
adamc@798 887 :: str ","
adamc@591 888 :: List.revAppend (cases,
adamc@798 889 [str "c0())"])), st)
adamc@591 890 end
adamc@589 891
adamc@589 892 | EStrcat (e1, e2) =>
adamc@589 893 let
adamc@589 894 val (e1, st) = jsE inner (e1, st)
adamc@589 895 val (e2, st) = jsE inner (e2, st)
adamc@589 896 in
adamc@693 897 (strcat [str "cat(", e1, str ",", e2, str ")"], st)
adamc@589 898 end
adamc@589 899
adamc@589 900 | EError (e, _) =>
adamc@589 901 let
adamc@589 902 val (e, st) = jsE inner (e, st)
adamc@589 903 in
adamc@726 904 (strcat [str "er(", e, str ")"],
adamc@589 905 st)
adamc@589 906 end
adamc@589 907
adamc@589 908 | EWrite e =>
adamc@589 909 let
adamc@589 910 val (e, st) = jsE inner (e, st)
adamc@589 911 in
adamc@589 912 (strcat [str "document.write(",
adamc@589 913 e,
adamc@589 914 str ".v)"], st)
adamc@589 915 end
adamc@589 916
adamc@589 917 | ESeq (e1, e2) =>
adamc@589 918 let
adamc@589 919 val (e1, st) = jsE inner (e1, st)
adamc@589 920 val (e2, st) = jsE inner (e2, st)
adamc@589 921 in
adamc@589 922 (strcat [str "(", e1, str ",", e2, str ")"], st)
adamc@589 923 end
adamc@589 924 | ELet (_, _, e1, e2) =>
adamc@589 925 let
adamc@589 926 val (e1, st) = jsE inner (e1, st)
adamc@589 927 val (e2, st) = jsE (inner + 1) (e2, st)
adamc@589 928 in
adamc@589 929 (strcat [str ("(_" ^ Int.toString (len + inner) ^ "="),
adamc@589 930 e1,
adamc@589 931 str ",",
adamc@589 932 e2,
adamc@572 933 str ")"], st)
adamc@572 934 end
adamc@589 935
adamc@794 936 | EJavaScript (Source _, _, SOME _) =>
adamc@794 937 (foundJavaScript := true;
adamc@794 938 (e, st))
adamc@603 939 | EJavaScript (_, _, SOME e) =>
adamc@794 940 (foundJavaScript := true;
adamc@794 941 (strcat [str "cs(function(){return ",
adamc@794 942 e,
adamc@794 943 str "})"],
adamc@794 944 st))
adamc@590 945
adamc@589 946 | EClosure _ => unsupported "EClosure"
adamc@589 947 | EQuery _ => unsupported "Query"
adamc@589 948 | EDml _ => unsupported "DML"
adamc@589 949 | ENextval _ => unsupported "Nextval"
adamc@589 950 | EUnurlify _ => unsupported "EUnurlify"
adamc@741 951 | EReturnBlob _ => unsupported "EUnurlify"
adamc@601 952 | EJavaScript (_, e, _) =>
adamc@601 953 let
adamc@601 954 val (e, st) = jsE inner (e, st)
adamc@601 955 in
adamc@794 956 foundJavaScript := true;
adamc@693 957 (strcat [str "cs(function(){return ",
adamc@603 958 e,
adamc@693 959 str "})"],
adamc@603 960 st)
adamc@601 961 end
adamc@590 962
adamc@589 963 | ESignalReturn e =>
adamc@572 964 let
adamc@572 965 val (e, st) = jsE inner (e, st)
adamc@572 966 in
adamc@589 967 (strcat [str "sr(",
adamc@589 968 e,
adamc@589 969 str ")"],
adamc@589 970 st)
adamc@589 971 end
adamc@589 972 | ESignalBind (e1, e2) =>
adamc@589 973 let
adamc@589 974 val (e1, st) = jsE inner (e1, st)
adamc@589 975 val (e2, st) = jsE inner (e2, st)
adamc@589 976 in
adamc@589 977 (strcat [str "sb(",
adamc@589 978 e1,
adamc@589 979 str ",",
adamc@589 980 e2,
adamc@589 981 str ")"],
adamc@589 982 st)
adamc@589 983 end
adamc@589 984 | ESignalSource e =>
adamc@589 985 let
adamc@589 986 val (e, st) = jsE inner (e, st)
adamc@589 987 in
adamc@589 988 (strcat [str "ss(",
adamc@589 989 e,
adamc@589 990 str ")"],
adamc@589 991 st)
adamc@572 992 end
adamc@608 993
adamc@736 994 | EServerCall (e, ek, t, eff) =>
adamc@609 995 let
adamc@614 996 val (e, st) = jsE inner (e, st)
adamc@609 997 val (ek, st) = jsE inner (ek, st)
adamc@613 998 val (unurl, st) = unurlifyExp loc (t, st)
adamc@609 999 in
adamc@764 1000 (strcat [str ("rc(cat(\"" ^ Settings.getUrlPrefix () ^ "\","),
adamc@614 1001 e,
adamc@703 1002 str ("), function(s){var t=s.split(\"/\");var i=0;return "
adamc@613 1003 ^ unurl ^ "},"),
adamc@609 1004 ek,
adamc@736 1005 str (","
adamc@736 1006 ^ (case eff of
adamc@736 1007 ReadCookieWrite => "true"
adamc@736 1008 | _ => "false")
adamc@736 1009 ^ ")")],
adamc@609 1010 st)
adamc@609 1011 end
adamc@670 1012
adamc@670 1013 | ERecv (e, ek, t) =>
adamc@670 1014 let
adamc@670 1015 val (e, st) = jsE inner (e, st)
adamc@670 1016 val (ek, st) = jsE inner (ek, st)
adamc@670 1017 val (unurl, st) = unurlifyExp loc (t, st)
adamc@670 1018 in
adamc@670 1019 (strcat [str "rv(",
adamc@670 1020 e,
adamc@670 1021 str (", function(s){var t=s.split(\"/\");var i=0;return "
adamc@670 1022 ^ unurl ^ "},"),
adamc@670 1023 ek,
adamc@670 1024 str ")"],
adamc@670 1025 st)
adamc@670 1026 end
adamc@695 1027
adamc@695 1028 | ESleep (e, ek) =>
adamc@695 1029 let
adamc@695 1030 val (e, st) = jsE inner (e, st)
adamc@695 1031 val (ek, st) = jsE inner (ek, st)
adamc@695 1032 in
adamc@695 1033 (strcat [str "window.setTimeout(",
adamc@695 1034 ek,
adamc@695 1035 str ", ",
adamc@695 1036 e,
adamc@695 1037 str ")"],
adamc@695 1038 st)
adamc@695 1039 end
adamc@567 1040 end
adamc@589 1041 in
adamc@589 1042 jsE
adamc@589 1043 end
adamc@567 1044
adamc@589 1045 val decl : state -> decl -> decl * state =
adamc@589 1046 U.Decl.foldMapB {typ = fn x => x,
adamc@589 1047 exp = fn (env, e, st) =>
adamc@589 1048 let
adamc@800 1049 fun doCode m env orig e =
adamc@589 1050 let
adamc@589 1051 val len = length env
adamc@589 1052 fun str s = (EPrim (Prim.String s), #2 e)
adamc@567 1053
adamc@589 1054 val locals = List.tabulate
adamc@589 1055 (varDepth e,
adamc@589 1056 fn i => str ("var _" ^ Int.toString (len + i) ^ ";"))
adamc@800 1057 val (e, st) = jsExp m env 0 (e, st)
adamc@589 1058 in
adamc@589 1059 (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st)
adamc@589 1060 end
adamc@589 1061 in
adamc@589 1062 case e of
adamc@651 1063 EJavaScript (m, orig, NONE) =>
adamc@794 1064 (foundJavaScript := true;
adamc@800 1065 doCode m env orig orig)
adamc@589 1066 | _ => (e, st)
adamc@589 1067 end,
adamc@589 1068 decl = fn (_, e, st) => (e, st),
adamc@589 1069 bind = fn (env, U.Decl.RelE (_, t)) => t :: env
adamc@589 1070 | (env, _) => env}
adamc@589 1071 []
adamc@567 1072
adamc@567 1073 fun doDecl (d, st) =
adamc@567 1074 let
adamc@567 1075 val (d, st) = decl st d
adamc@567 1076 in
adamc@567 1077 (List.revAppend (#decls st, [d]),
adamc@567 1078 {decls = [],
adamc@589 1079 script = #script st,
adamc@595 1080 included = #included st,
adamc@595 1081 injectors = #injectors st,
adamc@800 1082 listInjectors = #listInjectors st,
adamc@638 1083 decoders = #decoders st,
adamc@595 1084 maxName = #maxName st})
adamc@567 1085 end
adamc@567 1086
adamc@567 1087 val (ds, st) = ListUtil.foldlMapConcat doDecl
adamc@567 1088 {decls = [],
adamc@589 1089 script = [],
adamc@595 1090 included = IS.empty,
adamc@595 1091 injectors = IM.empty,
adamc@800 1092 listInjectors = TM.empty,
adamc@638 1093 decoders = IM.empty,
adamc@595 1094 maxName = U.File.maxName file + 1}
adamc@567 1095 file
adamc@569 1096
adamc@569 1097 val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.libJs, file = "urweb.js"})
adamc@569 1098 fun lines acc =
adamc@569 1099 case TextIO.inputLine inf of
adamc@569 1100 NONE => String.concat (rev acc)
adamc@569 1101 | SOME line => lines (line :: acc)
adamc@569 1102 val lines = lines []
adamc@794 1103
adamc@794 1104 val script =
adamc@794 1105 if !foundJavaScript then
adamc@794 1106 lines ^ String.concat (rev (#script st))
adamc@794 1107 else
adamc@794 1108 ""
adamc@567 1109 in
adamc@569 1110 TextIO.closeIn inf;
adamc@794 1111 (DJavaScript script, ErrorMsg.dummySpan) :: ds
adamc@567 1112 end
adamc@567 1113
adamc@567 1114 end