changeset 283:c0e4ac23522d

'error' function
author Adam Chlipala <adamc@hcoop.net>
date Sun, 07 Sep 2008 10:02:27 -0400 (2008-09-07)
parents 0236d9412ad2
children 77a28e7430bf
files include/urweb.h lib/basis.urs src/c/urweb.c src/cjr.sml src/cjr_print.sml src/cjrize.sml src/mono.sml src/mono_print.sml src/mono_reduce.sml src/mono_util.sml src/monoize.sml src/prepare.sml tests/error.ur tests/error.urp
diffstat 14 files changed, 85 insertions(+), 2 deletions(-) [+]
line wrap: on
line diff
--- a/include/urweb.h	Sun Sep 07 09:28:13 2008 -0400
+++ b/include/urweb.h	Sun Sep 07 10:02:27 2008 -0400
@@ -17,7 +17,8 @@
 failure_kind lw_begin_init(lw_context);
 failure_kind lw_begin(lw_context, char *path);
 
-void lw_error(lw_context, failure_kind, const char *fmt, ...);
+__attribute__((noreturn)) void lw_error(lw_context, failure_kind, const char *fmt, ...);
+__attribute__((noreturn)) void lw_Basis_error(lw_context, lw_Basis_string);
 char *lw_error_message(lw_context);
 
 void *lw_malloc(lw_context, size_t);
--- a/lib/basis.urs	Sun Sep 07 09:28:13 2008 -0400
+++ b/lib/basis.urs	Sun Sep 07 10:02:27 2008 -0400
@@ -17,6 +17,11 @@
 val eq_bool : eq bool
 
 
+(** String operations *)
+
+val strcat : string -> string -> string
+
+
 (** SQL *)
 
 con sql_table :: {Type} -> Type
@@ -256,3 +261,8 @@
 val submit : ctx ::: {Unit} -> [LForm] ~ ctx
         -> use ::: {Type} -> unit
         -> tag [Action = $use -> transaction page] ([LForm] ++ ctx) ([LForm] ++ ctx) use []
+
+
+(** Aborting *)
+
+val error : t ::: Type -> xml [Body] [] [] -> t
--- a/src/c/urweb.c	Sun Sep 07 09:28:13 2008 -0400
+++ b/src/c/urweb.c	Sun Sep 07 10:02:27 2008 -0400
@@ -96,7 +96,7 @@
   return r;
 }
 
-void lw_error(lw_context ctx, failure_kind fk, const char *fmt, ...) {
+__attribute__((noreturn)) void lw_error(lw_context ctx, failure_kind fk, const char *fmt, ...) {
   va_list ap;
   va_start(ap, fmt);
 
@@ -105,6 +105,10 @@
   longjmp(ctx->jmp_buf, fk);
 }
 
+__attribute__((noreturn)) void lw_Basis_error(lw_context ctx, const char *s) {
+  lw_error(ctx, FATAL, s);
+}
+
 char *lw_error_message(lw_context ctx) {
   return ctx->error_message;
 }
--- a/src/cjr.sml	Sun Sep 07 09:28:13 2008 -0400
+++ b/src/cjr.sml	Sun Sep 07 10:02:27 2008 -0400
@@ -66,6 +66,8 @@
 
        | ECase of exp * (pat * exp) list * { disc : typ, result : typ }
 
+       | EError of exp * typ
+
        | EWrite of exp
        | ESeq of exp * exp
        | ELet of string * typ * exp * exp
--- a/src/cjr_print.sml	Sun Sep 07 09:28:13 2008 -0400
+++ b/src/cjr_print.sml	Sun Sep 07 10:02:27 2008 -0400
@@ -455,6 +455,20 @@
         end
 
       | EFfi (m, x) => box [string "lw_", string m, string "_", string x]
+      | EError (e, t) =>
+        box [string "({",
+             newline,
+             p_typ env t,
+             space,
+             string "tmp;",
+             newline,
+             string "lw_Basis_error(ctx, ",
+             p_exp env e,
+             string ");",
+             newline,
+             string "tmp;",
+             newline,
+             string "})"]
       | EFfiApp (m, x, es) => box [string "lw_",
                                    string m,
                                    string "_",
--- a/src/cjrize.sml	Sun Sep 07 09:28:13 2008 -0400
+++ b/src/cjrize.sml	Sun Sep 07 10:02:27 2008 -0400
@@ -253,6 +253,14 @@
                 ((L'.ECase (e, pes, {disc = disc, result = result}), loc), sm)
             end
 
+      | L.EError (e, t) =>
+        let
+            val (e, sm) = cifyExp (e, sm)
+            val (t, sm) = cifyTyp (t, sm)
+        in
+            ((L'.EError (e, t), loc), sm)
+        end
+
       | L.EStrcat (e1, e2) =>
         let
             val (e1, sm) = cifyExp (e1, sm)
--- a/src/mono.sml	Sun Sep 07 09:28:13 2008 -0400
+++ b/src/mono.sml	Sun Sep 07 10:02:27 2008 -0400
@@ -69,6 +69,8 @@
 
        | EStrcat of exp * exp
 
+       | EError of exp * typ
+
        | EWrite of exp
        | ESeq of exp * exp
        | ELet of string * typ * exp * exp
--- a/src/mono_print.sml	Sun Sep 07 09:28:13 2008 -0400
+++ b/src/mono_print.sml	Sun Sep 07 10:02:27 2008 -0400
@@ -173,6 +173,15 @@
                                                                               space,
                                                                               p_exp (E.patBinds env p) e]) pes])
 
+      | EError (e, t) => box [string "(error",
+                              space,
+                              p_exp env e,
+                              space,
+                              string ":",
+                              space,
+                              p_typ env t,
+                              string ")"]
+
       | EStrcat (e1, e2) => box [p_exp' true env e1,
                                  space,
                                  string "^",
--- a/src/mono_reduce.sml	Sun Sep 07 09:28:13 2008 -0400
+++ b/src/mono_reduce.sml	Sun Sep 07 10:02:27 2008 -0400
@@ -55,6 +55,8 @@
 
       | ECase (e, pes, _) => impure e orelse List.exists (fn (_, e) => impure e) pes
 
+      | EError (e, _) => impure e
+
       | EStrcat (e1, e2) => impure e1 orelse impure e2
 
       | ESeq (e1, e2) => impure e1 orelse impure e2
--- a/src/mono_util.sml	Sun Sep 07 09:28:13 2008 -0400
+++ b/src/mono_util.sml	Sun Sep 07 10:02:27 2008 -0400
@@ -197,6 +197,13 @@
                                                         fn result' =>
                                                            (ECase (e', pes', {disc = disc', result = result'}), loc)))))
 
+              | EError (e, t) =>
+                S.bind2 (mfe ctx e,
+                         fn e' =>
+                            S.map2 (mft t,
+                                    fn t' =>
+                                       (EError (e', t'), loc)))
+
               | EStrcat (e1, e2) =>
                 S.bind2 (mfe ctx e1,
                       fn e1' =>
--- a/src/monoize.sml	Sun Sep 07 09:28:13 2008 -0400
+++ b/src/monoize.sml	Sun Sep 07 10:02:27 2008 -0400
@@ -1279,6 +1279,15 @@
                      _), _),
                     xml) => monoExp (env, st, fm) xml
 
+          | L.ECApp ((L.EFfi ("Basis", "error"), _), t) =>
+            let
+                val t = monoType env t
+            in
+                ((L'.EAbs ("s", (L'.TFfi ("Basis", "string"), loc), t,
+                           (L'.EError ((L'.ERel 0, loc), t), loc)), loc),
+                 fm)
+            end
+
           | L.EApp (e1, e2) =>
             let
                 val (e1, fm) = monoExp (env, st, fm) e1
--- a/src/prepare.sml	Sun Sep 07 09:28:13 2008 -0400
+++ b/src/prepare.sml	Sun Sep 07 10:02:27 2008 -0400
@@ -106,6 +106,13 @@
             ((ECase (e, pes, ts), loc), sns)
         end
 
+      | EError (e, t) =>
+        let
+            val (e, sns) = prepExp (e, sns)
+        in
+            ((EError (e, t), loc), sns)
+        end
+
       | EWrite e =>
         let
             val (e, sns) = prepExp (e, sns)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/error.ur	Sun Sep 07 10:02:27 2008 -0400
@@ -0,0 +1,3 @@
+fun main () : transaction page = return <html><body>
+        <font size={error <body>I couldn't make up my <b>mind</b>!</body>}>Hello!</font>
+</body></html>
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/error.urp	Sun Sep 07 10:02:27 2008 -0400
@@ -0,0 +1,5 @@
+debug
+database dbname=test
+exe /tmp/webapp
+
+error