[commit: ghc] master: Compare the kinds of type variables when comparing types (2c207b6)

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

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/2c207b6f60ba5d271f400747256e4a32ca8f7e63

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

commit 2c207b6f60ba5d271f400747256e4a32ca8f7e63
Author: Simon Peyton Jones <[email protected]>
Date:   Tue Oct 2 18:11:08 2012 +0100

    Compare the kinds of type variables when comparing types
    
    This is just a bug that's been around since we introduced
    polymorphic kinds.  The roots are in Type.cmpTypeX, but
    there was a variant in TcRnDriver.checkBootTyCon, which
    is where it came up.
    
    Fixes Trac #7272

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

 compiler/typecheck/TcRnDriver.lhs |   71 ++++++++++++++++---------------------
 compiler/types/Type.lhs           |   16 +++++++-
 2 files changed, 45 insertions(+), 42 deletions(-)

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index d48be70..a573623 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -63,7 +63,6 @@ import CoreSyn
 import ErrUtils
 import Id
 import VarEnv
-import Var
 import Module
 import UniqFM
 import Name
@@ -726,15 +725,12 @@ checkBootTyCon tc1 tc2
 
   | Just c1 <- tyConClass_maybe tc1
   , Just c2 <- tyConClass_maybe tc2
-  = let
-       (clas_tyvars1, clas_fds1, sc_theta1, _, ats1, op_stuff1)
+  , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1)
           = classExtraBigSig c1
-       (clas_tyvars2, clas_fds2, sc_theta2, _, ats2, op_stuff2)
+        (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2)
           = classExtraBigSig c2
-
-       env0 = mkRnEnv2 emptyInScopeSet
-       env = rnBndrs2 env0 clas_tyvars1 clas_tyvars2
-
+  , Just env <- eqTyVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2
+  = let
        eqSig (id1, def_meth1) (id2, def_meth2)
          = idName id1 == idName id2 &&
            eqTypeX env op_ty1 op_ty2 &&
@@ -751,18 +747,15 @@ checkBootTyCon tc1 tc2
 
        -- Ignore the location of the defaults
        eqATDef (ATD tvs1 ty_pats1 ty1 _loc1) (ATD tvs2 ty_pats2 ty2 _loc2)
-         = eqListBy same_kind tvs1 tvs2 &&
-           eqListBy (eqTypeX env) ty_pats1 ty_pats2 &&
+         | Just env <- eqTyVarBndrs emptyRnEnv2 tvs1 tvs2
+         = eqListBy (eqTypeX env) ty_pats1 ty_pats2 &&
            eqTypeX env ty1 ty2
-         where env = rnBndrs2 env0 tvs1 tvs2
+         | otherwise = False
 
        eqFD (as1,bs1) (as2,bs2) =
          eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
          eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
-
-       same_kind tv1 tv2 = eqKind (tyVarKind tv1) (tyVarKind tv2)
     in
-       eqListBy same_kind clas_tyvars1 clas_tyvars2 &&
              -- Checks kind of class
        eqListBy eqFD clas_fds1 clas_fds2 &&
        (null sc_theta1 && null op_stuff1 && null ats1
@@ -773,23 +766,20 @@ checkBootTyCon tc1 tc2
 
   | Just syn_rhs1 <- synTyConRhs_maybe tc1
   , Just syn_rhs2 <- synTyConRhs_maybe tc2
+  , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
   = ASSERT(tc1 == tc2)
-    let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2
-        env = rnBndrs2 env0 tvs1 tvs2
-
-        eqSynRhs (SynFamilyTyCon a1 b1) (SynFamilyTyCon a2 b2)
-            = a1 == a2 && b1 == b2
+    let eqSynRhs SynFamilyTyCon SynFamilyTyCon
+            = True
         eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
             = eqTypeX env t1 t2
         eqSynRhs _ _ = False
     in
-    equalLength tvs1 tvs2 &&
     eqSynRhs syn_rhs1 syn_rhs2
 
   | isAlgTyCon tc1 && isAlgTyCon tc2
+  , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
   = ASSERT(tc1 == tc2)
-    eqKind (tyConKind tc1) (tyConKind tc2) &&
-    eqListBy eqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
+    eqListBy (eqPredX env) (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
     eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
 
   | isForeignTyCon tc1 && isForeignTyCon tc2
@@ -798,24 +788,25 @@ checkBootTyCon tc1 tc2
 
   | otherwise = False
   where
-        env0 = mkRnEnv2 emptyInScopeSet
-
-        eqAlgRhs (AbstractTyCon dis1) rhs2
-          | dis1      = isDistinctAlgRhs rhs2   --Check compatibility
-          | otherwise = True
-        eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True
-        eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} =
-            eqListBy eqCon (data_cons tc1) (data_cons tc2)
-        eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} =
-            eqCon (data_con tc1) (data_con tc2)
-        eqAlgRhs _ _ = False
-
-        eqCon c1 c2
-          =  dataConName c1 == dataConName c2
-          && dataConIsInfix c1 == dataConIsInfix c2
-          && dataConStrictMarks c1 == dataConStrictMarks c2
-          && dataConFieldLabels c1 == dataConFieldLabels c2
-          && eqType (dataConUserType c1) (dataConUserType c2)
+    eqAlgRhs (AbstractTyCon dis1) rhs2
+      | dis1      = isDistinctAlgRhs rhs2   --Check compatibility
+      | otherwise = True
+    eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True
+    eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} =
+        eqListBy eqCon (data_cons tc1) (data_cons tc2)
+    eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} =
+        eqCon (data_con tc1) (data_con tc2)
+    eqAlgRhs _ _ = False
+
+    eqCon c1 c2
+      =  dataConName c1 == dataConName c2
+      && dataConIsInfix c1 == dataConIsInfix c2
+      && dataConStrictMarks c1 == dataConStrictMarks c2
+      && dataConFieldLabels c1 == dataConFieldLabels c2
+      && eqType (dataConUserType c1) (dataConUserType c2)
+
+emptyRnEnv2 :: RnEnv2
+emptyRnEnv2 = mkRnEnv2 emptyInScopeSet
 
 ----------------
 missingBootThing :: Name -> String -> SDoc
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index a8fb161..5770661 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -95,7 +95,7 @@ module Type (
 
 	-- * Type comparison
         eqType, eqTypeX, eqTypes, cmpType, cmpTypes, 
-	eqPred, eqPredX, cmpPred, eqKind,
+	eqPred, eqPredX, cmpPred, eqKind, eqTyVarBndrs,
 
 	-- * Forcing evaluation of types
         seqType, seqTypes,
@@ -1187,6 +1187,17 @@ eqPred = eqType
 
 eqPredX :: RnEnv2 -> PredType -> PredType -> Bool
 eqPredX env p1 p2 = isEqual $ cmpTypeX env p1 p2
+
+eqTyVarBndrs :: RnEnv2 -> [TyVar] -> [TyVar] -> Maybe RnEnv2
+-- Check that the tyvar lists are the same length
+-- and have matching kinds; if so, extend the RnEnv2
+-- Returns Nothing if they don't match
+eqTyVarBndrs env [] [] 
+ = Just env
+eqTyVarBndrs env (tv1:tvs1) (tv2:tvs2)
+ | eqTypeX env (tyVarKind tv1) (tyVarKind tv2)
+ = eqTyVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2
+eqTyVarBndrs _ _ _= Nothing
 \end{code}
 
 Now here comes the real worker
@@ -1217,7 +1228,8 @@ cmpTypeX env t1 t2 | Just t1' <- coreView t1 = cmpTypeX env t1' t2
 -- So the RHS has a data type
 
 cmpTypeX env (TyVarTy tv1)       (TyVarTy tv2)       = rnOccL env tv1 `compare` rnOccR env tv2
-cmpTypeX env (ForAllTy tv1 t1)   (ForAllTy tv2 t2)   = cmpTypeX (rnBndr2 env tv1 tv2) t1 t2
+cmpTypeX env (ForAllTy tv1 t1)   (ForAllTy tv2 t2)   = cmpTypeX env (tyVarKind tv1) (tyVarKind tv1)
+                                                       `thenCmp` cmpTypeX (rnBndr2 env tv1 tv2) t1 t2
 cmpTypeX env (AppTy s1 t1)       (AppTy s2 t2)       = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2
 cmpTypeX env (FunTy s1 t1)       (FunTy s2 t2)       = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2
 cmpTypeX env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` cmpTypesX env tys1 tys2