aboutsummaryrefslogtreecommitdiffhomepage
path: root/src/jscomp.sml
diff options
context:
space:
mode:
Diffstat (limited to 'src/jscomp.sml')
-rw-r--r--src/jscomp.sml344
1 files changed, 344 insertions, 0 deletions
diff --git a/src/jscomp.sml b/src/jscomp.sml
new file mode 100644
index 00000000..0dd7882a
--- /dev/null
+++ b/src/jscomp.sml
@@ -0,0 +1,344 @@
+(* Copyright (c) 2008, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ * derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+structure JsComp :> JSCOMP = struct
+
+open Mono
+
+structure EM = ErrorMsg
+structure E = MonoEnv
+structure U = MonoUtil
+
+type state = {
+ decls : decl list,
+ script : string
+}
+
+fun varDepth (e, _) =
+ case e of
+ EPrim _ => 0
+ | ERel _ => 0
+ | ENamed _ => 0
+ | ECon (_, _, NONE) => 0
+ | ECon (_, _, SOME e) => varDepth e
+ | ENone _ => 0
+ | ESome (_, e) => varDepth e
+ | EFfi _ => 0
+ | EFfiApp (_, _, es) => foldl Int.max 0 (map varDepth es)
+ | EApp (e1, e2) => Int.max (varDepth e1, varDepth e2)
+ | EAbs _ => 0
+ | EUnop (_, e) => varDepth e
+ | EBinop (_, e1, e2) => Int.max (varDepth e1, varDepth e2)
+ | ERecord xes => foldl Int.max 0 (map (fn (_, e, _) => varDepth e) xes)
+ | EField (e, _) => varDepth e
+ | ECase (e, pes, _) =>
+ foldl Int.max (varDepth e)
+ (map (fn (p, e) => E.patBindsN p + varDepth e) pes)
+ | EStrcat (e1, e2) => Int.max (varDepth e1, varDepth e2)
+ | EError (e, _) => varDepth e
+ | EWrite e => varDepth e
+ | ESeq (e1, e2) => Int.max (varDepth e1, varDepth e2)
+ | ELet (_, _, e1, e2) => Int.max (varDepth e1, 1 + varDepth e2)
+ | EClosure _ => 0
+ | EQuery _ => 0
+ | EDml _ => 0
+ | ENextval _ => 0
+ | EUnurlify _ => 0
+ | EJavaScript _ => 0
+
+fun jsExp inAttr outer =
+ let
+ val len = length outer
+
+ fun jsE inner (e as (_, loc), st) =
+ let
+ fun str s = (EPrim (Prim.String s), loc)
+
+ fun var n = Int.toString (len + inner - n - 1)
+
+ fun patCon pc =
+ case pc of
+ PConVar n => str (Int.toString n)
+ | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"")
+
+ fun strcat es =
+ case es of
+ [] => (EPrim (Prim.String ""), loc)
+ | [x] => x
+ | x :: es' => (EStrcat (x, strcat es'), loc)
+
+ fun isNullable (t, _) =
+ case t of
+ TOption _ => true
+ | _ => false
+
+ fun unsupported s =
+ (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
+ (str "ERROR", st))
+ in
+ case #1 e of
+ EPrim (Prim.String s) =>
+ (str ("\""
+ ^ String.translate (fn #"'" =>
+ if inAttr then
+ "\\047"
+ else
+ "'"
+ | #"<" =>
+ if inAttr then
+ "<"
+ else
+ "\\074"
+ | #"\\" => "\\\\"
+ | ch => String.str ch) s
+ ^ "\""), st)
+ | EPrim p => (str (Prim.toString p), st)
+ | ERel n =>
+ if n < inner then
+ (str ("uwr" ^ var n), st)
+ else
+ (str ("uwo" ^ var n), st)
+ | ENamed _ => raise Fail "Named"
+ | ECon (_, pc, NONE) => (patCon pc, st)
+ | ECon (_, pc, SOME e) =>
+ let
+ val (s, st) = jsE inner (e, st)
+ in
+ (strcat [str "{n:",
+ patCon pc,
+ str ",v:",
+ s,
+ str "}"], st)
+ end
+ | ENone _ => (str "null", st)
+ | ESome (t, e) =>
+ let
+ val (e, st) = jsE inner (e, st)
+ in
+ (if isNullable t then
+ strcat [str "{v:", e, str "}"]
+ else
+ e, st)
+ end
+
+ | EFfi (_, s) => (str s, st)
+ | EFfiApp (_, s, []) => (str (s ^ "()"), st)
+ | EFfiApp (_, s, [e]) =>
+ let
+ val (e, st) = jsE inner (e, st)
+
+ in
+ (strcat [str (s ^ "("),
+ e,
+ str ")"], st)
+ end
+ | EFfiApp (_, s, e :: es) =>
+ let
+ val (e, st) = jsE inner (e, st)
+ val (es, st) = ListUtil.foldlMapConcat
+ (fn (e, st) =>
+ let
+ val (e, st) = jsE inner (e, st)
+ in
+ ([str ",", e], st)
+ end)
+ st es
+ in
+ (strcat (str (s ^ "(")
+ :: e
+ :: es
+ @ [str ")"]), st)
+ end
+
+ | EApp (e1, e2) =>
+ let
+ val (e1, st) = jsE inner (e1, st)
+ val (e2, st) = jsE inner (e2, st)
+ in
+ (strcat [e1, str "(", e2, str ")"], st)
+ end
+ | EAbs (_, _, _, e) =>
+ let
+ val locals = List.tabulate
+ (varDepth e,
+ fn i => str ("var uwr" ^ Int.toString (len + inner + i) ^ ";"))
+ val (e, st) = jsE (inner + 1) (e, st)
+ in
+ (strcat (str ("function(uwr"
+ ^ Int.toString (len + inner)
+ ^ "){")
+ :: locals
+ @ [str "return ",
+ e,
+ str "}"]),
+ st)
+ end
+
+ | EUnop (s, e) =>
+ let
+ val (e, st) = jsE inner (e, st)
+ in
+ (strcat [str ("(" ^ s),
+ e,
+ str ")"],
+ st)
+ end
+ | EBinop (s, e1, e2) =>
+ let
+ val (e1, st) = jsE inner (e1, st)
+ val (e2, st) = jsE inner (e2, st)
+ in
+ (strcat [str "(",
+ e1,
+ str s,
+ e2,
+ str ")"],
+ st)
+ end
+
+ | ERecord [] => (str "null", st)
+ | ERecord [(x, e, _)] =>
+ let
+ val (e, st) = jsE inner (e, st)
+ in
+ (strcat [str "{uw_x:", e, str "}"], st)
+ end
+ | ERecord ((x, e, _) :: xes) =>
+ let
+ val (e, st) = jsE inner (e, st)
+
+ val (es, st) =
+ foldr (fn ((x, e, _), (es, st)) =>
+ let
+ val (e, st) = jsE inner (e, st)
+ in
+ (str (",uw_" ^ x ^ ":")
+ :: e
+ :: es,
+ st)
+ end)
+ ([str "}"], st) xes
+ in
+ (strcat (str ("{uw_" ^ x ^ ":")
+ :: e
+ :: es),
+ st)
+ end
+ | EField (e, x) =>
+ let
+ val (e, st) = jsE inner (e, st)
+ in
+ (strcat [e,
+ str ("." ^ x)], st)
+ end
+
+ | ECase _ => raise Fail "Jscomp: ECase"
+
+ | EStrcat (e1, e2) =>
+ let
+ val (e1, st) = jsE inner (e1, st)
+ val (e2, st) = jsE inner (e2, st)
+ in
+ (strcat [str "(", e1, str "+", e2, str ")"], st)
+ end
+
+ | EError (e, _) =>
+ let
+ val (e, st) = jsE inner (e, st)
+ in
+ (strcat [str "alert(\"ERROR: \"+", e, str ")"],
+ st)
+ end
+
+ | EWrite _ => unsupported "EWrite"
+
+ | ESeq (e1, e2) =>
+ let
+ val (e1, st) = jsE inner (e1, st)
+ val (e2, st) = jsE inner (e2, st)
+ in
+ (strcat [str "(", e1, str ",", e2, str ")"], st)
+ end
+ | ELet (_, _, e1, e2) =>
+ let
+ val (e1, st) = jsE inner (e1, st)
+ val (e2, st) = jsE (inner + 1) (e2, st)
+ in
+ (strcat [str ("(uwr" ^ Int.toString (len + inner) ^ "="),
+ e1,
+ str ",",
+ e2,
+ str ")"], st)
+ end
+
+ | EClosure _ => unsupported "EClosure"
+ | EQuery _ => unsupported "Query"
+ | EDml _ => unsupported "DML"
+ | ENextval _ => unsupported "Nextval"
+ | EUnurlify _ => unsupported "EUnurlify"
+ | EJavaScript _ => unsupported "Nested JavaScript"
+ end
+ in
+ jsE
+ end
+
+val decl : state -> decl -> decl * state =
+ U.Decl.foldMapB {typ = fn x => x,
+ exp = fn (env, e, st) =>
+ case e of
+ EJavaScript (EAbs (_, t, _, e), _) =>
+ let
+ val (e, st) = jsExp true (t :: env) 0 (e, st)
+ in
+ (#1 e, st)
+ end
+ | _ => (e, st),
+ decl = fn (_, e, st) => (e, st),
+ bind = fn (env, U.Decl.RelE (_, t)) => t :: env
+ | (env, _) => env}
+ []
+
+fun process file =
+ let
+ fun doDecl (d, st) =
+ let
+ val (d, st) = decl st d
+ in
+ (List.revAppend (#decls st, [d]),
+ {decls = [],
+ script = #script st})
+ end
+
+ val (ds, st) = ListUtil.foldlMapConcat doDecl
+ {decls = [],
+ script = ""}
+ file
+ in
+ ds
+ end
+
+end
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-04 16:53:56 +0000