Start of JsComp

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>