summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2010-09-07 08:28:07 -0400
committerGravatar Adam Chlipala <adam@chlipala.net>2010-09-07 08:28:07 -0400
commit2abed5bc95fa69a49d955e0b115d0db874f53a3a (patch)
treeab4a39c6f88b3e8719c9e41dfcd7f147126ef790
parent9b122d78f58a8c22d0f4c4bde2d935c4508e00b8 (diff)
Server-side 'onError'
-rw-r--r--include/types.h4
-rw-r--r--include/urweb.h1
-rw-r--r--src/c/request.c101
-rw-r--r--src/c/urweb.c18
-rw-r--r--src/cjr.sml1
-rw-r--r--src/cjr_env.sml1
-rw-r--r--src/cjr_print.sml26
-rw-r--r--src/cjrize.sml1
-rw-r--r--src/compiler.sig3
-rw-r--r--src/compiler.sml23
-rw-r--r--src/core.sml1
-rw-r--r--src/core_env.sml1
-rw-r--r--src/core_print.sml1
-rw-r--r--src/core_util.sml6
-rw-r--r--src/corify.sml14
-rw-r--r--src/css.sml1
-rw-r--r--src/demo.sml3
-rw-r--r--src/elab.sml1
-rw-r--r--src/elab_env.sml1
-rw-r--r--src/elab_print.sml1
-rw-r--r--src/elab_util.sml5
-rw-r--r--src/elaborate.sml27
-rw-r--r--src/expl.sml1
-rw-r--r--src/expl_env.sml1
-rw-r--r--src/expl_print.sml1
-rw-r--r--src/explify.sml3
-rw-r--r--src/mono.sml1
-rw-r--r--src/mono_env.sml1
-rw-r--r--src/mono_print.sml2
-rw-r--r--src/mono_shake.sml7
-rw-r--r--src/mono_util.sml5
-rw-r--r--src/monoize.sml3
-rw-r--r--src/prepare.sml1
-rw-r--r--src/reduce.sml1
-rw-r--r--src/reduce_local.sml1
-rw-r--r--src/settings.sig2
-rw-r--r--src/settings.sml4
-rw-r--r--src/shake.sml11
-rw-r--r--src/source.sml1
-rw-r--r--src/source_print.sml1
-rw-r--r--src/unnest.sml1
-rw-r--r--tests/onerror.ur4
-rw-r--r--tests/onerror.urp4
-rw-r--r--tests/onerror.urs1
-rw-r--r--tests/onerrorE.ur5
45 files changed, 244 insertions, 59 deletions
diff --git a/include/types.h b/include/types.h
index 138760e5..ac70c34f 100644
--- a/include/types.h
+++ b/include/types.h
@@ -73,6 +73,10 @@ typedef struct {
uw_Basis_string (*cookie_sig)(uw_context);
int (*check_url)(const char *);
int (*check_mime)(const char *);
+
+ void (*on_error)(uw_context, char *);
} uw_app;
+#define ERROR_BUF_LEN 1024
+
#endif
diff --git a/include/urweb.h b/include/urweb.h
index 32e9b4e1..f254da2a 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -36,6 +36,7 @@ failure_kind uw_begin_init(uw_context);
void uw_set_on_success(char *);
void uw_set_headers(uw_context, char *(*get_header)(void *, const char *), void *get_header_data);
failure_kind uw_begin(uw_context, char *path);
+failure_kind uw_begin_onError(uw_context, char *msg);
void uw_login(uw_context);
void uw_commit(uw_context);
int uw_rollback(uw_context);
diff --git a/src/c/request.c b/src/c/request.c
index 5e57d7b0..f72a3199 100644
--- a/src/c/request.c
+++ b/src/c/request.c
@@ -131,6 +131,8 @@ request_result uw_request(uw_request_context rc, uw_context ctx,
char *inputs;
const char *prefix = uw_get_url_prefix(ctx);
char *s;
+ int had_error = 0;
+ char errmsg[ERROR_BUF_LEN];
for (s = path; *s; ++s) {
if (s[0] == '%' && s[1] == '2' && s[2] == '7') {
@@ -336,32 +338,42 @@ request_result uw_request(uw_request_context rc, uw_context ctx,
log_debug(logger_data, "Serving URI %s....\n", path);
while (1) {
- size_t path_len = strlen(path);
+ if (!had_error) {
+ size_t path_len = strlen(path);
- on_success(ctx);
+ on_success(ctx);
+
+ if (path_len + 1 > rc->path_copy_size) {
+ rc->path_copy_size = path_len + 1;
+ rc->path_copy = realloc(rc->path_copy, rc->path_copy_size);
+ }
+ strcpy(rc->path_copy, path);
+ fk = uw_begin(ctx, rc->path_copy);
+ } else
+ fk = uw_begin_onError(ctx, errmsg);
- if (path_len + 1 > rc->path_copy_size) {
- rc->path_copy_size = path_len + 1;
- rc->path_copy = realloc(rc->path_copy, rc->path_copy_size);
- }
- strcpy(rc->path_copy, path);
- fk = uw_begin(ctx, rc->path_copy);
if (fk == SUCCESS || fk == RETURN_INDIRECTLY) {
uw_commit(ctx);
- if (uw_has_error(ctx)) {
+ if (uw_has_error(ctx) && !had_error) {
log_error(logger_data, "Fatal error: %s\n", uw_error_message(ctx));
uw_reset_keep_error_message(ctx);
on_failure(ctx);
- uw_write_header(ctx, "Content-type: text/html\r\n");
- uw_write(ctx, "<html><head><title>Fatal Error</title></head><body>");
- uw_write(ctx, "Fatal error: ");
- uw_write(ctx, uw_error_message(ctx));
- uw_write(ctx, "\n</body></html>");
+
+ if (uw_get_app(ctx)->on_error) {
+ had_error = 1;
+ strcpy(errmsg, uw_error_message(ctx));
+ } else {
+ uw_write_header(ctx, "Content-type: text/html\r\n");
+ uw_write(ctx, "<html><head><title>Fatal Error</title></head><body>");
+ uw_write(ctx, "Fatal error: ");
+ uw_write(ctx, uw_error_message(ctx));
+ uw_write(ctx, "\n</body></html>");
- return FAILED;
+ return FAILED;
+ }
} else
- return SERVED;
+ return had_error ? FAILED : SERVED;
} else if (fk == BOUNDED_RETRY) {
if (retries_left) {
log_debug(logger_data, "Error triggers bounded retry: %s\n", uw_error_message(ctx));
@@ -372,14 +384,19 @@ request_result uw_request(uw_request_context rc, uw_context ctx,
try_rollback(ctx, logger_data, log_error);
- uw_reset_keep_error_message(ctx);
- on_failure(ctx);
- uw_write_header(ctx, "Content-type: text/plain\r\n");
- uw_write(ctx, "Fatal error (out of retries): ");
- uw_write(ctx, uw_error_message(ctx));
- uw_write(ctx, "\n");
-
- return FAILED;
+ if (!had_error && uw_get_app(ctx)->on_error) {
+ had_error = 1;
+ strcpy(errmsg, uw_error_message(ctx));
+ } else {
+ uw_reset_keep_error_message(ctx);
+ on_failure(ctx);
+ uw_write_header(ctx, "Content-type: text/plain\r\n");
+ uw_write(ctx, "Fatal error (out of retries): ");
+ uw_write(ctx, uw_error_message(ctx));
+ uw_write(ctx, "\n");
+
+ return FAILED;
+ }
}
} else if (fk == UNLIMITED_RETRY)
log_debug(logger_data, "Error triggers unlimited retry: %s\n", uw_error_message(ctx));
@@ -388,26 +405,36 @@ request_result uw_request(uw_request_context rc, uw_context ctx,
try_rollback(ctx, logger_data, log_error);
- uw_reset_keep_error_message(ctx);
- on_failure(ctx);
- uw_write_header(ctx, "Content-type: text/html\r\n");
- uw_write(ctx, "<html><head><title>Fatal Error</title></head><body>");
- uw_write(ctx, "Fatal error: ");
- uw_write(ctx, uw_error_message(ctx));
- uw_write(ctx, "\n</body></html>");
+ if (uw_get_app(ctx)->on_error && !had_error) {
+ had_error = 1;
+ strcpy(errmsg, uw_error_message(ctx));
+ } else {
+ uw_reset_keep_error_message(ctx);
+ on_failure(ctx);
+ uw_write_header(ctx, "Content-type: text/html\r\n");
+ uw_write(ctx, "<html><head><title>Fatal Error</title></head><body>");
+ uw_write(ctx, "Fatal error: ");
+ uw_write(ctx, uw_error_message(ctx));
+ uw_write(ctx, "\n</body></html>");
- return FAILED;
+ return FAILED;
+ }
} else {
log_error(logger_data, "Unknown uw_handle return code!\n");
try_rollback(ctx, logger_data, log_error);
- uw_reset_keep_request(ctx);
- on_failure(ctx);
- uw_write_header(ctx, "Content-type: text/plain\r\n");
- uw_write(ctx, "Unknown uw_handle return code!\n");
+ if (uw_get_app(ctx)->on_error && !had_error) {
+ had_error = 1;
+ strcpy(errmsg, "Unknown uw_handle return code");
+ } else {
+ uw_reset_keep_request(ctx);
+ on_failure(ctx);
+ uw_write_header(ctx, "Content-type: text/plain\r\n");
+ uw_write(ctx, "Unknown uw_handle return code!\n");
- return FAILED;
+ return FAILED;
+ }
}
if (try_rollback(ctx, logger_data, log_error))
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 74e1b12e..cac518ec 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -353,8 +353,6 @@ int uw_time = 0;
// Single-request state
-#define ERROR_BUF_LEN 1024
-
typedef struct regions {
struct regions *next;
} regions;
@@ -714,6 +712,22 @@ failure_kind uw_begin(uw_context ctx, char *path) {
return r;
}
+failure_kind uw_begin_onError(uw_context ctx, char *msg) {
+ int r = setjmp(ctx->jmp_buf);
+
+ if (ctx->app->on_error) {
+ if (r == 0) {
+ if (ctx->app->db_begin(ctx))
+ uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN");
+
+ ctx->app->on_error(ctx, msg);
+ }
+
+ return r;
+ } else
+ uw_error(ctx, FATAL, "Tried to run nonexistent onError handler");
+}
+
uw_Basis_client uw_Basis_self(uw_context ctx) {
if (ctx->client == NULL)
uw_error(ctx, FATAL, "Call to Basis.self() from page that has only server-side code");
diff --git a/src/cjr.sml b/src/cjr.sml
index f34662dc..5013033f 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -124,6 +124,7 @@ datatype decl' =
| DStyle of string
| DTask of task * exp
+ | DOnError of int
withtype decl = decl' located
diff --git a/src/cjr_env.sml b/src/cjr_env.sml
index ac83f263..21188b51 100644
--- a/src/cjr_env.sml
+++ b/src/cjr_env.sml
@@ -172,5 +172,6 @@ fun declBinds env (d, loc) =
| DCookie _ => env
| DStyle _ => env
| DTask _ => env
+ | DOnError _ => env
end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 7331196f..9b5edab5 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -113,9 +113,11 @@ and p_typ env = p_typ' false env
fun p_rel env n = string ("__uwr_" ^ ident (#1 (E.lookupERel env n)) ^ "_" ^ Int.toString (E.countERels env - n - 1))
handle CjrEnv.UnboundRel _ => string ("__uwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1))
-fun p_enamed env n =
- string ("__uwn_" ^ ident (#1 (E.lookupENamed env n)) ^ "_" ^ Int.toString n)
- handle CjrEnv.UnboundNamed _ => string ("__uwn_UNBOUND_" ^ Int.toString n)
+fun p_enamed' env n =
+ "__uwn_" ^ ident (#1 (E.lookupENamed env n)) ^ "_" ^ Int.toString n
+ handle CjrEnv.UnboundNamed _ => "__uwn_UNBOUND_" ^ Int.toString n
+
+fun p_enamed env n = string (p_enamed' env n)
fun p_con_named env n =
string ("__uwc_" ^ ident (#1 (E.lookupConstructor env n)) ^ "_" ^ Int.toString n)
@@ -2156,6 +2158,7 @@ fun p_decl env (dAll as (d, _) : decl) =
string "*/"]
| DTask _ => box []
+ | DOnError _ => box []
datatype 'a search =
Found of 'a
@@ -2791,6 +2794,8 @@ fun p_file env (ds, ps) =
val initializers = List.mapPartial (fn (DTask (Initialize, e), _) => SOME e | _ => NONE) ds
+ val onError = ListUtil.search (fn (DOnError n, _) => SOME n | _ => NONE) ds
+
val now = Time.now ()
val nowD = Date.fromTimeUniv now
val rfcFmt = "%a, %d %b %Y %H:%M:%S"
@@ -2957,6 +2962,18 @@ fun p_file env (ds, ps) =
string "static void uw_initializer(uw_context ctx) { };",
newline],
+ case onError of
+ NONE => box []
+ | SOME n => box [string "static void uw_onError(uw_context ctx, char *msg) {",
+ newline,
+ box [string "uw_write(ctx, ",
+ p_enamed env n,
+ string "(ctx, msg, uw_unit_v));",
+ newline],
+ string "}",
+ newline,
+ newline],
+
string "uw_app uw_application = {",
p_list_sep (box [string ",", newline]) string
[Int.toString (SM.foldl Int.max 0 fnums + 1),
@@ -2965,7 +2982,8 @@ fun p_file env (ds, ps) =
"uw_client_init", "uw_initializer", "uw_expunger",
"uw_db_init", "uw_db_begin", "uw_db_commit", "uw_db_rollback", "uw_db_close",
"uw_handle",
- "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime"],
+ "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime",
+ case onError of NONE => "NULL" | SOME _ => "uw_onError"],
string "};",
newline]
end
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 22463cd4..2e7afa43 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -675,6 +675,7 @@ fun cifyDecl ((d, loc), sm) =
| _ => (ErrorMsg.errorAt loc "Initializer has not been fully determined";
(NONE, NONE, sm)))
| L.DPolicy _ => (NONE, NONE, sm)
+ | L.DOnError n => (SOME (L'.DOnError n, loc), NONE, sm)
fun cjrize ds =
let
diff --git a/src/compiler.sig b/src/compiler.sig
index c9b96a52..d0f6ac72 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -54,7 +54,8 @@ signature COMPILER = sig
protocol : string option,
dbms : string option,
sigFile : string option,
- safeGets : string list
+ safeGets : string list,
+ onError : (string * string list * string) option
}
val compile : string -> bool
val compiler : string -> unit
diff --git a/src/compiler.sml b/src/compiler.sml
index 6167f08a..c01024f0 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -58,7 +58,8 @@ type job = {
protocol : string option,
dbms : string option,
sigFile : string option,
- safeGets : string list
+ safeGets : string list,
+ onError : (string * string list * string) option
}
type ('src, 'dst) phase = {
@@ -396,6 +397,7 @@ fun parseUrp' accLibs fname =
val dbms = ref NONE
val sigFile = ref (Settings.getSigFile ())
val safeGets = ref []
+ val onError = ref NONE
fun finish sources =
let
@@ -425,7 +427,8 @@ fun parseUrp' accLibs fname =
protocol = !protocol,
dbms = !dbms,
sigFile = !sigFile,
- safeGets = rev (!safeGets)
+ safeGets = rev (!safeGets),
+ onError = !onError
}
fun mergeO f (old, new) =
@@ -469,7 +472,8 @@ fun parseUrp' accLibs fname =
protocol = mergeO #2 (#protocol old, #protocol new),
dbms = mergeO #2 (#dbms old, #dbms new),
sigFile = mergeO #2 (#sigFile old, #sigFile new),
- safeGets = #safeGets old @ #safeGets new
+ safeGets = #safeGets old @ #safeGets new,
+ onError = mergeO #2 (#onError old, #onError new)
}
in
if accLibs then
@@ -631,6 +635,12 @@ fun parseUrp' accLibs fname =
(case String.fields (fn ch => ch = #"=") arg of
[n, v] => pathmap := M.insert (!pathmap, n, v)
| _ => ErrorMsg.error "path argument not of the form name=value'")
+ | "onError" =>
+ (case String.fields (fn ch => ch = #".") arg of
+ m1 :: (fs as _ :: _) =>
+ onError := SOME (m1, List.take (fs, length fs - 1), List.last fs)
+ | _ => ErrorMsg.error "invalid 'onError' argument")
+
| _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
read ()
end
@@ -657,6 +667,7 @@ fun parseUrp' accLibs fname =
Option.app Settings.setProtocol (#protocol job);
Option.app Settings.setDbms (#dbms job);
Settings.setSafeGets (#safeGets job);
+ Settings.setOnError (#onError job);
job
end
in
@@ -709,7 +720,7 @@ structure SS = BinarySetFn(struct
end)
val parse = {
- func = fn {database, sources = fnames, ffi, ...} : job =>
+ func = fn {database, sources = fnames, ffi, onError, ...} : job =>
let
val mrs = !moduleRoots
@@ -884,6 +895,10 @@ val parse = {
val ds = case database of
NONE => ds
| SOME s => (Source.DDatabase s, loc) :: ds
+
+ val ds = case onError of
+ NONE => ds
+ | SOME v => ds @ [(Source.DOnError v, loc)]
in
ds
end handle Empty => ds
diff --git a/src/core.sml b/src/core.sml
index e5358f48..6d9e56b6 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -136,6 +136,7 @@ datatype decl' =
| DStyle of string * int * string
| DTask of exp * exp
| DPolicy of exp
+ | DOnError of int
withtype decl = decl' located
diff --git a/src/core_env.sml b/src/core_env.sml
index 478ef495..9a4f9ec7 100644
--- a/src/core_env.sml
+++ b/src/core_env.sml
@@ -350,6 +350,7 @@ fun declBinds env (d, loc) =
end
| DTask _ => env
| DPolicy _ => env
+ | DOnError _ => env
fun patBinds env (p, loc) =
case p of
diff --git a/src/core_print.sml b/src/core_print.sml
index f18ea4b9..ca8066b3 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -628,6 +628,7 @@ fun p_decl env (dAll as (d, _) : decl) =
| DPolicy e1 => box [string "policy",
space,
p_exp env e1]
+ | DOnError _ => string "ONERROR"
fun p_file env file =
let
diff --git a/src/core_util.sml b/src/core_util.sml
index eedcd2bb..e71d7276 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -997,6 +997,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} =
fn e' =>
(DPolicy e', loc))
+ | DOnError _ => S.return2 dAll
+
and mfvi ctx (x, n, t, e, s) =
S.bind2 (mfc ctx t,
fn t' =>
@@ -1152,6 +1154,7 @@ fun mapfoldB (all as {bind, ...}) =
end
| DTask _ => ctx
| DPolicy _ => ctx
+ | DOnError _ => ctx
in
S.map2 (mff ctx' ds',
fn ds' =>
@@ -1216,7 +1219,8 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
| DCookie (_, n, _, _) => Int.max (n, count)
| DStyle (_, n, _) => Int.max (n, count)
| DTask _ => count
- | DPolicy _ => count) 0
+ | DPolicy _ => count
+ | DOnError _ => count) 0
end
diff --git a/src/corify.sml b/src/corify.sml
index 88473455..27e6c4c7 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -1083,6 +1083,17 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
| L.DPolicy e1 =>
([(L'.DPolicy (corifyExp st e1), loc)], st)
+ | L.DOnError (m, ms, x) =>
+ let
+ val st = St.lookupStrById st m
+ val st = foldl St.lookupStrByName st ms
+ in
+ case St.lookupValByName st x of
+ St.ENormal n => ([(L'.DOnError n, loc)], st)
+ | _ => (ErrorMsg.errorAt loc "Wrong type of identifier for 'onError'";
+ ([], st))
+ end
+
and corifyStr mods ((str, _), st) =
case str of
L.StrConst ds =>
@@ -1141,7 +1152,8 @@ fun maxName ds = foldl (fn ((d, _), n) =>
| L.DCookie (_, _, n', _) => Int.max (n, n')
| L.DStyle (_, _, n') => Int.max (n, n')
| L.DTask _ => n
- | L.DPolicy _ => n)
+ | L.DPolicy _ => n
+ | L.DOnError _ => n)
0 ds
and maxNameStr (str, _) =
diff --git a/src/css.sml b/src/css.sml
index 31c4b9b1..73f180d9 100644
--- a/src/css.sml
+++ b/src/css.sml
@@ -288,6 +288,7 @@ fun summarize file =
| DStyle (_, n, s) => (IM.insert (globals, n, (SOME s, [])), classes)
| DTask _ => st
| DPolicy _ => st
+ | DOnError _ => st
end
val (globals, classes) = foldl decl (IM.empty, IM.empty) file
diff --git a/src/demo.sml b/src/demo.sml
index a67411de..358815de 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -115,7 +115,8 @@ fun make' {prefix, dirname, guided} =
protocol = mergeWith #2 (#protocol combined, #protocol urp),
dbms = mergeWith #2 (#dbms combined, #dbms urp),
sigFile = mergeWith #2 (#sigFile combined, #sigFile urp),
- safeGets = []
+ safeGets = [],
+ onError = NONE
}
val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp")
diff --git a/src/elab.sml b/src/elab.sml
index e040a059..6d405af6 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -172,6 +172,7 @@ datatype decl' =
| DStyle of int * string * int
| DTask of exp * exp
| DPolicy of exp
+ | DOnError of int * string list * string
and str' =
StrConst of decl list
diff --git a/src/elab_env.sml b/src/elab_env.sml
index bb34c345..16596622 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -1633,5 +1633,6 @@ fun declBinds env (d, loc) =
end
| DTask _ => env
| DPolicy _ => env
+ | DOnError _ => env
end
diff --git a/src/elab_print.sml b/src/elab_print.sml
index 42a0a107..4fb7ee73 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -816,6 +816,7 @@ fun p_decl env (dAll as (d, _) : decl) =
| DPolicy e1 => box [string "policy",
space,
p_exp env e1]
+ | DOnError _ => string "ONERROR"
and p_str env (str, _) =
case str of
diff --git a/src/elab_util.sml b/src/elab_util.sml
index ec6c51ba..ccfb86a3 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -883,7 +883,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
| DStyle (tn, x, n) =>
bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc)))
| DTask _ => ctx
- | DPolicy _ => ctx,
+ | DPolicy _ => ctx
+ | DOnError _ => ctx,
mfd ctx d)) ctx ds,
fn ds' => (StrConst ds', loc))
| StrVar _ => S.return2 strAll
@@ -1018,6 +1019,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
S.map2 (mfe ctx e1,
fn e1' =>
(DPolicy e1', loc))
+ | DOnError _ => S.return2 dAll
and mfvi ctx (x, n, c, e) =
S.bind2 (mfc ctx c,
@@ -1162,6 +1164,7 @@ and maxNameDecl (d, _) =
| DStyle (n1, _, n2) => Int.max (n1, n2)
| DTask _ => 0
| DPolicy _ => 0
+ | DOnError _ => 0
and maxNameStr (str, _) =
case str of
StrConst ds => maxName ds
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 505699bd..e7848f21 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -2679,6 +2679,7 @@ and sgiOfDecl (d, loc) =
| L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)]
| L'.DTask _ => []
| L'.DPolicy _ => []
+ | L'.DOnError _ => []
and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) =
((*prefaces "subSgn" [("sgn1", p_sgn env sgn1),
@@ -3858,6 +3859,32 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
([(L'.DPolicy e1', loc)], (env, denv, gs1 @ gs))
end
+ | L.DOnError (m1, ms, s) =>
+ (case E.lookupStr env m1 of
+ NONE => (expError env (UnboundStrInExp (loc, m1));
+ ([], (env, denv, [])))
+ | SOME (n, sgn) =>
+ let
+ val (str, sgn) = foldl (fn (m, (str, sgn)) =>
+ case E.projectStr env {sgn = sgn, str = str, field = m} of
+ NONE => (conError env (UnboundStrInCon (loc, m));
+ (strerror, sgnerror))
+ | SOME sgn => ((L'.StrProj (str, m), loc), sgn))
+ ((L'.StrVar n, loc), sgn) ms
+
+ val t = case E.projectVal env {sgn = sgn, str = str, field = s} of
+ NONE => (expError env (UnboundExp (loc, s));
+ cerror)
+ | SOME t => t
+
+ val page = (L'.CModProj (!basis_r, [], "page"), loc)
+ val xpage = (L'.CApp ((L'.CModProj (!basis_r, [], "transaction"), loc), page), loc)
+ val func = (L'.TFun ((L'.CModProj (!basis_r, [], "xbody"), loc), xpage), loc)
+ in
+ unifyCons env loc t func;
+ ([(L'.DOnError (n, ms, s), loc)], (env, denv, gs))
+ end)
+
(*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*)
in
(*prefaces "/elabDecl" [("d", SourcePrint.p_decl dAll)];*)
diff --git a/src/expl.sml b/src/expl.sml
index 1212383f..119c1d92 100644
--- a/src/expl.sml
+++ b/src/expl.sml
@@ -149,6 +149,7 @@ datatype decl' =
| DStyle of int * string * int
| DTask of exp * exp
| DPolicy of exp
+ | DOnError of int * string list * string
and str' =
StrConst of decl list
diff --git a/src/expl_env.sml b/src/expl_env.sml
index 9abe7099..f5a5eb0a 100644
--- a/src/expl_env.sml
+++ b/src/expl_env.sml
@@ -345,6 +345,7 @@ fun declBinds env (d, loc) =
end
| DTask _ => env
| DPolicy _ => env
+ | DOnError _ => env
fun sgiBinds env (sgi, loc) =
case sgi of
diff --git a/src/expl_print.sml b/src/expl_print.sml
index 5a914194..d89b0512 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -730,6 +730,7 @@ fun p_decl env (dAll as (d, _) : decl) =
| DPolicy e1 => box [string "policy",
space,
p_exp env e1]
+ | DOnError _ => string "ONERROR"
and p_str env (str, _) =
case str of
diff --git a/src/explify.sml b/src/explify.sml
index 0013906f..4f4f83e1 100644
--- a/src/explify.sml
+++ b/src/explify.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008, Adam Chlipala
+(* Copyright (c) 2008-2010, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -197,6 +197,7 @@ fun explifyDecl (d, loc : EM.span) =
| L.DStyle (nt, x, n) => SOME (L'.DStyle (nt, x, n), loc)
| L.DTask (e1, e2) => SOME (L'.DTask (explifyExp e1, explifyExp e2), loc)
| L.DPolicy e1 => SOME (L'.DPolicy (explifyExp e1), loc)
+ | L.DOnError v => SOME (L'.DOnError v, loc)
and explifyStr (str, loc) =
case str of
diff --git a/src/mono.sml b/src/mono.sml
index 554b1dc5..1d446dda 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -151,6 +151,7 @@ datatype decl' =
| DTask of exp * exp
| DPolicy of policy
+ | DOnError of int
withtype decl = decl' located
diff --git a/src/mono_env.sml b/src/mono_env.sml
index 87f96488..1df38db3 100644
--- a/src/mono_env.sml
+++ b/src/mono_env.sml
@@ -131,6 +131,7 @@ fun declBinds env (d, loc) =
| DStyle _ => env
| DTask _ => env
| DPolicy _ => env
+ | DOnError _ => env
fun patBinds env (p, loc) =
case p of
diff --git a/src/mono_print.sml b/src/mono_print.sml
index c3f2866e..63c98f44 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -527,7 +527,7 @@ fun p_decl env (dAll as (d, _) : decl) =
| DPolicy p => box [string "policy",
space,
p_policy env p]
-
+ | DOnError _ => string "ONERROR"
fun p_file env file =
let
diff --git a/src/mono_shake.sml b/src/mono_shake.sml
index 50c4b387..d8baf07e 100644
--- a/src/mono_shake.sml
+++ b/src/mono_shake.sml
@@ -70,6 +70,7 @@ fun shake file =
in
usedVars st e1
end
+ | ((DOnError n, _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n))
| (_, st) => st) (IS.empty, IS.empty) file
val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) =>
@@ -87,7 +88,8 @@ fun shake file =
| ((DCookie _, _), acc) => acc
| ((DStyle _, _), acc) => acc
| ((DTask _, _), acc) => acc
- | ((DPolicy _, _), acc) => acc)
+ | ((DPolicy _, _), acc) => acc
+ | ((DOnError _, _), acc) => acc)
(IM.empty, IM.empty) file
fun typ (c, s) =
@@ -155,7 +157,8 @@ fun shake file =
| (DCookie _, _) => true
| (DStyle _, _) => true
| (DTask _, _) => true
- | (DPolicy _, _) => true) file
+ | (DPolicy _, _) => true
+ | (DOnError _, _) => true) file
end
end
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 8a567e83..d75b8300 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -538,6 +538,7 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
S.map2 (mfpol ctx pol,
fn p' =>
(DPolicy p', loc))
+ | DOnError _ => S.return2 dAll
and mfpol ctx pol =
case pol of
@@ -644,6 +645,7 @@ fun mapfoldB (all as {bind, ...}) =
| DStyle _ => ctx
| DTask _ => ctx
| DPolicy _ => ctx
+ | DOnError _ => ctx
in
S.map2 (mff ctx' ds',
fn ds' =>
@@ -698,7 +700,8 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
| DCookie _ => count
| DStyle _ => count
| DTask _ => count
- | DPolicy _ => count) 0
+ | DPolicy _ => count
+ | DOnError _ => count) 0
end
diff --git a/src/monoize.sml b/src/monoize.sml
index 07e69834..bd5787b4 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3962,6 +3962,9 @@ fun monoDecl (env, fm) (all as (d, loc)) =
in
SOME (env, fm, ps)
end
+ | L.DOnError n => SOME (env,
+ fm,
+ [(L'.DOnError n, loc)])
end
datatype expungable = Client | Channel
diff --git a/src/prepare.sml b/src/prepare.sml
index 81de2fa7..4d81940f 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -331,6 +331,7 @@ fun prepDecl (d as (_, loc), st) =
in
((DTask (tk, e), loc), st)
end
+ | DOnError _ => (d, st)
fun prepare (ds, ps) =
let
diff --git a/src/reduce.sml b/src/reduce.sml
index 36c9f44e..7a962926 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -803,6 +803,7 @@ fun reduce file =
namedC,
namedE))
end
+ | DOnError _ => (d, st)
val (file, _) = ListUtil.foldlMap doDecl (IS.empty, IM.empty, IM.empty) file
in
diff --git a/src/reduce_local.sml b/src/reduce_local.sml
index cfa6bfd8..0e87e34a 100644
--- a/src/reduce_local.sml
+++ b/src/reduce_local.sml
@@ -378,6 +378,7 @@ fun reduce file =
| DStyle _ => d
| DTask (e1, e2) => (DTask (exp [] e1, exp [] e2), loc)
| DPolicy e1 => (DPolicy (exp [] e1), loc)
+ | DOnError _ => d
in
map doDecl file
end
diff --git a/src/settings.sig b/src/settings.sig
index 51d06902..3ebf9300 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -206,4 +206,6 @@ signature SETTINGS = sig
val setSafeGets : string list -> unit
val isSafeGet : string -> bool
+ val setOnError : (string * string list * string) option -> unit
+ val getOnError : unit -> (string * string list * string) option
end
diff --git a/src/settings.sml b/src/settings.sml
index af16f9ca..5da1a24e 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -486,4 +486,8 @@ val safeGet = ref SS.empty
fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls)
fun isSafeGet x = SS.member (!safeGet, x)
+val onError = ref (NONE : (string * string list * string) option)
+fun setOnError x = onError := x
+fun getOnError () = !onError
+
end
diff --git a/src/shake.sml b/src/shake.sml
index bc81def9..096c31fd 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -101,6 +101,11 @@ fun shake file =
st
else
usedVars st e1
+ | ((DOnError n, _), st as (usedE, usedC)) =>
+ if !sliceDb then
+ st
+ else
+ (IS.add (usedE, n), usedC)
| (_, acc) => acc) (IS.empty, IS.empty) file
val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef)
@@ -128,7 +133,8 @@ fun shake file =
| ((DStyle (_, n, _), _), (cdef, edef)) =>
(cdef, IM.insert (edef, n, ([], dummyt, dummye)))
| ((DTask _, _), acc) => acc
- | ((DPolicy _, _), acc) => acc)
+ | ((DPolicy _, _), acc) => acc
+ | ((DOnError _, _), acc) => acc)
(IM.empty, IM.empty) file
fun kind (_, s) = s
@@ -216,7 +222,8 @@ fun shake file =
| (DCookie _, _) => not (!sliceDb)
| (DStyle _, _) => not (!sliceDb)
| (DTask _, _) => not (!sliceDb)
- | (DPolicy _, _) => not (!sliceDb)) file
+ | (DPolicy _, _) => not (!sliceDb)
+ | (DOnError _, _) => not (!sliceDb)) file
end
end
diff --git a/src/source.sml b/src/source.sml
index 9768cfc0..b85384ab 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -169,6 +169,7 @@ datatype decl' =
| DStyle of string
| DTask of exp * exp
| DPolicy of exp
+ | DOnError of string * string list * string
and str' =
StrConst of decl list
diff --git a/src/source_print.sml b/src/source_print.sml
index 590d15d5..f6218d22 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -672,6 +672,7 @@ fun p_decl ((d, _) : decl) =
| DPolicy e1 => box [string "policy",
space,
p_exp e1]
+ | DOnError _ => string "ONERROR"
and p_str (str, _) =
case str of
diff --git a/src/unnest.sml b/src/unnest.sml
index a2ec32b0..2d6956cb 100644
--- a/src/unnest.sml
+++ b/src/unnest.sml
@@ -434,6 +434,7 @@ fun unnest file =
| DStyle _ => default ()
| DTask _ => explore ()
| DPolicy _ => explore ()
+ | DOnError _ => default ()
end
and doStr (all as (str, loc), st) =
diff --git a/tests/onerror.ur b/tests/onerror.ur
new file mode 100644
index 00000000..9877d8d7
--- /dev/null
+++ b/tests/onerror.ur
@@ -0,0 +1,4 @@
+fun main n =
+ case n of
+ 0 => error <xml>Zero is bad!</xml>
+ | _ => return <xml/>
diff --git a/tests/onerror.urp b/tests/onerror.urp
new file mode 100644
index 00000000..39d7ac7d
--- /dev/null
+++ b/tests/onerror.urp
@@ -0,0 +1,4 @@
+onError OnerrorE.err
+
+onerrorE
+onerror
diff --git a/tests/onerror.urs b/tests/onerror.urs
new file mode 100644
index 00000000..38b757ea
--- /dev/null
+++ b/tests/onerror.urs
@@ -0,0 +1 @@
+val main : int -> transaction page
diff --git a/tests/onerrorE.ur b/tests/onerrorE.ur
new file mode 100644
index 00000000..b2948c71
--- /dev/null
+++ b/tests/onerrorE.ur
@@ -0,0 +1,5 @@
+fun err x = return <xml><body>
+ <h1>Bad thing!</h1>
+
+ {x}
+</body></xml>