Mercurial > urweb

annotate src/jscomp.sml @ 813:7b380e2b9e68

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