[commit: ghc] ghc-kinds: isSubKind BOX BOX is now valid (801c46e)

[Julien Cretin]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : ghc-kinds

http://hackage.haskell.org/trac/ghc/changeset/801c46e1d9e3f108228481ba6f63a8d9fba246cc

>---------------------------------------------------------------

commit 801c46e1d9e3f108228481ba6f63a8d9fba246cc
Author: Julien Cretin <ghc at ia0.eu>
Date:   Tue Sep 13 14:29:29 2011 +0200

    isSubKind BOX BOX is now valid

>---------------------------------------------------------------

 compiler/TODO           |    4 ----
 compiler/types/Kind.lhs |   15 +++++++++------
 2 files changed, 9 insertions(+), 10 deletions(-)

diff --git a/compiler/TODO b/compiler/TODO
index fbd3d91..eea6e40 100644
--- a/compiler/TODO
+++ b/compiler/TODO
@@ -1,9 +1,5 @@
 ## TODO FIRST
 
-* kind substitution in types, substTyVarBndr
-  look at CoreSubst, substIdBndr
-  no_kind_change : verify that kind is closed
-
 * UserKiVar (in Parser mkHsForAll or renamer)
   look at kind annotation to know if a UserTyvar is a kind variable
   (UserKiVar) or a type variable (UserTyVar)
diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs
index d75f694..56458a9 100644
--- a/compiler/types/Kind.lhs
+++ b/compiler/types/Kind.lhs
@@ -183,12 +183,15 @@ isKind k = isSuperKind (typeKind k)
 
 isSubKind :: Kind -> Kind -> Bool
 -- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@
-isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2
--- IA0: isSubKind (TyConApp kc1 k1s) (TyConApp kc2 k2s) = panic "IA0: isSubKind"  -- IA0_WHEN: *^n -> *
-isSubKind (FunTy a1 r1) (FunTy a2 r2)	      = (a2 `isSubKind` a1) && (r1 `isSubKind` r2)
-isSubKind (TyConApp kc1 k1s) (TyConApp kc2 k2s) =
-  not (isSubOpenTypeKindCon kc1) && kc1 == kc2
-  && length k1s == length k2s && all (uncurry eqKind) (zip k1s k2s)
+isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind` a1) && (r1 `isSubKind` r2)
+isSubKind (TyConApp kc1 k1s) (TyConApp kc2 k2s)
+  | isSuperKindTyCon kc1 =  -- handles BOX
+    isSuperKindTyCon kc2 && null k1s && null k2s
+  | isSuperKind (tyConKind kc1) =  -- handles not promoted kinds (*, #, (#), etc.)
+    ASSERT( isSuperKind (tyConKind kc2) && null k1s && null k2s )
+    kc1 `isSubKindCon` kc2
+  | otherwise =  -- handles promoted kinds (List *, Nat, etc.)
+    kc1 == kc2 && length k1s == length k2s && all (uncurry eqKind) (zip k1s k2s)
 isSubKind (TyVarTy kv1) (TyVarTy kv2) = kv1 == kv2
 isSubKind (ForAllTy {}) (ForAllTy {}) = panic "IA0: isSubKind on ForAllTy"
 isSubKind _ _ = False