Mercurial > urweb

annotate src/jscomp.sml @ 2038:ec2c7a22df0d

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