Mercurial > urweb
changeset 1294:b4480a56cab7
Server-side 'onError'
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Tue, 07 Sep 2010 08:28:07 -0400 |
| parents | acabf3935060 |
| children | 929981850d9d |
| files | include/types.h include/urweb.h src/c/request.c src/c/urweb.c src/cjr.sml src/cjr_env.sml src/cjr_print.sml src/cjrize.sml src/compiler.sig src/compiler.sml src/core.sml src/core_env.sml src/core_print.sml src/core_util.sml src/corify.sml src/css.sml src/demo.sml src/elab.sml src/elab_env.sml src/elab_print.sml src/elab_util.sml src/elaborate.sml src/expl.sml src/expl_env.sml src/expl_print.sml src/explify.sml src/mono.sml src/mono_env.sml src/mono_print.sml src/mono_shake.sml src/mono_util.sml src/monoize.sml src/prepare.sml src/reduce.sml src/reduce_local.sml src/settings.sig src/settings.sml src/shake.sml src/source.sml src/source_print.sml src/unnest.sml tests/onerror.ur tests/onerror.urp tests/onerror.urs tests/onerrorE.ur |
| diffstat | 45 files changed, 244 insertions(+), 59 deletions(-) [+] |
line wrap: on
line diff
--- a/include/types.h Sun Sep 05 14:00:57 2010 -0400 +++ b/include/types.h Tue Sep 07 08:28:07 2010 -0400 @@ -73,6 +73,10 @@ 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
--- a/include/urweb.h Sun Sep 05 14:00:57 2010 -0400 +++ b/include/urweb.h Tue Sep 07 08:28:07 2010 -0400 @@ -36,6 +36,7 @@ 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);
--- a/src/c/request.c Sun Sep 05 14:00:57 2010 -0400 +++ b/src/c/request.c Tue Sep 07 08:28:07 2010 -0400 @@ -131,6 +131,8 @@ 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 @@ 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); + 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 (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 @@ 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 @@ 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))
--- a/src/c/urweb.c Sun Sep 05 14:00:57 2010 -0400 +++ b/src/c/urweb.c Tue Sep 07 08:28:07 2010 -0400 @@ -353,8 +353,6 @@ // Single-request state -#define ERROR_BUF_LEN 1024 - typedef struct regions { struct regions *next; } regions; @@ -714,6 +712,22 @@ 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");
--- a/src/cjr.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/cjr.sml Tue Sep 07 08:28:07 2010 -0400 @@ -124,6 +124,7 @@ | DStyle of string | DTask of task * exp + | DOnError of int withtype decl = decl' located
--- a/src/cjr_env.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/cjr_env.sml Tue Sep 07 08:28:07 2010 -0400 @@ -172,5 +172,6 @@ | DCookie _ => env | DStyle _ => env | DTask _ => env + | DOnError _ => env end
--- a/src/cjr_print.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/cjr_print.sml Tue Sep 07 08:28:07 2010 -0400 @@ -113,9 +113,11 @@ 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 @@ string "*/"] | DTask _ => box [] + | DOnError _ => box [] datatype 'a search = Found of 'a @@ -2791,6 +2794,8 @@ 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 @@ 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 @@ "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
--- a/src/cjrize.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/cjrize.sml Tue Sep 07 08:28:07 2010 -0400 @@ -675,6 +675,7 @@ | _ => (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
--- a/src/compiler.sig Sun Sep 05 14:00:57 2010 -0400 +++ b/src/compiler.sig Tue Sep 07 08:28:07 2010 -0400 @@ -54,7 +54,8 @@ 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
--- a/src/compiler.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/compiler.sml Tue Sep 07 08:28:07 2010 -0400 @@ -58,7 +58,8 @@ 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 @@ val dbms = ref NONE val sigFile = ref (Settings.getSigFile ()) val safeGets = ref [] + val onError = ref NONE fun finish sources = let @@ -425,7 +427,8 @@ protocol = !protocol, dbms = !dbms, sigFile = !sigFile, - safeGets = rev (!safeGets) + safeGets = rev (!safeGets), + onError = !onError } fun mergeO f (old, new) = @@ -469,7 +472,8 @@ 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 @@ (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 @@ 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 @@ 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 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
--- a/src/core.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/core.sml Tue Sep 07 08:28:07 2010 -0400 @@ -136,6 +136,7 @@ | DStyle of string * int * string | DTask of exp * exp | DPolicy of exp + | DOnError of int withtype decl = decl' located
--- a/src/core_env.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/core_env.sml Tue Sep 07 08:28:07 2010 -0400 @@ -350,6 +350,7 @@ end | DTask _ => env | DPolicy _ => env + | DOnError _ => env fun patBinds env (p, loc) = case p of
--- a/src/core_print.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/core_print.sml Tue Sep 07 08:28:07 2010 -0400 @@ -628,6 +628,7 @@ | DPolicy e1 => box [string "policy", space, p_exp env e1] + | DOnError _ => string "ONERROR" fun p_file env file = let
--- a/src/core_util.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/core_util.sml Tue Sep 07 08:28:07 2010 -0400 @@ -997,6 +997,8 @@ 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 @@ end | DTask _ => ctx | DPolicy _ => ctx + | DOnError _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -1216,7 +1219,8 @@ | DCookie (_, n, _, _) => Int.max (n, count) | DStyle (_, n, _) => Int.max (n, count) | DTask _ => count - | DPolicy _ => count) 0 + | DPolicy _ => count + | DOnError _ => count) 0 end
--- a/src/corify.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/corify.sml Tue Sep 07 08:28:07 2010 -0400 @@ -1083,6 +1083,17 @@ | 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 @@ | 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, _) =
--- a/src/css.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/css.sml Tue Sep 07 08:28:07 2010 -0400 @@ -288,6 +288,7 @@ | 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
--- a/src/demo.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/demo.sml Tue Sep 07 08:28:07 2010 -0400 @@ -115,7 +115,8 @@ 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")
--- a/src/elab.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/elab.sml Tue Sep 07 08:28:07 2010 -0400 @@ -172,6 +172,7 @@ | DStyle of int * string * int | DTask of exp * exp | DPolicy of exp + | DOnError of int * string list * string and str' = StrConst of decl list
--- a/src/elab_env.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/elab_env.sml Tue Sep 07 08:28:07 2010 -0400 @@ -1633,5 +1633,6 @@ end | DTask _ => env | DPolicy _ => env + | DOnError _ => env end
--- a/src/elab_print.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/elab_print.sml Tue Sep 07 08:28:07 2010 -0400 @@ -816,6 +816,7 @@ | DPolicy e1 => box [string "policy", space, p_exp env e1] + | DOnError _ => string "ONERROR" and p_str env (str, _) = case str of
--- a/src/elab_util.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/elab_util.sml Tue Sep 07 08:28:07 2010 -0400 @@ -883,7 +883,8 @@ | 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 @@ 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 @@ | DStyle (n1, _, n2) => Int.max (n1, n2) | DTask _ => 0 | DPolicy _ => 0 + | DOnError _ => 0 and maxNameStr (str, _) = case str of StrConst ds => maxName ds
--- a/src/elaborate.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/elaborate.sml Tue Sep 07 08:28:07 2010 -0400 @@ -2679,6 +2679,7 @@ | 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 @@ ([(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)];*)
--- a/src/expl.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/expl.sml Tue Sep 07 08:28:07 2010 -0400 @@ -149,6 +149,7 @@ | DStyle of int * string * int | DTask of exp * exp | DPolicy of exp + | DOnError of int * string list * string and str' = StrConst of decl list
--- a/src/expl_env.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/expl_env.sml Tue Sep 07 08:28:07 2010 -0400 @@ -345,6 +345,7 @@ end | DTask _ => env | DPolicy _ => env + | DOnError _ => env fun sgiBinds env (sgi, loc) = case sgi of
--- a/src/expl_print.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/expl_print.sml Tue Sep 07 08:28:07 2010 -0400 @@ -730,6 +730,7 @@ | DPolicy e1 => box [string "policy", space, p_exp env e1] + | DOnError _ => string "ONERROR" and p_str env (str, _) = case str of
--- a/src/explify.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/explify.sml Tue Sep 07 08:28:07 2010 -0400 @@ -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 @@ | 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
--- a/src/mono.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/mono.sml Tue Sep 07 08:28:07 2010 -0400 @@ -151,6 +151,7 @@ | DTask of exp * exp | DPolicy of policy + | DOnError of int withtype decl = decl' located
--- a/src/mono_env.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/mono_env.sml Tue Sep 07 08:28:07 2010 -0400 @@ -131,6 +131,7 @@ | DStyle _ => env | DTask _ => env | DPolicy _ => env + | DOnError _ => env fun patBinds env (p, loc) = case p of
--- a/src/mono_print.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/mono_print.sml Tue Sep 07 08:28:07 2010 -0400 @@ -527,7 +527,7 @@ | DPolicy p => box [string "policy", space, p_policy env p] - + | DOnError _ => string "ONERROR" fun p_file env file = let
--- a/src/mono_shake.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/mono_shake.sml Tue Sep 07 08:28:07 2010 -0400 @@ -70,6 +70,7 @@ 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 @@ | ((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 @@ | (DCookie _, _) => true | (DStyle _, _) => true | (DTask _, _) => true - | (DPolicy _, _) => true) file + | (DPolicy _, _) => true + | (DOnError _, _) => true) file end end
--- a/src/mono_util.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/mono_util.sml Tue Sep 07 08:28:07 2010 -0400 @@ -538,6 +538,7 @@ 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 @@ | DStyle _ => ctx | DTask _ => ctx | DPolicy _ => ctx + | DOnError _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -698,7 +700,8 @@ | DCookie _ => count | DStyle _ => count | DTask _ => count - | DPolicy _ => count) 0 + | DPolicy _ => count + | DOnError _ => count) 0 end
--- a/src/monoize.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/monoize.sml Tue Sep 07 08:28:07 2010 -0400 @@ -3962,6 +3962,9 @@ in SOME (env, fm, ps) end + | L.DOnError n => SOME (env, + fm, + [(L'.DOnError n, loc)]) end datatype expungable = Client | Channel
--- a/src/prepare.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/prepare.sml Tue Sep 07 08:28:07 2010 -0400 @@ -331,6 +331,7 @@ in ((DTask (tk, e), loc), st) end + | DOnError _ => (d, st) fun prepare (ds, ps) = let
--- a/src/reduce.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/reduce.sml Tue Sep 07 08:28:07 2010 -0400 @@ -803,6 +803,7 @@ namedC, namedE)) end + | DOnError _ => (d, st) val (file, _) = ListUtil.foldlMap doDecl (IS.empty, IM.empty, IM.empty) file in
--- a/src/reduce_local.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/reduce_local.sml Tue Sep 07 08:28:07 2010 -0400 @@ -378,6 +378,7 @@ | DStyle _ => d | DTask (e1, e2) => (DTask (exp [] e1, exp [] e2), loc) | DPolicy e1 => (DPolicy (exp [] e1), loc) + | DOnError _ => d in map doDecl file end
--- a/src/settings.sig Sun Sep 05 14:00:57 2010 -0400 +++ b/src/settings.sig Tue Sep 07 08:28:07 2010 -0400 @@ -206,4 +206,6 @@ 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
--- a/src/settings.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/settings.sml Tue Sep 07 08:28:07 2010 -0400 @@ -486,4 +486,8 @@ 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
--- a/src/shake.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/shake.sml Tue Sep 07 08:28:07 2010 -0400 @@ -101,6 +101,11 @@ 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 @@ | ((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 @@ | (DCookie _, _) => not (!sliceDb) | (DStyle _, _) => not (!sliceDb) | (DTask _, _) => not (!sliceDb) - | (DPolicy _, _) => not (!sliceDb)) file + | (DPolicy _, _) => not (!sliceDb) + | (DOnError _, _) => not (!sliceDb)) file end end
--- a/src/source.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/source.sml Tue Sep 07 08:28:07 2010 -0400 @@ -169,6 +169,7 @@ | DStyle of string | DTask of exp * exp | DPolicy of exp + | DOnError of string * string list * string and str' = StrConst of decl list
--- a/src/source_print.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/source_print.sml Tue Sep 07 08:28:07 2010 -0400 @@ -672,6 +672,7 @@ | DPolicy e1 => box [string "policy", space, p_exp e1] + | DOnError _ => string "ONERROR" and p_str (str, _) = case str of
--- a/src/unnest.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/unnest.sml Tue Sep 07 08:28:07 2010 -0400 @@ -434,6 +434,7 @@ | DStyle _ => default () | DTask _ => explore () | DPolicy _ => explore () + | DOnError _ => default () end and doStr (all as (str, loc), st) =
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/onerror.ur Tue Sep 07 08:28:07 2010 -0400 @@ -0,0 +1,4 @@ +fun main n = + case n of + 0 => error <xml>Zero is bad!</xml> + | _ => return <xml/>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/onerror.urp Tue Sep 07 08:28:07 2010 -0400 @@ -0,0 +1,4 @@ +onError OnerrorE.err + +onerrorE +onerror