Handling singnal bind

13 files changed, 122 insertions, 30 deletions

diff --git a/jslib/urweb.js b/jslib/urweb.js
index b7a1af91..f552b26b 100644
--- a/jslib/urweb.js
+++ b/jslib/urweb.js
@@ -1,4 +1,5 @@
-function sreturn(v) { return {v : v} }
+function sr(v) { return {v : v} }
+function sb(x,y) { return {v : y(x.v).v} }
 
 function dyn(s) {
   var x = document.createElement("span");
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 78513ef7..a46c725e 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -423,6 +423,7 @@ fun cifyExp (eAll as (e, loc), sm) =
 
       | L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains"
       | L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains"
+      | L.ESignalBind _ => raise Fail "Cjrize: ESignalBind remains"
 
 fun cifyDecl ((d, loc), sm) =
     case d of
diff --git a/src/compiler.sig b/src/compiler.sig
index 1f1f4973..c156b268 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -102,8 +102,9 @@ 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 toJscomp : (string, Mono.file) transform
+    val toMono_opt3 : (string, Mono.file) transform
     val toFuse : (string, Mono.file) transform
     val toUntangle2 : (string, Mono.file) transform
     val toMono_shake2 : (string, Mono.file) transform
diff --git a/src/compiler.sml b/src/compiler.sml
index ecee1065..6d499283 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -511,21 +511,23 @@ 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 toJscomp = transform jscomp "jscomp" o toMono_opt2
 
-val toMono_opt2 = transform mono_opt "mono_opt2" o toJscomp
+val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp
 
 val fuse = {
     func = Fuse.fuse,
     print = MonoPrint.p_file MonoEnv.empty
 }
 
-val toFuse = transform fuse "fuse" o toMono_opt2
+val toFuse = transform fuse "fuse" o toMono_opt3
 
 val toUntangle2 = transform untangle "untangle2" o toFuse
 
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 95c18016..c38056e8 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -33,6 +33,20 @@ structure EM = ErrorMsg
 structure E = MonoEnv
 structure U = MonoUtil
 
+val funcs = [(("Basis", "alert"), "alert"),
+             (("Basis", "htmlifyString"), "escape")]
+
+structure FM = BinaryMapFn(struct
+                           type ord_key = string * string
+                           fun compare ((m1, x1), (m2, x2)) =
+                               Order.join (String.compare (m1, m2),
+                                           fn () => String.compare (x1, x2))
+                           end)
+
+val funcs = foldl (fn ((k, v), m) => FM.insert (m, k, v)) FM.empty funcs
+
+fun ffi k = FM.find (funcs, k)
+
 type state = {
      decls : decl list,
      script : string
@@ -70,6 +84,7 @@ fun varDepth (e, _) =
       | EUnurlify _ => 0
       | EJavaScript _ => 0
       | ESignalReturn e => varDepth e
+      | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2)
 
 fun strcat loc es =
     case es of
@@ -150,33 +165,50 @@ fun jsExp mode outer =
                              e, st)
                     end
 
-                  | EFfi (_, s) => (str s, st)
-                  | EFfiApp (_, s, []) => (str (s ^ "()"), st)
-                  | EFfiApp (_, s, [e]) =>
+                  | EFfi k =>
                     let
-                        val (e, st) = jsE inner (e, st)
-                        
+                        val name = case ffi k of
+                                       NONE => (EM.errorAt loc "Unsupported FFI identifier in JavaScript";
+                                                "ERROR")
+                                     | SOME s => s
                     in
-                        (strcat [str (s ^ "("),
-                                 e,
-                                 str ")"], st)
+                        (str name, st)
                     end
-                  | EFfiApp (_, s, e :: es) =>
+                  | EFfiApp (m, x, args) =>
                     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
+                        val name = case ffi (m, x) of
+                                       NONE => (EM.errorAt loc "Unsupported FFI function in JavaScript";
+                                                "ERROR")
+                                     | SOME s => s
                     in
-                        (strcat (str (s ^ "(")
-                                 :: e
-                                 :: es
-                                 @ [str ")"]), st)
+                        case args of
+                            [] => (str (name ^ "()"), st)
+                          | [e] =>
+                            let
+                                val (e, st) = jsE inner (e, st)
+                                              
+                            in
+                                (strcat [str (name ^ "("),
+                                         e,
+                                         str ")"], st)
+                            end
+                          | 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 (name ^ "(")
+                                         :: e
+                                         :: es
+                                         @ [str ")"]), st)
+                            end
                     end
 
                   | EApp (e1, e2) =>
@@ -317,11 +349,23 @@ fun jsExp mode outer =
                     let
                         val (e, st) = jsE inner (e, st)
                     in
-                        (strcat [str "sreturn(",
+                        (strcat [str "sr(",
                                  e,
                                  str ")"],
                          st)
                     end
+                  | ESignalBind (e1, e2) =>
+                    let
+                        val (e1, st) = jsE inner (e1, st)
+                        val (e2, st) = jsE inner (e2, st)
+                    in
+                        (strcat [str "sb(",
+                                 e1,
+                                 str ",",
+                                 e2,
+                                 str ")"],
+                         st)
+                    end
             end
     in
         jsE
diff --git a/src/mono.sml b/src/mono.sml
index 1a7fde00..54b77550 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -105,6 +105,7 @@ datatype exp' =
        | EJavaScript of javascript_mode * exp
 
        | ESignalReturn of exp
+       | ESignalBind of exp * exp
 
 withtype exp = exp' located
 
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 6c0e6e21..550a055c 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -360,6 +360,9 @@ fun exp e =
       | EWrite (EPrim (Prim.String ""), loc) =>
         ERecord []
 
+      | ESignalBind ((ESignalReturn e1, loc), e2) =>
+        optExp (EApp (e2, e1), loc)
+
       | _ => e
 
 and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
diff --git a/src/mono_print.sml b/src/mono_print.sml
index e44bb74c..608fe269 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -285,6 +285,12 @@ fun p_exp' par env (e, _) =
       | ESignalReturn e => box [string "Return(",
                                 p_exp env e,
                                 string ")"]
+      | ESignalBind (e1, e2) => box [string "Return(",
+                                     p_exp env e1,
+                                     string ",",
+                                     space,
+                                     p_exp env e2,
+                                     string ")"]
 
 and p_exp env = p_exp' false env
 
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index e1da02c9..841e034e 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -77,6 +77,7 @@ fun impure (e, _) =
       | EClosure (_, es) => List.exists impure es
       | EJavaScript (_, e) => impure e
       | ESignalReturn e => impure e
+      | ESignalBind (e1, e2) => impure e1 orelse impure e2
 
 
 val liftExpInExp = Monoize.liftExpInExp
@@ -333,6 +334,7 @@ fun reduce file =
               | EUnurlify (e, _) => summarize d e
               | EJavaScript (_, e) => summarize d e
               | ESignalReturn e => summarize d e
+              | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
 
 
         fun exp env e =
@@ -478,6 +480,9 @@ fun reduce file =
                       | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) =>
                         EPrim (Prim.String (s1 ^ s2))
 
+                      | ESignalBind ((ESignalReturn e1, loc), e2) =>
+                        #1 (reduceExp env (EApp (e2, e1), loc))
+
                       | _ => e
             in
                 (*Print.prefaces "exp'" [("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*)
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 9788a551..a85443d7 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -328,6 +328,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
                 S.map2 (mfe ctx e,
                      fn e' =>
                         (ESignalReturn e', loc))
+              | ESignalBind (e1, e2) =>
+                S.bind2 (mfe ctx e1,
+                      fn e1' =>
+                         S.map2 (mfe ctx e2,
+                              fn e2' =>
+                                 (ESignalBind (e1', e2'), loc)))
     in
         mfe
     end
diff --git a/src/monoize.sml b/src/monoize.sml
index 63d84d8c..30bd5daa 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -957,8 +957,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                 val mt1 = (L'.TFun (un, t1), loc)
                 val mt2 = (L'.TFun (un, t2), loc)
             in
-                ((L'.EAbs ("m1", mt1, (L'.TFun (mt1, (L'.TFun (mt2, (L'.TFun (un, un), loc)), loc)), loc),
-                           (L'.EAbs ("m2", mt2, (L'.TFun (un, un), loc),
+                ((L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc)), loc),
+                           (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc),
                                      (L'.EAbs ("_", un, un,
                                                (L'.ELet ("r", t1, (L'.EApp ((L'.ERel 2, loc),
                                                                             (L'.ERecord [], loc)), loc),
@@ -989,6 +989,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                            (L'.ESignalReturn (L'.ERel 0, loc), loc)), loc),
                  fm)
             end
+          | L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _),
+                    (L.EFfi ("Basis", "signal_monad"), _)) =>
+            let
+                val t1 = monoType env t1
+                val t2 = monoType env t2
+                val un = (L'.TRecord [], loc)
+                val mt1 = (L'.TSignal t1, loc)
+                val mt2 = (L'.TSignal t2, loc)
+            in
+                ((L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), mt2), loc),
+                           (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), mt2,
+                                     (L'.ESignalBind ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
+                 fm)
+            end
 
           | L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) =>
             let
diff --git a/tests/sbind.ur b/tests/sbind.ur
new file mode 100644
index 00000000..6e3ca782
--- /dev/null
+++ b/tests/sbind.ur
@@ -0,0 +1,5 @@
+fun main () : transaction page = return <xml><body>
+  <p>Before</p>
+  <p><dyn signal={s <- return "Bye"; return <xml>{[s]}</xml>}/></p>
+  <p>After</p>
+</body></xml>
diff --git a/tests/sbind.urp b/tests/sbind.urp
new file mode 100644
index 00000000..d8735c70
--- /dev/null
+++ b/tests/sbind.urp
@@ -0,0 +1,3 @@
+debug
+
+sbind