From 049d3500132b56ac2429a8a6ee0cc5ba1fbaae5a Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 16 Nov 2014 15:03:29 -0500 Subject: Textual HTML5 AJAX widgets --- lib/js/urweb.js | 34 ++++++++++++----- lib/ur/basis.urs | 15 ++++++-- src/monoize.sml | 101 ++++++++++++++++---------------------------------- tests/ctextbox.urp | 1 + tests/html5_cforms.ur | 29 +++++++++++++++ 5 files changed, 98 insertions(+), 82 deletions(-) create mode 100644 tests/html5_cforms.ur diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 5cc49fec..c62670e7 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -1038,28 +1038,44 @@ function input(x, s, recreate, type, name) { return x; } -function inp(s, name) { +function inpt(type, s, name) { if (suspendScripts) return; var x = input(document.createElement("input"), s, - function(x) { return function(v) { if (x.value != v) x.value = v; }; }, "text", name); + function(x) { return function(v) { if (x.value != v) x.value = v; }; }, type, name); x.value = s.data; x.onkeyup = x.oninput = x.onchange = x.onpropertychange = function() { sv(s, x.value) }; return x; } +function inp(s, name) { + return inpt("text", s, name); +} + function password(s, name) { - if (suspendScripts) - return; + return inpt("password", s, name); +} - var x = input(document.createElement("input"), s, - function(x) { return function(v) { if (x.value != v) x.value = v; }; }, "password", name); - x.value = s.data; - x.onkeyup = x.oninput = x.onchange = x.onpropertychange = function() { sv(s, x.value) }; +function email(s, name) { + return inpt("email", s, name); +} - return x; +function search(s, name) { + return inpt("search", s, name); +} + +function url(s, name) { + return inpt("url", s, name); +} + +function tel(s, name) { + return inpt("tel", s, name); +} + +function color(s, name) { + return inpt("color", s, name); } function selectValue(x) { diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 9fb04484..1ee5be50 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -1036,10 +1036,17 @@ con cformTag = fn (attrs :: {Type}) (inner :: {Unit}) => -> [[Body] ~ ctx] => [[Body] ~ inner] => unit -> tag attrs ([Body] ++ ctx) ([Body] ++ inner) [] [] -val ctextbox : cformTag ([Value = string, Size = int, Source = source string, Placeholder = string, Onchange = transaction unit, - Ontext = transaction unit] ++ boxAttrs ++ inputAttrs) [] -val cpassword : cformTag ([Value = string, Size = int, Source = source string, Placeholder = string, Onchange = transaction unit, - Ontext = transaction unit] ++ boxAttrs ++ inputAttrs) [] +type ctext = cformTag ([Value = string, Size = int, Source = source string, Placeholder = string, + Onchange = transaction unit, Ontext = transaction unit] ++ boxAttrs ++ inputAttrs) [] + +val ctextbox : ctext +val cpassword : ctext +val cemail : ctext +val csearch : ctext +val curl : ctext +val ctel : ctext +val ccolor : ctext + val button : cformTag ([Value = string] ++ boxAttrs) [] val ccheckbox : cformTag ([Value = bool, Size = int, Source = source bool, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) [] diff --git a/src/monoize.sml b/src/monoize.sml index 9ca21058..63ae0b31 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3283,7 +3283,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (style, fm) = monoExp (env, st, fm) style val (dynStyle, fm) = monoExp (env, st, fm) dynStyle - val dynamics = ["dyn", "ctextbox", "cpassword", "ccheckbox", "cselect", "coption", "ctextarea", "active", "script"] + val dynamics = ["dyn", "ctextbox", "cpassword", "ccheckbox", "cselect", "coption", "ctextarea", "active", "script", "cemail", "csearch", "curl", "ctel", "ccolor"] fun isSome (e, _) = case e of @@ -3583,6 +3583,29 @@ fun monoExp (env, st, fm) (all as (e, loc)) = else "span" + fun cinput (fallback, dynamic) = + case List.find (fn ("Source", _, _) => true | _ => false) attrs of + NONE => + let + val (ts, fm) = tagStart "input" + in + ((L'.EStrcat (ts, + strH (" type=\"" ^ fallback ^ "\" />")), + loc), fm) + end + | SOME (_, src, _) => + let + val sc = strcat [str (dynamic ^ "(exec("), + (L'.EJavaScript (L'.Script, src), loc), + str "))"] + val sc = setAttrs sc + in + (strcat [str ""], + fm) + end + val baseAll as (base, fm) = case tag of "body" => let @@ -3726,75 +3749,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); raise Fail "No name passed to lselect tag")) - | "ctextbox" => - (case List.find (fn ("Source", _, _) => true | _ => false) attrs of - NONE => - let - val (ts, fm) = tagStart "input" - in - ((L'.EStrcat (ts, - strH " type=\"text\" />"), - loc), fm) - end - | SOME (_, src, _) => - let - val sc = strcat [str "inp(exec(", - (L'.EJavaScript (L'.Script, src), loc), - str "))"] - val sc = setAttrs sc - in - (strcat [str ""], - fm) - end) - - | "cpassword" => - (case List.find (fn ("Source", _, _) => true | _ => false) attrs of - NONE => - let - val (ts, fm) = tagStart "input" - in - ((L'.EStrcat (ts, - strH " type=\"password\" />"), - loc), fm) - end - | SOME (_, src, _) => - let - val sc = strcat [str "password(exec(", - (L'.EJavaScript (L'.Script, src), loc), - str "))"] - val sc = setAttrs sc - in - (strcat [str ""], - fm) - end) - - | "ccheckbox" => - (case List.find (fn ("Source", _, _) => true | _ => false) attrs of - NONE => - let - val (ts, fm) = tagStart "input type=\"checkbox\"" - in - ((L'.EStrcat (ts, - strH " />"), - loc), fm) - end - | SOME (_, src, _) => - let - val sc = strcat [str "chk(exec(", - (L'.EJavaScript (L'.Script, src), loc), - str "))"] - val sc = setAttrs sc - in - (strcat [str ""], - fm) - end) + | "ctextbox" => cinput ("text", "inp") + | "cpassword" => cinput ("password", "password") + | "cemail" => cinput ("email", "email") + | "csearch" => cinput ("search", "search") + | "curl" => cinput ("url", "url") + | "ctel" => cinput ("tel", "tel") + | "ccolor" => cinput ("color", "color") + | "ccheckbox" => cinput ("checkbox", "chk") | "cselect" => (case List.find (fn ("Source", _, _) => true | _ => false) attrs of NONE => diff --git a/tests/ctextbox.urp b/tests/ctextbox.urp index d5cb5e9f..5c6c5df8 100644 --- a/tests/ctextbox.urp +++ b/tests/ctextbox.urp @@ -1,4 +1,5 @@ debug allow url http://localhost/* +rewrite url Ctextbox/* ctextbox diff --git a/tests/html5_cforms.ur b/tests/html5_cforms.ur new file mode 100644 index 00000000..a62dbf23 --- /dev/null +++ b/tests/html5_cforms.ur @@ -0,0 +1,29 @@ +fun dn [a] (_ : show a) (x : source a) : xbody = + + + +fun main () : transaction page = + a <- source ""; + b <- source True; + c <- source "a@b"; + d <- source ""; + e <- source ""; + f <- source ""; + + return + + + + + + + +
+ + {dn a}; + {dn b}; + {dn c}; + {dn d}; + {dn e}; + {dn f} +
-- cgit v1.2.3