diff options
Diffstat (limited to 'compiler/GHC/Tc/TyCl/Class.hs')
| -rw-r--r-- | compiler/GHC/Tc/TyCl/Class.hs | 36 |
1 files changed, 27 insertions, 9 deletions
diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs index a55a774069..1c1f6608cd 100644 --- a/compiler/GHC/Tc/TyCl/Class.hs +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -13,6 +13,7 @@ module GHC.Tc.TyCl.Class ( tcClassSigs , tcClassDecl2 + , ClassScopedTVEnv , findMethodBind , instantiateMethod , tcClassMinimalDef @@ -39,7 +40,7 @@ import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Instantiate( tcSuperSkolTyVars ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType -import GHC.Core.Type ( piResultTys ) +import GHC.Core.Type ( piResultTys, substTyVar ) import GHC.Core.Predicate import GHC.Core.Multiplicity import GHC.Tc.Types.Origin @@ -187,10 +188,16 @@ tcClassSigs clas sigs def_methods ************************************************************************ -} -tcClassDecl2 :: LTyClDecl GhcRn -- The class declaration +-- | Maps class names to the type variables that scope over their bodies. +-- See @Note [Scoped tyvars in a TcTyCon]@ in "GHC.Core.TyCon". +type ClassScopedTVEnv = NameEnv [(Name, TyVar)] + +tcClassDecl2 :: ClassScopedTVEnv -- Class scoped type variables + -> LTyClDecl GhcRn -- The class declaration -> TcM (LHsBinds GhcTc) -tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, +tcClassDecl2 class_scoped_tv_env + (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, tcdMeths = default_binds})) = recoverM (return emptyLHsBinds) $ setSrcSpan (getLocA class_name) $ @@ -205,20 +212,31 @@ tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, -- And since ds is big, it doesn't get inlined, so we don't get good -- default methods. Better to make separate AbsBinds for each ; let (tyvars, _, _, op_items) = classBigSig clas - prag_fn = mkPragEnv sigs default_binds - sig_fn = mkHsSigFun sigs - clas_tyvars = snd (tcSuperSkolTyVars tyvars) - pred = mkClassPred clas (mkTyVarTys clas_tyvars) + prag_fn = mkPragEnv sigs default_binds + sig_fn = mkHsSigFun sigs + (skol_subst, clas_tyvars) = tcSuperSkolTyVars tyvars + pred = mkClassPred clas (mkTyVarTys clas_tyvars) + scoped_tyvars = + case lookupNameEnv class_scoped_tv_env (unLoc class_name) of + Just tvs -> tvs + Nothing -> pprPanic "tcClassDecl2: Class name not in tcg_class_scoped_tvs_env" + (ppr class_name) + -- The substitution returned by tcSuperSkolTyVars maps each type + -- variable to a TyVarTy, so it is safe to call getTyVar below. + scoped_clas_tyvars = + mapSnd ( getTyVar ("tcClassDecl2: Super-skolem substitution maps " + ++ "type variable to non-type variable") + . substTyVar skol_subst ) scoped_tyvars ; this_dict <- newEvVar pred ; let tc_item = tcDefMeth clas clas_tyvars this_dict default_binds sig_fn prag_fn - ; dm_binds <- tcExtendTyVarEnv clas_tyvars $ + ; dm_binds <- tcExtendNameTyVarEnv scoped_clas_tyvars $ mapM tc_item op_items ; return (unionManyBags dm_binds) } -tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) +tcClassDecl2 _ d = pprPanic "tcClassDecl2" (ppr d) tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn -> HsSigFun -> TcPragEnv -> ClassOpItem |