diff options
author | Adam Chlipala <adamc@hcoop.net> | 2009-04-16 12:36:01 -0400 |
---|---|---|
committer | Adam Chlipala <adamc@hcoop.net> | 2009-04-16 12:36:01 -0400 |
commit | 237c9393b135b40e07f97b00699fd6cf9b48dac4 (patch) | |
tree | e5b913873d3ffcd5abcc024dbc7d74e8d1c2aad2 | |
parent | 9ac7c1a3cfcd247d5f6313b0e122049ec0b98fe5 (diff) |
onError
-rw-r--r-- | lib/js/urweb.js | 12 | ||||
-rw-r--r-- | lib/ur/basis.urs | 5 | ||||
-rw-r--r-- | src/jscomp.sml | 5 | ||||
-rw-r--r-- | src/mono_reduce.sml | 5 | ||||
-rw-r--r-- | src/scriptcheck.sml | 16 | ||||
-rw-r--r-- | tests/jserror.ur | 3 | ||||
-rw-r--r-- | tests/jserror.urp | 3 |
7 files changed, 33 insertions, 16 deletions
diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 5ff5b9fb..5cf159ad 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -250,6 +250,18 @@ function pf() { 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 diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index cfb80850..2633d48e 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -550,6 +550,7 @@ val td : other ::: {Unit} -> [other ~ [Body, Tr]] => (** Aborting *) -val error : t ::: Type -> xml [Body] [] [] -> t - +val error : t ::: Type -> xbody -> t +val onError : (xbody -> transaction unit) -> transaction unit +(* Client-side only *) diff --git a/src/jscomp.sml b/src/jscomp.sml index 9a621906..d7a74fab 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -52,7 +52,8 @@ val funcs = [(("Basis", "alert"), "alert"), (("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 @@ fun process file = let val (e, st) = jsE inner (e, st) in - (strcat [str "alert(cat(\"ERROR: \",", e, str "))"], + (strcat [str "er(", e, str ")"], st) end diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index dafc6ded..19140b81 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -61,6 +61,7 @@ fun impure (e, _) = | 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 @@ fun match (env, p : pat, e : exp) = consider (xps, env) end + | (PNone _, ENone _) => Yes env + | (PSome (_, p), ESome (_, e)) => match (env, p, e) + | _ => Maybe datatype event = @@ -282,6 +286,7 @@ fun reduce file = | 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 _ => diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml index a3928921..352ef46c 100644 --- a/src/scriptcheck.sml +++ b/src/scriptcheck.sml @@ -60,13 +60,6 @@ fun classify (ds, ps) = 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 @@ fun classify (ds, ps) = | 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 diff --git a/tests/jserror.ur b/tests/jserror.ur new file mode 100644 index 00000000..ab2c955c --- /dev/null +++ b/tests/jserror.ur @@ -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> diff --git a/tests/jserror.urp b/tests/jserror.urp new file mode 100644 index 00000000..74cceb4f --- /dev/null +++ b/tests/jserror.urp @@ -0,0 +1,3 @@ +debug + +jserror |