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@574: (("Basis", "htmlifyString"), "escape"), adamc@574: (("Basis", "new_client_source"), "sc")] 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@568: fun jsExp mode 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@567: | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"") adamc@567: adamc@568: adamc@567: adamc@567: fun isNullable (t, _) = adamc@567: case t of adamc@567: TOption _ => 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@577: | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript"; adamc@577: str "ERROR") adamc@567: in adamc@567: case #1 e of adamc@567: EPrim (Prim.String s) => adamc@567: (str ("\"" adamc@567: ^ String.translate (fn #"'" => adamc@568: if mode = Attribute then adamc@567: "\\047" adamc@567: else adamc@567: "'" adamc@577: | #"\"" => "\\\"" adamc@567: | #"<" => adamc@568: if mode = Script then adamc@567: "<" adamc@567: else adamc@567: "\\074" adamc@567: | #"\\" => "\\\\" adamc@567: | ch => String.str ch) s adamc@567: ^ "\""), st) adamc@567: | EPrim p => (str (Prim.toString p), st) adamc@567: | ERel n => adamc@567: if n < inner then adamc@567: (str ("uwr" ^ var n), st) adamc@567: else adamc@577: let adamc@577: val n = n - inner adamc@577: in adamc@577: (quoteExp (List.nth (outer, n)) (ERel n, 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@567: fn i => str ("var uwr" ^ Int.toString (len + inner + i) ^ ";")) adamc@567: val (e, st) = jsE (inner + 1) (e, st) adamc@567: in adamc@567: (strcat (str ("function(uwr" 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@567: (strcat [str "{uw_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@567: (str (",uw_" ^ x ^ ":") adamc@567: :: e adamc@567: :: es, adamc@567: st) adamc@567: end) adamc@567: ([str "}"], st) xes adamc@567: in adamc@567: (strcat (str ("{uw_" ^ 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@567: str ("." ^ x)], st) adamc@567: end adamc@567: adamc@567: | ECase _ => raise Fail "Jscomp: ECase" 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@567: (strcat [str ("(uwr" ^ 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@578: fun doCode m 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@568: fn i => str ("var uwr" ^ Int.toString (len + i) ^ ";")) adamc@568: val (e, st) = jsExp m 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@578: EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => doCode m (t :: env) orig e adamc@578: | EJavaScript (m, e, _) => doCode m 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