Error-parsing ints

8 files changed, 76 insertions, 20 deletions

diff --git a/include/urweb.h b/include/urweb.h
index 83039520..7715cc21 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -18,7 +18,6 @@ failure_kind lw_begin_init(lw_context);
 failure_kind lw_begin(lw_context, char *path);
 
 __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);
@@ -81,3 +80,5 @@ lw_Basis_string lw_Basis_boolToString(lw_context, lw_Basis_bool);
 lw_Basis_int *lw_Basis_stringToInt(lw_context, lw_Basis_string);
 lw_Basis_float *lw_Basis_stringToFloat(lw_context, lw_Basis_string);
 lw_Basis_bool *lw_Basis_stringToBool(lw_context, lw_Basis_string);
+
+lw_Basis_int lw_Basis_stringToInt_error(lw_context, lw_Basis_string);
diff --git a/lib/basis.urs b/lib/basis.urs
index b2f3122d..3bd2459c 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -32,6 +32,8 @@ val show_bool : show bool
 
 class read
 val read : t ::: Type -> read t -> string -> option t
+val readError : t ::: Type -> read t -> string -> t
+(* [readError] calls [error] if the input is malformed. *)
 val read_int : read int
 val read_float : read float
 val read_string : read string
diff --git a/src/c/urweb.c b/src/c/urweb.c
index bf697340..1286ca5e 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -105,10 +105,6 @@ __attribute__((noreturn)) void lw_error(lw_context ctx, failure_kind fk, const c
   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;
 }
@@ -793,3 +789,13 @@ lw_Basis_bool *lw_Basis_stringToBool(lw_context ctx, lw_Basis_string s) {
   else
     return NULL;
 }
+
+lw_Basis_int lw_Basis_stringToInt_error(lw_context ctx, lw_Basis_string s) {
+  char *endptr;
+  lw_Basis_int n = strtoll(s, &endptr, 10);
+
+  if (*s != '\0' && *endptr == '\0')
+    return n;
+  else
+    lw_error(ctx, FATAL, "Can't parse int: %s", s);
+}
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 905c4e10..e9bc54de 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -554,7 +554,9 @@ fun p_exp' par env (e, loc) =
              space,
              string "tmp;",
              newline,
-             string "lw_Basis_error(ctx, ",
+             string "lw_error(ctx, FATAL, \"",
+             string (ErrorMsg.spanToString loc),
+             string ": %s\", ",
              p_exp env e,
              string ");",
              newline,
diff --git a/src/mono_print.sml b/src/mono_print.sml
index a2c55b6a..19084a65 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -62,11 +62,9 @@ fun p_typ' par env (t, _) =
               string (#1 (E.lookupDatatype env n)))
          handle E.UnboundNamed _ => string ("UNBOUND_DATATYPE_" ^ Int.toString n))
       | TFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
-      | TOption t =>
-        (case #1 t of
-             TDatatype _ => p_typ env t
-           | TFfi ("Basis", "string") => p_typ env t
-           | _ => box [p_typ env t, string "*"])
+      | TOption t => box [string "option(",
+                          p_typ env t,
+                          string ")"]
 
 and p_typ env = p_typ' false env
 
diff --git a/src/monoize.sml b/src/monoize.sml
index e0f73802..ebca1d43 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -64,6 +64,15 @@ fun monoName env (all as (c, loc)) =
           | _ => poly ()
     end
 
+fun readType' (t, loc) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc),
+                                   (L'.TOption t, loc)), loc)
+fun readErrType (t, loc) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc),
+                                     t), loc)
+fun readType (t, loc) =
+    (L'.TRecord [("Read", readType' (t, loc)),
+                 ("ReadError", readErrType (t, loc))],
+     loc)
+
 fun monoType env =
     let
         fun mt env dtmap (all as (c, loc)) =
@@ -86,8 +95,7 @@ fun monoType env =
                   | L.CApp ((L.CFfi ("Basis", "show"), _), t) =>
                     (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
                   | L.CApp ((L.CFfi ("Basis", "read"), _), t) =>
-                    (L'.TFun ((L'.TFfi ("Basis", "string"), loc),
-                              (L'.TOption (mt env dtmap t), loc)), loc)
+                    readType (mt env dtmap t, loc)
 
                   | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) =>
                     (L'.TFfi ("Basis", "string"), loc)
@@ -498,22 +506,53 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                 val t = monoType env t
                 val s = (L'.TFfi ("Basis", "string"), loc)
             in
-                ((L'.EAbs ("f", (L'.TFun (t, s), loc), (L'.TFun (t, s), loc),
-                           (L'.ERel 0, loc)), loc), fm)
+                ((L'.EAbs ("f", readType (t, loc), readType' (t, loc),
+                           (L'.EField ((L'.ERel 0, loc), "Read"), loc)), loc), fm)
+            end
+          | L.ECApp ((L.EFfi ("Basis", "readError"), _), t) =>
+            let
+                val t = monoType env t
+                val s = (L'.TFfi ("Basis", "string"), loc)
+            in
+                ((L'.EAbs ("f", readType (t, loc), readErrType (t, loc),
+                           (L'.EField ((L'.ERel 0, loc), "ReadError"), loc)), loc), fm)
             end
           | L.EFfi ("Basis", "read_int") =>
-            ((L'.EFfi ("Basis", "stringToInt"), loc), fm)
+            let
+                val t = (L'.TFfi ("Basis", "int"), loc)
+            in
+                ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToInt"), loc), readType' (t, loc)),
+                               ("ReadError", (L'.EFfi ("Basis", "stringToInt_error"), loc), readErrType (t, loc))],
+                  loc),
+                 fm)
+            end
           | L.EFfi ("Basis", "read_float") =>
-            ((L'.EFfi ("Basis", "stringToFloat"), loc), fm)
+            let
+                val t = (L'.TFfi ("Basis", "float"), loc)
+            in
+                ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToFloat"), loc), readType' (t, loc)),
+                              ("ReadError", (L'.EFfi ("Basis", "stringToFloat_error"), loc), readErrType (t, loc))],
+                  loc),
+                 fm)
+            end
           | L.EFfi ("Basis", "read_string") =>
             let
                 val s = (L'.TFfi ("Basis", "string"), loc)
             in
-                ((L'.EAbs ("s", s, (L'.TOption s, loc),
-                           (L'.ESome (s, (L'.ERel 0, loc)), loc)), loc), fm)
+                ((L'.ERecord [("Read", (L'.EAbs ("s", s, (L'.TOption s, loc),
+                                                 (L'.ESome (s, (L'.ERel 0, loc)), loc)), loc), readType' (s, loc)),
+                              ("ReadError", (L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), readErrType (s, loc))], loc),
+                 fm)
             end
           | L.EFfi ("Basis", "read_bool") =>
-            ((L'.EFfi ("Basis", "stringToBool"), loc), fm)
+            let
+                val t = (L'.TFfi ("Basis", "bool"), loc)
+            in
+                ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToBool"), loc), readType' (t, loc)),
+                              ("ReadError", (L'.EFfi ("Basis", "stringToBool_error"), loc), readErrType (t, loc))],
+                  loc),
+                 fm)
+            end
 
           | L.ECApp ((L.EFfi ("Basis", "return"), _), t) =>
             let
diff --git a/tests/fromStringErr.ur b/tests/fromStringErr.ur
new file mode 100644
index 00000000..07899d02
--- /dev/null
+++ b/tests/fromStringErr.ur
@@ -0,0 +1,3 @@
+fun main () : transaction page = return <html><body>
+        3 = {cdata (show _ (readError _ "3" : int))}<br/>
+</body></html>
diff --git a/tests/fromStringErr.urp b/tests/fromStringErr.urp
new file mode 100644
index 00000000..9f6abbee
--- /dev/null
+++ b/tests/fromStringErr.urp
@@ -0,0 +1,5 @@
+debug
+database dbname=test
+exe /tmp/webapp
+
+fromStringErr