'error' function

14 files changed, 85 insertions, 2 deletions

diff --git a/include/urweb.h b/include/urweb.h
index 2c7576d9..8b74a21b 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -17,7 +17,8 @@ void lw_reset_keep_error_message(lw_context);
 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);
diff --git a/lib/basis.urs b/lib/basis.urs
index 38049f13..b9f773c2 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -17,6 +17,11 @@ val eq_string : eq string
 val eq_bool : eq bool
 
 
+(** String operations *)
+
+val strcat : string -> string -> string
+
+
 (** SQL *)
 
 con sql_table :: {Type} -> Type
@@ -256,3 +261,8 @@ val loption : unit -> tag [Value = string] select [] [] []
 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
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 6f54e1a7..c5f3a716 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -96,7 +96,7 @@ failure_kind lw_begin(lw_context ctx, char *path) {
   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 @@ void lw_error(lw_context ctx, failure_kind fk, const char *fmt, ...) {
   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;
 }
diff --git a/src/cjr.sml b/src/cjr.sml
index 0f261de6..398f94c6 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -66,6 +66,8 @@ datatype exp' =
 
        | 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
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index c813a260..25a84b9c 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -455,6 +455,20 @@ fun p_exp' par env (e, loc) =
         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 "_",
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 71bb2a0d..f3e24710 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -253,6 +253,14 @@ fun cifyExp (eAll as (e, loc), sm) =
                 ((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)
diff --git a/src/mono.sml b/src/mono.sml
index cbe935c0..4ac21330 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -69,6 +69,8 @@ datatype exp' =
 
        | EStrcat of exp * exp
 
+       | EError of exp * typ
+
        | EWrite of exp
        | ESeq of exp * exp
        | ELet of string * typ * exp * exp
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 3c090124..7ae28cf7 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -173,6 +173,15 @@ fun p_exp' par env (e, _) =
                                                                               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 "^",
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index cc44869a..c1972729 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -55,6 +55,8 @@ fun impure (e, _) =
 
       | 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
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 2b257641..f3604cf3 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -197,6 +197,13 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
                                                         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' =>
diff --git a/src/monoize.sml b/src/monoize.sml
index c79bea67..5fd344d4 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1279,6 +1279,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                      _), _),
                     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
diff --git a/src/prepare.sml b/src/prepare.sml
index 67f6e0b6..64ccb465 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -106,6 +106,13 @@ fun prepExp (e as (_, loc), sns) =
             ((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)
diff --git a/tests/error.ur b/tests/error.ur
new file mode 100644
index 00000000..e5586d8d
--- /dev/null
+++ b/tests/error.ur
@@ -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>
diff --git a/tests/error.urp b/tests/error.urp
new file mode 100644
index 00000000..d6579653
--- /dev/null
+++ b/tests/error.urp
@@ -0,0 +1,5 @@
+debug
+database dbname=test
+exe /tmp/webapp
+
+error