Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : ghc-7.6
http://hackage.haskell.org/trac/ghc/changeset/ed6b56407275d15a8c0b9aede8f90e3f5e0f7281 >--------------------------------------------------------------- commit ed6b56407275d15a8c0b9aede8f90e3f5e0f7281 Author: Ian Lynagh <i...@well-typed.com> Date: Thu Nov 29 16:42:20 2012 +0000 MERGED: Compare the kinds of type variables when comparing types commit 2c207b6f60ba5d271f400747256e4a32ca8f7e63 Author: Simon Peyton Jones <simo...@microsoft.com> 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 | 37 ++++++++++++++----------------------- compiler/types/Type.lhs | 16 ++++++++++++++-- 2 files changed, 28 insertions(+), 25 deletions(-) diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 0d00fb6..530530a 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 @@ -772,23 +765,20 @@ checkBootTyCon tc1 tc2 eqListBy eqAT ats1 ats2) | isSynTyCon tc1 && isSynTyCon 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 SynFamilyTyCon + let eqSynRhs SynFamilyTyCon SynFamilyTyCon = True eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2) = eqTypeX env t1 t2 eqSynRhs _ _ = False in - equalLength tvs1 tvs2 && eqSynRhs (synTyConRhs tc1) (synTyConRhs tc2) | 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 @@ -797,8 +787,6 @@ checkBootTyCon tc1 tc2 | otherwise = False where - env0 = mkRnEnv2 emptyInScopeSet - eqAlgRhs (AbstractTyCon dis1) rhs2 | dis1 = isDistinctAlgRhs rhs2 --Check compatibility | otherwise = True @@ -816,6 +804,9 @@ checkBootTyCon tc1 tc2 && dataConFieldLabels c1 == dataConFieldLabels c2 && eqType (dataConUserType c1) (dataConUserType c2) +emptyRnEnv2 :: RnEnv2 +emptyRnEnv2 = mkRnEnv2 emptyInScopeSet + ---------------- missingBootThing :: Name -> String -> SDoc missingBootThing name what diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 98aee9e..ca17b27 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -93,7 +93,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, @@ -1178,6 +1178,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 @@ -1208,7 +1219,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 _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
