summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/js/urweb.js10
-rw-r--r--lib/ur/basis.urs12
-rw-r--r--src/monoize.sml31
-rw-r--r--tests/cselect.ur11
-rw-r--r--tests/cselect.urp3
-rw-r--r--tests/cselect.urs1
6 files changed, 61 insertions, 7 deletions
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index a29914b9..5482c2a5 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -281,7 +281,7 @@ function dyn(s) {
populate(x);
}
-function inp(t, s) {
+function inp(t, s, content) {
var x = document.createElement(t);
x.dead = false;
x.signal = ss(s);
@@ -289,7 +289,13 @@ function inp(t, s) {
x.recreate = function(v) { if (x.value != v) x.value = v; };
populate(x);
addNode(x);
- x.onkeyup = function() { sv(s, x.value) };
+ if (t == "select") {
+ x.onchange = function() { sv(s, x.value) };
+ x.innerHTML = content;
+ sv(s, x.value);
+ } else
+ x.onkeyup = function() { sv(s, x.value) };
+
return x;
}
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 9736ce1e..cc18d7b2 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -623,13 +623,17 @@ val submit : ctx ::: {Unit} -> use ::: {Type}
(*** AJAX-oriented widgets *)
-con cformTag = fn (attrs :: {Type}) =>
+con cformTag = fn (attrs :: {Type}) (inner :: {Unit}) =>
ctx ::: {Unit}
-> [[Body] ~ ctx] =>
- unit -> tag attrs ([Body] ++ ctx) [] [] []
+ unit -> tag attrs ([Body] ++ ctx) inner [] []
-val ctextbox : cformTag [Value = string, Size = int, Source = source string]
-val button : cformTag [Value = string, Onclick = transaction unit]
+val ctextbox : cformTag [Value = string, Size = int, Source = source string] []
+val button : cformTag [Value = string, Onclick = transaction unit] []
+
+con cselect = [Cselect]
+val cselect : cformTag [Source = source string] cselect
+val coption : unit -> tag [Value = string, Selected = bool] cselect [] [] []
(*** Tables *)
diff --git a/src/monoize.sml b/src/monoize.sml
index b71b13a5..86a27543 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2563,7 +2563,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| SOME (_, src, _) =>
(strcat [str "<span><script type=\"text/javascript\">inp(\"input\",",
(L'.EJavaScript (L'.Script, src, NONE), loc),
- str ")</script></span>"],
+ str ",\"\")</script></span>"],
fm))
| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
raise Fail "No name passed to textbox tag"))
@@ -2635,6 +2635,33 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
let
val sc = strcat [str "inp(\"input\",",
(L'.EJavaScript (L'.Script, src, NONE), loc),
+ str ",\"\")"]
+ val sc = setAttrs sc
+ in
+ (strcat [str "<span><script type=\"text/javascript\">",
+ sc,
+ str "</script></span>"],
+ fm)
+ end)
+
+ | "cselect" =>
+ (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
+ NONE =>
+ let
+ val (ts, fm) = tagStart "select"
+ in
+ ((L'.EStrcat (ts,
+ (L'.EPrim (Prim.String "/>"), loc)),
+ loc), fm)
+ end
+ | SOME (_, src, _) =>
+ let
+ val (xml, fm) = monoExp (env, st, fm) xml
+
+ val sc = strcat [str "inp(\"select\",",
+ (L'.EJavaScript (L'.Script, src, NONE), loc),
+ str ",",
+ (L'.EJavaScript (L'.Script, xml, NONE), loc),
str ")"]
val sc = setAttrs sc
in
@@ -2644,6 +2671,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fm)
end)
+ | "coption" => normal ("option", NONE, NONE)
+
| "tabl" => normal ("table", NONE, NONE)
| _ => normal (tag, NONE, NONE)
end
diff --git a/tests/cselect.ur b/tests/cselect.ur
new file mode 100644
index 00000000..ca05f504
--- /dev/null
+++ b/tests/cselect.ur
@@ -0,0 +1,11 @@
+fun main () =
+ s <- source "";
+ return <xml><body>
+ <cselect source={s}>
+ <coption>Wilbur</coption>
+ <coption>Walbur</coption>
+ </cselect>
+
+ Hello, I'm <dyn signal={s <- signal s; return <xml>{[s]}</xml>}/>.
+ I'll be your waiter for this evening.
+ </body></xml>
diff --git a/tests/cselect.urp b/tests/cselect.urp
new file mode 100644
index 00000000..30dfa2c0
--- /dev/null
+++ b/tests/cselect.urp
@@ -0,0 +1,3 @@
+debug
+
+cselect
diff --git a/tests/cselect.urs b/tests/cselect.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/cselect.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page