Bring tcTyConScopedTyVars into scope in tcClassDecl2

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.

2 files changed, 31 insertions, 13 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
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