changeset 292:6e665c7c96f6

Error-parsing ints
author Adam Chlipala <adamc@hcoop.net>
date Sun, 07 Sep 2008 12:15:46 -0400 (2008-09-07)
parents 550100a44cca
children 711aad3869d1
files include/urweb.h lib/basis.urs src/c/urweb.c src/cjr_print.sml src/mono_print.sml src/monoize.sml tests/fromStringErr.ur tests/fromStringErr.urp
diffstat 8 files changed, 76 insertions(+), 20 deletions(-) [+]
line wrap: on
line diff
--- a/include/urweb.h	Sun Sep 07 11:56:53 2008 -0400
+++ b/include/urweb.h	Sun Sep 07 12:15:46 2008 -0400
@@ -18,7 +18,6 @@
 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_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);
--- a/lib/basis.urs	Sun Sep 07 11:56:53 2008 -0400
+++ b/lib/basis.urs	Sun Sep 07 12:15:46 2008 -0400
@@ -32,6 +32,8 @@
 
 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
--- a/src/c/urweb.c	Sun Sep 07 11:56:53 2008 -0400
+++ b/src/c/urweb.c	Sun Sep 07 12:15:46 2008 -0400
@@ -105,10 +105,6 @@
   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 @@
   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);
+}
--- a/src/cjr_print.sml	Sun Sep 07 11:56:53 2008 -0400
+++ b/src/cjr_print.sml	Sun Sep 07 12:15:46 2008 -0400
@@ -554,7 +554,9 @@
              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,
--- a/src/mono_print.sml	Sun Sep 07 11:56:53 2008 -0400
+++ b/src/mono_print.sml	Sun Sep 07 12:15:46 2008 -0400
@@ -62,11 +62,9 @@
               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
 
--- a/src/monoize.sml	Sun Sep 07 11:56:53 2008 -0400
+++ b/src/monoize.sml	Sun Sep 07 12:15:46 2008 -0400
@@ -64,6 +64,15 @@
           | _ => 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 @@
                   | 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 @@
                 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
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/fromStringErr.ur	Sun Sep 07 12:15:46 2008 -0400
@@ -0,0 +1,3 @@
+fun main () : transaction page = return <html><body>
+        3 = {cdata (show _ (readError _ "3" : int))}<br/>
+</body></html>
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/fromStringErr.urp	Sun Sep 07 12:15:46 2008 -0400
@@ -0,0 +1,5 @@
+debug
+database dbname=test
+exe /tmp/webapp
+
+fromStringErr