summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/compiler.sig2
-rw-r--r--src/compiler.sml9
-rw-r--r--src/jscomp.sig32
-rw-r--r--src/jscomp.sml344
-rw-r--r--src/mono_env.sig1
-rw-r--r--src/mono_env.sml11
-rw-r--r--src/mono_opt.sml5
-rw-r--r--src/mono_util.sig11
-rw-r--r--src/mono_util.sml15
-rw-r--r--src/prim.sig2
-rw-r--r--src/prim.sml6
-rw-r--r--src/sources3
-rw-r--r--tests/alert.ur2
13 files changed, 436 insertions, 7 deletions
diff --git a/src/compiler.sig b/src/compiler.sig
index 59ad32be..1f1f4973 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -75,6 +75,7 @@ signature COMPILER = sig
val untangle : (Mono.file, Mono.file) phase
val mono_reduce : (Mono.file, Mono.file) phase
val mono_shake : (Mono.file, Mono.file) phase
+ val jscomp : (Mono.file, Mono.file) phase
val fuse : (Mono.file, Mono.file) phase
val pathcheck : (Mono.file, Mono.file) phase
val cjrize : (Mono.file, Cjr.file) phase
@@ -101,6 +102,7 @@ signature COMPILER = sig
val toUntangle : (string, Mono.file) transform
val toMono_reduce : (string, Mono.file) transform
val toMono_shake : (string, Mono.file) transform
+ val toJscomp : (string, Mono.file) transform
val toMono_opt2 : (string, Mono.file) transform
val toFuse : (string, Mono.file) transform
val toUntangle2 : (string, Mono.file) transform
diff --git a/src/compiler.sml b/src/compiler.sml
index 0ff4ee6a..ecee1065 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -511,7 +511,14 @@ val mono_shake = {
val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce
-val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake
+val jscomp = {
+ func = JsComp.process,
+ print = MonoPrint.p_file MonoEnv.empty
+}
+
+val toJscomp = transform jscomp "jscomp" o toMono_reduce
+
+val toMono_opt2 = transform mono_opt "mono_opt2" o toJscomp
val fuse = {
func = Fuse.fuse,
diff --git a/src/jscomp.sig b/src/jscomp.sig
new file mode 100644
index 00000000..929c507d
--- /dev/null
+++ b/src/jscomp.sig
@@ -0,0 +1,32 @@
+(* 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.
+ *)
+
+signature JSCOMP = sig
+
+ val process : Mono.file -> Mono.file
+
+end
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
diff --git a/src/mono_env.sig b/src/mono_env.sig
index cb6f2352..c59596ae 100644
--- a/src/mono_env.sig
+++ b/src/mono_env.sig
@@ -47,5 +47,6 @@ signature MONO_ENV = sig
val declBinds : env -> Mono.decl -> env
val patBinds : env -> Mono.pat -> env
+ val patBindsN : Mono.pat -> int
end
diff --git a/src/mono_env.sml b/src/mono_env.sml
index 47ffd28d..cce4a4c4 100644
--- a/src/mono_env.sml
+++ b/src/mono_env.sml
@@ -122,4 +122,15 @@ fun patBinds env (p, loc) =
| PNone _ => env
| PSome (_, p) => patBinds env p
+fun patBindsN (p, loc) =
+ case p of
+ PWild => 0
+ | PVar _ => 1
+ | PPrim _ => 0
+ | PCon (_, _, NONE) => 0
+ | PCon (_, _, SOME p) => patBindsN p
+ | PRecord xps => foldl (fn ((_, p, _), count) => count + patBindsN p) 0 xps
+ | PNone _ => 0
+ | PSome (_, p) => patBindsN p
+
end
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 7f83c003..6c0e6e21 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -360,11 +360,6 @@ fun exp e =
| EWrite (EPrim (Prim.String ""), loc) =>
ERecord []
- | EJavaScript (EAbs (_, (TRecord [], _), _, (EFfiApp ("Basis", "alert", [s]), _)), loc) =>
- EStrcat ((EPrim (Prim.String "alert("), loc),
- (EStrcat ((EFfiApp ("Basis", "jsifyString", [s]), loc),
- (EPrim (Prim.String ")"), loc)), loc))
-
| _ => e
and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
diff --git a/src/mono_util.sig b/src/mono_util.sig
index 32a83855..2a96211a 100644
--- a/src/mono_util.sig
+++ b/src/mono_util.sig
@@ -71,6 +71,11 @@ structure Exp : sig
val exists : {typ : Mono.typ' -> bool,
exp : Mono.exp' -> bool} -> Mono.exp -> bool
+
+ val foldB : {typ : Mono.typ' * 'state -> 'state,
+ exp : 'context * Mono.exp' * 'state -> 'state,
+ bind : 'context * binder -> 'context}
+ -> 'context -> 'state -> Mono.exp -> 'state
end
structure Decl : sig
@@ -95,6 +100,12 @@ structure Decl : sig
exp : Mono.exp' -> Mono.exp',
decl : Mono.decl' -> Mono.decl'}
-> Mono.decl -> Mono.decl
+
+ val foldMapB : {typ : Mono.typ' * 'state -> Mono.typ' * 'state,
+ exp : 'context * Mono.exp' * 'state -> Mono.exp' * 'state,
+ decl : 'context * Mono.decl' * 'state -> Mono.decl' * 'state,
+ bind : 'context * binder -> 'context}
+ -> 'context -> 'state -> Mono.decl -> Mono.decl * 'state
end
structure File : sig
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 18b5c948..ebc30984 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -357,6 +357,13 @@ fun exists {typ, exp} k =
S.Return _ => true
| S.Continue _ => false
+fun foldB {typ, exp, bind} ctx s e =
+ case mapfoldB {typ = fn t => fn s => S.Continue (t, typ (t, s)),
+ exp = fn ctx => fn e => fn s => S.Continue (e, exp (ctx, e, s)),
+ bind = bind} ctx e s of
+ S.Continue (_, s) => s
+ | S.Return _ => raise Fail "MonoUtil.Exp.foldB: Impossible"
+
end
structure Decl = struct
@@ -433,6 +440,14 @@ fun map {typ, exp, decl} e =
S.Return () => raise Fail "MonoUtil.Decl.map: Impossible"
| S.Continue (e, ()) => e
+fun foldMapB {typ, exp, decl, bind} ctx s d =
+ case mapfoldB {typ = fn c => fn s => S.Continue (typ (c, s)),
+ exp = fn ctx => fn e => fn s => S.Continue (exp (ctx, e, s)),
+ decl = fn ctx => fn d => fn s => S.Continue (decl (ctx, d, s)),
+ bind = bind} ctx d s of
+ S.Continue v => v
+ | S.Return _ => raise Fail "MonoUtil.Decl.foldMapB: Impossible"
+
end
structure File = struct
diff --git a/src/prim.sig b/src/prim.sig
index 3083a26e..54625379 100644
--- a/src/prim.sig
+++ b/src/prim.sig
@@ -38,4 +38,6 @@ signature PRIM = sig
val equal : t * t -> bool
val compare : t * t -> order
+ val toString : t -> string
+
end
diff --git a/src/prim.sml b/src/prim.sml
index daf666e8..468b28d5 100644
--- a/src/prim.sml
+++ b/src/prim.sml
@@ -53,6 +53,12 @@ fun float2s n =
else
Real64.toString n
+fun toString t =
+ case t of
+ Int n => int2s n
+ | Float n => float2s n
+ | String s => s
+
fun p_t_GCC t =
case t of
Int n => string (int2s n)
diff --git a/src/sources b/src/sources
index 6972dc36..05b1cc54 100644
--- a/src/sources
+++ b/src/sources
@@ -137,6 +137,9 @@ untangle.sml
mono_shake.sig
mono_shake.sml
+jscomp.sig
+jscomp.sml
+
pathcheck.sig
pathcheck.sml
diff --git a/tests/alert.ur b/tests/alert.ur
index 7b2eaacf..3fe68d75 100644
--- a/tests/alert.ur
+++ b/tests/alert.ur
@@ -1,3 +1,3 @@
fun main () : transaction page = return <xml><body>
- <a onclick={alert "You clicked it!"}>Click Me!</a>
+ <a onclick={alert "You clicked it! That's some fancy shooting!"}>Click Me!</a>
</body></xml>
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-20 08:07:59 +0000