Skip to content
Browse files

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
  • Loading branch information...
1 parent 4708d38 commit 2c207b6f60ba5d271f400747256e4a32ca8f7e63 @simonpj simonpj committed Oct 2, 2012
Showing with 45 additions and 42 deletions.
  1. +31 −40 compiler/typecheck/TcRnDriver.lhs
  2. +14 −2 compiler/types/Type.lhs
View
71 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
View
16 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

0 comments on commit 2c207b6

Please sign in to comment.
Something went wrong with that request. Please try again.