summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRyan Scott <ryan.gl.scott@gmail.com>2021-04-29 17:35:47 -0400
committerRyan Scott <ryan.gl.scott@gmail.com>2021-04-30 11:48:19 -0400
commit89bf726c87483fab493fbef57a539f51585820a3 (patch)
tree95d817824931ba80030e1a4e51d2729419191a73
parent2d2985a79eec3d6ae9aee96b264c97c2b158f196 (diff)
downloadhaskell-wip/T19738.tar.gz
Bring tcTyConScopedTyVars into scope in tcClassDecl2wip/T19738
It is possible that the type variables bound by a class header will map to something different in the typechecker in the presence of `StandaloneKindSignatures`. `tcClassDecl2` was not aware of this, however, leading to #19738. To fix it, in `tcTyClDecls` we map each class `TcTyCon` to its `tcTyConScopedTyVars` as a `ClassScopedTVEnv`. We then plumb that `ClassScopedTVEnv` to `tcClassDecl2` where it can be used. Fixes #19738.
-rw-r--r--compiler/GHC/Core/TyCon.hs30
-rw-r--r--compiler/GHC/Tc/Deriv.hs2
-rw-r--r--compiler/GHC/Tc/Module.hs15
-rw-r--r--compiler/GHC/Tc/TyCl.hs39
-rw-r--r--compiler/GHC/Tc/TyCl/Class.hs36
-rw-r--r--compiler/GHC/Tc/TyCl/Instance.hs8
-rw-r--r--testsuite/tests/typecheck/should_compile/T19738.hs11
-rw-r--r--testsuite/tests/typecheck/should_compile/all.T1
8 files changed, 112 insertions, 30 deletions
diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs
index a460116c3b..56fe29cb7e 100644
--- a/compiler/GHC/Core/TyCon.hs
+++ b/compiler/GHC/Core/TyCon.hs
@@ -976,6 +976,36 @@ where
* required_tvs the same as tyConTyVars
* tyConArity = length required_tvs
+There are some situations where we need to keep the tcTyConScopedTyVars around
+for later use, even after the TcTyCon has been zonked away:
+
+* When typechecking `deriving` clauses for top-level data declarations, the
+ tcTyConScopedTyVars are brought into scope in through the `di_scoped_tvs`
+ field of GHC.Tc.Deriv.DerivInfo. Example (#16731):
+
+ class C x1 x2
+
+ type T :: a -> Type
+ data T (x :: z) deriving (C z)
+
+ When typechecking `C z`, we want `z` to map to `a`, which is exactly what the
+ tcTyConScopedTyVars for T give us.
+
+* Similarly, when typechecking default definitions for class methods, the
+ tcTyConScopedTyVars ought to be brought into scope. Example (#19738):
+
+ type P :: k -> Type
+ data P a = MkP
+
+ type T :: k -> Constraint
+ class T (a :: j) where
+ f :: P a
+ f = MkP @j @a
+
+ We pass the tcTyConScopedTyVars to GHC.Tc.TyCl.Class.tcClassDecl2, the
+ function responsible for typechecking the default definition of `f`, by way
+ of a ClassScopedTVEnv, which maps each class name to its scoped tyvars.
+
See also Note [How TcTyCons work] in GHC.Tc.TyCl
Note [Promoted GADT data constructors]
diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs
index fa8817b36a..a899349702 100644
--- a/compiler/GHC/Tc/Deriv.hs
+++ b/compiler/GHC/Tc/Deriv.hs
@@ -170,6 +170,8 @@ data DerivInfo = DerivInfo { di_rep_tc :: TyCon
-- or the *representation* tycon for data families
, di_scoped_tvs :: ![(Name,TyVar)]
-- ^ Variables that scope over the deriving clause.
+ -- See @Note [Scoped tyvars in a TcTyCon]@ in
+ -- "GHC.Core.TyCon".
, di_clauses :: [LHsDerivingClause GhcRn]
, di_ctxt :: SDoc -- ^ error context
}
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 0511e1e268..fc330061e8 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -75,6 +75,7 @@ import GHC.Tc.Gen.Default
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Rule
import GHC.Tc.Gen.Foreign
+import GHC.Tc.TyCl.Class ( ClassScopedTVEnv )
import GHC.Tc.TyCl.Instance
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
@@ -699,7 +700,7 @@ tcRnHsBootDecls hsc_src decls
-- Typecheck type/class/instance decls
; traceTc "Tc2 (boot)" empty
- ; (tcg_env, inst_infos, _deriv_binds)
+ ; (tcg_env, inst_infos, _deriv_binds, _class_scoped_tv_env)
<- tcTyClsInstDecls tycl_decls deriv_decls val_binds
; setGblEnv tcg_env $ do {
@@ -1456,7 +1457,8 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
-- Source-language instances, including derivings,
-- and import the supporting declarations
traceTc "Tc3" empty ;
- (tcg_env, inst_infos, XValBindsLR (NValBinds deriv_binds deriv_sigs))
+ (tcg_env, inst_infos, class_scoped_tv_env,
+ XValBindsLR (NValBinds deriv_binds deriv_sigs))
<- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;
setGblEnv tcg_env $ do {
@@ -1497,7 +1499,8 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
-- Second pass over class and instance declarations,
-- now using the kind-checked decls
traceTc "Tc6" empty ;
- inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ;
+ inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls)
+ inst_infos class_scoped_tv_env ;
-- Foreign exports
traceTc "Tc7" empty ;
@@ -1733,13 +1736,14 @@ tcTyClsInstDecls :: [TyClGroup GhcRn]
[InstInfo GhcRn], -- Source-code instance decls to
-- process; contains all dfuns for
-- this module
+ ClassScopedTVEnv, -- Class scoped type variables
HsValBinds GhcRn) -- Supporting bindings for derived
-- instances
tcTyClsInstDecls tycl_decls deriv_decls binds
= tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $
tcAddPatSynPlaceholders (getPatSynBinds binds) $
- do { (tcg_env, inst_info, deriv_info)
+ do { (tcg_env, inst_info, deriv_info, class_scoped_tv_env)
<- tcTyAndClassDecls tycl_decls ;
; setGblEnv tcg_env $ do {
-- With the @TyClDecl@s and @InstDecl@s checked we're ready to
@@ -1753,7 +1757,8 @@ tcTyClsInstDecls tycl_decls deriv_decls binds
<- tcInstDeclsDeriv deriv_info deriv_decls
; setGblEnv tcg_env' $ do {
failIfErrsM
- ; pure (tcg_env', inst_info' ++ inst_info, val_binds)
+ ; pure ( tcg_env', inst_info' ++ inst_info
+ , class_scoped_tv_env, val_binds )
}}}
{- *********************************************************************
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index 076c0c0ee0..b2b9f2c106 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -144,31 +144,35 @@ tcTyAndClassDecls :: [TyClGroup GhcRn] -- Mutually-recursive groups in
-- and their implicit Ids,DataCons
, [InstInfo GhcRn] -- Source-code instance decls info
, [DerivInfo] -- Deriving info
+ , ClassScopedTVEnv -- Class scoped type variables
)
-- Fails if there are any errors
tcTyAndClassDecls tyclds_s
-- The code recovers internally, but if anything gave rise to
-- an error we'd better stop now, to avoid a cascade
-- Type check each group in dependency order folding the global env
- = checkNoErrs $ fold_env [] [] tyclds_s
+ = checkNoErrs $ fold_env [] [] emptyNameEnv tyclds_s
where
fold_env :: [InstInfo GhcRn]
-> [DerivInfo]
+ -> ClassScopedTVEnv
-> [TyClGroup GhcRn]
- -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
- fold_env inst_info deriv_info []
+ -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ClassScopedTVEnv)
+ fold_env inst_info deriv_info class_scoped_tv_env []
= do { gbl_env <- getGblEnv
- ; return (gbl_env, inst_info, deriv_info) }
- fold_env inst_info deriv_info (tyclds:tyclds_s)
- = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds
+ ; return (gbl_env, inst_info, deriv_info, class_scoped_tv_env) }
+ fold_env inst_info deriv_info class_scoped_tv_env (tyclds:tyclds_s)
+ = do { (tcg_env, inst_info', deriv_info', class_scoped_tv_env')
+ <- tcTyClGroup tyclds
; setGblEnv tcg_env $
-- remaining groups are typechecked in the extended global env.
fold_env (inst_info' ++ inst_info)
(deriv_info' ++ deriv_info)
+ (class_scoped_tv_env' `plusNameEnv` class_scoped_tv_env)
tyclds_s }
tcTyClGroup :: TyClGroup GhcRn
- -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
+ -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ClassScopedTVEnv)
-- Typecheck one strongly-connected component of type, class, and instance decls
-- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls
tcTyClGroup (TyClGroup { group_tyclds = tyclds
@@ -180,7 +184,7 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
-- Step 1: Typecheck the standalone kind signatures and type/class declarations
; traceTc "---- tcTyClGroup ---- {" empty
; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))
- ; (tyclss, data_deriv_info, kindless) <-
+ ; (tyclss, data_deriv_info, class_scoped_tv_env, kindless) <-
tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution]
do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs
; tcTyClDecls tyclds kisig_env role_annots }
@@ -216,7 +220,7 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
; let deriv_info = datafam_deriv_info ++ data_deriv_info
; let gbl_env'' = gbl_env'
{ tcg_ksigs = tcg_ksigs gbl_env' `unionNameSet` kindless }
- ; return (gbl_env'', inst_info, deriv_info) }
+ ; return (gbl_env'', inst_info, deriv_info, class_scoped_tv_env) }
-- Gives the kind for every TyCon that has a standalone kind signature
type KindSigEnv = NameEnv Kind
@@ -225,7 +229,7 @@ tcTyClDecls
:: [LTyClDecl GhcRn]
-> KindSigEnv
-> RoleAnnotEnv
- -> TcM ([TyCon], [DerivInfo], NameSet)
+ -> TcM ([TyCon], [DerivInfo], ClassScopedTVEnv, NameSet)
tcTyClDecls tyclds kisig_env role_annots
= do { -- Step 1: kind-check this group and returns the final
-- (possibly-polymorphic) kind of each TyCon and Class
@@ -239,11 +243,12 @@ tcTyClDecls tyclds kisig_env role_annots
-- NB: We have to be careful here to NOT eagerly unfold
-- type synonyms, as we have not tested for type synonym
-- loops yet and could fall into a black hole.
- ; fixM $ \ ~(rec_tyclss, _, _) -> do
+ ; fixM $ \ ~(rec_tyclss, _, _, _) -> do
{ tcg_env <- getGblEnv
-- Forced so we don't retain a reference to the TcGblEnv
; let !src = tcg_src tcg_env
roles = inferRoles src role_annots rec_tyclss
+ class_scoped_tv_env = mk_class_scoped_tv_env tc_tycons
-- Populate environment with knot-tied ATyCon for TyCons
-- NB: if the decls mention any ill-staged data cons
@@ -260,7 +265,7 @@ tcTyClDecls tyclds kisig_env role_annots
-- Kind and type check declarations for this group
mapAndUnzipM (tcTyClDecl roles) tyclds
- ; return (tycons, concat data_deriv_infos, kindless)
+ ; return (tycons, concat data_deriv_infos, class_scoped_tv_env, kindless)
} }
where
ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma
@@ -268,6 +273,16 @@ tcTyClDecls tyclds kisig_env role_annots
, ppr (tyConResKind tc)
, ppr (isTcTyCon tc) ])
+ -- Map each class TcTyCon to their tcTyConScopedTyVars. This is ultimately
+ -- meant to be passed to GHC.Tc.TyCl.Class.tcClassDecl2, which consults
+ -- it when bringing type variables into scope over class method defaults.
+ -- See @Note [Scoped tyvars in a TcTyCon]@ in "GHC.Core.TyCon".
+ mk_class_scoped_tv_env :: [TcTyCon] -> ClassScopedTVEnv
+ mk_class_scoped_tv_env tc_tycons =
+ mkNameEnv [ (tyConName tc_tycon, tcTyConScopedTyVars tc_tycon)
+ | tc_tycon <- tc_tycons, tyConFlavour tc_tycon == ClassFlavour
+ ]
+
zipRecTyClss :: [TcTyCon]
-> [TyCon] -- Knot-tied
-> [(Name,TyThing)]
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
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index b9a4e17bf7..5a824b0e48 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -27,7 +27,7 @@ import GHC.Hs
import GHC.Tc.Gen.Bind
import GHC.Tc.TyCl
import GHC.Tc.TyCl.Utils ( addTyConsToGblEnv )
-import GHC.Tc.TyCl.Class ( tcClassDecl2, tcATDefault,
+import GHC.Tc.TyCl.Class ( tcClassDecl2, ClassScopedTVEnv, tcATDefault,
HsSigFun, mkHsSigFun, badMethodErr,
findMethodBind, instantiateMethod )
import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities )
@@ -1143,17 +1143,17 @@ takes a slightly different approach.
* *
********************************************************************* -}
-tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn]
+tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn] -> ClassScopedTVEnv
-> TcM (LHsBinds GhcTc)
-- (a) From each class declaration,
-- generate any default-method bindings
-- (b) From each instance decl
-- generate the dfun binding
-tcInstDecls2 tycl_decls inst_decls
+tcInstDecls2 tycl_decls inst_decls class_scoped_tv_env
= do { -- (a) Default methods from class decls
let class_decls = filter (isClassDecl . unLoc) tycl_decls
- ; dm_binds_s <- mapM tcClassDecl2 class_decls
+ ; dm_binds_s <- mapM (tcClassDecl2 class_scoped_tv_env) class_decls
; let dm_binds = unionManyBags dm_binds_s
-- (b) instance declarations
diff --git a/testsuite/tests/typecheck/should_compile/T19738.hs b/testsuite/tests/typecheck/should_compile/T19738.hs
new file mode 100644
index 0000000000..4c704b6d5e
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T19738.hs
@@ -0,0 +1,11 @@
+module T19738 where
+
+import Data.Kind
+
+type P :: k -> Type
+data P a = MkP
+
+type T :: k -> Constraint
+class T (a :: j) where
+ f :: P a
+ f = MkP @j @a
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 9b3753848f..9d0225a6c2 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -783,4 +783,5 @@ test('T18467', normal, compile, [''])
test('T19315', normal, compile, [''])
test('T19535', normal, compile, [''])
+test('T19738', normal, compile, [''])
test('T19742', normal, compile, [''])