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 <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 | 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 _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
