New event records for key and mouse handlers

8 files changed, 111 insertions, 32 deletions

diff --git a/doc/manual.tex b/doc/manual.tex
index 589177dd..ceb012bc 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -2068,13 +2068,13 @@ $$\begin{array}{l}
 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}
+ \mt{val} \; \mt{onClick} : (\mt{mouseEvent} \to \mt{transaction} \; \mt{unit}) \to \mt{transaction} \; \mt{unit} \\
+ \mt{val} \; \mt{onDblclick} : (\mt{mouseEvent} \to \mt{transaction} \; \mt{unit}) \to \mt{transaction} \; \mt{unit} \\
+ \mt{val} \; \mt{onKeydown} : (\mt{keyEvent} \to \mt{transaction} \; \mt{unit}) \to \mt{transaction} \; \mt{unit} \\
+ \mt{val} \; \mt{onKeypress} : (\mt{keyEvent} \to \mt{transaction} \; \mt{unit}) \to \mt{transaction} \; \mt{unit} \\
+ \mt{val} \; \mt{onKeyup} : (\mt{keyEvent} \to \mt{transaction} \; \mt{unit}) \to \mt{transaction} \; \mt{unit} \\
+ \mt{val} \; \mt{onMousedown} : (\mt{mouseEvent} \to \mt{transaction} \; \mt{unit}) \to \mt{transaction} \; \mt{unit} \\
+ \mt{val} \; \mt{onMouseup} : (\mt{mouseEvent} \to \mt{transaction} \; \mt{unit}) \to \mt{transaction} \; \mt{unit}
 \end{array}$$
 
 Versions of standard JavaScript functions are provided that event handlers may call to mask default handling or prevent bubbling of events up to parent DOM nodes, respectively.
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 509ff007..5846863a 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -441,22 +441,55 @@ function servErr(s) {
     window.setTimeout(function () { runHandlers("Server", serverHandlers, s); }, 0);
 }
 
-// Key events
+// Key and mouse events
 
 var uw_event = null;
 
-function kc() {
-    return window.event ? event.keyCode : (uw_event ? uw_event.which : 0);
+function uw_getEvent() {
+    return window.event ? window.event : uw_event;
 }
 
+function firstGood(x, y) {
+    if (x == undefined || x == 0)
+        return y;
+    else
+        return x;
+}
+
+function uw_mouseEvent() {
+    var ev = uw_getEvent();
+
+    return {_ScreenX : firstGood(ev.screenX, 0),
+            _ScreenY : firstGood(ev.screenY, 0),
+            _ClientX : firstGood(ev.clientX, 0),
+            _ClientY : firstGood(ev.clientY, 0),
+            _CtrlKey : firstGood(ev.ctrlKey, false),
+            _ShiftKey : firstGood(ev.shiftKey, false),
+            _AltKey : firstGood(ev.altKey, false),
+            _MetaKey : firstGood(ev.metaKey, false),
+            _Button : ev.button == 2 ? "Right" : ev.button == 1 ? "Middle" : "Left"};
+}
+
+function uw_keyEvent() {
+    var ev = uw_getEvent();
+
+    return {_KeyCode : firstGood(ev.keyCode, ev.which),
+            _CtrlKey : firstGood(ev.ctrlKey, false),
+            _ShiftKey : firstGood(ev.shiftKey, false),
+            _AltKey : firstGood(ev.altKey, false),
+            _MetaKey : firstGood(ev.metaKey, false)};
+}
+
+
+
 // Document events
 
 function uw_handler(name, f) {
     var old = document[name];
     if (old == undefined)
-        document[name] = function(event) { uw_event = event; execF(f); };
+        document[name] = function(event) { uw_event = event; execF(execF(f, uw_mouseEvent())); };
     else
-        document[name] = function(event) { uw_event = event; old(); execF(f); };
+        document[name] = function(event) { uw_event = event; old(); execF(execF(f, uw_mouseEvent())); };
 }
 
 function uw_onClick(f) {
@@ -478,9 +511,9 @@ function uw_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())); };
+        document[name] = function(event) { uw_event = event; execF(execF(f, uw_keyEvent())); };
     else
-        document[name] = function(event) { uw_event = event; old(); execF(execF(f, kc())); };
+        document[name] = function(event) { uw_event = event; old(); execF(execF(f, uw_keyEvent())); };
 }
 
 function uw_onKeydown(f) {
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index bea6e105..cd38c783 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -784,12 +784,22 @@ con bodyTagStandalone = fn (attrs :: {Type}) =>
 val br : bodyTagStandalone [Id = id]
 
 con focusEvents = [Onblur = transaction unit, Onfocus = transaction unit]
-con mouseEvents = [Onclick = transaction unit, Ondblclick = transaction unit,
-                   Onmousedown = transaction unit, Onmousemove = transaction unit,
-                   Onmouseout = transaction unit, Onmouseover = transaction unit,
-                   Onmouseup = transaction unit]
-con keyEvents = [Onkeydown = int -> transaction unit, Onkeypress = int -> transaction unit,
-                 Onkeyup = int -> transaction unit]
+
+datatype mouseButton = Left | Right | Middle
+
+type mouseEvent = { ScreenX : int, ScreenY : int, ClientX : int, ClientY : int,
+                    CtrlKey : bool, ShiftKey : bool, AltKey : bool, MetaKey : bool,
+                    Button : mouseButton }
+
+con mouseEvents = map (fn _ :: Unit => mouseEvent -> transaction unit)
+                          [Onclick, Ondblclick, Onmousedown, Onmousemove, Onmouseout, Onmouseover, Onmouseup]
+
+type keyEvent = { KeyCode : int,
+                  CtrlKey : bool, ShiftKey : bool, AltKey : bool, MetaKey : bool }
+
+con keyEvents = map (fn _ :: Unit => keyEvent -> transaction unit)
+                        [Onkeydown, Onkeypress, Onkeyup]
+
 (* Key arguments are character codes. *)
 con resizeEvents = [Onresize = transaction unit]
 con scrollEvents = [Onscroll = transaction unit]
@@ -955,13 +965,13 @@ 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 onClick : (mouseEvent -> transaction unit) -> transaction unit
+val onDblclick : (mouseEvent -> transaction unit) -> transaction unit
+val onKeydown : (keyEvent -> transaction unit) -> transaction unit
+val onKeypress : (keyEvent -> transaction unit) -> transaction unit
+val onKeyup : (keyEvent -> transaction unit) -> transaction unit
+val onMousedown : (mouseEvent -> transaction unit) -> transaction unit
+val onMouseup : (mouseEvent -> transaction unit) -> transaction unit
 
 (* Prevents default handling of current event *)
 val preventDefault : transaction unit
diff --git a/src/monoize.sml b/src/monoize.sml
index 4985c932..86d8389f 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3311,8 +3311,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                         val e =
                                                             case #1 dom of
                                                                 L'.TRecord [] => (L'.EApp (e, (L'.ERecord [], loc)), loc)
-                                                              | _ => (L'.EApp ((L'.EApp (e, (L'.EFfiApp ("Basis", "kc", []), loc)),
-                                                                                 loc), (L'.ERecord [], loc)), loc)
+                                                              | _ =>
+                                                                if String.isPrefix "Onkey" x then
+                                                                    (L'.EApp ((L'.EApp (e, (L'.EFfiApp ("Basis", "keyEvent", []), loc)),
+                                                                               loc), (L'.ERecord [], loc)), loc)
+                                                                else
+                                                                    (L'.EApp ((L'.EApp (e, (L'.EFfiApp ("Basis", "mouseEvent", []), loc)),
+                                                                               loc), (L'.ERecord [], loc)), loc)
+
                                                         val s' = " " ^ lowercaseFirst x ^ "='uw_event=event;exec("
                                                     in
                                                         ((L'.EStrcat (s,
diff --git a/src/settings.sml b/src/settings.sml
index 28739d6a..66bc7238 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -160,7 +160,8 @@ val benignBase = basis ["get_cookie",
                         "onConnectFail",
                         "onDisconnect",
                         "onServerError",
-                        "kc",
+                        "mouseEvent",
+                        "keyEvent",
                         "debug",
                         "rand",
                         "now",
@@ -194,7 +195,8 @@ val clientBase = basis ["get_client_source",
                         "onConnectFail",
                         "onDisconnect",
                         "onServerError",
-                        "kc",
+                        "mouseEvent",
+                        "keyEvent",
                         "onClick",
                         "onDblclick",
                         "onKeydown",
@@ -267,7 +269,8 @@ val jsFuncsBase = basisM [("alert", "alert"),
                           ("substring", "ssub"),
                           ("strcspn", "sspn"),
                           ("strlenGe", "strlenGe"),
-                          ("kc", "kc"),
+                          ("mouseEvent", "uw_mouseEvent"),
+                          ("keyEvent", "uw_keyEvent"),
                           ("minTime", "0"),
 
                           ("islower", "isLower"),
diff --git a/tests/globalHandlers.ur b/tests/globalHandlers.ur
new file mode 100644
index 00000000..2b4fba7b
--- /dev/null
+++ b/tests/globalHandlers.ur
@@ -0,0 +1,4 @@
+fun main () : transaction page = return <xml>
+  <body onload={onDblclick (fn ev => alert ("ScreenX = " ^ show ev.ScreenX ^ "\nShiftKey = " ^ show ev.ShiftKey));
+                onKeypress (fn ev => alert ("KeyCode = " ^ show ev.KeyCode ^ "\nShiftKey = " ^ show ev.ShiftKey))}/>
+</xml>
diff --git a/tests/keyEvent.ur b/tests/keyEvent.ur
new file mode 100644
index 00000000..875e2b68
--- /dev/null
+++ b/tests/keyEvent.ur
@@ -0,0 +1,7 @@
+fun main () : transaction page = return <xml><body>
+  <ctextbox onkeypress={fn ev => alert ("KeyCode = " ^ show ev.KeyCode
+                                        ^ "\nCtrlKey = " ^ show ev.CtrlKey
+                                        ^ "\nShiftKey = " ^ show ev.ShiftKey
+                                        ^ "\nAltKey = " ^ show ev.AltKey
+                                        ^ "\nMetaKey = " ^ show ev.MetaKey)}/>
+</body></xml>
diff --git a/tests/mouseEvent.ur b/tests/mouseEvent.ur
new file mode 100644
index 00000000..2192e0b0
--- /dev/null
+++ b/tests/mouseEvent.ur
@@ -0,0 +1,16 @@
+val show_mouseButton = mkShow (fn b => case b of
+                                           Left => "Left"
+                                         | Middle => "Middle"
+                                         | Right => "Right")
+
+fun main () : transaction page = return <xml><body>
+  <button onclick={fn ev => alert ("ScreenX = " ^ show ev.ScreenX
+                                   ^ "\nScreenY = " ^ show ev.ScreenY
+                                   ^ "\nClientX = " ^ show ev.ClientX
+                                   ^ "\nClientY = " ^ show ev.ClientY
+                                   ^ "\nCtrlKey = " ^ show ev.CtrlKey
+                                   ^ "\nShiftKey = " ^ show ev.ShiftKey
+                                   ^ "\nAltKey = " ^ show ev.AltKey
+                                   ^ "\nMetaKey = " ^ show ev.MetaKey
+                                   ^ "\nButton = " ^ show ev.Button)}/>
+</body></xml>