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@572: val funcs = [(("Basis", "alert"), "alert"), adamc@586: (("Basis", "htmlifyBool"), "bs"), adamc@583: (("Basis", "htmlifyFloat"), "ts"), adamc@582: (("Basis", "htmlifyInt"), "ts"), adamc@574: (("Basis", "htmlifyString"), "escape"), adamc@579: (("Basis", "new_client_source"), "sc"), adamc@579: (("Basis", "set_client_source"), "sv")] 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@567: script : string 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@567: 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@579: fun jsExp mode skip outer = adamc@567: let adamc@567: val len = length outer adamc@567: adamc@567: fun jsE inner (e as (_, loc), st) = adamc@567: let adamc@567: fun str s = (EPrim (Prim.String s), loc) adamc@567: adamc@567: fun var n = Int.toString (len + inner - n - 1) adamc@567: adamc@567: fun patCon pc = adamc@567: case pc of adamc@567: PConVar n => str (Int.toString n) adamc@586: | PConFfi {mod = "Basis", con = "True", ...} => str "true" adamc@586: | PConFfi {mod = "Basis", con = "False", ...} => str "false" adamc@567: | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"") adamc@567: adamc@567: fun isNullable (t, _) = adamc@567: case t of adamc@567: TOption _ => true adamc@583: | TRecord [] => true adamc@567: | _ => false adamc@567: adamc@567: fun unsupported s = adamc@567: (EM.errorAt loc (s ^ " in code to be compiled to JavaScript"); adamc@567: (str "ERROR", st)) adamc@568: adamc@568: val strcat = strcat loc adamc@577: adamc@577: fun quoteExp (t : typ) e = adamc@577: case #1 t of adamc@577: TSource => strcat [str "s", adamc@577: (EFfiApp ("Basis", "htmlifyInt", [e]), loc)] adamc@579: | TRecord [] => str "null" adamc@579: | TFfi ("Basis", "string") => e adamc@577: | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript"; adamc@579: Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)]; adamc@577: str "ERROR") adamc@584: adamc@584: fun jsPrim p = adamc@584: case p of adamc@584: Prim.String s => adamc@584: str ("\"" adamc@584: ^ String.translate (fn #"'" => adamc@584: if mode = Attribute then adamc@584: "\\047" adamc@584: else adamc@584: "'" adamc@584: | #"\"" => "\\\"" adamc@584: | #"<" => adamc@584: if mode = Script then adamc@584: "<" adamc@584: else adamc@584: "\\074" adamc@584: | #"\\" => "\\\\" adamc@584: | ch => String.str ch) s adamc@584: ^ "\"") adamc@584: | _ => str (Prim.toString p) adamc@584: adamc@585: fun jsPat depth inner (p, _) succ fail = adamc@584: case p of adamc@584: PWild => succ adamc@585: | PVar _ => strcat [str ("(_" ^ Int.toString (len + inner) ^ "=d" ^ Int.toString depth ^ ","), adamc@584: succ, adamc@584: str ")"] adamc@585: | PPrim p => strcat [str ("(d" ^ Int.toString depth ^ "=="), adamc@584: jsPrim p, adamc@584: str "?", adamc@584: succ, adamc@584: str ":", adamc@584: fail, adamc@584: str ")"] adamc@587: | PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE) => adamc@587: strcat [str ("(d" ^ Int.toString depth ^ "?"), adamc@587: succ, adamc@587: str ":", adamc@587: fail, adamc@587: str ")"] adamc@587: | PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE) => adamc@587: strcat [str ("(d" ^ Int.toString depth ^ "?"), adamc@587: fail, adamc@587: str ":", adamc@587: succ, adamc@587: str ")"] adamc@588: | PCon (_, pc, NONE) => adamc@588: strcat [str ("(d" ^ Int.toString depth ^ "=="), adamc@588: patCon pc, adamc@588: str "?", adamc@588: succ, adamc@588: str ":", adamc@588: fail, adamc@588: str ")"] adamc@588: | PCon (_, pc, SOME p) => adamc@588: strcat [str ("(d" ^ Int.toString depth ^ ".n=="), adamc@588: patCon pc, adamc@588: str ("?(d" ^ Int.toString depth ^ "=d" ^ Int.toString depth ^ ".v,"), adamc@588: succ, adamc@588: str "):", adamc@588: fail, adamc@588: str ")"] adamc@584: | PRecord xps => adamc@584: let adamc@584: val (_, succ) = foldl adamc@584: (fn ((x, p, _), (inner, succ)) => adamc@584: (inner + E.patBindsN p, adamc@585: strcat [str ("(d" ^ Int.toString (depth+1) ^ "=d" adamc@585: ^ Int.toString depth ^ "._" ^ x ^ ","), adamc@585: jsPat (depth+1) inner p succ fail, adamc@585: str ")"])) adamc@584: (inner, succ) xps adamc@584: in adamc@584: succ adamc@584: end adamc@585: | PNone _ => strcat [str ("(d" ^ Int.toString depth ^ "?"), adamc@584: fail, adamc@584: str ":", adamc@584: succ, adamc@584: str ")"] adamc@585: | PSome (_, p) => strcat [str ("(d" ^ Int.toString depth ^ "?"), adamc@585: jsPat depth inner p succ fail, adamc@584: str ":", adamc@584: fail, adamc@584: str ")"] adamc@567: in adamc@567: case #1 e of adamc@584: EPrim p => (jsPrim p, st) adamc@567: | ERel n => adamc@567: if n < inner then adamc@583: (str ("_" ^ var n), st) adamc@567: else adamc@577: let adamc@577: val n = n - inner adamc@577: in adamc@579: (quoteExp (List.nth (outer, n)) (ERel (n - skip), loc), st) adamc@577: end adamc@567: | ENamed _ => raise Fail "Named" adamc@567: | ECon (_, pc, NONE) => (patCon pc, st) adamc@567: | ECon (_, pc, SOME e) => adamc@567: let adamc@567: val (s, st) = jsE inner (e, st) adamc@567: in adamc@567: (strcat [str "{n:", adamc@567: patCon pc, adamc@567: str ",v:", adamc@567: s, adamc@567: str "}"], st) adamc@567: end adamc@567: | ENone _ => (str "null", st) adamc@567: | ESome (t, e) => adamc@567: let adamc@567: val (e, st) = jsE inner (e, st) adamc@567: in adamc@567: (if isNullable t then adamc@567: strcat [str "{v:", e, str "}"] adamc@567: else adamc@567: e, st) adamc@567: end adamc@567: adamc@572: | EFfi k => adamc@567: let adamc@572: val name = case ffi k of adamc@574: NONE => (EM.errorAt loc ("Unsupported FFI identifier " ^ #2 k ^ " in JavaScript"); adamc@572: "ERROR") adamc@572: | SOME s => s adamc@567: in adamc@572: (str name, st) adamc@567: end adamc@572: | EFfiApp (m, x, args) => adamc@567: let adamc@578: val args = adamc@578: case (m, x, args) of adamc@578: ("Basis", "new_client_source", [(EJavaScript (_, e, _), _)]) => [e] adamc@578: | ("Basis", "set_client_source", [e1, (EJavaScript (_, e2, _), _)]) => [e1, e2] adamc@578: | _ => args adamc@578: adamc@572: val name = case ffi (m, x) of adamc@574: NONE => (EM.errorAt loc ("Unsupported FFI function " ^ x ^ " in JavaScript"); adamc@572: "ERROR") adamc@572: | SOME s => s adamc@567: in adamc@572: case args of adamc@572: [] => (str (name ^ "()"), st) adamc@572: | [e] => adamc@572: let adamc@572: val (e, st) = jsE inner (e, st) adamc@572: in adamc@572: (strcat [str (name ^ "("), adamc@572: e, adamc@572: str ")"], st) adamc@572: end adamc@572: | e :: es => adamc@572: let adamc@572: val (e, st) = jsE inner (e, st) adamc@572: val (es, st) = ListUtil.foldlMapConcat adamc@572: (fn (e, st) => adamc@572: let adamc@572: val (e, st) = jsE inner (e, st) adamc@572: in adamc@572: ([str ",", e], st) adamc@572: end) adamc@572: st es adamc@572: in adamc@572: (strcat (str (name ^ "(") adamc@572: :: e adamc@572: :: es adamc@572: @ [str ")"]), st) adamc@572: end adamc@567: end adamc@567: adamc@567: | EApp (e1, e2) => adamc@567: let adamc@567: val (e1, st) = jsE inner (e1, st) adamc@567: val (e2, st) = jsE inner (e2, st) adamc@567: in adamc@567: (strcat [e1, str "(", e2, str ")"], st) adamc@567: end adamc@567: | EAbs (_, _, _, e) => adamc@567: let adamc@567: val locals = List.tabulate adamc@567: (varDepth e, adamc@585: fn i => str ("var _" ^ Int.toString (len + inner + i + 1) ^ ";")) adamc@567: val (e, st) = jsE (inner + 1) (e, st) adamc@567: in adamc@583: (strcat (str ("function(_" adamc@567: ^ Int.toString (len + inner) adamc@567: ^ "){") adamc@567: :: locals adamc@567: @ [str "return ", adamc@567: e, adamc@567: str "}"]), adamc@567: st) adamc@567: end adamc@567: adamc@567: | EUnop (s, e) => adamc@567: let adamc@567: val (e, st) = jsE inner (e, st) adamc@567: in adamc@567: (strcat [str ("(" ^ s), adamc@567: e, adamc@567: str ")"], adamc@567: st) adamc@567: end adamc@567: | EBinop (s, e1, e2) => adamc@567: let adamc@567: val (e1, st) = jsE inner (e1, st) adamc@567: val (e2, st) = jsE inner (e2, st) adamc@567: in adamc@567: (strcat [str "(", adamc@567: e1, adamc@567: str s, adamc@567: e2, adamc@567: str ")"], adamc@567: st) adamc@567: end adamc@567: adamc@567: | ERecord [] => (str "null", st) adamc@567: | ERecord [(x, e, _)] => adamc@567: let adamc@567: val (e, st) = jsE inner (e, st) adamc@567: in adamc@583: (strcat [str "{_x:", e, str "}"], st) adamc@567: end adamc@567: | ERecord ((x, e, _) :: xes) => adamc@567: let adamc@567: val (e, st) = jsE inner (e, st) adamc@567: adamc@567: val (es, st) = adamc@567: foldr (fn ((x, e, _), (es, st)) => adamc@567: let adamc@567: val (e, st) = jsE inner (e, st) adamc@567: in adamc@583: (str (",_" ^ x ^ ":") adamc@567: :: e adamc@567: :: es, adamc@567: st) adamc@567: end) adamc@567: ([str "}"], st) xes adamc@567: in adamc@583: (strcat (str ("{_" ^ x ^ ":") adamc@567: :: e adamc@567: :: es), adamc@567: st) adamc@567: end adamc@567: | EField (e, x) => adamc@567: let adamc@567: val (e, st) = jsE inner (e, st) adamc@567: in adamc@567: (strcat [e, adamc@583: str ("._" ^ x)], st) adamc@567: end adamc@567: adamc@584: | ECase (e, pes, _) => adamc@584: let adamc@584: val plen = length pes adamc@584: adamc@584: val (cases, st) = ListUtil.foldliMap adamc@584: (fn (i, (p, e), st) => adamc@584: let adamc@584: val (e, st) = jsE (inner + E.patBindsN p) (e, st) adamc@584: val fail = adamc@584: if i = plen - 1 then adamc@584: str "pf()" adamc@584: else adamc@584: str ("c" ^ Int.toString (i+1) ^ "()") adamc@585: val c = jsPat 0 inner p e fail adamc@584: in adamc@584: (strcat [str ("c" ^ Int.toString i ^ "=function(){return "), adamc@584: c, adamc@584: str "},"], adamc@584: st) adamc@584: end) adamc@584: st pes adamc@584: adamc@584: val (e, st) = jsE inner (e, st) adamc@584: in adamc@584: (strcat (str "(" adamc@584: :: List.revAppend (cases, adamc@585: [str "d0=", adamc@584: e, adamc@584: str ",c0())"])), st) adamc@584: end adamc@567: adamc@567: | EStrcat (e1, e2) => adamc@567: let adamc@567: val (e1, st) = jsE inner (e1, st) adamc@567: val (e2, st) = jsE inner (e2, st) adamc@567: in adamc@567: (strcat [str "(", e1, str "+", e2, str ")"], st) adamc@567: end adamc@567: adamc@567: | EError (e, _) => adamc@567: let adamc@567: val (e, st) = jsE inner (e, st) adamc@567: in adamc@567: (strcat [str "alert(\"ERROR: \"+", e, str ")"], adamc@567: st) adamc@567: end adamc@567: adamc@568: | EWrite e => adamc@568: let adamc@568: val (e, st) = jsE inner (e, st) adamc@568: in adamc@568: (strcat [str "document.write(", adamc@568: e, adamc@569: str ".v)"], st) adamc@568: end adamc@567: adamc@567: | ESeq (e1, e2) => adamc@567: let adamc@567: val (e1, st) = jsE inner (e1, st) adamc@567: val (e2, st) = jsE inner (e2, st) adamc@567: in adamc@567: (strcat [str "(", e1, str ",", e2, str ")"], st) adamc@567: end adamc@567: | ELet (_, _, e1, e2) => adamc@567: let adamc@567: val (e1, st) = jsE inner (e1, st) adamc@567: val (e2, st) = jsE (inner + 1) (e2, st) adamc@567: in adamc@583: (strcat [str ("(_" ^ Int.toString (len + inner) ^ "="), adamc@567: e1, adamc@567: str ",", adamc@567: e2, adamc@567: str ")"], st) adamc@567: end adamc@567: adamc@567: | EClosure _ => unsupported "EClosure" adamc@567: | EQuery _ => unsupported "Query" adamc@567: | EDml _ => unsupported "DML" adamc@567: | ENextval _ => unsupported "Nextval" adamc@567: | EUnurlify _ => unsupported "EUnurlify" adamc@567: | EJavaScript _ => unsupported "Nested JavaScript" adamc@568: | ESignalReturn e => adamc@568: let adamc@568: val (e, st) = jsE inner (e, st) adamc@568: in adamc@572: (strcat [str "sr(", adamc@569: e, adamc@569: str ")"], adamc@568: st) adamc@568: end adamc@572: | ESignalBind (e1, e2) => adamc@572: let adamc@572: val (e1, st) = jsE inner (e1, st) adamc@572: val (e2, st) = jsE inner (e2, st) adamc@572: in adamc@572: (strcat [str "sb(", adamc@572: e1, adamc@572: str ",", adamc@572: e2, adamc@572: str ")"], adamc@572: st) adamc@572: end adamc@574: | ESignalSource e => adamc@574: let adamc@574: val (e, st) = jsE inner (e, st) adamc@574: in adamc@574: (strcat [str "ss(", adamc@574: e, adamc@574: str ")"], adamc@574: st) adamc@574: end adamc@567: end adamc@567: in adamc@567: jsE adamc@567: end adamc@567: adamc@567: val decl : state -> decl -> decl * state = adamc@567: U.Decl.foldMapB {typ = fn x => x, adamc@567: exp = fn (env, e, st) => adamc@568: let adamc@579: fun doCode m skip env orig e = adamc@568: let adamc@568: val len = length env adamc@568: fun str s = (EPrim (Prim.String s), #2 e) adamc@568: adamc@568: val locals = List.tabulate adamc@568: (varDepth e, adamc@583: fn i => str ("var _" ^ Int.toString (len + i) ^ ";")) adamc@579: val (e, st) = jsExp m skip env 0 (e, st) adamc@568: in adamc@578: (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st) adamc@568: end adamc@568: in adamc@568: case e of adamc@579: EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => doCode m 1 (t :: env) orig e adamc@579: | EJavaScript (m, e, _) => doCode m 0 env e e adamc@568: | _ => (e, st) adamc@568: end, adamc@567: decl = fn (_, e, st) => (e, st), adamc@567: bind = fn (env, U.Decl.RelE (_, t)) => t :: env adamc@567: | (env, _) => env} adamc@567: [] adamc@567: adamc@567: fun process file = adamc@567: let 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@567: script = #script st}) adamc@567: end adamc@567: adamc@567: val (ds, st) = ListUtil.foldlMapConcat doDecl adamc@567: {decls = [], adamc@567: script = ""} 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@569: (DJavaScript lines, ErrorMsg.dummySpan) :: ds adamc@567: end adamc@567: adamc@567: end