Initial <dyn> support

10 files changed, 133 insertions, 28 deletions

diff --git a/lib/basis.urs b/lib/basis.urs
index ac4c4832..a61bf3ce 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -376,6 +376,9 @@ con form = [Body, Form]
 con tabl = [Body, Table]
 con tr = [Body, Tr]
 
+val dyn : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> unit
+          -> tag [Signal = signal (xml ctx use bind)] ctx [] use bind
+
 val head : unit -> tag [] html head [] []
 val title : unit -> tag [] head [] [] []
 
@@ -433,7 +436,7 @@ con select = [Select]
 val select : formTag string select []
 val option : unit -> tag [Value = string, Selected = bool] select [] [] []
 
-val submit : ctx ::: {Unit} ->  use ::: {Type}
+val submit : ctx ::: {Unit} -> use ::: {Type}
              -> fn [[Form] ~ ctx] =>
                    unit
                    -> tag [Value = string, Action = $use -> transaction page]
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 1152b0ef..f3c5e5a7 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -120,6 +120,7 @@ fun cifyTyp x =
                 in
                     ((L'.TOption t, loc), sm)
                 end
+              | L.TSignal _ => raise Fail "Cjrize: TSignal remains"
     in
         cify IM.empty x
     end
@@ -420,7 +421,8 @@ fun cifyExp (eAll as (e, loc), sm) =
             ((L'.EUnurlify (e, t), loc), sm)
         end
 
-      | L.EJavaScript _ => raise Fail "EJavaScript remains"
+      | L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains"
+      | L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains"
 
 fun cifyDecl ((d, loc), sm) =
     case d of
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 0dd7882a..b0842c6b 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -69,8 +69,15 @@ fun varDepth (e, _) =
       | ENextval _ => 0
       | EUnurlify _ => 0
       | EJavaScript _ => 0
+      | ESignalReturn e => varDepth e
 
-fun jsExp inAttr outer =
+fun strcat loc es =
+    case es of
+        [] => (EPrim (Prim.String ""), loc)
+      | [x] => x
+      | x :: es' => (EStrcat (x, strcat loc es'), loc)
+
+fun jsExp mode outer =
     let
         val len = length outer
 
@@ -85,11 +92,7 @@ fun jsExp inAttr outer =
                         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
@@ -99,17 +102,19 @@ fun jsExp inAttr outer =
                 fun unsupported s =
                   (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
                    (str "ERROR", st))
+
+                val strcat = strcat loc
             in
                 case #1 e of
                     EPrim (Prim.String s) =>
                     (str ("\""
                           ^ String.translate (fn #"'" =>
-                                                 if inAttr then
+                                                 if mode = Attribute then
                                                      "\\047"
                                                  else
                                                      "'"
                                                | #"<" =>
-                                                 if inAttr then
+                                                 if mode = Script then
                                                      "<"
                                                  else
                                                      "\\074"
@@ -274,7 +279,14 @@ fun jsExp inAttr outer =
                          st)
                     end
 
-                  | EWrite _ => unsupported "EWrite"
+                  | EWrite e =>
+                    let
+                        val (e, st) = jsE inner (e, st)
+                    in
+                        (strcat [str "document.write(",
+                                 e,
+                                 str ")"], st)
+                    end
 
                   | ESeq (e1, e2) =>
                     let
@@ -301,6 +313,15 @@ fun jsExp inAttr outer =
                   | ENextval _ => unsupported "Nextval"
                   | EUnurlify _ => unsupported "EUnurlify"
                   | EJavaScript _ => unsupported "Nested JavaScript"
+                  | ESignalReturn e =>
+                    let
+                        val (e, st) = jsE inner (e, st)
+                    in
+                        (strcat [(*str "sreturn(",*)
+                                 e(*,
+                                 str ")"*)],
+                         st)
+                    end
             end
     in
         jsE
@@ -309,14 +330,25 @@ fun jsExp inAttr outer =
 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),
+                              let
+                                  fun doCode m env e =
+                                      let
+                                          val len = length env
+                                          fun str s = (EPrim (Prim.String s), #2 e)
+
+                                          val locals = List.tabulate
+                                                           (varDepth e,
+                                                         fn i => str ("var uwr" ^ Int.toString (len + i) ^ ";"))
+                                          val (e, st) = jsExp m env 0 (e, st)
+                                      in
+                                          (#1 (strcat (#2 e) (locals @ [e])), st)
+                                      end
+                              in
+                                  case e of
+                                      EJavaScript (m, (EAbs (_, t, _, e), _)) => doCode m (t :: env) e
+                                    | EJavaScript (m, e) => doCode m env e
+                                    | _ => (e, st)
+                              end,
                      decl = fn (_, e, st) => (e, st),
                      bind = fn (env, U.Decl.RelE (_, t)) => t :: env
                              | (env, _) => env}
diff --git a/src/mono.sml b/src/mono.sml
index 187b1853..c6e0ae8a 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -37,6 +37,7 @@ datatype typ' =
        | TDatatype of int * (datatype_kind * (string * int * typ option) list) ref
        | TFfi of string * string
        | TOption of typ
+       | TSignal of typ
 
 withtype typ = typ' located
 
@@ -55,6 +56,11 @@ datatype pat' =
 
 withtype pat = pat' located
 
+datatype javascript_mode =
+         Attribute
+       | Script
+       | File
+
 datatype exp' =
          EPrim of Prim.t
        | ERel of int
@@ -96,8 +102,9 @@ datatype exp' =
 
        | EUnurlify of exp * typ
 
-       | EJavaScript of exp
+       | EJavaScript of javascript_mode * exp
 
+       | ESignalReturn of exp
 
 withtype exp = exp' located
 
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 7b675438..89b6c35b 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -65,6 +65,9 @@ fun p_typ' par env (t, _) =
       | TOption t => box [string "option(",
                           p_typ env t,
                           string ")"]
+      | TSignal t => box [string "signal(",
+                          p_typ env t,
+                          string ")"]
 
 and p_typ env = p_typ' false env
 
@@ -275,9 +278,13 @@ fun p_exp' par env (e, _) =
       | EUnurlify (e, _) => box [string "unurlify(",
                                  p_exp env e,
                                  string ")"]
-      | EJavaScript e => box [string "JavaScript(",
-                              p_exp env e,
-                              string ")"]
+      | EJavaScript (_, e) => box [string "JavaScript(",
+                                   p_exp env e,
+                                   string ")"]
+
+      | ESignalReturn e => box [string "Return(",
+                                p_exp env e,
+                                string ")"]
 
 and p_exp env = p_exp' false env
 
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 040414f3..e1da02c9 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -75,7 +75,8 @@ fun impure (e, _) =
       | ELet (_, _, e1, e2) => impure e1 orelse impure e2
 
       | EClosure (_, es) => List.exists impure es
-      | EJavaScript e => impure e
+      | EJavaScript (_, e) => impure e
+      | ESignalReturn e => impure e
 
 
 val liftExpInExp = Monoize.liftExpInExp
@@ -330,7 +331,8 @@ fun reduce file =
               | EDml e => summarize d e @ [WriteDb]
               | ENextval e => summarize d e @ [WriteDb]
               | EUnurlify (e, _) => summarize d e
-              | EJavaScript e => summarize d e
+              | EJavaScript (_, e) => summarize d e
+              | ESignalReturn e => summarize d e
 
 
         fun exp env e =
@@ -421,6 +423,7 @@ fun reduce file =
                             fun trySub () =
                                 case t of
                                     (TFfi ("Basis", "string"), _) => doSub ()
+                                  | (TSignal _, _) => e
                                   | _ =>
                                     case e' of
                                         (ECase _, _) => e
diff --git a/src/mono_util.sml b/src/mono_util.sml
index ebc30984..553f802e 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -51,6 +51,7 @@ fun compare ((t1, _), (t2, _)) =
       | (TDatatype (n1, _), TDatatype (n2, _)) => Int.compare (n1, n2)
       | (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2))
       | (TOption t1, TOption t2) => compare (t1, t2)
+      | (TSignal t1, TSignal t2) => compare (t1, t2)
 
       | (TFun _, _) => LESS
       | (_, TFun _) => GREATER
@@ -64,6 +65,9 @@ fun compare ((t1, _), (t2, _)) =
       | (TFfi _, _) => LESS
       | (_, TFfi _) => GREATER
 
+      | (TOption _, _) => LESS
+      | (_, TOption _) => GREATER
+
 and compareFields ((x1, t1), (x2, t2)) =
     join (String.compare (x1, x2),
           fn () => compare (t1, t2))
@@ -96,6 +100,10 @@ fun mapfold fc =
                 S.map2 (mft t,
                         fn t' =>
                            (TOption t, loc))
+              | TSignal t =>
+                S.map2 (mft t,
+                        fn t' =>
+                           (TSignal t, loc))
     in
         mft
     end
@@ -311,10 +319,14 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
                         S.map2 (mft t,
                                 fn t' =>
                                    (EUnurlify (e', t'), loc)))
-              | EJavaScript e =>
+              | EJavaScript (m, e) =>
+                S.map2 (mfe ctx e,
+                     fn e' =>
+                        (EJavaScript (m, e'), loc))
+              | ESignalReturn e =>
                 S.map2 (mfe ctx e,
                      fn e' =>
-                        (EJavaScript e', loc))
+                        (ESignalReturn e', loc))
     in
         mfe
     end
diff --git a/src/monoize.sml b/src/monoize.sml
index e92a1c8a..1b7b467d 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -135,6 +135,8 @@ fun monoType env =
                     (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc)
                   | L.CApp ((L.CFfi ("Basis", "source"), _), t) =>
                     (L'.TFfi ("Basis", "int"), loc)
+                  | L.CApp ((L.CFfi ("Basis", "signal"), _), t) =>
+                    (L'.TSignal (mt env dtmap t), loc)
                   | L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) =>
                     (L'.TFfi ("Basis", "string"), loc)
                   | L.CApp ((L.CFfi ("Basis", "sql_table"), _), _) =>
@@ -978,6 +980,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                  fm)
             end
 
+          | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), _), _), t), _),
+                    (L.EFfi ("Basis", "signal_monad"), _)) =>
+            let
+                val t = monoType env t
+            in
+                ((L'.EAbs ("x", t, (L'.TSignal t, loc),
+                           (L'.ESignalReturn (L'.ERel 0, loc), loc)), loc),
+                 fm)
+            end
+
           | L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) =>
             let
                 val s = (L'.TFfi ("Basis", "string"), loc)
@@ -1752,7 +1764,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                             (L'.EStrcat (
                                                              (L'.EPrim (Prim.String s'), loc),
                                                              (L'.EStrcat (
-                                                              (L'.EJavaScript e, loc),
+                                                              (L'.EJavaScript (L'.Attribute, e), loc),
                                                               (L'.EPrim (Prim.String "'"), loc)), loc)),
                                                              loc)), loc),
                                                fm)
@@ -1833,6 +1845,25 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                 case tag of
                     "body" => normal ("body", NONE,
                                       SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc))
+
+                  | "dyn" =>
+                    (case #1 attrs of
+                         (*L'.ERecord [("Signal", (L'.ESignalReturn e, _), _)] => (e, fm)
+                       | L'.ERecord [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _),
+                                                          e), _), _)] => (e, fm) *)
+
+                         L'.ERecord [("Signal", e, _)] =>
+                         ((L'.EStrcat
+                               ((L'.EPrim (Prim.String "<script type=\"text/javascript\">"), loc),
+                                (L'.EStrcat ((L'.EJavaScript (L'.Script,
+                                                              (L'.ELet ("signal", (L'.TSignal
+                                                                                       (L'.TFfi ("Basis", "string"), loc),
+                                                                                   loc),
+                                                                        e,
+                                                                        (L'.EWrite (L'.ERel 0, loc), loc)), loc)), loc),
+                                             (L'.EPrim (Prim.String "</script>"), loc)), loc)), loc),
+                          fm)
+                       | _ => raise Fail "Monoize: Bad dyn attributes")
                     
                   | "submit" => normal ("input type=\"submit\"", NONE, NONE)
 
diff --git a/tests/sreturn.ur b/tests/sreturn.ur
new file mode 100644
index 00000000..62db377d
--- /dev/null
+++ b/tests/sreturn.ur
@@ -0,0 +1,5 @@
+fun main () : transaction page = return <xml><body>
+  <p>Before</p>
+  <p><dyn signal={return <xml>Hi!</xml>}/></p>
+  <p>After</p>
+</body></xml>
diff --git a/tests/sreturn.urp b/tests/sreturn.urp
new file mode 100644
index 00000000..5591aa5e
--- /dev/null
+++ b/tests/sreturn.urp
@@ -0,0 +1,3 @@
+debug
+
+sreturn