diff options
| -rw-r--r-- | include/urweb.h | 2 | ||||
| -rw-r--r-- | lib/basis.urs | 7 | ||||
| -rw-r--r-- | src/c/urweb.c | 35 | ||||
| -rw-r--r-- | src/cjrize.sml | 2 | ||||
| -rw-r--r-- | src/mono.sml | 2 | ||||
| -rw-r--r-- | src/mono_opt.sml | 5 | ||||
| -rw-r--r-- | src/mono_print.sml | 3 | ||||
| -rw-r--r-- | src/mono_reduce.sml | 2 | ||||
| -rw-r--r-- | src/mono_util.sml | 4 | ||||
| -rw-r--r-- | src/monoize.sml | 13 | ||||
| -rw-r--r-- | tests/alert.ur | 3 | ||||
| -rw-r--r-- | tests/alert.urp | 3 |
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 |