Commit 2c207b6f authored by Simon Peyton Jones's avatar Simon Peyton Jones

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
parent 4708d383
......@@ -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
......
......@@ -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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment