summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-12-21 12:30:57 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-12-21 12:30:57 -0500
commitd5c3faacb1c3114fe6802973a62528cda8be8ac7 (patch)
tree8193826346d3d4131730c22f1c5fb17eee1e0576
parent0a3abbb2250da6464e91566a1f275829158d3058 (diff)
Handling singnal bind
-rw-r--r--jslib/urweb.js3
-rw-r--r--src/cjrize.sml1
-rw-r--r--src/compiler.sig3
-rw-r--r--src/compiler.sml8
-rw-r--r--src/jscomp.sml90
-rw-r--r--src/mono.sml1
-rw-r--r--src/mono_opt.sml3
-rw-r--r--src/mono_print.sml6
-rw-r--r--src/mono_reduce.sml5
-rw-r--r--src/mono_util.sml6
-rw-r--r--src/monoize.sml18
-rw-r--r--tests/sbind.ur5
-rw-r--r--tests/sbind.urp3
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