summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-12-19 12:38:11 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-12-19 12:38:11 -0500
commite478b4d432d65b33613a601f71204fc0c656c3db (patch)
tree120f43205b07cf55f8d1af41742dd275a4d863ca
parented7c55c7d3d47e59b73cda4d1d7663bec6728934 (diff)
Displayed an alert dialog
-rw-r--r--include/urweb.h2
-rw-r--r--lib/basis.urs7
-rw-r--r--src/c/urweb.c35
-rw-r--r--src/cjrize.sml2
-rw-r--r--src/mono.sml2
-rw-r--r--src/mono_opt.sml5
-rw-r--r--src/mono_print.sml3
-rw-r--r--src/mono_reduce.sml2
-rw-r--r--src/mono_util.sml4
-rw-r--r--src/monoize.sml13
-rw-r--r--tests/alert.ur3
-rw-r--r--tests/alert.urp3
12 files changed, 80 insertions, 1 deletions
diff --git a/include/urweb.h b/include/urweb.h
index 3d7b967c..647f153a 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -94,6 +94,8 @@ uw_Basis_string uw_Basis_sqlifyTimeN(uw_context, uw_Basis_time*);
char *uw_Basis_ensqlBool(uw_Basis_bool);
+char *uw_Basis_jsifyString(uw_context, uw_Basis_string);
+
uw_Basis_string uw_Basis_intToString(uw_context, uw_Basis_int);
uw_Basis_string uw_Basis_floatToString(uw_context, uw_Basis_float);
uw_Basis_string uw_Basis_boolToString(uw_context, uw_Basis_bool);
diff --git a/lib/basis.urs b/lib/basis.urs
index ffba2b37..ac4c4832 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -100,6 +100,11 @@ val getCookie : t ::: Type -> http_cookie t -> transaction (option t)
val setCookie : t ::: Type -> http_cookie t -> t -> transaction unit
+(** JavaScript-y gadgets *)
+
+val alert : string -> transaction unit
+
+
(** SQL *)
con sql_table :: {Type} -> Type
@@ -403,7 +408,7 @@ val ul : bodyTag []
val hr : bodyTag []
-val a : bodyTag [Link = transaction page]
+val a : bodyTag [Link = transaction page, Onclick = transaction unit]
val form : ctx ::: {Unit} -> bind ::: {Type}
-> fn [[Body] ~ ctx] =>
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 7a9b3e79..64cdb81e 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -1056,6 +1056,41 @@ char *uw_Basis_ensqlBool(uw_Basis_bool b) {
return (char *)&true;
}
+uw_Basis_string uw_Basis_jsifyString(uw_context ctx, uw_Basis_string s) {
+ char *r, *s2;
+
+ uw_check_heap(ctx, strlen(s) * 4 + 2);
+
+ r = s2 = ctx->heap_front;
+ *s2++ = '"';
+
+ for (; *s; s++) {
+ char c = *s;
+
+ switch (c) {
+ case '"':
+ strcpy(s2, "\\\"");
+ s2 += 2;
+ break;
+ case '\\':
+ strcpy(s2, "\\\\");
+ s2 += 2;
+ break;
+ default:
+ if (isprint(c))
+ *s2++ = c;
+ else {
+ sprintf(s2, "\\%3o", c);
+ s2 += 4;
+ }
+ }
+ }
+
+ strcpy(s2, "\"");
+ ctx->heap_front = s2 + 1;
+ return r;
+}
+
uw_Basis_string uw_Basis_intToString(uw_context ctx, uw_Basis_int n) {
int len;
char *r;
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 6c34923b..1152b0ef 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -420,6 +420,8 @@ fun cifyExp (eAll as (e, loc), sm) =
((L'.EUnurlify (e, t), loc), sm)
end
+ | L.EJavaScript _ => raise Fail "EJavaScript remains"
+
fun cifyDecl ((d, loc), sm) =
case d of
L.DDatatype (x, n, xncs) =>
diff --git a/src/mono.sml b/src/mono.sml
index f465d2bd..187b1853 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -96,6 +96,8 @@ datatype exp' =
| EUnurlify of exp * typ
+ | EJavaScript of exp
+
withtype exp = exp' located
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 6c0e6e21..7f83c003 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -360,6 +360,11 @@ fun exp e =
| EWrite (EPrim (Prim.String ""), loc) =>
ERecord []
+ | EJavaScript (EAbs (_, (TRecord [], _), _, (EFfiApp ("Basis", "alert", [s]), _)), loc) =>
+ EStrcat ((EPrim (Prim.String "alert("), loc),
+ (EStrcat ((EFfiApp ("Basis", "jsifyString", [s]), loc),
+ (EPrim (Prim.String ")"), loc)), loc))
+
| _ => e
and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 8d91d048..7b675438 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -275,6 +275,9 @@ fun p_exp' par env (e, _) =
| EUnurlify (e, _) => box [string "unurlify(",
p_exp env e,
string ")"]
+ | EJavaScript e => box [string "JavaScript(",
+ p_exp env e,
+ string ")"]
and p_exp env = p_exp' false env
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 9cf6d8e8..040414f3 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -75,6 +75,7 @@ fun impure (e, _) =
| ELet (_, _, e1, e2) => impure e1 orelse impure e2
| EClosure (_, es) => List.exists impure es
+ | EJavaScript e => impure e
val liftExpInExp = Monoize.liftExpInExp
@@ -329,6 +330,7 @@ fun reduce file =
| EDml e => summarize d e @ [WriteDb]
| ENextval e => summarize d e @ [WriteDb]
| EUnurlify (e, _) => summarize d e
+ | EJavaScript e => summarize d e
fun exp env e =
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 2b2476e7..18b5c948 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -311,6 +311,10 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
S.map2 (mft t,
fn t' =>
(EUnurlify (e', t'), loc)))
+ | EJavaScript e =>
+ S.map2 (mfe ctx e,
+ fn e' =>
+ (EJavaScript e', loc))
in
mfe
end
diff --git a/src/monoize.sml b/src/monoize.sml
index e23d4f80..e92a1c8a 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1744,6 +1744,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
result = (L'.TFfi ("Basis", "string"), loc)}), loc),
fm)
end
+ | (L'.TFun _, _) =>
+ let
+ val s' = " " ^ lowercaseFirst x ^ "='"
+ in
+ ((L'.EStrcat (s,
+ (L'.EStrcat (
+ (L'.EPrim (Prim.String s'), loc),
+ (L'.EStrcat (
+ (L'.EJavaScript e, loc),
+ (L'.EPrim (Prim.String "'"), loc)), loc)),
+ loc)), loc),
+ fm)
+ end
| _ =>
let
val fooify =
diff --git a/tests/alert.ur b/tests/alert.ur
new file mode 100644
index 00000000..7b2eaacf
--- /dev/null
+++ b/tests/alert.ur
@@ -0,0 +1,3 @@
+fun main () : transaction page = return <xml><body>
+ <a onclick={alert "You clicked it!"}>Click Me!</a>
+ </body></xml>
diff --git a/tests/alert.urp b/tests/alert.urp
new file mode 100644
index 00000000..3976e9b0
--- /dev/null
+++ b/tests/alert.urp
@@ -0,0 +1,3 @@
+debug
+
+alert