Key events get key code input

6 files changed, 24 insertions, 9 deletions

diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 29728a7a..3d4dbea2 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -648,5 +648,12 @@ function rv(chn, parse, k) {
 }
 
 
+// Key events
+
+function kc(e) {
+  return window.event ? e.keyCode : e.which;
+}
+
+
 // App-specific code
 
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 5f13f5c9..7f06a47a 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -555,8 +555,9 @@ 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 = transaction unit, Onkeypress = transaction unit,
-                 Onkeyup = transaction unit]
+con keyEvents = [Onkeydown = int -> transaction unit, Onkeypress = int -> transaction unit,
+                 Onkeyup = int -> transaction unit]
+(* Key arguments are character codes. *)
 con resizeEvents = [Onresize = transaction unit]
 
 con boxEvents = focusEvents ++ mouseEvents ++ keyEvents ++ resizeEvents
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 79ae814e..63f3d883 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -768,6 +768,7 @@ fun process file =
                             in
                                 (str name, st)
                             end
+                          | EFfiApp ("Basis", "kc", []) => (str "kc(event)", st)
                           | EFfiApp (m, x, args) =>
                             let
                                 val name = case Settings.jsFunc (m, x) of
diff --git a/src/monoize.sml b/src/monoize.sml
index a6e38fd7..488f3b20 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2505,10 +2505,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                        result = (L'.TFfi ("Basis", "string"), loc)}), loc),
                                            fm)
                                       end
-                                    | (L'.TFun _, _) =>
+                                    | (L'.TFun (dom, _), _) =>
                                       let
                                           val s' = " " ^ lowercaseFirst x ^ "='"
-                                          val e = (L'.EApp (e, (L'.ERecord [], loc)), 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)
                                       in
                                           ((L'.EStrcat (s,
                                                         (L'.EStrcat (
diff --git a/src/settings.sml b/src/settings.sml
index c7e68960..3b6de173 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -91,7 +91,8 @@ val effectfulBase = basis ["dml",
                            "onFail",
                            "onConnectFail",
                            "onDisconnect",
-                           "onServerError"]
+                           "onServerError",
+                           "kc"]
 
 val effectful = ref effectfulBase
 fun setEffectful ls = effectful := S.addList (effectfulBase, ls)
@@ -108,7 +109,8 @@ val clientBase = basis ["get",
                         "onFail",
                         "onConnectFail",
                         "onDisconnect",
-                        "onServerError"]
+                        "onServerError",
+                        "kc"]
 val client = ref clientBase
 fun setClientOnly ls = client := S.addList (clientBase, ls)
 fun isClientOnly x = S.member (!client, x)
@@ -162,7 +164,8 @@ val jsFuncsBase = basisM [("alert", "alert"),
                           ("strindex", "sidx"),
                           ("strchr", "schr"),
                           ("substring", "ssub"),
-                          ("strcspn", "sspn")]
+                          ("strcspn", "sspn"),
+                          ("kc", "kc")]
 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/event.ur b/tests/event.ur
index cb02bc2f..84d53b6b 100644
--- a/tests/event.ur
+++ b/tests/event.ur
@@ -7,8 +7,8 @@ fun main () =
       <span onmousedown={set s "Mouse down"} onmouseup={set s "Mouse up"}>SPAN</span>
       <span onmouseout={set s "Mouse out"} onmouseover={set s "Mouse over"}>SPAN</span>
       <span onmousemove={set s "Mouse move"}>SPAN</span>
-      <button onkeydown={set s "Key down"} onkeyup={set s "Key up"}/>
-      <button onkeypress={set s "Key press"}/>
+      <button onkeydown={fn k => set s ("Key down: " ^ show k)} onkeyup={fn _ => set s "Key up"}/>
+      <button onkeypress={fn _ => set s "Key press"}/>
       <br/>
       <br/>