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@800: structure TM = BinaryMapFn(struct adamc@800: type ord_key = typ adamc@800: val compare = U.Typ.compare adamc@800: end) adamc@800: 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@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@741: | EReturnBlob {blob = e1, mimeType = e2, ...} => Int.max (varDepth e1, varDepth e2) 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@910: | EServerCall (e, ek, _, _) => Int.max (varDepth e, varDepth ek) adamc@670: | ERecv (e, ek, _) => Int.max (varDepth e, varDepth ek) adamc@695: | ESleep (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@741: | EReturnBlob {blob = e1, mimeType = e2, ...} => cu inner e1 andalso cu inner e2 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@815: | 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@910: | EServerCall (e, ek, _, _) => cu inner e andalso cu inner ek adamc@670: | ERecv (e, ek, _) => cu inner e andalso cu inner ek adamc@695: | ESleep (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@801: fun patDepth (p, _) = adamc@801: case p of adamc@801: PWild => 0 adamc@801: | PVar _ => 0 adamc@801: | PPrim _ => 0 adamc@801: | PCon (_, _, NONE) => 0 adamc@801: | PCon (_, _, SOME p) => 1 + patDepth p adamc@801: | PRecord xpts => foldl Int.max 0 (map (fn (_, p, _) => 1 + patDepth p) xpts) adamc@801: | PNone _ => 0 adamc@801: | PSome (_, p) => 1 + patDepth p adamc@801: adamc@801: val compact = adamc@801: U.Exp.mapB {typ = fn t => t, adamc@801: exp = fn inner => fn e => adamc@801: case e of adamc@801: ERel n => adamc@801: if n >= inner then adamc@801: ERel (n - inner) adamc@801: else adamc@801: e adamc@801: | _ => e, adamc@801: bind = fn (inner, b) => adamc@801: case b of adamc@801: U.Exp.RelE _ => inner+1 adamc@801: | _ => inner} adamc@813: adamc@815: exception CantEmbed of typ adamc@815: adamc@847: fun inString {needle, haystack} = adamc@847: let adamc@847: val (_, suffix) = Substring.position needle (Substring.full haystack) adamc@847: in adamc@847: not (Substring.isEmpty suffix) adamc@847: end adamc@847: 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@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) 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@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 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@813: (case #1 e' of adamc@813: 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), adamc@911: strcat loc [str loc ((if isNullable t' then adamc@911: "{v:" adamc@911: else adamc@911: "") ^ "{_1:"), adamc@800: e', adamc@800: str loc ",_2:", adamc@800: (EApp ((ENamed n', loc), adamc@800: (EField ((ERel 0, loc), "2"), loc)), loc), adamc@911: str loc ((if isNullable t' then adamc@911: "}" adamc@911: else adamc@911: "") ^ "}")])], 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: adamc@834: | _ => ((*Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];*) adamc@834: raise CantEmbed t) adamc@590: adamc@613: fun unurlifyExp loc (t : typ, st) = adamc@613: case #1 t of adamc@613: TRecord [] => ("null", st) adamc@910: | TFfi ("Basis", "unit") => ("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@912: | TFfi ("Basis", "bool") => ("t[i++] == \"1\"", 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@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 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@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@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@838: (*if mode = Script then adamc@589: "<" adamc@838: 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@821: | Prim.Char ch => str ("'" ^ String.str ch ^ "'") 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@906: strcat [str ("(d" ^ Int.toString depth ^ "!=null?"), 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@906: strcat [str ("(d" ^ Int.toString depth ^ "!=null?(d" adamc@810: ^ Int.toString (depth+1) ^ "=d" ^ Int.toString depth adamc@596: ^ (if isNullable t then adamc@810: ".v," adamc@596: else adamc@813: "") adamc@813: ^ ","), adamc@810: jsPat (depth+1) 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@810: str ("?(d" ^ Int.toString (depth+1) ^ "=d" ^ Int.toString depth ^ ".v,"), adamc@810: jsPat (depth+1) 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@906: | PNone _ => strcat [str ("(d" ^ Int.toString depth ^ "!=null?"), adamc@589: fail, adamc@589: str ":", adamc@589: succ, adamc@589: str ")"] adamc@906: | PSome (t, p) => strcat [str ("(d" ^ Int.toString depth ^ "!=null?(d" ^ Int.toString (depth+1) adamc@829: ^ "=d" ^ Int.toString depth adamc@829: ^ (if isNullable t then adamc@829: ".v" adamc@829: else adamc@829: "") adamc@829: ^ ","), adamc@829: jsPat (depth+1) inner p succ fail, adamc@829: str "):", adamc@829: fail, adamc@829: 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@910: adamc@910: val hasQuery = U.Exp.exists {typ = fn _ => false, adamc@910: exp = fn EQuery _ => true adamc@910: | _ => false} adamc@910: adamc@910: val indirectQuery = U.Exp.exists {typ = fn _ => false, adamc@910: exp = fn ENamed n => adamc@910: (case IM.find (nameds, n) of adamc@910: NONE => false adamc@910: | SOME e => hasQuery e) adamc@910: | _ => false} adamc@910: adamc@567: in adamc@910: (*if indirectQuery e then adamc@910: Print.preface ("Indirect", MonoPrint.p_exp MonoEnv.empty e) adamc@910: else adamc@910: ();*) adamc@910: 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@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@813: (*val () = Print.prefaces "quote" [("t", MonoPrint.p_typ MonoEnv.empty adamc@813: (List.nth (outer, n)))]*) adamc@589: in adamc@800: quoteExp (List.nth (outer, n)) ((ERel n, 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@800: listInjectors = #listInjectors st, adamc@638: decoders = #decoders st, adamc@595: maxName = #maxName st} adamc@578: adamc@801: val old = e adamc@800: val (e, st) = jsExp mode [] 0 (e, st) adamc@801: val new = e adamc@601: val e = deStrcat 0 e adamc@589: adamc@589: val sc = "_n" ^ Int.toString n ^ "=" ^ 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@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@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@589: (str name, st) adamc@589: end adamc@895: | EFfiApp ("Basis", "kc", []) => (str "kc(event)", 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 " 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@729: val s = adamc@729: case s of adamc@729: "!strcmp" => "==" adamc@729: | _ => s adamc@729: 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@835: (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@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@934: (strcat [e', adamc@934: str ("._" ^ 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@934: in adamc@934: quoteExp t (e, 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@591: | ECase (e', pes, {result, ...}) => adamc@801: let adamc@801: val plen = length pes adamc@589: adamc@801: val (cases, st) = ListUtil.foldliMap adamc@801: (fn (i, (p, e), st) => adamc@801: let adamc@801: val (e, st) = jsE (inner + E.patBindsN p) (e, st) adamc@801: val fail = adamc@801: if i = plen - 1 then adamc@810: str ("pf(\"" ^ ErrorMsg.spanToString loc ^ "\")") adamc@801: else adamc@801: str ("c" ^ Int.toString (i+1) ^ "()") adamc@801: val c = jsPat 0 inner p e fail adamc@801: in adamc@801: (strcat [str ("c" ^ Int.toString i ^ "=function(){return "), adamc@801: c, adamc@801: str "},"], adamc@801: st) adamc@801: end) adamc@801: st pes adamc@589: adamc@801: val depth = foldl Int.max 0 (map (fn (p, _) => 1 + patDepth p) pes) adamc@801: val normalDepth = foldl Int.max 0 (map (fn (_, e) => 1 + varDepth e) pes) adamc@801: val (e, st) = jsE inner (e', st) adamc@801: adamc@801: val len = inner + len adamc@801: val normalVars = List.tabulate (normalDepth, fn n => "_" ^ Int.toString (n + len)) adamc@801: val patVars = List.tabulate (depth, fn n => "d" ^ Int.toString n) adamc@827: val caseVars = ListUtil.mapi (fn (i, _) => "c" ^ Int.toString i) pes adamc@801: in adamc@801: (strcat (str "(function (){ var " adamc@827: :: str (String.concatWith "," (normalVars @ patVars @ caseVars) ^ ";d0=") adamc@801: :: e adamc@801: :: str ";\nreturn (" adamc@801: :: List.revAppend (cases, adamc@801: [str "c0()) } ())"])), 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 adamc@693: (strcat [str "cat(", 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@726: (strcat [str "er(", 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@815: | EJavaScript (Source _, e) => adamc@794: (foundJavaScript := true; adamc@815: jsE inner (e, st)) adamc@815: | EJavaScript (_, e) => adamc@815: let adamc@850: val locals = List.tabulate adamc@850: (varDepth e, adamc@850: fn i => str ("var _" ^ Int.toString (len + inner + i) ^ ";")) adamc@850: adamc@815: val (e, st) = jsE inner (e, st) adamc@815: in adamc@815: foundJavaScript := true; adamc@850: (strcat (str "cs(function(){" adamc@850: :: locals adamc@850: @ [str "return ", adamc@850: compact inner e, adamc@850: str "})"]), adamc@815: st) adamc@815: end 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@741: | EReturnBlob _ => unsupported "EUnurlify" 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@910: | EServerCall (e, ek, t, eff) => 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@764: (strcat [str ("rc(cat(\"" ^ Settings.getUrlPrefix () ^ "\","), adamc@614: e, adamc@703: str ("), function(s){var t=s.split(\"/\");var i=0;return " adamc@613: ^ unurl ^ "},"), adamc@609: ek, adamc@736: str ("," adamc@736: ^ (case eff of adamc@736: ReadCookieWrite => "true" adamc@736: | _ => "false") adamc@736: ^ ")")], 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@695: adamc@695: | ESleep (e, ek) => adamc@695: let adamc@695: val (e, st) = jsE inner (e, st) adamc@695: val (ek, st) = jsE inner (ek, st) adamc@695: in adamc@695: (strcat [str "window.setTimeout(", adamc@695: ek, adamc@695: str ", ", adamc@695: e, adamc@695: str ")"], adamc@695: st) adamc@695: end adamc@567: end adamc@589: in adamc@589: jsE adamc@589: end adamc@567: 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 adamc@847: 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 adamc@815: val (es, st) = ListUtil.foldlMap (exp outer) 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 adamc@815: | EBinop (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 adamc@815: ((EBinop (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 adamc@815: | EReturnBlob {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 adamc@815: ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st) adamc@815: 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 adamc@815: | EDml e => adamc@815: let adamc@815: val (e, st) = exp outer (e, st) adamc@815: in adamc@815: ((EDml e, 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@815: adamc@815: | EUnurlify (e, t) => adamc@815: let adamc@815: val (e, st) = exp outer (e, st) adamc@815: in adamc@815: ((EUnurlify (e, t), loc), st) adamc@815: end adamc@815: adamc@815: | EJavaScript (m, e') => adamc@815: (let adamc@815: val len = length outer adamc@815: fun str s = (EPrim (Prim.String s), #2 e') adamc@815: adamc@815: val locals = List.tabulate adamc@815: (varDepth e', adamc@815: fn i => str ("var _" ^ Int.toString (len + i) ^ ";")) adamc@815: adamc@815: val (e', st) = jsExp m outer 0 (e', st) adamc@815: adamc@815: val e' = adamc@815: case locals of adamc@815: [] => e' adamc@815: | _ => adamc@815: strcat (#2 e') (str "(function(){" adamc@815: :: locals adamc@815: @ [str "return ", adamc@815: e', adamc@815: str "}())"]) adamc@815: in adamc@815: (e', st) adamc@815: end handle CantEmbed _ => (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: adamc@910: | EServerCall (e1, e2, t, ef) => 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@910: ((EServerCall (e1, e2, t, ef), loc), st) adamc@815: end adamc@815: | ERecv (e1, e2, t) => 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: ((ERecv (e1, e2, t), loc), st) adamc@815: end adamc@815: | ESleep (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: ((ESleep (e1, e2), 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} adamc@815: 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@794: adamc@794: val script = adamc@794: if !foundJavaScript then adamc@794: lines ^ String.concat (rev (#script st)) adamc@794: else adamc@794: "" adamc@567: in adamc@569: TextIO.closeIn inf; adamc@794: (DJavaScript script, ErrorMsg.dummySpan) :: ds adamc@567: end adamc@567: adamc@567: end