Mercurial > urweb

changeset 726:6fc633d990e7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
onError
author Adam Chlipala <adamc@hcoop.net>
date Thu, 16 Apr 2009 12:36:01 -0400
parents 4c5796512edc
children ba4c230b7231
files lib/js/urweb.js lib/ur/basis.urs src/jscomp.sml src/mono_reduce.sml src/scriptcheck.sml tests/jserror.ur tests/jserror.urp
diffstat 7 files changed, 33 insertions(+), 16 deletions(-) [+]
line wrap: on
line diff
--- a/lib/js/urweb.js	Thu Apr 16 12:07:21 2009 -0400
+++ b/lib/js/urweb.js	Thu Apr 16 12:36:01 2009 -0400
@@ -250,6 +250,18 @@
   whine("Pattern match failure");
 }
 
+var errorHandlers = null;
+
+function onError(f) {
+  errorHandlers = cons(f, errorHandlers);
+}
+
+function er(s) {
+  for (var ls = errorHandlers; ls; ls = ls.next)
+    ls.data(s)(null);
+  throw s;
+}
+
 
 // Remote calls
 
--- a/lib/ur/basis.urs	Thu Apr 16 12:07:21 2009 -0400
+++ b/lib/ur/basis.urs	Thu Apr 16 12:36:01 2009 -0400
@@ -550,6 +550,7 @@
 
 (** Aborting *)
 
-val error : t ::: Type -> xml [Body] [] [] -> t
+val error : t ::: Type -> xbody -> t
 
-
+val onError : (xbody -> transaction unit) -> transaction unit
+(* Client-side only *)
--- a/src/jscomp.sml	Thu Apr 16 12:07:21 2009 -0400
+++ b/src/jscomp.sml	Thu Apr 16 12:36:01 2009 -0400
@@ -52,7 +52,8 @@
              (("Basis", "recv"), "rv"),
              (("Basis", "strcat"), "cat"),
              (("Basis", "intToString"), "ts"),
-             (("Basis", "floatToString"), "ts")]
+             (("Basis", "floatToString"), "ts"),
+             (("Basis", "onError"), "onError")]
 
 structure FM = BinaryMapFn(struct
                            type ord_key = string * string
@@ -861,7 +862,7 @@
                             let
                                 val (e, st) = jsE inner (e, st)
                             in
-                                (strcat [str "alert(cat(\"ERROR: \",", e, str "))"],
+                                (strcat [str "er(", e, str ")"],
                                  st)
                             end
 
--- a/src/mono_reduce.sml	Thu Apr 16 12:07:21 2009 -0400
+++ b/src/mono_reduce.sml	Thu Apr 16 12:36:01 2009 -0400
@@ -61,6 +61,7 @@
       | EFfiApp ("Basis", "new_channel", _) => true
       | EFfiApp ("Basis", "subscribe", _) => true
       | EFfiApp ("Basis", "send", _) => true
+      | EFfiApp ("Basis", "onError", _) => true
       | EFfiApp _ => false
       | EApp ((EFfi _, _), _) => false
       | EApp _ => true
@@ -207,6 +208,9 @@
             consider (xps, env)
         end
 
+      | (PNone _, ENone _) => Yes env
+      | (PSome (_, p), ESome (_, e)) => match (env, p, e)
+
       | _ => Maybe
 
 datatype event =
@@ -282,6 +286,7 @@
                       | EFfiApp ("Basis", "new_channel", es) => ffi es
                       | EFfiApp ("Basis", "subscribe", es) => ffi es
                       | EFfiApp ("Basis", "send", es) => ffi es
+                      | EFfiApp ("Basis", "onError", es) => ffi es
                       | EFfiApp (_, _, es) => List.concat (map (summarize d) es)
                       | EApp ((EFfi _, _), e) => summarize d e
                       | EApp _ =>
--- a/src/scriptcheck.sml	Thu Apr 16 12:07:21 2009 -0400
+++ b/src/scriptcheck.sml	Thu Apr 16 12:36:01 2009 -0400
@@ -60,13 +60,6 @@
 
         fun hasClient {basis, words, onload} csids =
             let
-                fun realOnload ss =
-                    case ss of
-                        [] => false
-                      | (EFfiApp ("Basis", "get_settings", _), _) :: ss => realOnload ss
-                      | (EPrim (Prim.String s), _) :: ss => not (String.isPrefix "'" s)
-                      | _ => true
-
                 fun hasClient e =
                     case #1 e of
                         EPrim (Prim.String s) => List.exists (fn n => inString {needle = n, haystack = s}) words
@@ -79,11 +72,10 @@
                       | ESome (_, e) => hasClient e
                       | EFfi ("Basis", x) => SS.member (basis, x)
                       | EFfi _ => false
-                      | EFfiApp ("Basis", "strcat", all as ((EPrim (Prim.String s1), _) :: ss)) =>
-                        if onload andalso String.isSuffix " onload='" s1 then
-                            realOnload ss orelse List.exists hasClient all
-                        else
-                            List.exists hasClient all
+                      | EFfiApp ("Basis", "maybe_onload",
+                                 [(EFfiApp ("Basis", "strcat", all as [_, (EPrim (Prim.String s), _)]), _)]) =>
+                        List.exists hasClient all
+                        orelse (onload andalso size s > 0)
                       | EFfiApp ("Basis", x, es) => SS.member (basis, x)
                                                     orelse List.exists hasClient es
                       | EFfiApp (_, _, es) => List.exists hasClient es
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/jserror.ur	Thu Apr 16 12:36:01 2009 -0400
@@ -0,0 +1,3 @@
+fun main () : transaction page = return <xml>
+  <body onload={onError (fn s => alert "There was an error."); error <xml>Badder</xml>}/>
+</xml>
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/jserror.urp	Thu Apr 16 12:36:01 2009 -0400
@@ -0,0 +1,3 @@
+debug
+
+jserror