Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : ghc-kinds
http://hackage.haskell.org/trac/ghc/changeset/64049716110b10b598c9c4653323b96a43a6d910 >--------------------------------------------------------------- commit 64049716110b10b598c9c4653323b96a43a6d910 Author: Julien Cretin <g...@ia0.eu> Date: Sat Sep 24 12:28:45 2011 +0200 make isSubKind guards symetric >--------------------------------------------------------------- compiler/typecheck/TcCanonical.lhs | 3 +-- compiler/types/Kind.lhs | 16 +++++++++------- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index eb018f9..fe1db59 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -501,8 +501,7 @@ canEq fl eqv ty1 ty2 , Nothing <- tcView ty2 -- See Note [Naked given applications] , Just (s1,t1) <- tcSplitAppTy_maybe ty1 , Just (s2,t2) <- tcSplitAppTy_maybe ty2 - = ASSERT( not (isKind t1) ) - ASSERT( not (isKind t2) ) + = ASSERT( not (isKind t1) && not (isKind t2) ) if isWanted fl then do { eqv1 <- newEqVar s1 s2 ; eqv2 <- newEqVar t1 t2 diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index c9aa692..9c4ecf0 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -192,15 +192,17 @@ isSubKind :: Kind -> Kind -> Bool isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind` a1) && (r1 `isSubKind` r2) -isSubKind (TyConApp kc1 k1s) (TyConApp kc2 k2s) - | isPromotedTypeTyCon kc1 = -- handles promoted kinds (List *, Nat, etc.) - kc1 == kc2 && length k1s == length k2s && all (uncurry eqKind) (zip k1s k2s) +isSubKind k1@(TyConApp kc1 k1s) k2@(TyConApp kc2 k2s) + | isPromotedTypeTyCon kc1 || isPromotedTypeTyCon kc2 + -- handles promoted kinds (List *, Nat, etc.) + = eqKind k1 k2 - | isSuperKindTyCon kc1 = -- handles BOX - ASSERT2( isSuperKindTyCon kc2 && null k1s && null k2s, ppr kc1 <+> ppr kc2 ) - True + | isSuperKindTyCon kc1 || isSuperKindTyCon kc2 + -- handles BOX + = ASSERT2( isSuperKindTyCon kc2 && null k1s && null k2s, ppr kc1 <+> ppr kc2 ) + True - | otherwise = -- handles not promoted kinds (*, #, (#), etc.) + | otherwise = -- handles usual kinds (*, #, (#), etc.) ASSERT( null k1s && null k2s ) kc1 `isSubKindCon` kc2 _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
