Mercurial > urweb

changeset 566:a152905c3c3b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Displayed an alert dialog
author Adam Chlipala <adamc@hcoop.net>
date Fri, 19 Dec 2008 12:38:11 -0500
parents 74800be65591
children 1901db85acb4
files include/urweb.h lib/basis.urs src/c/urweb.c src/cjrize.sml src/mono.sml src/mono_opt.sml src/mono_print.sml src/mono_reduce.sml src/mono_util.sml src/monoize.sml tests/alert.ur tests/alert.urp
diffstat 12 files changed, 80 insertions(+), 1 deletions(-) [+]
line wrap: on
line diff
--- a/include/urweb.h	Fri Dec 19 11:47:18 2008 -0500
+++ b/include/urweb.h	Fri Dec 19 12:38:11 2008 -0500
@@ -94,6 +94,8 @@
 
 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);
--- a/lib/basis.urs	Fri Dec 19 11:47:18 2008 -0500
+++ b/lib/basis.urs	Fri Dec 19 12:38:11 2008 -0500
@@ -100,6 +100,11 @@
 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 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] =>
--- a/src/c/urweb.c	Fri Dec 19 11:47:18 2008 -0500
+++ b/src/c/urweb.c	Fri Dec 19 12:38:11 2008 -0500
@@ -1056,6 +1056,41 @@
     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;
--- a/src/cjrize.sml	Fri Dec 19 11:47:18 2008 -0500
+++ b/src/cjrize.sml	Fri Dec 19 12:38:11 2008 -0500
@@ -420,6 +420,8 @@
             ((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) =>
--- a/src/mono.sml	Fri Dec 19 11:47:18 2008 -0500
+++ b/src/mono.sml	Fri Dec 19 12:38:11 2008 -0500
@@ -96,6 +96,8 @@
 
        | EUnurlify of exp * typ
 
+       | EJavaScript of exp
+
 
 withtype exp = exp' located
 
--- a/src/mono_opt.sml	Fri Dec 19 11:47:18 2008 -0500
+++ b/src/mono_opt.sml	Fri Dec 19 12:38:11 2008 -0500
@@ -360,6 +360,11 @@
       | 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)
--- a/src/mono_print.sml	Fri Dec 19 11:47:18 2008 -0500
+++ b/src/mono_print.sml	Fri Dec 19 12:38:11 2008 -0500
@@ -275,6 +275,9 @@
       | 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
 
--- a/src/mono_reduce.sml	Fri Dec 19 11:47:18 2008 -0500
+++ b/src/mono_reduce.sml	Fri Dec 19 12:38:11 2008 -0500
@@ -75,6 +75,7 @@
       | 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 @@
               | 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 =
--- a/src/mono_util.sml	Fri Dec 19 11:47:18 2008 -0500
+++ b/src/mono_util.sml	Fri Dec 19 12:38:11 2008 -0500
@@ -311,6 +311,10 @@
                         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
--- a/src/monoize.sml	Fri Dec 19 11:47:18 2008 -0500
+++ b/src/monoize.sml	Fri Dec 19 12:38:11 2008 -0500
@@ -1744,6 +1744,19 @@
                                                            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 =
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/alert.ur	Fri Dec 19 12:38:11 2008 -0500
@@ -0,0 +1,3 @@
+fun main () : transaction page = return <xml><body>
+    <a onclick={alert "You clicked it!"}>Click Me!</a>
+  </body></xml>
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/alert.urp	Fri Dec 19 12:38:11 2008 -0500
@@ -0,0 +1,3 @@
+debug
+
+alert