summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/js/urweb.js22
-rw-r--r--lib/ur/basis.urs1
-rw-r--r--src/monoize.sml23
-rw-r--r--src/settings.sml3
4 files changed, 44 insertions, 5 deletions
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 6215a54c..8ca6b89c 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -512,7 +512,18 @@ function tbx(s) {
function addOnChange(x, f) {
var old = x.onchange;
- x.onchange = function() { old(); f (); };
+ if (old == null)
+ x.onchange = f;
+ else
+ x.onchange = function() { old(); f(); };
+}
+
+function addOnKeyUp(x, f) {
+ var old = x.onkeyup;
+ if (old == null)
+ x.onkeyup = f;
+ else
+ x.onkeyup = function(x) { old(x); f(x); };
}
@@ -893,7 +904,7 @@ function sp(e) {
var uw_event = null;
function kc() {
- return window.event ? uw_event.keyCode : uw_event.which;
+ return window.event ? event.keyCode : (uw_event ? uw_event.keyCode : 0);
}
@@ -1164,5 +1175,12 @@ function execF(f, x) {
}
+// Wrappers
+
+function confrm(s) {
+ return confirm(s) ? true : false;
+}
+
+
// App-specific code
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index d9967d12..5ed616a0 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -158,6 +158,7 @@ val clearCookie : t ::: Type -> http_cookie t -> transaction unit
(** JavaScript-y gadgets *)
val alert : string -> transaction unit
+val confirm : string -> transaction bool
val spawn : transaction unit -> transaction unit
val sleep : int -> transaction unit
diff --git a/src/monoize.sml b/src/monoize.sml
index 85ff1905..b76abb67 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2958,7 +2958,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
L'.TRecord [] => ((L'.EApp (e, (L'.ERecord [], loc)), loc), s')
| _ => ((L'.EApp ((L'.EApp (e, (L'.EFfiApp ("Basis", "kc", []), loc)),
loc), (L'.ERecord [], loc)), loc),
- s' ^ "uwe=event;")
+ s' ^ "uw_event=event;")
val s' = s' ^ "exec("
in
((L'.EStrcat (s,
@@ -3068,10 +3068,27 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
SOME (strcat [str "addOnChange(d,exec(",
(L'.EJavaScript (L'.Script, e), loc),
str "))"])
- | (x, e, _) =>
+ | (x, e, (L'.TFun ((L'.TRecord [], _), _), _)) =>
SOME (strcat [str ("d." ^ lowercaseFirst x ^ "=exec("),
(L'.EJavaScript (L'.Script, e), loc),
- str ");"]))
+ str ");"])
+ | (x, e, _) =>
+ let
+ val e = (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
+ (L'.EApp ((L'.EApp (liftExpInExp 0 e,
+ (L'.EFfiApp ("Basis", "kc", []), loc)),
+ loc), (L'.ERecord [], loc)), loc)), loc)
+ in
+ case x of
+ "Onkeyup" =>
+ SOME (strcat [str ("((function(c){addOnKeyUp(d,function(){window.uw_event=window.event;return c();});})(exec("),
+ (L'.EJavaScript (L'.Script, e), loc),
+ str ")));"])
+ | _ =>
+ SOME (strcat [str ("((function(c){d." ^ lowercaseFirst x ^ "=function(){window.uw_event=window.event;return c();};})(exec("),
+ (L'.EJavaScript (L'.Script, e), loc),
+ str ")));"])
+ end)
attrs
val t = (L'.TFfi ("Basis", "string"), loc)
diff --git a/src/settings.sml b/src/settings.sml
index 40f2ff20..93b022ab 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -110,6 +110,7 @@ val benignBase = basis ["get_cookie",
"set_client_source",
"current",
"alert",
+ "confirm",
"onError",
"onFail",
"onConnectFail",
@@ -127,6 +128,7 @@ val clientBase = basis ["get",
"set",
"current",
"alert",
+ "confirm",
"recv",
"sleep",
"spawn",
@@ -154,6 +156,7 @@ fun isServerOnly x = S.member (!server, x)
val basisM = foldl (fn ((k, v : string), m) => M.insert (m, ("Basis", k), v)) M.empty
val jsFuncsBase = basisM [("alert", "alert"),
+ ("confirm", "confrm"),
("get_client_source", "sg"),
("current", "scur"),
("htmlifyBool", "bs"),