diff src/mono_util.sml @ 164:6847741e1f5f

Datatypes through monoize
author Adam Chlipala <adamc@hcoop.net>
date Tue, 29 Jul 2008 13:32:07 -0400
parents f0d3402184d1
children 25b169416ea8
line wrap: on
line diff
--- a/src/mono_util.sml	Tue Jul 29 13:16:21 2008 -0400
+++ b/src/mono_util.sml	Tue Jul 29 13:32:07 2008 -0400
@@ -258,7 +258,16 @@
 
         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 @@
                             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