diff options
| -rw-r--r-- | lib/js/urweb.js | 10 | ||||
| -rw-r--r-- | lib/ur/basis.urs | 12 | ||||
| -rw-r--r-- | src/monoize.sml | 31 | ||||
| -rw-r--r-- | tests/cselect.ur | 11 | ||||
| -rw-r--r-- | tests/cselect.urp | 3 | ||||
| -rw-r--r-- | tests/cselect.urs | 1 |
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 |