adamc@567: (* Copyright (c) 2008, 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@572: val funcs = [(("Basis", "alert"), "alert"), adamc@601: (("Basis", "get_client_source"), "sg"), adamc@586: (("Basis", "htmlifyBool"), "bs"), adamc@583: (("Basis", "htmlifyFloat"), "ts"), adamc@582: (("Basis", "htmlifyInt"), "ts"), adamc@597: (("Basis", "htmlifyString"), "eh"), adamc@579: (("Basis", "new_client_source"), "sc"), adamc@614: (("Basis", "set_client_source"), "sv"), adamc@649: (("Basis", "stringToFloat_error"), "pfl"), adamc@649: (("Basis", "stringToInt_error"), "pi"), adamc@614: (("Basis", "urlifyInt"), "ts"), adamc@614: (("Basis", "urlifyFloat"), "ts"), adamc@679: (("Basis", "urlifyString"), "uf"), adamc@691: (("Basis", "recv"), "rv"), adamc@691: (("Basis", "strcat"), "cat")] adamc@572: adamc@572: structure FM = BinaryMapFn(struct adamc@572: type ord_key = string * string adamc@572: fun compare ((m1, x1), (m2, x2)) = adamc@572: Order.join (String.compare (m1, m2), adamc@572: fn () => String.compare (x1, x2)) adamc@572: end) adamc@572: adamc@572: val funcs = foldl (fn ((k, v), m) => FM.insert (m, k, v)) FM.empty funcs adamc@572: adamc@572: fun ffi k = FM.find (funcs, k) adamc@572: adamc@567: type state = { adamc@567: decls : decl list, adamc@589: script : string list, adamc@595: included : IS.set, adamc@595: injectors : int IM.map, adamc@638: decoders : int IM.map, adamc@595: maxName : int adamc@567: } adamc@567: adamc@567: fun varDepth (e, _) = adamc@567: case e of adamc@567: EPrim _ => 0 adamc@567: | ERel _ => 0 adamc@567: | ENamed _ => 0 adamc@567: | ECon (_, _, NONE) => 0 adamc@567: | ECon (_, _, SOME e) => varDepth e adamc@567: | ENone _ => 0 adamc@567: | ESome (_, e) => varDepth e adamc@567: | EFfi _ => 0 adamc@567: | EFfiApp (_, _, es) => foldl Int.max 0 (map varDepth es) adamc@567: | EApp (e1, e2) => Int.max (varDepth e1, varDepth e2) adamc@567: | EAbs _ => 0 adamc@567: | EUnop (_, e) => varDepth e adamc@567: | EBinop (_, e1, e2) => Int.max (varDepth e1, varDepth e2) adamc@567: | ERecord xes => foldl Int.max 0 (map (fn (_, e, _) => varDepth e) xes) adamc@567: | EField (e, _) => varDepth e adamc@567: | ECase (e, pes, _) => adamc@567: foldl Int.max (varDepth e) adamc@567: (map (fn (p, e) => E.patBindsN p + varDepth e) pes) adamc@567: | EStrcat (e1, e2) => Int.max (varDepth e1, varDepth e2) adamc@567: | EError (e, _) => varDepth e adamc@567: | EWrite e => varDepth e adamc@567: | ESeq (e1, e2) => Int.max (varDepth e1, varDepth e2) adamc@567: | ELet (_, _, e1, e2) => Int.max (varDepth e1, 1 + varDepth e2) adamc@567: | EClosure _ => 0 adamc@567: | EQuery _ => 0 adamc@567: | EDml _ => 0 adamc@567: | ENextval _ => 0 adamc@567: | EUnurlify _ => 0 adamc@567: | EJavaScript _ => 0 adamc@568: | ESignalReturn e => varDepth e adamc@572: | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2) adamc@574: | ESignalSource e => varDepth e adamc@614: | EServerCall (e, ek, _) => Int.max (varDepth e, varDepth ek) adamc@670: | ERecv (e, ek, _) => Int.max (varDepth e, varDepth ek) adamc@567: adamc@591: fun closedUpto d = adamc@591: let adamc@591: fun cu inner (e, _) = adamc@591: case e of adamc@591: EPrim _ => true adamc@591: | ERel n => n < inner orelse n - inner >= d adamc@591: | ENamed _ => true adamc@591: | ECon (_, _, NONE) => true adamc@591: | ECon (_, _, SOME e) => cu inner e adamc@591: | ENone _ => true adamc@591: | ESome (_, e) => cu inner e adamc@591: | EFfi _ => true adamc@591: | EFfiApp (_, _, es) => List.all (cu inner) es adamc@591: | EApp (e1, e2) => cu inner e1 andalso cu inner e2 adamc@591: | EAbs (_, _, _, e) => cu (inner + 1) e adamc@591: | EUnop (_, e) => cu inner e adamc@591: | EBinop (_, e1, e2) => cu inner e1 andalso cu inner e2 adamc@591: | ERecord xes => List.all (fn (_, e, _) => cu inner e) xes adamc@591: | EField (e, _) => cu inner e adamc@591: | ECase (e, pes, _) => adamc@591: cu inner e adamc@591: andalso List.all (fn (p, e) => cu (inner + E.patBindsN p) e) pes adamc@591: | EStrcat (e1, e2) => cu inner e1 andalso cu inner e2 adamc@591: | EError (e, _) => cu inner e adamc@591: | EWrite e => cu inner e adamc@591: | ESeq (e1, e2) => cu inner e1 andalso cu inner e2 adamc@591: | ELet (_, _, e1, e2) => cu inner e1 andalso cu (inner + 1) e2 adamc@591: | EClosure (_, es) => List.all (cu inner) es adamc@591: | EQuery {query, body, initial, ...} => adamc@591: cu inner query adamc@591: andalso cu (inner + 2) body adamc@591: andalso cu inner initial adamc@591: | EDml e => cu inner e adamc@591: | ENextval e => cu inner e adamc@591: | EUnurlify (e, _) => cu inner e adamc@591: | EJavaScript (_, e, _) => cu inner e adamc@591: | ESignalReturn e => cu inner e adamc@591: | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2 adamc@591: | ESignalSource e => cu inner e adamc@614: | EServerCall (e, ek, _) => cu inner e andalso cu inner ek adamc@670: | ERecv (e, ek, _) => cu inner e andalso cu inner ek adamc@591: in adamc@591: cu 0 adamc@591: end adamc@591: adamc@568: fun strcat loc es = adamc@568: case es of adamc@568: [] => (EPrim (Prim.String ""), loc) adamc@568: | [x] => x adamc@568: | x :: es' => (EStrcat (x, strcat loc es'), loc) adamc@568: adamc@589: fun process 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@596: | ((DDatatype (_, _, cs), _), state as (someTs, nameds)) => adamc@596: if ElabUtil.classifyDatatype cs = Option then adamc@596: (foldl (fn ((_, n, SOME t), someTs) => IM.insert (someTs, n, t) adamc@596: | (_, someTs) => someTs) someTs cs, adamc@596: nameds) adamc@596: else adamc@596: state adamc@595: | (_, state) => state) adamc@596: (IM.empty, IM.empty) file adamc@567: adamc@590: fun str loc s = (EPrim (Prim.String s), loc) adamc@590: adamc@594: fun isNullable (t, _) = adamc@594: case t of adamc@594: TOption _ => 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 adamc@593: TSource => (strcat loc [str loc "s", adamc@593: (EFfiApp ("Basis", "htmlifyInt", [e]), 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: adamc@593: | TFfi ("Basis", "string") => ((EFfiApp ("Basis", "jsifyString", [e]), loc), st) adamc@593: | TFfi ("Basis", "int") => ((EFfiApp ("Basis", "htmlifyInt", [e]), loc), st) adamc@593: | TFfi ("Basis", "float") => ((EFfiApp ("Basis", "htmlifyFloat", [e]), loc), st) adamc@682: | TFfi ("Basis", "channel") => ((EFfiApp ("Basis", "jsifyChannel", [e]), 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@594: ((ECase (e, adamc@594: [((PNone t, loc), adamc@594: str loc "null"), adamc@594: ((PSome (t, (PVar ("x", t), loc)), loc), adamc@594: if isNullable t then adamc@594: strcat loc [str loc "{v:", e', str loc "}"] adamc@594: else adamc@594: e')], adamc@594: {disc = (TOption t, loc), adamc@594: result = (TFfi ("Basis", "string"), loc)}), loc), adamc@594: st) adamc@594: end adamc@594: 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@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@595: val st = {decls = (DValRec [("jsify", n', (TFun (t, s), loc), adamc@595: body, "jsify")], loc) :: #decls st, adamc@595: script = #script st, adamc@595: included = #included st, adamc@595: injectors = #injectors 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: adamc@590: | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript"; adamc@590: Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)]; adamc@593: (str loc "ERROR", st)) adamc@590: adamc@613: fun unurlifyExp loc (t : typ, st) = adamc@613: case #1 t of adamc@613: TRecord [] => ("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@613: | TFfi ("Basis", "int") => ("parseInt(t[i++])", st) adamc@613: | TFfi ("Basis", "float") => ("parseFloat(t[i++])", st) adamc@682: | TFfi ("Basis", "channel") => ("(t[i++].length > 0 ? parseInt(t[i]) : null)", st) adamc@613: adamc@613: | TFfi ("Basis", "bool") => ("t[i++] == \"True\"", st) adamc@613: 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@638: ("(uu=t[i++],uu==\"Some\"?" ^ e ^ ":null)", st) adamc@638: end adamc@613: 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@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@638: ("pf()", 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@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@589: fun jsExp mode skip outer = adamc@567: let adamc@589: val len = length outer adamc@567: adamc@589: fun jsE inner (e as (_, loc), st) = adamc@589: let adamc@590: val str = str loc adamc@567: adamc@589: fun var n = Int.toString (len + inner - n - 1) 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@589: | 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@591: (str "ERROR", st)) adamc@577: adamc@589: val strcat = strcat loc adamc@584: adamc@589: fun jsPrim p = adamc@589: case p of adamc@589: Prim.String s => adamc@589: str ("\"" adamc@589: ^ String.translate (fn #"'" => adamc@589: if mode = Attribute then adamc@589: "\\047" adamc@589: else adamc@589: "'" adamc@589: | #"\"" => "\\\"" adamc@589: | #"<" => adamc@589: if mode = Script then adamc@589: "<" adamc@589: else adamc@589: "\\074" adamc@589: | #"\\" => "\\\\" adamc@646: | #"\n" => "\\n" adamc@646: | #"\r" => "\\r" adamc@646: | #"\t" => "\\t" adamc@646: | ch => adamc@646: if Char.isPrint ch then adamc@646: String.str ch adamc@646: else adamc@646: "\\" ^ padWith (#"0", adamc@646: Int.fmt StringCvt.OCT (ord ch), adamc@646: 3)) s adamc@589: ^ "\"") adamc@589: | _ => str (Prim.toString p) adamc@589: adamc@589: fun jsPat depth inner (p, _) succ fail = adamc@589: case p of adamc@589: PWild => succ adamc@589: | PVar _ => strcat [str ("(_" ^ Int.toString (len + inner) ^ "=d" adamc@589: ^ Int.toString depth ^ ","), adamc@589: succ, adamc@589: str ")"] adamc@589: | PPrim p => strcat [str ("(d" ^ Int.toString depth ^ "=="), adamc@589: jsPrim p, adamc@589: str "?", adamc@589: succ, adamc@589: str ":", adamc@589: fail, adamc@589: str ")"] adamc@589: | PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE) => adamc@589: strcat [str ("(d" ^ Int.toString depth ^ "?"), adamc@589: succ, adamc@589: str ":", adamc@589: fail, adamc@589: str ")"] adamc@589: | PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE) => adamc@589: strcat [str ("(d" ^ Int.toString depth ^ "?"), adamc@589: fail, adamc@589: str ":", adamc@589: succ, adamc@589: str ")"] adamc@596: | PCon (Option, _, NONE) => adamc@596: strcat [str ("(d" ^ Int.toString depth ^ "?"), adamc@596: fail, adamc@596: str ":", adamc@596: succ, adamc@596: str ")"] 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@596: | SOME t => adamc@596: strcat [str ("(d" ^ Int.toString depth ^ "?(" adamc@596: ^ (if isNullable t then adamc@596: "d" ^ Int.toString depth ^ "=d" adamc@596: ^ Int.toString depth ^ ".v," adamc@596: else adamc@596: "")), adamc@596: jsPat depth inner p succ fail, adamc@596: str "):", adamc@596: fail, adamc@596: str ")"]) adamc@589: | PCon (_, pc, NONE) => adamc@589: strcat [str ("(d" ^ Int.toString depth ^ "=="), adamc@589: patCon pc, adamc@589: str "?", adamc@589: succ, adamc@589: str ":", adamc@589: fail, adamc@589: str ")"] adamc@589: | PCon (_, pc, SOME p) => adamc@589: strcat [str ("(d" ^ Int.toString depth ^ ".n=="), adamc@589: patCon pc, adamc@589: str ("?(d" ^ Int.toString depth ^ "=d" ^ Int.toString depth ^ ".v,"), adamc@589: jsPat depth inner p succ fail, adamc@589: str "):", adamc@589: fail, adamc@589: str ")"] adamc@589: | PRecord xps => adamc@589: let adamc@589: val (_, succ) = foldl adamc@589: (fn ((x, p, _), (inner, succ)) => adamc@589: (inner + E.patBindsN p, adamc@589: strcat [str ("(d" ^ Int.toString (depth+1) ^ "=d" adamc@589: ^ Int.toString depth ^ "._" ^ x ^ ","), adamc@589: jsPat (depth+1) inner p succ fail, adamc@589: str ")"])) adamc@589: (inner, succ) xps adamc@589: in adamc@589: succ adamc@589: end adamc@589: | PNone _ => strcat [str ("(d" ^ Int.toString depth ^ "?"), adamc@589: fail, adamc@589: str ":", adamc@589: succ, adamc@589: str ")"] adamc@594: | PSome (t, p) => strcat (str ("(d" ^ Int.toString depth ^ "?") adamc@594: :: (if isNullable t then adamc@594: [str ("d" ^ Int.toString depth adamc@594: ^ "=d" ^ Int.toString depth ^ ".v")] adamc@594: else adamc@594: []) adamc@594: @ [jsPat depth inner p succ fail, adamc@594: str ":", adamc@594: fail, adamc@594: 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: adamc@601: fun deStrcat level (all as (e, _)) = adamc@589: case e of adamc@601: EPrim (Prim.String s) => jsifyStringMulti (level, s) adamc@601: | EStrcat (e1, e2) => deStrcat level e1 ^ deStrcat level e2 adamc@601: | EFfiApp ("Basis", "jsifyString", [e]) => "\"" ^ deStrcat (level + 1) e ^ "\"" adamc@601: | _ => (Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)]; adamc@601: raise Fail "Jscomp: deStrcat") adamc@590: adamc@590: val quoteExp = quoteExp loc adamc@567: in adamc@590: (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e)];*) adamc@590: adamc@589: case #1 e of adamc@589: EPrim p => (jsPrim p, st) adamc@589: | ERel n => adamc@589: if n < inner then adamc@589: (str ("_" ^ var n), st) adamc@589: else adamc@589: let adamc@589: val n = n - inner adamc@589: in adamc@593: quoteExp (List.nth (outer, n)) ((ERel (n - skip), loc), 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@638: decoders = #decoders st, adamc@595: maxName = #maxName st} adamc@578: adamc@589: val (e, st) = jsExp mode skip [] 0 (e, st) adamc@601: val e = deStrcat 0 e adamc@589: adamc@589: val sc = "_n" ^ Int.toString n ^ "=" ^ e ^ ";\n" adamc@589: in adamc@589: {decls = #decls st, adamc@589: script = sc :: #script st, adamc@595: included = #included st, adamc@595: injectors = #injectors st, adamc@638: decoders= #decoders st, adamc@595: maxName = #maxName st} adamc@589: end adamc@589: in adamc@589: (str ("_n" ^ Int.toString n), st) adamc@589: end adamc@589: adamc@596: | ECon (Option, _, NONE) => (str "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@596: strcat [str "{v:", adamc@596: e, adamc@596: str "}"] adamc@596: else adamc@596: e, st) adamc@596: end adamc@596: adamc@589: | ECon (_, pc, NONE) => (patCon pc, st) adamc@589: | ECon (_, pc, SOME e) => adamc@589: let adamc@589: val (s, st) = jsE inner (e, st) adamc@589: in adamc@589: (strcat [str "{n:", adamc@589: patCon pc, adamc@589: str ",v:", adamc@589: s, adamc@589: str "}"], st) adamc@589: end adamc@596: adamc@589: | ENone _ => (str "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@589: strcat [str "{v:", e, str "}"] adamc@589: else adamc@589: e, st) adamc@589: end adamc@589: adamc@589: | EFfi k => adamc@589: let adamc@589: val name = case ffi 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@589: (str name, st) adamc@589: end adamc@589: | EFfiApp (m, x, args) => adamc@589: let adamc@589: val args = adamc@589: case (m, x, args) of adamc@589: ("Basis", "new_client_source", [(EJavaScript (_, e, _), _)]) => [e] adamc@589: | ("Basis", "set_client_source", [e1, (EJavaScript (_, e2, _), _)]) => [e1, e2] adamc@589: | _ => args adamc@589: adamc@589: val name = case ffi (m, x) of adamc@589: NONE => (EM.errorAt loc ("Unsupported FFI function " adamc@589: ^ x ^ " in JavaScript"); adamc@589: "ERROR") adamc@589: | SOME s => s adamc@589: in adamc@589: case args of adamc@589: [] => (str (name ^ "()"), st) adamc@589: | [e] => adamc@589: let adamc@589: val (e, st) = jsE inner (e, st) adamc@589: in adamc@589: (strcat [str (name ^ "("), adamc@589: e, adamc@589: str ")"], st) adamc@589: end adamc@589: | e :: es => adamc@589: let adamc@589: val (e, st) = jsE inner (e, st) adamc@589: val (es, st) = ListUtil.foldlMapConcat adamc@589: (fn (e, st) => adamc@589: let adamc@589: val (e, st) = jsE inner (e, st) adamc@589: in adamc@589: ([str ",", e], st) adamc@589: end) adamc@589: st es adamc@589: in adamc@589: (strcat (str (name ^ "(") adamc@589: :: e adamc@589: :: es adamc@589: @ [str ")"]), st) adamc@589: end 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@589: (strcat [e1, str "(", e2, str ")"], st) adamc@589: end adamc@589: | EAbs (_, _, _, e) => adamc@589: let adamc@589: val locals = List.tabulate adamc@589: (varDepth e, adamc@589: fn i => str ("var _" ^ Int.toString (len + inner + i + 1) ^ ";")) adamc@589: val (e, st) = jsE (inner + 1) (e, st) adamc@589: in adamc@589: (strcat (str ("function(_" adamc@589: ^ Int.toString (len + inner) adamc@589: ^ "){") adamc@589: :: locals adamc@589: @ [str "return ", adamc@589: e, adamc@589: str "}"]), adamc@589: st) adamc@589: end adamc@589: adamc@589: | EUnop (s, e) => adamc@589: let adamc@589: val (e, st) = jsE inner (e, st) adamc@589: in adamc@589: (strcat [str ("(" ^ s), adamc@572: e, adamc@589: str ")"], adamc@589: st) adamc@589: end adamc@589: | EBinop (s, 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@589: (strcat [str "(", adamc@589: e1, adamc@589: str s, adamc@589: e2, adamc@589: str ")"], adamc@589: st) adamc@589: end adamc@589: adamc@589: | ERecord [] => (str "null", st) adamc@589: | ERecord [(x, e, _)] => adamc@589: let adamc@589: val (e, st) = jsE inner (e, st) adamc@589: in adamc@589: (strcat [str "{_x:", e, str "}"], st) adamc@589: end adamc@589: | ERecord ((x, e, _) :: xes) => adamc@589: let adamc@589: val (e, st) = jsE inner (e, st) adamc@589: 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@589: (str (",_" ^ x ^ ":") adamc@589: :: e adamc@589: :: es, adamc@589: st) adamc@589: end) adamc@589: ([str "}"], st) xes adamc@589: in adamc@589: (strcat (str ("{_" ^ x ^ ":") adamc@589: :: e adamc@589: :: es), adamc@589: st) adamc@589: end adamc@589: | EField (e, x) => adamc@589: let adamc@589: val (e, st) = jsE inner (e, st) adamc@589: in adamc@589: (strcat [e, adamc@589: str ("._" ^ x)], st) adamc@589: end adamc@589: adamc@591: | ECase (e', pes, {result, ...}) => adamc@679: (*if closedUpto inner e andalso List.all (fn (_, e) => closedUpto inner e) pes then adamc@593: let adamc@593: val (e', st) = quoteExp result ((ERel 0, loc), st) adamc@593: in adamc@593: ((ELet ("js", result, e, e'), loc), adamc@593: st) adamc@593: end adamc@679: else*) adamc@591: let adamc@591: val plen = length pes adamc@589: adamc@591: val (cases, st) = ListUtil.foldliMap adamc@591: (fn (i, (p, e), st) => adamc@591: let adamc@591: val (e, st) = jsE (inner + E.patBindsN p) (e, st) adamc@591: val fail = adamc@591: if i = plen - 1 then adamc@591: str "pf()" adamc@591: else adamc@591: str ("c" ^ Int.toString (i+1) ^ "()") adamc@591: val c = jsPat 0 inner p e fail adamc@591: in adamc@591: (strcat [str ("c" ^ Int.toString i ^ "=function(){return "), adamc@591: c, adamc@591: str "},"], adamc@591: st) adamc@591: end) adamc@591: st pes adamc@589: adamc@591: val (e, st) = jsE inner (e', st) adamc@591: in adamc@591: (strcat (str "(" adamc@591: :: List.revAppend (cases, adamc@591: [str "d0=", adamc@591: e, adamc@591: str ",c0())"])), st) adamc@591: 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 adamc@589: (strcat [str "(", e1, str "+", e2, str ")"], 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 adamc@589: (strcat [str "alert(\"ERROR: \"+", e, str ")"], adamc@589: st) adamc@589: end adamc@589: adamc@589: | EWrite e => adamc@589: let adamc@589: val (e, st) = jsE inner (e, st) adamc@589: in adamc@589: (strcat [str "document.write(", adamc@589: e, adamc@589: str ".v)"], 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@589: (strcat [str "(", e1, str ",", 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@589: (strcat [str ("(_" ^ Int.toString (len + inner) ^ "="), adamc@589: e1, adamc@589: str ",", adamc@589: e2, adamc@572: str ")"], st) adamc@572: end adamc@589: adamc@601: | EJavaScript (Source _, _, SOME _) => (e, st) adamc@603: | EJavaScript (_, _, SOME e) => adamc@603: (strcat [str "\"cr(\"+ca(function(){return ", adamc@603: e, adamc@603: str "})+\")\""], adamc@603: st) adamc@590: adamc@589: | EClosure _ => unsupported "EClosure" adamc@589: | EQuery _ => unsupported "Query" adamc@589: | EDml _ => unsupported "DML" adamc@589: | ENextval _ => unsupported "Nextval" adamc@589: | EUnurlify _ => unsupported "EUnurlify" adamc@601: | EJavaScript (_, e, _) => adamc@601: let adamc@601: val (e, st) = jsE inner (e, st) adamc@601: in adamc@603: (strcat [str "\"cr(\"+ca(function(){return ", adamc@603: e, adamc@603: str "})+\")\""], adamc@603: st) adamc@601: end adamc@590: adamc@589: | ESignalReturn e => adamc@572: let adamc@572: val (e, st) = jsE inner (e, st) adamc@572: in adamc@589: (strcat [str "sr(", adamc@589: e, adamc@589: str ")"], 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 adamc@589: (strcat [str "sb(", adamc@589: e1, adamc@589: str ",", adamc@589: e2, adamc@589: str ")"], 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 adamc@589: (strcat [str "ss(", adamc@589: e, adamc@589: str ")"], adamc@589: st) adamc@572: end adamc@608: adamc@614: | EServerCall (e, ek, t) => adamc@609: let adamc@614: val (e, st) = jsE inner (e, st) adamc@609: val (ek, st) = jsE inner (ek, st) adamc@613: val (unurl, st) = unurlifyExp loc (t, st) adamc@609: in adamc@614: (strcat [str ("rc(\"" ^ !Monoize.urlPrefix ^ "\"+"), adamc@614: e, adamc@614: str (", function(s){var t=s.split(\"/\");var i=0;return " adamc@613: ^ unurl ^ "},"), adamc@609: ek, adamc@609: str ")"], adamc@609: st) adamc@609: end adamc@670: adamc@670: | ERecv (e, ek, t) => adamc@670: let adamc@670: val (e, st) = jsE inner (e, st) adamc@670: val (ek, st) = jsE inner (ek, st) adamc@670: val (unurl, st) = unurlifyExp loc (t, st) adamc@670: in adamc@670: (strcat [str "rv(", adamc@670: e, adamc@670: str (", function(s){var t=s.split(\"/\");var i=0;return " adamc@670: ^ unurl ^ "},"), adamc@670: ek, adamc@670: str ")"], adamc@670: st) adamc@670: end adamc@567: end adamc@589: in adamc@589: jsE adamc@589: end adamc@567: adamc@589: val decl : state -> decl -> decl * state = adamc@589: U.Decl.foldMapB {typ = fn x => x, adamc@589: exp = fn (env, e, st) => adamc@589: let adamc@589: fun doCode m skip env orig e = adamc@589: let adamc@589: val len = length env adamc@589: fun str s = (EPrim (Prim.String s), #2 e) adamc@567: adamc@589: val locals = List.tabulate adamc@589: (varDepth e, adamc@589: fn i => str ("var _" ^ Int.toString (len + i) ^ ";")) adamc@589: val (e, st) = jsExp m skip env 0 (e, st) adamc@589: in adamc@589: (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st) adamc@589: end adamc@589: in adamc@589: case e of adamc@651: EJavaScript (m, orig, NONE) => adamc@591: doCode m 0 env orig orig adamc@589: | _ => (e, st) adamc@589: end, adamc@589: decl = fn (_, e, st) => (e, st), adamc@589: bind = fn (env, U.Decl.RelE (_, t)) => t :: env adamc@589: | (env, _) => env} adamc@589: [] adamc@567: adamc@567: fun doDecl (d, st) = adamc@567: let adamc@567: val (d, st) = decl st d adamc@567: in adamc@567: (List.revAppend (#decls st, [d]), adamc@567: {decls = [], adamc@589: script = #script st, adamc@595: included = #included st, adamc@595: injectors = #injectors 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@638: decoders = IM.empty, adamc@595: maxName = U.File.maxName file + 1} adamc@567: file adamc@569: adamc@569: val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.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@567: in adamc@569: TextIO.closeIn inf; adamc@589: (DJavaScript (lines ^ String.concat (rev (#script st))), ErrorMsg.dummySpan) :: ds adamc@567: end adamc@567: adamc@567: end