'read' type class

13 files changed, 82 insertions, 20 deletions

diff --git a/lib/basis.urs b/lib/basis.urs
index 4275e195..b2f3122d 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -30,9 +30,12 @@ val show_float : show float
 val show_string : show string
 val show_bool : show bool
 
-val stringToInt : string -> option int
-val stringToFloat : string -> option float
-val stringToBool : string -> option bool
+class read
+val read : t ::: Type -> read t -> string -> option t
+val read_int : read int
+val read_float : read float
+val read_string : read string
+val read_bool : read bool
 
 
 (** SQL *)
diff --git a/src/cjr.sml b/src/cjr.sml
index d4c88246..74c4bca2 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -60,6 +60,7 @@ datatype exp' =
        | ERel of int
        | ENamed of int
        | ECon of datatype_kind * patCon * exp option
+       | ESome of typ * exp
        | EFfi of string * string
        | EFfiApp of string * string * exp list
        | EApp of exp * exp
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 8ca7c09d..905c4e10 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -520,6 +520,31 @@ fun p_exp' par env (e, loc) =
                  newline,
                  string "})"]          
         end
+      | ESome (t, e) =>
+        (case #1 t of
+             TDatatype _ => p_exp' par env e
+           | TFfi ("Basis", "string") => p_exp' par env e
+           | _ => box [string "({",
+                       newline,
+                       p_typ env t,
+                       space,
+                       string "*tmp",
+                       space,
+                       string "=",
+                       space,
+                       string "lw_malloc(ctx, sizeof(",
+                       p_typ env t,
+                       string "));",
+                       newline,
+                       string "*tmp",
+                       space,
+                       string "=",
+                       p_exp' par env e,
+                       string ";",
+                       newline,
+                       string "tmp;",
+                       newline,
+                       string "})"])
 
       | EFfi (m, x) => box [string "lw_", string m, string "_", string x]
       | EError (e, t) =>
diff --git a/src/cjrize.sml b/src/cjrize.sml
index a45cf02d..e137c6fd 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -211,6 +211,13 @@ fun cifyExp (eAll as (e, loc), sm) =
         in
             ((L'.ECon (dk, pc, eo), loc), sm)
         end
+      | L.ESome (t, e) =>
+        let
+            val (t, sm) = cifyTyp (t, sm)
+            val (e, sm) = cifyExp (e, sm)
+        in
+            ((L'.ESome (t, e), loc), sm)
+        end
       | L.EFfi mx => ((L'.EFfi mx, loc), sm)
       | L.EFfiApp (m, x, es) =>
         let
diff --git a/src/mono.sml b/src/mono.sml
index 3885c789..8c69443a 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -60,6 +60,7 @@ datatype exp' =
        | ERel of int
        | ENamed of int
        | ECon of datatype_kind * patCon * exp option
+       | ESome of typ * exp
        | EFfi of string * string
        | EFfiApp of string * string * exp list
        | EApp of exp * exp
diff --git a/src/mono_print.sml b/src/mono_print.sml
index da777a82..a2c55b6a 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -132,6 +132,9 @@ fun p_exp' par env (e, _) =
       | ECon (_, pc, SOME e) => parenIf par (box [p_patCon env pc,
                                                   space,
                                                   p_exp' true env e])
+      | ESome (_, e) => parenIf par (box [string "Some",
+                                          space,
+                                          p_exp' true env e])
 
       | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
       | EFfiApp (m, x, es) => box [string "FFI(",
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index c1972729..42f32256 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -45,6 +45,7 @@ fun impure (e, _) =
       | ERel _ => false
       | ENamed _ => false
       | ECon (_, _, eo) => (case eo of NONE => false | SOME e => impure e)
+      | ESome (_, e) => impure e
       | EFfi _ => false
       | EFfiApp _ => false
       | EApp ((EFfi _, _), _) => false
diff --git a/src/mono_util.sml b/src/mono_util.sml
index b2fdff52..90ae3a4f 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -145,6 +145,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
                 S.map2 (mfe ctx e,
                         fn e' =>
                            (ECon (dk, n, SOME e'), loc))
+              | ESome (t, e) =>
+                S.bind2 (mft t,
+                         fn t' =>
+                            S.map2 (mfe ctx e,
+                                 fn e' =>
+                                    (ESome (t', e'), loc)))
               | EFfi _ => S.return2 eAll
               | EFfiApp (m, x, es) =>
                 S.map2 (ListUtil.mapfold (fn e => mfe ctx e) es,
diff --git a/src/monoize.sml b/src/monoize.sml
index 802b12f8..e0f73802 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -85,6 +85,9 @@ 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)
 
                   | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) =>
                     (L'.TFfi ("Basis", "string"), loc)
@@ -490,6 +493,28 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
           | L.EFfi ("Basis", "show_bool") =>
             ((L'.EFfi ("Basis", "boolToString"), loc), fm)
 
+          | L.ECApp ((L.EFfi ("Basis", "read"), _), t) =>
+            let
+                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)
+            end
+          | L.EFfi ("Basis", "read_int") =>
+            ((L'.EFfi ("Basis", "stringToInt"), loc), fm)
+          | L.EFfi ("Basis", "read_float") =>
+            ((L'.EFfi ("Basis", "stringToFloat"), loc), fm)
+          | 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)
+            end
+          | L.EFfi ("Basis", "read_bool") =>
+            ((L'.EFfi ("Basis", "stringToBool"), loc), fm)
+
           | L.ECApp ((L.EFfi ("Basis", "return"), _), t) =>
             let
                 val t = monoType env t
diff --git a/tests/fromString.ur b/tests/fromString.ur
index 673503ae..7c1c5a34 100644
--- a/tests/fromString.ur
+++ b/tests/fromString.ur
@@ -1,15 +1,15 @@
 fun s2i s =
-        case stringToInt s of
+        case read _ s of
           None => 0
         | Some n => n
 
 fun s2f s =
-        case stringToFloat s of
+        case read _ s of
           None => 0.0
         | Some n => n
 
 fun s2b s =
-        case stringToBool s of
+        case read _ s of
           None => False
         | Some b => b
 
diff --git a/tests/show.ur b/tests/show.ur
deleted file mode 100644
index 6a22fe64..00000000
--- a/tests/show.ur
+++ /dev/null
@@ -1,6 +0,0 @@
-fun main () : transaction page = return <html><body>
-        6 = {cdata (show _ 6)}<br/>
-        12.34 = {cdata (show _ 12.34)}<br/>
-        Hi = {cdata (show _ "Hi")}<br/>
-        False = {cdata (show _ False)}<br/>
-</body></html>
diff --git a/tests/show.urp b/tests/show.urp
deleted file mode 100644
index fa69257a..00000000
--- a/tests/show.urp
+++ /dev/null
@@ -1,5 +0,0 @@
-debug
-database dbname=test
-exe /tmp/webapp
-
-show
diff --git a/tests/toString.ur b/tests/toString.ur
index f51ef098..6a22fe64 100644
--- a/tests/toString.ur
+++ b/tests/toString.ur
@@ -1,5 +1,6 @@
 fun main () : transaction page = return <html><body>
-        6 = {cdata (intToString 6)}<br/>
-        12.34 = {cdata (floatToString 12.34)}<br/>
-        False = {cdata (boolToString False)}<br/>
+        6 = {cdata (show _ 6)}<br/>
+        12.34 = {cdata (show _ 12.34)}<br/>
+        Hi = {cdata (show _ "Hi")}<br/>
+        False = {cdata (show _ False)}<br/>
 </body></html>