diff options
author | Adam Chlipala <adamc@hcoop.net> | 2008-07-01 13:23:46 -0400 |
---|---|---|
committer | Adam Chlipala <adamc@hcoop.net> | 2008-07-01 13:23:46 -0400 |
commit | 73b8b2cf8afd5cc8969b3bd4d2c238d9c453e8fd (patch) | |
tree | c082faa41b174478cadc17f84b65635593ca97af | |
parent | a0b2a6145f200885f5dd7b365d2ffad51851795e (diff) |
Push KUnit and CUnit through the phases
-rw-r--r-- | src/core.sml | 3 | ||||
-rw-r--r-- | src/core_print.sml | 2 | ||||
-rw-r--r-- | src/core_util.sml | 4 | ||||
-rw-r--r-- | src/corify.sml | 2 | ||||
-rw-r--r-- | src/expl.sml | 3 | ||||
-rw-r--r-- | src/expl_print.sml | 2 | ||||
-rw-r--r-- | src/expl_util.sml | 4 | ||||
-rw-r--r-- | src/explify.sml | 4 | ||||
-rw-r--r-- | src/monoize.sml | 1 | ||||
-rw-r--r-- | tests/disjoint.lac | 2 |
10 files changed, 25 insertions, 2 deletions
diff --git a/src/core.sml b/src/core.sml index 78f0cce0..badb08ea 100644 --- a/src/core.sml +++ b/src/core.sml @@ -34,6 +34,7 @@ datatype kind' = | KArrow of kind * kind | KName | KRecord of kind + | KUnit withtype kind = kind' located @@ -54,6 +55,8 @@ datatype con' = | CConcat of con * con | CFold of kind * kind + | CUnit + withtype con = con' located datatype exp' = diff --git a/src/core_print.sml b/src/core_print.sml index b6e611f4..935cfbac 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -48,6 +48,7 @@ fun p_kind' par (k, _) = p_kind k2]) | KName => string "Name" | KRecord k => box [string "{", p_kind k, string "}"] + | KUnit => string "Unit" and p_kind k = p_kind' false k @@ -135,6 +136,7 @@ fun p_con' par env (c, _) = space, p_con env c2]) | CFold _ => string "fold" + | CUnit => string "()" and p_con env = p_con' false env diff --git a/src/core_util.sml b/src/core_util.sml index 8a174d9e..f0a37356 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -55,6 +55,8 @@ fun mapfold f = S.map2 (mfk k, fn k' => (KRecord k', loc)) + + | KUnit => S.return2 kAll in mfk end @@ -149,6 +151,8 @@ fun mapfoldB {kind = fk, con = fc, bind} = S.map2 (mfk k2, fn k2' => (CFold (k1', k2'), loc))) + + | CUnit => S.return2 cAll in mfc end diff --git a/src/corify.sml b/src/corify.sml index 5dfd0db6..baff8182 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -275,6 +275,7 @@ fun corifyKind (k, loc) = | L.KArrow (k1, k2) => (L'.KArrow (corifyKind k1, corifyKind k2), loc) | L.KName => (L'.KName, loc) | L.KRecord k => (L'.KRecord (corifyKind k), loc) + | L.KUnit => (L'.KUnit, loc) fun corifyCon st (c, loc) = case c of @@ -306,6 +307,7 @@ fun corifyCon st (c, loc) = (L'.CRecord (corifyKind k, map (fn (c1, c2) => (corifyCon st c1, corifyCon st c2)) xcs), loc) | L.CConcat (c1, c2) => (L'.CConcat (corifyCon st c1, corifyCon st c2), loc) | L.CFold (k1, k2) => (L'.CFold (corifyKind k1, corifyKind k2), loc) + | L.CUnit => (L'.CUnit, loc) fun corifyExp st (e, loc) = case e of diff --git a/src/expl.sml b/src/expl.sml index 87ca990e..b3bcf96b 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -33,6 +33,7 @@ datatype kind' = KType | KArrow of kind * kind | KName + | KUnit | KRecord of kind withtype kind = kind' located @@ -54,6 +55,8 @@ datatype con' = | CConcat of con * con | CFold of kind * kind + | CUnit + withtype con = con' located datatype exp' = diff --git a/src/expl_print.sml b/src/expl_print.sml index ab8462b8..447845a2 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -48,6 +48,7 @@ fun p_kind' par (k, _) = p_kind k2]) | KName => string "Name" | KRecord k => box [string "{", p_kind k, string "}"] + | KUnit => string "Unit" and p_kind k = p_kind' false k @@ -144,6 +145,7 @@ fun p_con' par env (c, _) = space, p_con env c2]) | CFold _ => string "fold" + | CUnit => string "()" and p_con env = p_con' false env diff --git a/src/expl_util.sml b/src/expl_util.sml index aea9e4f5..57498fde 100644 --- a/src/expl_util.sml +++ b/src/expl_util.sml @@ -55,6 +55,8 @@ fun mapfold f = S.map2 (mfk k, fn k' => (KRecord k', loc)) + + | KUnit => S.return2 kAll in mfk end @@ -144,6 +146,8 @@ fun mapfoldB {kind = fk, con = fc, bind} = S.map2 (mfk k2, fn k2' => (CFold (k1', k2'), loc))) + + | CUnit => S.return2 cAll in mfc end diff --git a/src/explify.sml b/src/explify.sml index 0fa3698b..e0226213 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -38,7 +38,7 @@ fun explifyKind (k, loc) = | L.KName => (L'.KName, loc) | L.KRecord k => (L'.KRecord (explifyKind k), loc) - | L.KUnit => raise Fail "Explify KUnit" + | L.KUnit => (L'.KUnit, loc) | L.KError => raise Fail ("explifyKind: KError at " ^ EM.spanToString loc) | L.KUnif (_, _, ref (SOME k)) => explifyKind k @@ -65,7 +65,7 @@ fun explifyCon (c, loc) = | L.CConcat (c1, c2) => (L'.CConcat (explifyCon c1, explifyCon c2), loc) | L.CFold (dom, ran) => (L'.CFold (explifyKind dom, explifyKind ran), loc) - | L.CUnit => raise Fail "Explify CUnit" + | L.CUnit => (L'.CUnit, loc) | L.CError => raise Fail ("explifyCon: CError at " ^ EM.spanToString loc) | L.CUnif (_, _, _, ref (SOME c)) => explifyCon c diff --git a/src/monoize.sml b/src/monoize.sml index 16c128aa..335b93e6 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -72,6 +72,7 @@ fun monoType env (all as (c, loc)) = | L.CRecord _ => poly () | L.CConcat _ => poly () | L.CFold _ => poly () + | L.CUnit => poly () end val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan) diff --git a/tests/disjoint.lac b/tests/disjoint.lac index 28b14423..26278014 100644 --- a/tests/disjoint.lac +++ b/tests/disjoint.lac @@ -31,3 +31,5 @@ val vt6 = v2 [#A] [[B = float, C = string]] {A = 8, B = 8.0, C = "8"} val vtX = v2 [#A] [[B = float, B = string]] {A = 8, B = 8.0, B = "8"} val vtX = v2 [#A] [[A = float, B = string]] {A = 8, A = 8.0, B = "8"} *) + +val main = vt6 |