New NameJs phase, still needing some debugging

10 files changed, 252 insertions, 3 deletions

diff --git a/src/compiler.sig b/src/compiler.sig
index f23728f0..7e4f2f6a 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -115,6 +115,7 @@ signature COMPILER = sig
     val mono_reduce : (Mono.file, Mono.file) phase
     val mono_shake : (Mono.file, Mono.file) phase
     val iflow : (Mono.file, Mono.file) phase
+    val namejs : (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
@@ -167,6 +168,8 @@ signature COMPILER = sig
     val toMono_shake : (string, Mono.file) transform
     val toMono_opt2 : (string, Mono.file) transform
     val toIflow : (string, Mono.file) transform
+    val toNamejs : (string, Mono.file) transform
+    val toNamejs_untangle : (string, Mono.file) transform
     val toJscomp : (string, Mono.file) transform
     val toMono_opt3 : (string, Mono.file) transform
     val toFuse : (string, Mono.file) transform
diff --git a/src/compiler.sml b/src/compiler.sml
index a9720cf6..d1d0484a 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -1346,12 +1346,21 @@ val iflow = {
 
 val toIflow = transform iflow "iflow" o toMono_opt2
 
+val namejs = {
+    func = NameJS.rewrite,
+    print = MonoPrint.p_file MonoEnv.empty
+}
+
+val toNamejs = transform namejs "namejs" o toIflow
+
+val toNamejs_untangle = transform untangle "namejs_untangle" o toNamejs
+
 val jscomp = {
     func = JsComp.process,
     print = MonoPrint.p_file MonoEnv.empty
 }
 
-val toJscomp = transform jscomp "jscomp" o toIflow
+val toJscomp = transform jscomp "jscomp" o toNamejs_untangle
 
 val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp
 
diff --git a/src/mono_util.sig b/src/mono_util.sig
index 7ce545e1..a5118072 100644
--- a/src/mono_util.sig
+++ b/src/mono_util.sig
@@ -107,6 +107,11 @@ structure Decl : sig
                decl : Mono.decl' -> Mono.decl'}
               -> Mono.decl -> Mono.decl
 
+    val foldMap : {typ : Mono.typ' * 'state -> Mono.typ' * 'state,
+                   exp : Mono.exp' * 'state -> Mono.exp' * 'state,
+                   decl : Mono.decl' * 'state -> Mono.decl' * 'state}
+                  -> 'state -> Mono.decl -> Mono.decl * 'state
+
     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,
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 38016f85..58498996 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -639,6 +639,13 @@ fun map {typ, exp, decl} e =
         S.Return () => raise Fail "MonoUtil.Decl.map: Impossible"
       | S.Continue (e, ()) => e
 
+fun foldMap {typ, exp, decl} s d =
+    case mapfold {typ = fn c => fn s => S.Continue (typ (c, s)),
+                  exp = fn e => fn s => S.Continue (exp (e, s)),
+                  decl = fn d => fn s => S.Continue (decl (d, s))} d s of
+        S.Continue v => v
+      | S.Return _ => raise Fail "MonoUtil.Decl.foldMap: Impossible"
+
 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)),
diff --git a/src/monoize.sml b/src/monoize.sml
index 371e1d43..1b9c97ed 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3478,9 +3478,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
 
                         val t = (L'.TFfi ("Basis", "string"), loc)
                         val setClass = (L'.ECase (class,
-                                                  [((L'.PNone t, loc),
+                                                  [((L'.PPrim (Prim.String ""), loc),
                                                     str ""),
-                                                   ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc),
+                                                   ((L'.PVar ("x", t), loc),
                                                     (L'.EStrcat ((L'.EPrim (Prim.String "d.className=\""), loc),
                                                                  (L'.EStrcat ((L'.ERel 0, loc),
                                                                               (L'.EPrim (Prim.String "\";"), loc)), loc)),
diff --git a/src/name_js.sig b/src/name_js.sig
new file mode 100644
index 00000000..6750b7a7
--- /dev/null
+++ b/src/name_js.sig
@@ -0,0 +1,35 @@
+(* Copyright (c) 2012, 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.
+ *)
+
+(* Phase that introduces names for fragments of JavaScript code, so that they
+ * may be moved to app.js and not repeated in each generated page *)
+
+signature NAME_JS = sig
+
+    val rewrite : Mono.file -> Mono.file
+
+end
diff --git a/src/name_js.sml b/src/name_js.sml
new file mode 100644
index 00000000..70ac000c
--- /dev/null
+++ b/src/name_js.sml
@@ -0,0 +1,151 @@
+(* Copyright (c) 2012, 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.
+ *)
+
+(* Phase that introduces names for fragments of JavaScript code, so that they
+ * may be moved to app.js and not repeated in each generated page *)
+
+structure NameJS :> NAME_JS = struct
+
+open Mono
+
+structure U = MonoUtil
+structure IS = IntBinarySet
+
+val freeVars = U.Exp.foldB {typ = #2,
+                            exp = fn (free, e, vs) =>
+                                     case e of
+                                         ERel n =>
+                                         if n < free then
+                                             vs
+                                         else
+                                             IS.add (vs, n - free)
+                                       | _ => vs,
+                            bind = fn (free, b) =>
+                                      case b of
+                                          U.Exp.RelE _ => free+1
+                                        | _ => free}
+               0 IS.empty
+
+fun index (ls, v) =
+    case ls of
+        [] => raise Fail "NameJs.index"
+      | v' :: ls' => if v = v' then 0 else 1 + index (ls', v)
+
+fun squish vs = U.Exp.mapB {typ = fn x => x,
+                            exp = fn free => fn e =>
+                                                case e of
+                                                    ERel n =>
+                                                    if n < free then
+                                                        e
+                                                    else
+                                                        ERel (free + index (vs, n - free) + 1)
+                                                  | _ => e,
+                            bind = fn (free, b) =>
+                                      case b of
+                                          U.Exp.RelE _ => free+1
+                                        | _ => free}
+                           0
+
+fun rewrite file =
+    let
+        val (file, _) = ListUtil.foldlMapConcat (fn (d, nextName) =>
+                                                    let
+                                                        val (d, (nextName, newDs)) =
+                                                            U.Decl.foldMapB {typ = fn x => x,
+                                                                             decl = fn (_, e, s) => (e, s),
+                                                                             exp = fn (env, e, st as (nextName, newDs)) =>
+                                                                                      case e of
+                                                                                          EJavaScript (mode, e') =>
+                                                                                          (case mode of
+                                                                                               Source _ => (e, st)
+                                                                                             | _ =>
+                                                                                               let
+                                                                                                   fun isTrulySimple (e, _) =
+                                                                                                       case e of
+                                                                                                           ERel _ => true
+                                                                                                         | ENamed _ => true
+                                                                                                         | ERecord [] => true
+                                                                                                         | _ => false
+
+                                                                                                   fun isAlreadySimple e =
+                                                                                                       case #1 e of
+                                                                                                           EApp (e, arg) => isTrulySimple arg andalso isAlreadySimple e
+                                                                                                         | _ => isTrulySimple e
+                                                                                               in
+                                                                                                   if isAlreadySimple e' then
+                                                                                                       (e, st)
+                                                                                                   else
+                                                                                                       let
+                                                                                                           val loc = #2 e'
+
+                                                                                                           val vs = freeVars e'
+                                                                                                           val vs = IS.listItems vs
+                                                                                                                    
+                                                                                                           val x = "script" ^ Int.toString nextName
+                                                                                                                   
+                                                                                                           val un = (TRecord [], loc)
+                                                                                                           val s = (TFfi ("Basis", "string"), loc)
+                                                                                                           val base = (TFun (un, s), loc)
+                                                                                                           val t = foldl (fn (n, t) => (TFun (#2 (List.nth (env, n)), t), loc)) base vs
+                                                                                                           val e' = squish vs e'
+                                                                                                           val e' = (EAbs ("_", un, s, e'), loc)
+                                                                                                           val (e', _) = foldl (fn (n, (e', t)) =>
+                                                                                                                                   let
+                                                                                                                                       val (x, this) = List.nth (env, n)
+                                                                                                                                   in
+                                                                                                                                       ((EAbs (x, this, t, e'), loc),
+                                                                                                                                        (TFun (this, t), loc))
+                                                                                                                                   end) (e', base) vs
+                                                                                                           val d = (x, nextName, t, e', "<script>")
+
+                                                                                                           val e = (ENamed nextName, loc)
+                                                                                                           val e = foldr (fn (n, e) => (EApp (e, (ERel n, loc)), loc)) e vs
+                                                                                                           val e = (EApp (e, (ERecord [], loc)), loc)
+                                                                                                           val e = EJavaScript (Script, e)
+                                                                                                       in
+                                                                                                           (e, (nextName+1, d :: newDs))
+                                                                                                       end
+                                                                                               end)
+                                                                                        | _ => (e, st),
+                                                                             bind = fn (env, b) =>
+                                                                                       case b of
+                                                                                           U.Decl.RelE x => x :: env
+                                                                                         | _ => env}
+                                                            [] (nextName, []) d
+                                                    in
+                                                        (case newDs of
+                                                             [] => [d]
+                                                           | _ => case #1 d of
+                                                                      DValRec vis => [(DValRec (vis @ newDs), #2 d)]
+                                                                    | _ => List.revAppend (map (fn vi => (DVal vi, #2 d)) newDs, [d]),
+                                                         nextName)
+                                                    end) (U.File.maxName file + 1) file
+    in
+        file
+    end
+
+end
diff --git a/src/sources b/src/sources
index 551d4ca5..b49f0ba8 100644
--- a/src/sources
+++ b/src/sources
@@ -188,6 +188,9 @@ sql.sml
 iflow.sig
 iflow.sml
 
+name_js.sig
+name_js.sml
+
 jscomp.sig
 jscomp.sml
 
diff --git a/tests/dynlines.ur b/tests/dynlines.ur
new file mode 100644
index 00000000..92866e69
--- /dev/null
+++ b/tests/dynlines.ur
@@ -0,0 +1,33 @@
+datatype lines = End | Line of source lines
+
+type t = { Head : source lines, Tail : source (source lines) }
+
+val create =
+    head <- source End;
+    tail <- source head;
+    return {Head = head, Tail = tail}
+
+fun renderL lines =
+    case lines of
+        End => <xml/>
+      | Line linesS => <xml>X<br/><dyn signal={renderS linesS}/></xml>
+
+and renderS linesS =
+    lines <- signal linesS;
+    return (renderL lines)
+
+fun render t = renderS t.Head
+
+fun write t =
+    oldTail <- get t.Tail;
+    newTail <- source End;
+    set oldTail (Line newTail);
+    set t.Tail newTail
+
+fun main () : transaction page =
+    b <- create;
+
+    return <xml><body>
+      <button onclick={fn _ => write b}/>
+      <dyn signal={render b}/>
+    </body></xml>
diff --git a/tests/namejs.ur b/tests/namejs.ur
new file mode 100644
index 00000000..50f6f52c
--- /dev/null
+++ b/tests/namejs.ur
@@ -0,0 +1,3 @@
+fun main (n : int) (s : string) : transaction page = return <xml><body>
+  <button onclick={fn _ => alert ("n = " ^ show n ^ "; s = " ^ s)}/>
+</body></xml>