Datatypes through monoize

7 files changed, 82 insertions, 11 deletions

diff --git a/src/cjrize.sml b/src/cjrize.sml
index 6796b467..062e2a5a 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -160,7 +160,9 @@ fun cifyExp ((e, loc), sm) =
 
 fun cifyDecl ((d, loc), sm) =
     case d of
-        L.DVal (x, n, t, e, _) =>
+        L.DDatatype _ => raise Fail "Cjrize DDatatype"
+
+      | L.DVal (x, n, t, e, _) =>
         let
             val (t, sm) = cifyTyp (t, sm)
 
diff --git a/src/mono.sml b/src/mono.sml
index 13ba3adf..cdfcecd3 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -60,7 +60,8 @@ datatype exp' =
 withtype exp = exp' located
 
 datatype decl' =
-         DVal of string * int * typ * exp * string
+         DDatatype of string * int * (string * int * typ option) list
+       | DVal of string * int * typ * exp * string
        | DValRec of (string * int * typ * exp * string) list
        | DExport of Core.export_kind * string * int * typ list
 
diff --git a/src/mono_env.sml b/src/mono_env.sml
index 0134b471..00f31c16 100644
--- a/src/mono_env.sml
+++ b/src/mono_env.sml
@@ -81,9 +81,17 @@ fun lookupENamed (env : env) n =
         NONE => raise UnboundNamed n
       | SOME x => x
 
-fun declBinds env (d, _) =
+fun declBinds env (d, loc) =
     case d of
-        DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s
+        DDatatype (x, n, xncs) =>
+        let
+            val env = pushTNamed env x n NONE
+        in
+            foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (TNamed n, loc) NONE ""
+                    | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (TNamed n, loc)), loc) NONE "")
+            env xncs
+        end
+      | DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s
       | DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis
       | DExport _ => env
 
diff --git a/src/mono_print.sml b/src/mono_print.sml
index c485e3c8..4ab38af3 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -162,9 +162,28 @@ fun p_vali env (x, n, t, e, s) =
              p_exp env e]
     end
 
+fun p_datatype env (x, n, cons) =
+    let
+        val env = E.pushTNamed env x n NONE
+    in
+        box [string "datatype",
+             space,
+             string x,
+             space,
+             string "=",
+             space,
+             p_list_sep (box [space, string "|", space])
+                        (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n))
+                                            else string x
+                          | (x, _, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n))
+                                                   else string x, space, string "of", space, p_typ env t])
+                        cons]
+    end
+
 fun p_decl env (dAll as (d, _) : decl) =
     case d of
-        DVal vi => box [string "val",
+        DDatatype x => p_datatype env x
+      | DVal vi => box [string "val",
                         space,
                         p_vali env vi]
       | DValRec vis =>
diff --git a/src/mono_shake.sml b/src/mono_shake.sml
index 76d05061..490c33c8 100644
--- a/src/mono_shake.sml
+++ b/src/mono_shake.sml
@@ -47,13 +47,22 @@ fun shake file =
                           (fn ((DExport (_, _, n, _), _), page_es) => n :: page_es
                             | (_, page_es) => page_es) [] file
 
-        val (cdef, edef) = foldl (fn ((DVal (_, n, t, e, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, (t, e)))
+        val (cdef, edef) = foldl (fn ((DDatatype _, _), acc) => acc
+                                   | ((DVal (_, n, t, e, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, (t, e)))
                                    | ((DValRec vis, _), (cdef, edef)) =>
                                      (cdef, foldl (fn ((_, n, t, e, _), edef) => IM.insert (edef, n, (t, e))) edef vis)
                                    | ((DExport _, _), acc) => acc)
                                  (IM.empty, IM.empty) file
 
-        fun typ (_, s) = s
+        fun typ (c, s) =
+            case c of
+                TNamed n =>
+                if IS.member (#con s, n) then
+                    s
+                else
+                    {exp = #exp s,
+                     con = IS.add (#con s, n)}
+              | _ => s
 
         fun exp (e, s) =
             case e of
@@ -80,7 +89,8 @@ fun shake file =
                               NONE => raise Fail "Shake: Couldn't find 'val'"
                             | SOME (t, e) => shakeExp s e) s page_es
     in
-        List.filter (fn (DVal (_, n, _, _, _), _) => IS.member (#exp s, n)
+        List.filter (fn (DDatatype (_, n, _), _) => IS.member (#con s, n)
+                      | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n)
                       | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis
                       | (DExport _, _) => true) file
     end
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 2395cc90..1232e7dd 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -258,7 +258,16 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
 
         and mfd' ctx (dAll as (d, loc)) =
             case d of
-                DVal vi =>
+                DDatatype (x, n, xncs) =>
+                S.map2 (ListUtil.mapfold (fn (x, n, c) =>
+                                             case c of
+                                                 NONE => S.return2 (x, n, c)
+                                               | SOME c =>
+                                                 S.map2 (mft c,
+                                                      fn c' => (x, n, SOME c'))) xncs,
+                        fn xncs' =>
+                           (DDatatype (x, n, xncs'), loc))
+              | DVal vi =>
                 S.map2 (mfvi ctx vi,
                      fn vi' =>
                         (DVal vi', loc))
@@ -313,7 +322,22 @@ fun mapfoldB (all as {bind, ...}) =
                             let
                                 val ctx' =
                                     case #1 d' of
-                                        DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s))
+                                        DDatatype (x, n, xncs) =>
+                                        let
+                                            val ctx = bind (ctx, NamedT (x, n, NONE))
+                                            val t = (TNamed n, #2 d')
+                                        in
+                                            foldl (fn ((x, n, to), ctx) =>
+                                                      let
+                                                          val t = case to of
+                                                                      NONE => t
+                                                                    | SOME t' => (TFun (t', t), #2 d')
+                                                      in
+                                                          bind (ctx, NamedE (x, n, t, NONE, ""))
+                                                      end)
+                                            ctx xncs
+                                        end
+                                      | DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s))
                                       | DValRec vis => foldl (fn ((x, n, t, e, s), ctx) =>
                                                                  bind (ctx, NamedE (x, n, t, SOME e, s))) ctx vis
                                       | DExport _ => ctx
diff --git a/src/monoize.sml b/src/monoize.sml
index b17fe805..8e3bfaba 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -115,6 +115,8 @@ fun fooifyExp name env =
                   | L'.TFfi ("Basis", "float") => (L'.EFfiApp ("Basis", name ^ "ifyFloat", [e]), loc)
                   | L'.TRecord [] => (L'.EPrim (Prim.String ""), loc)
 
+                  | L'.TNamed _ => (L'.EPrim (Prim.String ""), loc)
+
                   | _ => (E.errorAt loc "Don't know how to encode attribute type";
                           Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
                           dummyExp)
@@ -453,7 +455,12 @@ fun monoDecl env (all as (d, loc)) =
     in
         case d of
             L.DCon _ => NONE
-          | L.DDatatype _ => raise Fail "Monoize DDatatype"
+          | L.DDatatype (x, n, xncs) =>
+            let
+                val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs), loc)
+            in
+                SOME (Env.declBinds env all, d)
+            end
           | L.DVal (x, n, t, e, s) => SOME (Env.pushENamed env x n t (SOME e) s,
                                             (L'.DVal (x, n, monoType env t, monoExp (env, St.empty) e, s), loc))
           | L.DValRec vis =>