New client-side, document-level event handlers

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>