adam@1848: (* Copyright (c) 2008-2013, Adam Chlipala adamc@567: * All rights reserved. adamc@567: * adamc@567: * Redistribution and use in source and binary forms, with or without adamc@567: * modification, are permitted provided that the following conditions are met: adamc@567: * adamc@567: * - Redistributions of source code must retain the above copyright notice, adamc@567: * this list of conditions and the following disclaimer. adamc@567: * - Redistributions in binary form must reproduce the above copyright notice, adamc@567: * this list of conditions and the following disclaimer in the documentation adamc@567: * and/or other materials provided with the distribution. adamc@567: * - The names of contributors may not be used to endorse or promote products adamc@567: * derived from this software without specific prior written permission. adamc@567: * adamc@567: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@567: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@567: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@567: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@567: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@567: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@567: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@567: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@567: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@567: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@567: * POSSIBILITY OF SUCH DAMAGE. adamc@567: *) adamc@567: adamc@567: structure JsComp :> JSCOMP = struct adamc@567: adamc@567: open Mono adamc@567: adamc@567: structure EM = ErrorMsg adamc@567: structure E = MonoEnv adamc@567: structure U = MonoUtil adamc@567: adamc@589: structure IS = IntBinarySet adamc@589: structure IM = IntBinaryMap adamc@589: adamc@800: structure TM = BinaryMapFn(struct adamc@800: type ord_key = typ adamc@800: val compare = U.Typ.compare adamc@800: end) adamc@800: adam@1995: val explainEmbed = ref false adam@1995: adamc@567: type state = { adamc@840: decls : (string * int * (string * int * typ option) list) list, adamc@589: script : string list, adamc@595: included : IS.set, adamc@595: injectors : int IM.map, adamc@800: listInjectors : int TM.map, adamc@638: decoders : int IM.map, adamc@595: maxName : int adamc@567: } adamc@567: adamc@568: fun strcat loc es = adamc@568: case es of adam@2048: [] => (EPrim (Prim.String (Prim.Normal, "")), loc) adamc@568: | [x] => x adamc@568: | x :: es' => (EStrcat (x, strcat loc es'), loc) adamc@568: adamc@815: exception CantEmbed of typ adamc@815: adamc@970: fun inString {needle, haystack} = String.isSubstring needle haystack adamc@847: adam@1845: fun process (file : file) = adamc@567: let adamc@596: val (someTs, nameds) = adamc@596: foldl (fn ((DVal (_, n, t, e, _), _), (someTs, nameds)) => (someTs, IM.insert (nameds, n, e)) adamc@596: | ((DValRec vis, _), (someTs, nameds)) => adamc@596: (someTs, foldl (fn ((_, n, _, e, _), nameds) => IM.insert (nameds, n, e)) adamc@596: nameds vis) adamc@808: | ((DDatatype dts, _), state as (someTs, nameds)) => adamc@808: (foldl (fn ((_, _, cs), someTs) => adamc@808: if ElabUtil.classifyDatatype cs = Option then adamc@808: foldl (fn ((_, n, SOME t), someTs) => IM.insert (someTs, n, t) adamc@808: | (_, someTs) => someTs) someTs cs adamc@808: else adamc@808: someTs) someTs dts, adamc@808: nameds) adamc@595: | (_, state) => state) adam@1845: (IM.empty, IM.empty) (#1 file) adamc@567: adam@2048: fun str loc s = (EPrim (Prim.String (Prim.Normal, s)), loc) adamc@590: adamc@594: fun isNullable (t, _) = adamc@594: case t of adamc@594: TOption _ => true adamc@841: | TList _ => true adamc@841: | TDatatype (_, ref (Option, _)) => true adamc@594: | TRecord [] => true adamc@594: | _ => false adamc@594: adamc@593: fun quoteExp loc (t : typ) (e, st) = adamc@590: case #1 t of adam@1663: TSource => ((EFfiApp ("Basis", "htmlifySource", [(e, t)]), loc), st) adamc@590: adamc@593: | TRecord [] => (str loc "null", st) adamc@593: | TRecord [(x, t)] => adamc@593: let adamc@593: val (e, st) = quoteExp loc t ((EField (e, x), loc), st) adamc@593: in adamc@593: (strcat loc [str loc ("{_" ^ x ^ ":"), adamc@593: e, adamc@593: str loc "}"], st) adamc@593: end adamc@593: | TRecord ((x, t) :: xts) => adamc@593: let adamc@593: val (e', st) = quoteExp loc t ((EField (e, x), loc), st) adamc@593: val (es, st) = ListUtil.foldlMap adamc@593: (fn ((x, t), st) => adamc@593: let adamc@593: val (e, st) = quoteExp loc t ((EField (e, x), loc), st) adamc@593: in adamc@593: (strcat loc [str loc (",_" ^ x ^ ":"), e], st) adamc@593: end) adamc@593: st xts adamc@593: in adamc@593: (strcat loc (str loc ("{_" ^ x ^ ":") adamc@593: :: e' adamc@593: :: es adamc@593: @ [str loc "}"]), st) adamc@593: end adamc@590: adam@1663: | TFfi ("Basis", "string") => ((EFfiApp ("Basis", "jsifyString", [(e, t)]), loc), st) adam@1663: | TFfi ("Basis", "char") => ((EFfiApp ("Basis", "jsifyChar", [(e, t)]), loc), st) adam@1663: | TFfi ("Basis", "int") => ((EFfiApp ("Basis", "htmlifyInt", [(e, t)]), loc), st) adam@1663: | TFfi ("Basis", "float") => ((EFfiApp ("Basis", "htmlifyFloat", [(e, t)]), loc), st) adam@1663: | TFfi ("Basis", "channel") => ((EFfiApp ("Basis", "jsifyChannel", [(e, t)]), loc), st) adam@1663: | TFfi ("Basis", "time") => ((EFfiApp ("Basis", "jsifyTime", [(e, t)]), loc), st) adamc@593: adamc@593: | TFfi ("Basis", "bool") => ((ECase (e, adamc@593: [((PCon (Enum, PConFfi {mod = "Basis", adamc@593: datatyp = "bool", adamc@593: con = "True", adamc@593: arg = NONE}, NONE), loc), adamc@593: str loc "true"), adamc@593: ((PCon (Enum, PConFfi {mod = "Basis", adamc@593: datatyp = "bool", adamc@593: con = "False", adamc@593: arg = NONE}, NONE), loc), adamc@593: str loc "false")], adamc@593: {disc = (TFfi ("Basis", "bool"), loc), adamc@593: result = (TFfi ("Basis", "string"), loc)}), loc), adamc@593: st) adamc@592: adamc@594: | TOption t => adamc@594: let adamc@594: val (e', st) = quoteExp loc t ((ERel 0, loc), st) adamc@594: in adamc@813: (case #1 e' of adam@2048: EPrim (Prim.String (_, "ERROR")) => raise Fail "UHOH" adamc@813: | _ => adamc@813: (ECase (e, adamc@813: [((PNone t, loc), adamc@813: str loc "null"), adamc@813: ((PSome (t, (PVar ("x", t), loc)), loc), adamc@813: if isNullable t then adamc@813: strcat loc [str loc "{v:", e', str loc "}"] adamc@813: else adamc@813: e')], adamc@813: {disc = (TOption t, loc), adamc@813: result = (TFfi ("Basis", "string"), loc)}), loc), adamc@594: st) adamc@594: end adamc@594: adamc@800: | TList t' => adamc@800: (case TM.find (#listInjectors st, t') of adamc@800: SOME n' => ((EApp ((ENamed n', loc), e), loc), st) adamc@800: | NONE => adamc@800: let adamc@800: val rt = (TRecord [("1", t'), ("2", t)], loc) adamc@800: adamc@800: val n' = #maxName st adamc@800: val st = {decls = #decls st, adamc@800: script = #script st, adamc@800: included = #included st, adamc@800: injectors = #injectors st, adamc@800: listInjectors = TM.insert (#listInjectors st, t', n'), adamc@800: decoders = #decoders st, adamc@800: maxName = n' + 1} adamc@800: adamc@800: val s = (TFfi ("Basis", "string"), loc) adamc@801: val (e', st) = quoteExp loc t' ((EField ((ERel 0, loc), "1"), loc), st) adamc@800: adamc@800: val body = (ECase ((ERel 0, loc), adamc@800: [((PNone rt, loc), adamc@800: str loc "null"), adamc@800: ((PSome (rt, (PVar ("x", rt), loc)), loc), adam@1541: strcat loc [str loc "{_1:", adamc@800: e', adamc@800: str loc ",_2:", adamc@800: (EApp ((ENamed n', loc), adamc@800: (EField ((ERel 0, loc), "2"), loc)), loc), adam@1541: str loc "}"])], adamc@800: {disc = t, result = s}), loc) adamc@800: val body = (EAbs ("x", t, s, body), loc) adamc@800: adamc@840: val st = {decls = ("jsify", n', (TFun (t, s), loc), adamc@840: body, "jsify") :: #decls st, adamc@800: script = #script st, adamc@800: included = #included st, adamc@800: injectors = #injectors st, adamc@800: listInjectors = #listInjectors st, adamc@800: decoders= #decoders st, adamc@800: maxName = #maxName st} adamc@800: adamc@800: adamc@800: in adamc@800: ((EApp ((ENamed n', loc), e), loc), st) adamc@800: end) adamc@800: adamc@595: | TDatatype (n, ref (dk, cs)) => adamc@595: (case IM.find (#injectors st, n) of adamc@595: SOME n' => ((EApp ((ENamed n', loc), e), loc), st) adamc@595: | NONE => adamc@595: let adamc@595: val n' = #maxName st adamc@595: val st = {decls = #decls st, adamc@595: script = #script st, adamc@595: included = #included st, adamc@595: injectors = IM.insert (#injectors st, n, n'), adamc@800: listInjectors = #listInjectors st, adamc@638: decoders = #decoders st, adamc@595: maxName = n' + 1} adamc@595: adamc@595: val (pes, st) = ListUtil.foldlMap adamc@595: (fn ((_, cn, NONE), st) => adamc@595: (((PCon (dk, PConVar cn, NONE), loc), adamc@596: case dk of adamc@596: Option => str loc "null" adamc@596: | _ => str loc (Int.toString cn)), adamc@595: st) adamc@595: | ((_, cn, SOME t), st) => adamc@595: let adamc@595: val (e, st) = quoteExp loc t ((ERel 0, loc), st) adamc@595: in adamc@595: (((PCon (dk, PConVar cn, SOME (PVar ("x", t), loc)), loc), adamc@596: case dk of adamc@596: Option => adamc@596: if isNullable t then adamc@638: strcat loc [str loc "{v:", adamc@596: e, adamc@596: str loc "}"] adamc@596: else adamc@596: e adamc@597: | _ => strcat loc [str loc ("{n:" ^ Int.toString cn adamc@597: ^ ",v:"), adamc@597: e, adamc@597: str loc "}"]), adamc@595: st) adamc@595: end) adamc@595: st cs adamc@595: adamc@595: val s = (TFfi ("Basis", "string"), loc) adamc@595: val body = (ECase ((ERel 0, loc), pes, adamc@595: {disc = t, result = s}), loc) adamc@595: val body = (EAbs ("x", t, s, body), loc) adamc@595: adamc@840: val st = {decls = ("jsify", n', (TFun (t, s), loc), adamc@840: body, "jsify") :: #decls st, adamc@595: script = #script st, adamc@595: included = #included st, adamc@595: injectors = #injectors st, adamc@800: listInjectors = #listInjectors st, adamc@638: decoders= #decoders st, adamc@595: maxName = #maxName st} adamc@595: in adamc@595: ((EApp ((ENamed n', loc), e), loc), st) adamc@595: end) adamc@595: adam@1995: | _ => (if !explainEmbed then adam@1995: Print.prefaces "Can't embed" [("loc", Print.PD.string (ErrorMsg.spanToString loc)), adam@1995: ("e", MonoPrint.p_exp MonoEnv.empty e), adam@1995: ("t", MonoPrint.p_typ MonoEnv.empty t)] adam@1995: else adam@1995: (); adamc@834: raise CantEmbed t) adamc@590: adamc@613: fun unurlifyExp loc (t : typ, st) = adamc@613: case #1 t of adamc@1323: TRecord [] => ("(i++,null)", st) adamc@1323: | TFfi ("Basis", "unit") => ("(i++,null)", st) adamc@613: | TRecord [(x, t)] => adamc@613: let adamc@613: val (e, st) = unurlifyExp loc (t, st) adamc@613: in adamc@613: ("{_" ^ x ^ ":" ^ e ^ "}", adamc@613: st) adamc@613: end adamc@613: | TRecord ((x, t) :: xts) => adamc@613: let adamc@613: val (e', st) = unurlifyExp loc (t, st) adamc@613: val (es, st) = ListUtil.foldlMap adamc@638: (fn ((x, t), st) => adamc@638: let adamc@638: val (e, st) = unurlifyExp loc (t, st) adamc@638: in adamc@638: (",_" ^ x ^ ":" ^ e, st) adamc@638: end) adamc@638: st xts adamc@613: in adamc@613: (String.concat ("{_" adamc@613: :: x adamc@613: :: ":" adamc@613: :: e' adamc@613: :: es adamc@613: @ ["}"]), st) adamc@613: end adamc@613: adamc@679: | TFfi ("Basis", "string") => ("uu(t[i++])", st) adamc@1025: | TFfi ("Basis", "char") => ("uu(t[i++])", st) adamc@613: | TFfi ("Basis", "int") => ("parseInt(t[i++])", st) adam@1404: | TFfi ("Basis", "time") => ("parseInt(t[i++])", st) adamc@613: | TFfi ("Basis", "float") => ("parseFloat(t[i++])", st) adam@1319: | TFfi ("Basis", "channel") => ("(t[i++].length > 0 ? parseInt(t[i-1]) : null)", st) adamc@613: adamc@912: | TFfi ("Basis", "bool") => ("t[i++] == \"1\"", st) adamc@613: adam@1620: | TSource => ("parseSource(t[i++], t[i++])", st) adam@1620: adamc@638: | TOption t => adamc@613: let adamc@638: val (e, st) = unurlifyExp loc (t, st) adamc@638: val e = if isNullable t then adamc@638: "{v:" ^ e ^ "}" adamc@638: else adamc@638: e adamc@613: in adamc@703: ("(t[i++]==\"Some\"?" ^ e ^ ":null)", st) adamc@638: end adamc@613: adamc@905: | TList t => adamc@905: let adamc@905: val (e, st) = unurlifyExp loc (t, st) adamc@905: in adamc@905: ("uul(function(){return t[i++];},function(){return " ^ e ^ "})", st) adamc@905: end adamc@905: adamc@638: | TDatatype (n, ref (dk, cs)) => adamc@638: (case IM.find (#decoders st, n) of adamc@638: SOME n' => ("(tmp=_n" ^ Int.toString n' ^ "(t,i),i=tmp._1,tmp._2)", st) adamc@613: | NONE => adamc@613: let adamc@613: val n' = #maxName st adamc@613: val st = {decls = #decls st, adamc@613: script = #script st, adamc@613: included = #included st, adamc@638: injectors = #injectors st, adamc@800: listInjectors = #listInjectors st, adamc@638: decoders = IM.insert (#decoders st, n, n'), adamc@613: maxName = n' + 1} adamc@613: adamc@638: val (e, st) = foldl (fn ((x, cn, NONE), (e, st)) => adamc@638: ("x==\"" ^ x ^ "\"?" adamc@638: ^ (case dk of adamc@638: Option => "null" adamc@638: | _ => Int.toString cn) adamc@638: ^ ":" ^ e, adamc@613: st) adamc@638: | ((x, cn, SOME t), (e, st)) => adamc@613: let adamc@638: val (e', st) = unurlifyExp loc (t, st) adamc@613: in adamc@638: ("x==\"" ^ x ^ "\"?" adamc@638: ^ (case dk of adamc@638: Option => adamc@638: if isNullable t then adamc@638: "{v:" ^ e' ^ "}" adamc@638: else adamc@638: e' adamc@638: | _ => "{n:" ^ Int.toString cn ^ ",v:" ^ e' ^ "}") adamc@638: ^ ":" ^ e, adamc@613: st) adamc@613: end) adamc@810: ("pf(\"" ^ ErrorMsg.spanToString loc ^ "\")", st) cs adamc@613: adamc@638: val body = "function _n" ^ Int.toString n' ^ "(t,i){var x=t[i++];var r=" adamc@638: ^ e ^ ";return {_1:i,_2:r}}\n\n" adamc@613: adamc@638: val st = {decls = #decls st, adamc@638: script = body :: #script st, adamc@613: included = #included st, adamc@613: injectors = #injectors st, adamc@800: listInjectors = #listInjectors st, adamc@638: decoders = #decoders st, adamc@613: maxName = #maxName st} adamc@613: in adamc@638: ("(tmp=_n" ^ Int.toString n' ^ "(t,i),i=tmp._1,tmp._2)", st) adamc@638: end) adamc@613: adamc@613: | _ => (EM.errorAt loc "Don't know how to unurlify type in JavaScript"; adamc@613: Print.prefaces "Can't unurlify" [("t", MonoPrint.p_typ MonoEnv.empty t)]; adamc@613: ("ERROR", st)) adamc@613: adamc@646: fun padWith (ch, s, len) = adamc@646: if size s < len then adamc@646: padWith (ch, String.str ch ^ s, len - 1) adamc@646: else adamc@646: s adamc@646: adamc@794: val foundJavaScript = ref false adamc@794: adamc@800: fun jsExp mode outer = adamc@567: let adamc@589: val len = length outer adamc@567: adamc@589: fun jsE inner (e as (_, loc), st) = adamc@589: let adam@1995: (*val () = Print.prefaces "jsExp" [("e", MonoPrint.p_exp MonoEnv.empty e), adam@1995: ("loc", Print.PD.string (ErrorMsg.spanToString loc))]*) adam@1995: adamc@590: val str = str loc adamc@567: adamc@589: fun patCon pc = adamc@589: case pc of adamc@589: PConVar n => str (Int.toString n) adamc@589: | PConFfi {mod = "Basis", con = "True", ...} => str "true" adamc@589: | PConFfi {mod = "Basis", con = "False", ...} => str "false" adamc@970: | PConFfi {con, ...} => str ("\"" ^ con ^ "\"") adamc@567: adamc@591: fun unsupported s = adamc@591: (EM.errorAt loc (s ^ " in code to be compiled to JavaScript[2]"); adamc@910: Print.preface ("Code", MonoPrint.p_exp MonoEnv.empty e); adamc@591: (str "ERROR", st)) adamc@577: adamc@589: val strcat = strcat loc adamc@584: adamc@589: fun jsPrim p = adamc@943: let adamc@943: fun jsChar ch = adamc@943: case ch of adamc@943: #"'" => adamc@943: if mode = Attribute then adamc@943: "\\047" adamc@943: else adamc@943: "'" adamc@943: | #"\"" => "\\\"" adamc@943: | #"<" => "\\074" adamc@943: | #"\\" => "\\\\" adamc@943: | #"\n" => "\\n" adamc@943: | #"\r" => "\\r" adamc@943: | #"\t" => "\\t" adamc@943: | ch => adam@1285: if Char.isPrint ch orelse ord ch >= 128 then adamc@943: String.str ch adamc@943: else adamc@943: "\\" ^ padWith (#"0", adamc@943: Int.fmt StringCvt.OCT (ord ch), adamc@943: 3) adamc@943: in adamc@943: case p of adam@2048: Prim.String (_, s) => adamc@943: str ("\"" ^ String.translate jsChar s ^ "\"") adamc@1176: | Prim.Char ch => str ("\"" ^ jsChar ch ^ "\"") adamc@943: | _ => str (Prim.toString p) adamc@943: end adamc@589: adamc@970: fun jsPat (p, _) = adamc@589: case p of adamc@970: PWild => str "{c:\"w\"}" adamc@970: | PVar _ => str "{c:\"v\"}" adamc@970: | PPrim p => strcat [str "{c:\"c\",v:", adamc@589: jsPrim p, adamc@970: str "}"] adamc@589: | PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE) => adamc@970: str "{c:\"c\",v:true}" adamc@589: | PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE) => adamc@970: str "{c:\"c\",v:false}" adamc@596: | PCon (Option, _, NONE) => adamc@970: str "{c:\"c\",v:null}" adamc@596: | PCon (Option, PConVar n, SOME p) => adamc@596: (case IM.find (someTs, n) of adamc@596: NONE => raise Fail "Jscomp: Not in someTs" adamc@974: | SOME t => adamc@974: strcat [str ("{c:\"s\",n:" adamc@974: ^ (if isNullable t then adamc@974: "true" adamc@974: else adamc@974: "false") adamc@974: ^ ",p:"), adamc@974: jsPat p, adamc@974: str "}"]) adamc@974: | PCon (_, pc, NONE) => strcat [str "{c:\"c\",v:", adamc@970: patCon pc, adamc@970: str "}"] adamc@970: | PCon (_, pc, SOME p) => strcat [str "{c:\"1\",n:", adamc@970: patCon pc, adamc@970: str ",p:", adamc@970: jsPat p, adamc@970: str "}"] adamc@970: | PRecord xps => strcat [str "{c:\"r\",l:", adamc@970: foldr (fn ((x, p, _), e) => adamc@970: strcat [str ("cons({n:\"" ^ x ^ "\",p:"), adamc@970: jsPat p, adamc@970: str "},", adamc@970: e, adamc@970: str ")"]) adamc@970: (str "null") xps, adamc@970: str "}"] adamc@970: | PNone _ => str "{c:\"c\",v:null}" adamc@970: | PSome (t, p) => strcat [str ("{c:\"s\",n:" adamc@829: ^ (if isNullable t then adamc@970: "true" adamc@829: else adamc@970: "false") adamc@970: ^ ",p:"), adamc@970: jsPat p, adamc@970: str "}"] adamc@589: adamc@601: val jsifyString = String.translate (fn #"\"" => "\\\"" adamc@601: | #"\\" => "\\\\" adamc@601: | ch => String.str ch) adamc@601: adamc@601: fun jsifyStringMulti (n, s) = adamc@601: case n of adamc@601: 0 => s adamc@601: | _ => jsifyStringMulti (n - 1, jsifyString s) adamc@601: adam@1847: fun deStrcat level (all as (e, loc)) = adamc@589: case e of adam@2048: EPrim (Prim.String (_, s)) => jsifyStringMulti (level, s) adamc@601: | EStrcat (e1, e2) => deStrcat level e1 ^ deStrcat level e2 adam@1663: | EFfiApp ("Basis", "jsifyString", [(e, _)]) => "\"" ^ deStrcat (level + 1) e ^ "\"" adam@1847: | _ => (ErrorMsg.errorAt loc "Unexpected non-constant JavaScript code"; adam@1847: Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)]; adam@1847: "") adamc@590: adamc@590: val quoteExp = quoteExp loc adamc@567: in adamc@801: (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e), adamc@801: ("inner", Print.PD.string (Int.toString inner))];*) adamc@590: adamc@589: case #1 e of adamc@970: EPrim p => (strcat [str "{c:\"c\",v:", adamc@970: jsPrim p, adamc@970: str "}"], adamc@970: st) adamc@589: | ERel n => adamc@589: if n < inner then adamc@970: (str ("{c:\"v\",n:" ^ Int.toString n ^ "}"), st) adamc@589: else adamc@589: let adamc@589: val n = n - inner adamc@813: (*val () = Print.prefaces "quote" [("t", MonoPrint.p_typ MonoEnv.empty adamc@813: (List.nth (outer, n)))]*) adamc@970: val (e, st) = quoteExp (List.nth (outer, n)) ((ERel n, loc), st) adamc@589: in adamc@970: (strcat [str "{c:\"c\",v:", adamc@970: e, adamc@970: str "}"], st) adamc@589: end adamc@567: adamc@589: | ENamed n => adamc@589: let adamc@589: val st = adamc@589: if IS.member (#included st, n) then adamc@589: st adamc@589: else adamc@589: case IM.find (nameds, n) of adamc@589: NONE => raise Fail "Jscomp: Unbound ENamed" adamc@589: | SOME e => adamc@589: let adamc@589: val st = {decls = #decls st, adamc@589: script = #script st, adamc@595: included = IS.add (#included st, n), adamc@595: injectors = #injectors st, adamc@800: listInjectors = #listInjectors st, adamc@638: decoders = #decoders st, adamc@595: maxName = #maxName st} adamc@578: adamc@801: val old = e adamc@970: val (e, st) = jsExp mode [] (e, st) adamc@601: val e = deStrcat 0 e adamc@1262: val e = String.translate (fn #"'" => "\\'" adamc@1262: | #"\\" => "\\\\" adamc@1262: | ch => String.str ch) e adamc@589: adamc@1262: val sc = "urfuncs[" ^ Int.toString n ^ "] = {c:\"t\",f:'" adamc@1262: ^ e ^ "'};\n" adamc@589: in adamc@801: (*Print.prefaces "jsify'" [("old", MonoPrint.p_exp MonoEnv.empty old), adamc@801: ("new", MonoPrint.p_exp MonoEnv.empty new)];*) adamc@589: {decls = #decls st, adamc@589: script = sc :: #script st, adamc@595: included = #included st, adamc@595: injectors = #injectors st, adamc@800: listInjectors = #listInjectors st, adamc@638: decoders= #decoders st, adamc@595: maxName = #maxName st} adamc@589: end adamc@589: in adamc@970: (str ("{c:\"n\",n:" ^ Int.toString n ^ "}"), st) adamc@589: end adamc@589: adamc@970: | ECon (Option, _, NONE) => (str "{c:\"c\",v:null}", st) adamc@596: | ECon (Option, PConVar n, SOME e) => adamc@596: let adamc@596: val (e, st) = jsE inner (e, st) adamc@596: in adamc@596: case IM.find (someTs, n) of adamc@596: NONE => raise Fail "Jscomp: Not in someTs [2]" adamc@596: | SOME t => adamc@596: (if isNullable t then adamc@970: strcat [str "{c:\"s\",v:", adamc@596: e, adamc@596: str "}"] adamc@596: else adamc@596: e, st) adamc@596: end adamc@596: adamc@970: | ECon (_, pc, NONE) => (strcat [str "{c:\"c\",v:", adamc@970: patCon pc, adamc@970: str "}"], adamc@970: st) adamc@589: | ECon (_, pc, SOME e) => adamc@589: let adamc@589: val (s, st) = jsE inner (e, st) adamc@589: in adamc@970: (strcat [str "{c:\"1\",n:", adamc@589: patCon pc, adamc@589: str ",v:", adamc@589: s, adamc@589: str "}"], st) adamc@589: end adamc@596: adamc@970: | ENone _ => (str "{c:\"c\",v:null}", st) adamc@589: | ESome (t, e) => adamc@572: let adamc@572: val (e, st) = jsE inner (e, st) adamc@572: in adamc@589: (if isNullable t then adamc@970: strcat [str "{c:\"s\",v:", e, str "}"] adamc@589: else adamc@589: e, st) adamc@589: end adamc@589: adamc@589: | EFfi k => adamc@589: let adamc@765: val name = case Settings.jsFunc k of adamc@589: NONE => (EM.errorAt loc ("Unsupported FFI identifier " ^ #2 k adamc@589: ^ " in JavaScript"); adamc@589: "ERROR") adamc@589: | SOME s => s adamc@589: in adamc@970: (str ("{c:\"c\",v:" ^ name ^ "}"), st) adamc@589: end adamc@970: | EFfiApp ("Basis", "sigString", [_]) => (strcat [str "{c:\"c\",v:\"", adamc@970: e, adamc@970: str "\"}"], st) adamc@589: | EFfiApp (m, x, args) => adamc@589: let adamc@765: val name = case Settings.jsFunc (m, x) of adamc@589: NONE => (EM.errorAt loc ("Unsupported FFI function " adam@1433: ^ m ^ "." ^ x ^ " in JavaScript"); adamc@589: "ERROR") adamc@589: | SOME s => s adamc@970: adam@1663: val (e, st) = foldr (fn ((e, _), (acc, st)) => adamc@970: let adamc@970: val (e, st) = jsE inner (e, st) adamc@970: in adamc@970: (strcat [str "cons(", adamc@970: e, adamc@970: str ",", adamc@970: acc, adamc@970: str ")"], adamc@970: st) adamc@970: end) adamc@970: (str "null", st) args adamc@589: in adam@1798: (strcat [str ("{c:\"f\",f:" ^ name ^ ",a:"), adamc@970: e, adamc@970: str "}"], adamc@970: st) adamc@589: end adamc@589: adamc@589: | EApp (e1, e2) => adamc@589: let adamc@589: val (e1, st) = jsE inner (e1, st) adamc@589: val (e2, st) = jsE inner (e2, st) adamc@589: in adamc@970: (strcat [str "{c:\"a\",f:", adamc@970: e1, adamc@970: str ",x:", adamc@970: e2, adamc@970: str "}"], st) adamc@589: end adamc@589: | EAbs (_, _, _, e) => adamc@589: let adamc@589: val (e, st) = jsE (inner + 1) (e, st) adamc@589: in adamc@970: (strcat [str "{c:\"l\",b:", adamc@970: e, adamc@970: str "}"], st) adamc@589: end adamc@589: adamc@589: | EUnop (s, e) => adamc@589: let adamc@970: val name = case s of adamc@970: "!" => "not" adamc@970: | "-" => "neg" adamc@980: | _ => raise Fail ("Jscomp: Unknown unary operator " ^ s) adamc@970: adamc@589: val (e, st) = jsE inner (e, st) adamc@589: in adam@1798: (strcat [str ("{c:\"f\",f:" ^ name ^ ",a:cons("), adamc@572: e, adamc@970: str ",null)}"], adamc@589: st) adamc@589: end adam@1360: | EBinop (bi, s, e1, e2) => adamc@589: let adamc@970: val name = case s of adamc@970: "==" => "eq" adamc@970: | "!strcmp" => "eq" adamc@970: | "+" => "plus" adamc@970: | "-" => "minus" adamc@970: | "*" => "times" adam@1360: | "/" => (case bi of Int => "divInt" | NotInt => "div") adam@1360: | "%" => (case bi of Int => "modInt" | NotInt => "mod") adam@1619: | "fdiv" => "div" adam@1619: | "fmod" => "mod" adamc@970: | "<" => "lt" adamc@970: | "<=" => "le" adamc@980: | "strcmp" => "strcmp" adamc@980: | _ => raise Fail ("Jscomp: Unknown binary operator " ^ s) adamc@729: adamc@589: val (e1, st) = jsE inner (e1, st) adamc@589: val (e2, st) = jsE inner (e2, st) adamc@589: in adam@1798: (strcat [str ("{c:\"f\",f:" ^ name ^ ",a:cons("), adamc@589: e1, adamc@970: str ",cons(", adamc@589: e2, adamc@970: str ",null))}"], adamc@589: st) adamc@589: end adamc@589: adamc@970: | ERecord [] => (str "{c:\"c\",v:null}", st) adamc@970: | ERecord xes => adamc@589: let adamc@589: val (es, st) = adamc@589: foldr (fn ((x, e, _), (es, st)) => adamc@589: let adamc@589: val (e, st) = jsE inner (e, st) adamc@589: in adamc@973: (strcat [str ("cons({n:\"" ^ x ^ "\",v:"), adamc@970: e, adamc@970: str "},", adamc@970: es, adamc@970: str ")"], adamc@589: st) adamc@589: end) adamc@970: (str "null", st) xes adamc@589: in adamc@970: (strcat [str "{c:\"r\",l:", adamc@970: es, adamc@970: str "}"], adamc@589: st) adamc@589: end adamc@934: | EField (e', x) => adamc@589: let adamc@934: fun default () = adamc@934: let adamc@934: val (e', st) = jsE inner (e', st) adamc@934: in adamc@970: (strcat [str "{c:\".\",r:", adamc@970: e', adamc@970: str (",f:\"" ^ x ^ "\"}")], st) adamc@934: end adamc@934: adamc@934: fun seek (e, xs) = adamc@934: case #1 e of adamc@934: ERel n => adamc@934: if n < inner then adamc@934: default () adamc@934: else adamc@934: let adamc@934: val n = n - inner adamc@934: val t = List.nth (outer, n) adamc@934: val t = foldl (fn (x, (TRecord xts, _)) => adamc@934: (case List.find (fn (x', _) => x' = x) xts of adamc@934: NONE => raise Fail "Jscomp: Bad seek [1]" adamc@934: | SOME (_, t) => t) adamc@934: | _ => raise Fail "Jscomp: Bad seek [2]") adamc@934: t xs adamc@934: adamc@934: val e = (ERel n, loc) adamc@934: val e = foldl (fn (x, e) => (EField (e, x), loc)) e xs adamc@970: val (e, st) = quoteExp t (e, st) adamc@934: in adamc@970: (strcat [str "{c:\"c\",v:", adamc@970: e, adamc@970: str "}"], adamc@970: st) adamc@934: end adamc@934: | EField (e', x) => seek (e', x :: xs) adamc@934: | _ => default () adamc@589: in adamc@934: seek (e', [x]) adamc@934: end adamc@589: adamc@970: | ECase (e', pes, _) => adamc@801: let adamc@970: val (e', st) = jsE inner (e', st) adamc@589: adamc@970: val (ps, st) = adamc@970: foldr (fn ((p, e), (ps, st)) => adamc@970: let adamc@974: val (e, st) = jsE (inner + E.patBindsN p) (e, st) adamc@970: in adamc@970: (strcat [str "cons({p:", adamc@970: jsPat p, adamc@970: str ",b:", adamc@970: e, adamc@970: str "},", adamc@970: ps, adamc@970: str ")"], adamc@970: st) adamc@970: end) adamc@970: (str "null", st) pes adamc@801: in adamc@970: (strcat [str "{c:\"m\",e:", adamc@974: e', adamc@970: str ",p:", adamc@970: ps, adamc@970: str "}"], st) adamc@801: end adamc@589: adamc@589: | EStrcat (e1, e2) => adamc@589: let adamc@589: val (e1, st) = jsE inner (e1, st) adamc@589: val (e2, st) = jsE inner (e2, st) adamc@589: in adam@1798: (strcat [str "{c:\"f\",f:cat,a:cons(", e1, str ",cons(", e2, str ",null))}"], st) adamc@589: end adamc@589: adamc@589: | EError (e, _) => adamc@589: let adamc@589: val (e, st) = jsE inner (e, st) adamc@589: in adam@1798: (strcat [str "{c:\"f\",f:er,a:cons(", e, str ",null)}"], adamc@589: st) adamc@589: end adamc@589: adamc@589: | ESeq (e1, e2) => adamc@589: let adamc@589: val (e1, st) = jsE inner (e1, st) adamc@589: val (e2, st) = jsE inner (e2, st) adamc@589: in adamc@970: (strcat [str "{c:\";\",e1:", e1, str ",e2:", e2, str "}"], st) adamc@589: end adamc@589: | ELet (_, _, e1, e2) => adamc@589: let adamc@589: val (e1, st) = jsE inner (e1, st) adamc@589: val (e2, st) = jsE (inner + 1) (e2, st) adamc@589: in adamc@970: (strcat [str "{c:\"=\",e1:", adamc@589: e1, adamc@970: str ",e2:", adamc@589: e2, adamc@970: str "}"], st) adamc@572: end adamc@589: adamc@815: | EJavaScript (Source _, e) => adamc@794: (foundJavaScript := true; adamc@815: jsE inner (e, st)) adamc@815: | EJavaScript (_, e) => adamc@815: let adamc@815: val (e, st) = jsE inner (e, st) adamc@815: in adamc@815: foundJavaScript := true; adamc@970: (strcat [str "{c:\"e\",e:", adamc@970: e, adamc@970: str "}"], adamc@815: st) adamc@815: end adamc@590: adamc@970: | EWrite _ => unsupported "EWrite" adamc@589: | EClosure _ => unsupported "EClosure" adamc@589: | EQuery _ => unsupported "Query" adamc@589: | EDml _ => unsupported "DML" adamc@589: | ENextval _ => unsupported "Nextval" adamc@1073: | ESetval _ => unsupported "Nextval" adamc@1112: | EReturnBlob _ => unsupported "EReturnBlob" adam@1385: adam@1385: | ERedirect (e, _) => adam@1385: let adam@1385: val (e, st) = jsE inner (e, st) adam@1385: in adam@1798: (strcat [str "{c:\"f\",f:redirect,a:cons(", adam@1385: e, adam@1385: str ",null)}"], adam@1385: st) adam@1385: end adam@1385: adamc@1112: | EUnurlify (_, _, true) => unsupported "EUnurlify" adamc@590: adamc@1112: | EUnurlify (e, t, false) => adamc@1111: let adamc@1111: val (e, st) = jsE inner (e, st) adamc@1111: val (e', st) = unurlifyExp loc (t, st) adamc@1111: in adam@1798: (strcat [str ("{c:\"f\",f:unurlify,a:cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return " adamc@1111: ^ e' ^ "}},cons("), adamc@1111: e, adamc@1111: str ",null))}"], adamc@1111: st) adamc@1111: end adamc@1111: adamc@589: | ESignalReturn e => adamc@572: let adamc@572: val (e, st) = jsE inner (e, st) adamc@572: in adam@1798: (strcat [str "{c:\"f\",f:sr,a:cons(", adamc@589: e, adamc@970: str ",null)}"], adamc@589: st) adamc@589: end adamc@589: | ESignalBind (e1, e2) => adamc@589: let adamc@589: val (e1, st) = jsE inner (e1, st) adamc@589: val (e2, st) = jsE inner (e2, st) adamc@589: in adam@1798: (strcat [str "{c:\"f\",f:sb,a:cons(", adamc@589: e1, adamc@976: str ",cons(", adamc@589: e2, adamc@976: str ",null))}"], adamc@589: st) adamc@589: end adamc@589: | ESignalSource e => adamc@589: let adamc@589: val (e, st) = jsE inner (e, st) adamc@589: in adam@1798: (strcat [str "{c:\"f\",f:ss,a:cons(", adamc@589: e, adamc@970: str ",null)}"], adamc@589: st) adamc@572: end adamc@608: adam@1848: | EServerCall (e, t, eff, fm) => adamc@609: let adamc@614: val (e, st) = jsE inner (e, st) adamc@613: val (unurl, st) = unurlifyExp loc (t, st) adam@1848: val lastArg = case fm of adam@1848: None => "null" adam@1848: | Error => adam@1848: let adam@1848: val isN = if isNullable t then adam@1848: "true" adam@1848: else adam@1848: "false" adam@1848: in adam@1848: "cons({c:\"c\",v:" ^ isN ^ "},null)" adam@1848: end adamc@609: in adam@1798: (strcat [str ("{c:\"f\",f:rc,a:cons({c:\"c\",v:\"" adamc@970: ^ Settings.getUrlPrefix () adamc@970: ^ "\"},cons("), adamc@614: e, adamc@970: str (",cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return " adamc@1020: ^ unurl ^ "}},cons({c:\"K\"},cons({c:\"c\",v:" adamc@736: ^ (case eff of adamc@736: ReadCookieWrite => "true" adamc@736: | _ => "false") adam@1848: ^ "}," ^ lastArg ^ ")))))}")], adamc@609: st) adamc@609: end adamc@670: adamc@1021: | ERecv (e, t) => adamc@670: let adamc@670: val (e, st) = jsE inner (e, st) adamc@670: val (unurl, st) = unurlifyExp loc (t, st) adamc@670: in adam@1798: (strcat [str ("{c:\"f\",f:rv,a:cons("), adamc@670: e, adamc@970: str (",cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return " adamc@1021: ^ unurl ^ "}},cons({c:\"K\"},null)))}")], adamc@670: st) adamc@670: end adamc@695: adamc@1021: | ESleep e => adamc@695: let adamc@695: val (e, st) = jsE inner (e, st) adamc@695: in adam@1798: (strcat [str "{c:\"f\",f:sl,a:cons(", adamc@978: e, adamc@1021: str ",cons({c:\"K\"},null))}"], adamc@1021: st) adamc@1021: end adamc@1021: adamc@1021: | ESpawn e => adamc@1021: let adamc@1021: val (e, st) = jsE inner (e, st) adamc@1021: in adam@1798: (strcat [str "{c:\"f\",f:sp,a:cons(", adamc@1021: e, adamc@1021: str ",null)}"], adamc@695: st) adamc@695: end adamc@567: end adamc@589: in adamc@970: jsE 0 adamc@589: end adamc@567: adamc@815: fun patBinds ((p, _), env) = adamc@815: case p of adamc@815: PWild => env adamc@815: | PVar (_, t) => t :: env adamc@815: | PPrim _ => env adamc@815: | PCon (_, _, NONE) => env adamc@815: | PCon (_, _, SOME p) => patBinds (p, env) adamc@815: | PRecord xpts => foldl (fn ((_, p, _), env) => patBinds (p, env)) env xpts adamc@815: | PNone _ => env adamc@815: | PSome (_, p) => patBinds (p, env) adamc@815: adamc@815: fun exp outer (e as (_, loc), st) = adamc@815: ((*Print.preface ("exp", MonoPrint.p_exp MonoEnv.empty e);*) adamc@815: case #1 e of adamc@847: EPrim p => adamc@847: (case p of adam@2048: Prim.String (_, s) => if inString {needle = " (); adamc@847: (e, st)) adamc@815: | ERel _ => (e, st) adamc@815: | ENamed _ => (e, st) adamc@815: | ECon (_, _, NONE) => (e, st) adamc@815: | ECon (dk, pc, SOME e) => adamc@815: let adamc@815: val (e, st) = exp outer (e, st) adamc@815: in adamc@815: ((ECon (dk, pc, SOME e), loc), st) adamc@815: end adamc@815: | ENone _ => (e, st) adamc@815: | ESome (t, e) => adamc@815: let adamc@815: val (e, st) = exp outer (e, st) adamc@815: in adamc@815: ((ESome (t, e), loc), st) adamc@815: end adamc@815: | EFfi _ => (e, st) adamc@815: | EFfiApp (m, x, es) => adamc@815: let adam@1663: val (es, st) = ListUtil.foldlMap (fn ((e, t), st) => adam@1663: let adam@1663: val (e, st) = exp outer (e, st) adam@1663: in adam@1663: ((e, t), st) adam@1663: end) st es adamc@815: in adamc@815: ((EFfiApp (m, x, es), loc), st) adamc@815: end adamc@815: | EApp (e1, e2) => adamc@815: let adamc@815: val (e1, st) = exp outer (e1, st) adamc@815: val (e2, st) = exp outer (e2, st) adamc@815: in adamc@815: ((EApp (e1, e2), loc), st) adamc@815: end adamc@815: | EAbs (x, dom, ran, e) => adamc@815: let adamc@815: val (e, st) = exp (dom :: outer) (e, st) adamc@815: in adamc@815: ((EAbs (x, dom, ran, e), loc), st) adamc@815: end adamc@815: adamc@815: | EUnop (s, e) => adamc@815: let adamc@815: val (e, st) = exp outer (e, st) adamc@815: in adamc@815: ((EUnop (s, e), loc), st) adamc@815: end adam@1360: | EBinop (bi, s, e1, e2) => adamc@815: let adamc@815: val (e1, st) = exp outer (e1, st) adamc@815: val (e2, st) = exp outer (e2, st) adamc@815: in adam@1360: ((EBinop (bi, s, e1, e2), loc), st) adamc@815: end adamc@815: adamc@815: | ERecord xets => adamc@815: let adamc@815: val (xets, st) = ListUtil.foldlMap (fn ((x, e, t), st) => adamc@815: let adamc@815: val (e, st) = exp outer (e, st) adamc@815: in adamc@815: ((x, e, t), st) adamc@815: end) st xets adamc@815: in adamc@815: ((ERecord xets, loc), st) adamc@815: end adamc@815: | EField (e, s) => adamc@815: let adamc@815: val (e, st) = exp outer (e, st) adamc@815: in adamc@815: ((EField (e, s), loc), st) adamc@815: end adamc@815: adamc@815: | ECase (e, pes, ts) => adamc@815: let adamc@815: val (e, st) = exp outer (e, st) adamc@815: val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) => adamc@815: let adamc@815: val (e, st) = exp (patBinds (p, outer)) (e, st) adamc@815: in adamc@815: ((p, e), st) adamc@815: end) st pes adamc@815: in adamc@815: ((ECase (e, pes, ts), loc), st) adamc@815: end adamc@815: adamc@815: | EStrcat (e1, e2) => adamc@815: let adamc@815: val (e1, st) = exp outer (e1, st) adamc@815: val (e2, st) = exp outer (e2, st) adamc@815: in adamc@815: ((EStrcat (e1, e2), loc), st) adamc@815: end adamc@815: adamc@815: | EError (e, t) => adamc@815: let adamc@815: val (e, st) = exp outer (e, st) adamc@815: in adamc@815: ((EError (e, t), loc), st) adamc@815: end adam@1932: | EReturnBlob {blob = NONE, mimeType, t} => adam@1932: let adam@1932: val (mimeType, st) = exp outer (mimeType, st) adam@1932: in adam@1932: ((EReturnBlob {blob = NONE, mimeType = mimeType, t = t}, loc), st) adam@1932: end adam@1932: | EReturnBlob {blob = SOME blob, mimeType, t} => adamc@815: let adamc@815: val (blob, st) = exp outer (blob, st) adamc@815: val (mimeType, st) = exp outer (mimeType, st) adamc@815: in adam@1932: ((EReturnBlob {blob = SOME blob, mimeType = mimeType, t = t}, loc), st) adamc@815: end adamc@1065: | ERedirect (e, t) => adamc@1065: let adamc@1065: val (e, st) = exp outer (e, st) adamc@1065: in adamc@1065: ((ERedirect (e, t), loc), st) adamc@1065: end adamc@815: adamc@815: | EWrite e => adamc@815: let adamc@815: val (e, st) = exp outer (e, st) adamc@815: in adamc@815: ((EWrite e, loc), st) adamc@815: end adamc@815: | ESeq (e1, e2) => adamc@815: let adamc@815: val (e1, st) = exp outer (e1, st) adamc@815: val (e2, st) = exp outer (e2, st) adamc@815: in adamc@815: ((ESeq (e1, e2), loc), st) adamc@815: end adamc@815: | ELet (x, t, e1, e2) => adamc@815: let adamc@815: val (e1, st) = exp outer (e1, st) adamc@815: val (e2, st) = exp (t :: outer) (e2, st) adamc@815: in adamc@815: ((ELet (x, t, e1, e2), loc), st) adamc@815: end adamc@815: adamc@815: | EClosure (n, es) => adamc@815: let adamc@815: val (es, st) = ListUtil.foldlMap (exp outer) st es adamc@815: in adamc@815: ((EClosure (n, es), loc), st) adamc@815: end adamc@815: adamc@815: | EQuery {exps, tables, state, query, body, initial} => adamc@815: let adamc@934: val row = exps @ map (fn (x, xts) => (x, (TRecord xts, loc))) tables adamc@934: val row = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row adamc@934: val row = (TRecord row, loc) adamc@934: adamc@815: val (query, st) = exp outer (query, st) adamc@934: val (body, st) = exp (state :: row :: outer) (body, st) adamc@815: val (initial, st) = exp outer (initial, st) adamc@815: in adamc@815: ((EQuery {exps = exps, tables = tables, state = state, adamc@815: query = query, body = body, initial = initial}, loc), st) adamc@815: end adam@1293: | EDml (e, mode) => adamc@815: let adamc@815: val (e, st) = exp outer (e, st) adamc@815: in adam@1293: ((EDml (e, mode), loc), st) adamc@815: end adamc@815: | ENextval e => adamc@815: let adamc@815: val (e, st) = exp outer (e, st) adamc@815: in adamc@815: ((ENextval e, loc), st) adamc@815: end adamc@1073: | ESetval (e1, e2) => adamc@1073: let adamc@1073: val (e1, st) = exp outer (e1, st) adamc@1073: val (e2, st) = exp outer (e2, st) adamc@1073: in adamc@1073: ((ESetval (e1, e2), loc), st) adamc@1073: end adamc@815: adamc@1112: | EUnurlify (e, t, b) => adamc@815: let adamc@815: val (e, st) = exp outer (e, st) adamc@815: in adamc@1112: ((EUnurlify (e, t, b), loc), st) adamc@815: end adamc@815: adam@1422: | EJavaScript (m as Source t, e') => adam@1422: (foundJavaScript := true; adam@1422: let adam@1422: val (x', st) = jsExp m (t :: outer) ((ERel 0, loc), st) adam@1422: in adam@1422: ((ELet ("x", t, e', x'), loc), st) adam@1422: end adam@1445: handle CantEmbed _ => adam@1445: (jsExp m outer (e', st) adam@1445: handle CantEmbed t => ((*ErrorMsg.errorAt loc "Unable to embed type in JavaScript"; adam@1445: Print.preface ("Type", adam@1445: MonoPrint.p_typ MonoEnv.empty t);*) adam@1445: (e, st)))) adam@1422: adamc@815: | EJavaScript (m, e') => adamc@970: (foundJavaScript := true; adamc@970: jsExp m outer (e', st) adamc@1258: handle CantEmbed t => ((*ErrorMsg.errorAt loc "Unable to embed type in JavaScript"; adamc@1258: Print.preface ("Type", adamc@1258: MonoPrint.p_typ MonoEnv.empty t);*) adamc@1176: (e, st))) adamc@815: adamc@815: | ESignalReturn e => adamc@815: let adamc@815: val (e, st) = exp outer (e, st) adamc@815: in adamc@815: ((ESignalReturn e, loc), st) adamc@815: end adamc@815: | ESignalBind (e1, e2) => adamc@815: let adamc@815: val (e1, st) = exp outer (e1, st) adamc@815: val (e2, st) = exp outer (e2, st) adamc@815: in adamc@815: ((ESignalBind (e1, e2), loc), st) adamc@815: end adamc@815: | ESignalSource e => adamc@815: let adamc@815: val (e, st) = exp outer (e, st) adamc@815: in adamc@815: ((ESignalSource e, loc), st) adamc@815: end adamc@815: adam@1848: | EServerCall (e1, t, ef, fm) => adamc@815: let adamc@815: val (e1, st) = exp outer (e1, st) adamc@815: in adam@1848: ((EServerCall (e1, t, ef, fm), loc), st) adamc@815: end adamc@1021: | ERecv (e1, t) => adamc@815: let adamc@815: val (e1, st) = exp outer (e1, st) adamc@815: in adamc@1021: ((ERecv (e1, t), loc), st) adamc@815: end adamc@1021: | ESleep e1 => adamc@815: let adamc@815: val (e1, st) = exp outer (e1, st) adamc@815: in adamc@1021: ((ESleep e1, loc), st) adamc@1021: end adamc@1021: | ESpawn e1 => adamc@1021: let adamc@1021: val (e1, st) = exp outer (e1, st) adamc@1021: in adamc@1021: ((ESpawn e1, loc), st) adamc@815: end) adamc@815: adamc@815: fun decl (d as (_, loc), st) = adamc@815: case #1 d of adamc@815: DVal (x, n, t, e, s) => adamc@815: let adamc@815: val (e, st) = exp [] (e, st) adamc@815: in adamc@815: ((DVal (x, n, t, e, s), loc), st) adamc@815: end adamc@815: | DValRec vis => adamc@815: let adamc@815: val (vis, st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) => adamc@815: let adamc@815: val (e, st) = exp [] (e, st) adamc@815: in adamc@815: ((x, n, t, e, s), st) adamc@815: end) st vis adamc@815: in adamc@815: ((DValRec vis, loc), st) adamc@815: end adamc@815: | _ => (d, st) adamc@567: adamc@567: fun doDecl (d, st) = adamc@567: let adamc@815: (*val () = Print.preface ("doDecl", MonoPrint.p_decl MonoEnv.empty d)*) adamc@815: val (d, st) = decl (d, st) adamc@840: adamc@840: val ds = adamc@840: case #decls st of adamc@840: [] => [d] adamc@840: | vis => [(DValRec vis, #2 d), d] adamc@567: in adamc@840: (ds, adamc@567: {decls = [], adamc@589: script = #script st, adamc@595: included = #included st, adamc@595: injectors = #injectors st, adamc@800: listInjectors = #listInjectors st, adamc@638: decoders = #decoders st, adamc@595: maxName = #maxName st}) adamc@567: end adamc@567: adamc@567: val (ds, st) = ListUtil.foldlMapConcat doDecl adamc@567: {decls = [], adamc@589: script = [], adamc@595: included = IS.empty, adamc@595: injectors = IM.empty, adamc@800: listInjectors = TM.empty, adamc@638: decoders = IM.empty, adamc@595: maxName = U.File.maxName file + 1} adam@1845: (#1 file) adamc@569: ezyang@1739: val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Settings.libJs (), file = "urweb.js"}) adamc@569: fun lines acc = adamc@569: case TextIO.inputLine inf of adamc@569: NONE => String.concat (rev acc) adamc@569: | SOME line => lines (line :: acc) adamc@569: val lines = lines [] adamc@794: adamc@1323: val urlRules = foldr (fn (r, s) => adamc@1323: "cons({allow:" adamc@1323: ^ (if #action r = Settings.Allow then "true" else "false") adamc@1323: ^ ",prefix:" adamc@1323: ^ (if #kind r = Settings.Prefix then "true" else "false") adamc@1323: ^ ",pattern:\"" adamc@1323: ^ #pattern r adamc@1323: ^ "\"}," adamc@1323: ^ s adamc@1323: ^ ")") "null" (Settings.getUrlRules ()) adamc@1323: adamc@1323: val urlRules = "urlRules = " ^ urlRules ^ ";\n\n" adamc@1323: adamc@794: val script = adamc@794: if !foundJavaScript then adamc@1323: lines ^ urlRules ^ String.concat (rev (#script st)) adam@1656: ^ "\ntime_format = \"" ^ Prim.toCString (Settings.getTimeFormat ()) ^ "\";\n" adamc@794: else adamc@794: "" adamc@567: in adamc@569: TextIO.closeIn inf; adam@1845: ((DJavaScript script, ErrorMsg.dummySpan) :: ds, #2 file) adamc@567: end adamc@567: adamc@567: end