diff options
| -rw-r--r-- | doc/manual.tex | 12 | ||||
| -rw-r--r-- | lib/js/urweb.js | 63 | ||||
| -rw-r--r-- | lib/ur/basis.urs | 9 | ||||
| -rw-r--r-- | src/settings.sml | 29 | ||||
| -rw-r--r-- | tests/docevents.ur | 6 |
5 files changed, 107 insertions, 12 deletions
diff --git a/doc/manual.tex b/doc/manual.tex index b223e02a..a3800e17 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -1971,6 +1971,18 @@ $$\begin{array}{l} \mt{val} \; \mt{onServerError} : (\mt{string} \to \mt{transaction} \; \mt{unit}) \to \mt{transaction} \; \mt{unit} \end{array}$$ +There are also functions to register standard document-level event handlers. + +$$\begin{array}{l} + \mt{val} \; \mt{onClick} : \mt{transaction} \; \mt{unit} \to \mt{transaction} \; \mt{unit} \\ + \mt{val} \; \mt{onDblclick} : \mt{transaction} \; \mt{unit} \to \mt{transaction} \; \mt{unit} \\ + \mt{val} \; \mt{onKeydown} : (\mt{int} \to \mt{transaction} \; \mt{unit}) \to \mt{transaction} \; \mt{unit} \\ + \mt{val} \; \mt{onKeypress} : (\mt{int} \to \mt{transaction} \; \mt{unit}) \to \mt{transaction} \; \mt{unit} \\ + \mt{val} \; \mt{onKeyup} : (\mt{int} \to \mt{transaction} \; \mt{unit}) \to \mt{transaction} \; \mt{unit} \\ + \mt{val} \; \mt{onMousedown} : \mt{transaction} \; \mt{unit} \to \mt{transaction} \; \mt{unit} \\ + \mt{val} \; \mt{onMouseup} : \mt{transaction} \; \mt{unit} \to \mt{transaction} \; \mt{unit} +\end{array}$$ + \subsubsection{Functional-Reactive Page Generation} Most approaches to ``AJAX''-style coding involve imperative manipulation of the DOM tree representing an HTML document's structure. Ur/Web follows the \emph{functional-reactive} approach instead. Programs may allocate mutable \emph{sources} of arbitrary types, and an HTML page is effectively a pure function over the latest values of the sources. The page is not mutated directly, but rather it changes automatically as the sources are mutated. diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 4d9a1419..1277175d 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -202,6 +202,60 @@ function servErr(s) { window.setTimeout(function () { runHandlers("Server", serverHandlers, s); }, 0); } +// Key events + +var uw_event = null; + +function kc() { + return window.event ? event.keyCode : (uw_event ? uw_event.which : 0); +} + +// Document events + +function uw_handler(name, f) { + var old = document[name]; + if (old == undefined) + document[name] = function() { execF(f); return false; }; + else + document[name] = function() { old(); execF(f); return false; }; +} + +function uw_onClick(f) { + uw_handler("onclick", f); +} + +function uw_onDblclick(f) { + uw_handler("ondblclick", f); +} + +function uw_onMousedown(f) { + uw_handler("onmousedown", f); +} + +function uw_onMouseup(f) { + uw_handler("onmouseup", f); +} + +function uw_keyHandler(name, f) { + var old = document[name]; + if (old == undefined) + document[name] = function(event) { uw_event = event; execF(execF(f, kc())); return false; }; + else + document[name] = function(event) { uw_event = event; old(); execF(execF(f, kc())); return false; }; +} + +function uw_onKeydown(f) { + uw_keyHandler("onkeydown", f); +} + +function uw_onKeypress(f) { + uw_keyHandler("onkeypress", f); +} + +function uw_onKeyup(f) { + uw_keyHandler("onkeyup", f); +} + // Embedding closures in XML strings @@ -1025,15 +1079,6 @@ function sp(e) { } -// Key events - -var uw_event = null; - -function kc() { - return window.event ? event.keyCode : (uw_event ? uw_event.keyCode : 0); -} - - // The Ur interpreter var urfuncs = []; diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 494eaa4b..5ca27885 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -858,6 +858,15 @@ val onConnectFail : transaction unit -> transaction unit val onDisconnect : transaction unit -> transaction unit val onServerError : (string -> transaction unit) -> transaction unit +(* More standard document-level JavaScript handlers *) +val onClick : transaction unit -> transaction unit +val onDblclick : transaction unit -> transaction unit +val onKeydown : (int -> transaction unit) -> transaction unit +val onKeypress : (int -> transaction unit) -> transaction unit +val onKeyup : (int -> transaction unit) -> transaction unit +val onMousedown : transaction unit -> transaction unit +val onMouseup : transaction unit -> transaction unit + val show_xml : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> show (xml ctx use bind) diff --git a/src/settings.sml b/src/settings.sml index 7b19b1b1..8b376a00 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -147,7 +147,15 @@ val benignBase = basis ["get_cookie", "rand", "now", "getHeader", - "setHeader"] + "setHeader", + "spawn", + "onClick", + "onDblclick", + "onKeydown", + "onKeypress", + "onKeyup", + "onMousedown", + "onMouseup"] val benign = ref benignBase fun setBenignEffectful ls = benign := S.addList (benignBase, ls) @@ -166,7 +174,14 @@ val clientBase = basis ["get", "onConnectFail", "onDisconnect", "onServerError", - "kc"] + "kc", + "onClick", + "onDblclick", + "onKeydown", + "onKeypress", + "onKeyup", + "onMousedown", + "onMouseup"] val client = ref clientBase fun setClientOnly ls = client := S.addList (clientBase, ls) fun isClientOnly x = S.member (!client, x) @@ -255,7 +270,15 @@ val jsFuncsBase = basisM [("alert", "alert"), ("htmlifyTime", "showTime"), ("toSeconds", "toSeconds"), ("addSeconds", "addSeconds"), - ("diffInSeconds", "diffInSeconds")] + ("diffInSeconds", "diffInSeconds"), + + ("onClick", "uw_onClick"), + ("onDblclick", "uw_onDblclick"), + ("onKeydown", "uw_onKeydown"), + ("onKeypress", "uw_onKeypress"), + ("onKeyup", "uw_onKeyup"), + ("onMousedown", "uw_onMousedown"), + ("onMouseup", "uw_onMouseup")] val jsFuncs = ref jsFuncsBase fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls fun jsFunc x = M.find (!jsFuncs, x) diff --git a/tests/docevents.ur b/tests/docevents.ur new file mode 100644 index 00000000..eed38868 --- /dev/null +++ b/tests/docevents.ur @@ -0,0 +1,6 @@ +fun main () : transaction page = return <xml> + <body onload={onDblclick (alert "Double click"); + onKeypress (fn k => alert ("Keypress: " ^ show k))}> + Nothing here. + </body> +</xml> |