summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRyan Scott <ryan.gl.scott@gmail.com>2021-04-04 20:17:40 -0400
committerRyan Scott <ryan.gl.scott@gmail.com>2021-04-06 18:26:16 -0400
commit3dd6ca61365ab881906f12f6692ee286b22b3dd5 (patch)
tree9725429cad6b93184d132c3f91e348510a0e0089
parentce706faeef3964116c6e1dd0e6ae2f2e77fde57d (diff)
downloadhaskell-wip/T19649.tar.gz
Fix #19649 by using filterInScopeM in rnFamEqnwip/T19649
Previously, associated type family instances would incorrectly claim to implicitly quantify over type variables bound by the instance head in the `HsOuterImplicit`s that `rnFamEqn` returned. This is fixed by using `filterInScopeM` to filter out any type variables that the instance head binds. Fixes #19649.
-rw-r--r--compiler/GHC/Rename/HsType.hs2
-rw-r--r--compiler/GHC/Rename/Module.hs21
-rw-r--r--testsuite/tests/parser/should_compile/DumpRenamedAst.hs7
-rw-r--r--testsuite/tests/parser/should_compile/DumpRenamedAst.stderr258
4 files changed, 268 insertions, 20 deletions
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index 07cc79fd17..f49406c40a 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -31,7 +31,7 @@ module GHC.Rename.HsType (
bindHsOuterTyVarBndrs, bindHsForAllTelescope,
bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..),
rnImplicitTvOccs, bindSigTyVarsFV, bindHsQTyVars,
- FreeKiTyVars,
+ FreeKiTyVars, filterInScopeM,
extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
extractHsTysRdrTyVars, extractRdrKindSigVars,
extractConDeclGADTDetailsTyVars, extractDataDefnKindVars,
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index b5c91c8cc3..1f7fa67ad1 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -719,7 +719,10 @@ rnFamEqn doc atfi extra_kvars
-- data instance H :: k -> Type where ...
-- -- all_imp_vars = [k]
-- @
- ; let all_imp_vars = pat_kity_vars ++ extra_kvars
+ --
+ -- For associated type family instances, exclude the type variables
+ -- bound by the instance head with filterInScopeM (#19649).
+ ; all_imp_vars <- filterInScopeM $ pat_kity_vars ++ extra_kvars
; bindHsOuterTyVarBndrs doc mb_cls all_imp_vars outer_bndrs $ \rn_outer_bndrs ->
do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats
@@ -755,8 +758,18 @@ rnFamEqn doc atfi extra_kvars
-- parent instance declaration is mentioned on the RHS of the
-- associated family instance but not bound on the LHS, then reject
-- that type variable as being out of scope.
- -- See Note [Renaming associated types]
- ; let lhs_bound_vars = extendNameSetList pat_fvs all_nms
+ -- See Note [Renaming associated types].
+ -- Per that Note, the LHS type variables consist of:
+ --
+ -- * The variables mentioned in the instance's type patterns
+ -- (pat_fvs), and
+ --
+ -- * The variables mentioned in an outermost kind signature on the
+ -- RHS. This is a subset of `rhs_fvs`. To compute it, we look up
+ -- each RdrName in `extra_kvars` to find its corresponding Name in
+ -- the LocalRdrEnv.
+ ; extra_kvar_nms <- mapMaybeM (lookupLocalOccRn_maybe . unLoc) extra_kvars
+ ; let lhs_bound_vars = pat_fvs `extendNameSetList` extra_kvar_nms
improperly_scoped cls_tkv =
cls_tkv `elemNameSet` rhs_fvs
-- Mentioned on the RHS...
@@ -1120,7 +1133,7 @@ example:
Here, we /do/ want to warn that `CF` is unused in the module `C`, as it is
defined but not used (#18470).
-GHC accomplishes this in rnFamInstEqn when determining the set of free
+GHC accomplishes this in rnFamEqn when determining the set of free
variables to return at the end. If renaming a data family or open type family
equation, we add the name of the type family constructor to the set of returned
free variables to ensure that the name is marked as an occurrence. If renaming
diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.hs b/testsuite/tests/parser/should_compile/DumpRenamedAst.hs
index a0cb8a36b6..ba136db8e3 100644
--- a/testsuite/tests/parser/should_compile/DumpRenamedAst.hs
+++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.hs
@@ -24,4 +24,11 @@ data T f (a :: k) = MkT (f a)
type family F1 (a :: k) (f :: k -> Type) :: Type where
F1 @Peano a f = T @Peano f a
+class C a where
+ type F a b
+
+instance C [a] where
+ type F [a] b = Either a b -- Ensure that the HsOuterImplicit for the F
+ -- instance only quantifies over `b` (#19649)
+
main = putStrLn "hello"
diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
index ac53ca8274..f131c08880 100644
--- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
@@ -13,29 +13,29 @@
[(L
(SrcSpanAnn (EpAnn
(Anchor
- { DumpRenamedAst.hs:27:1-23 }
+ { DumpRenamedAst.hs:34:1-23 }
(UnchangedAnchor))
(AnnListItem
[])
(EpaComments
- [])) { DumpRenamedAst.hs:27:1-23 })
+ [])) { DumpRenamedAst.hs:34:1-23 })
(FunBind
{NameSet:
[]}
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:27:1-4 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:34:1-4 })
{Name: DumpRenamedAst.main})
(MG
(NoExtField)
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:27:1-23 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:34:1-23 })
[(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:27:1-23 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:34:1-23 })
(Match
(EpAnnNotUsed)
(FunRhs
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:27:1-4 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:34:1-4 })
{Name: DumpRenamedAst.main})
(Prefix)
(NoSrcStrict))
@@ -43,33 +43,33 @@
(GRHSs
(NoExtField)
[(L
- { DumpRenamedAst.hs:27:6-23 }
+ { DumpRenamedAst.hs:34:6-23 }
(GRHS
(EpAnnNotUsed)
[]
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:27:8-23 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:34:8-23 })
(HsApp
(EpAnn
(Anchor
- { DumpRenamedAst.hs:27:8-23 }
+ { DumpRenamedAst.hs:34:8-23 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
[]))
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:27:8-15 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:34:8-15 })
(HsVar
(NoExtField)
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:27:8-15 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:34:8-15 })
{Name: System.IO.putStrLn})))
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:27:17-23 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:34:17-23 })
(HsLit
(EpAnn
(Anchor
- { DumpRenamedAst.hs:27:17-23 }
+ { DumpRenamedAst.hs:34:17-23 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -993,7 +993,233 @@
(Nothing))))]
[]
[]
- [])]
+ [])
+ ,(TyClGroup
+ (NoExtField)
+ [(L
+ (SrcSpanAnn (EpAnn
+ (Anchor
+ { DumpRenamedAst.hs:(27,1)-(28,12) }
+ (UnchangedAnchor))
+ (AnnListItem
+ [])
+ (EpaComments
+ [])) { DumpRenamedAst.hs:(27,1)-(28,12) })
+ (ClassDecl
+ {NameSet:
+ []}
+ (Nothing)
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:27:7 })
+ {Name: DumpRenamedAst.C})
+ (HsQTvs
+ []
+ [(L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:27:9 })
+ (UserTyVar
+ (EpAnn
+ (Anchor
+ { DumpRenamedAst.hs:27:9 }
+ (UnchangedAnchor))
+ []
+ (EpaComments
+ []))
+ (())
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:27:9 })
+ {Name: a})))])
+ (Prefix)
+ []
+ []
+ {Bag(LocatedA (HsBind Name)):
+ []}
+ [(L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:28:3-12 })
+ (FamilyDecl
+ (EpAnnNotUsed)
+ (OpenTypeFamily)
+ (NotTopLevel)
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:28:8 })
+ {Name: DumpRenamedAst.F})
+ (HsQTvs
+ []
+ [(L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:28:10 })
+ (UserTyVar
+ (EpAnn
+ (Anchor
+ { DumpRenamedAst.hs:28:10 }
+ (UnchangedAnchor))
+ []
+ (EpaComments
+ []))
+ (())
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:28:10 })
+ {Name: a})))
+ ,(L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:28:12 })
+ (UserTyVar
+ (EpAnn
+ (Anchor
+ { DumpRenamedAst.hs:28:12 }
+ (UnchangedAnchor))
+ []
+ (EpaComments
+ []))
+ (())
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:28:12 })
+ {Name: b})))])
+ (Prefix)
+ (L
+ { <no location info> }
+ (NoSig
+ (NoExtField)))
+ (Nothing)))]
+ []
+ []))]
+ []
+ []
+ [(L
+ (SrcSpanAnn (EpAnn
+ (Anchor
+ { DumpRenamedAst.hs:(30,1)-(31,27) }
+ (UnchangedAnchor))
+ (AnnListItem
+ [])
+ (EpaComments
+ [])) { DumpRenamedAst.hs:(30,1)-(31,27) })
+ (ClsInstD
+ (NoExtField)
+ (ClsInstDecl
+ (NoExtField)
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:30:10-14 })
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ [{Name: a}])
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:30:10-14 })
+ (HsAppTy
+ (NoExtField)
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:30:10 })
+ (HsTyVar
+ (EpAnnNotUsed)
+ (NotPromoted)
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:30:10 })
+ {Name: DumpRenamedAst.C})))
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:30:12-14 })
+ (HsListTy
+ (EpAnn
+ (Anchor
+ { DumpRenamedAst.hs:30:12 }
+ (UnchangedAnchor))
+ (AnnParen
+ (AnnParensSquare)
+ (AR { DumpRenamedAst.hs:30:12 })
+ (AR { DumpRenamedAst.hs:30:14 }))
+ (EpaComments
+ []))
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:30:13 })
+ (HsTyVar
+ (EpAnnNotUsed)
+ (NotPromoted)
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:30:13 })
+ {Name: a})))))))))
+ {Bag(LocatedA (HsBind Name)):
+ []}
+ []
+ [(L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:31:3-27 })
+ (TyFamInstDecl
+ (EpAnn
+ (Anchor
+ { DumpRenamedAst.hs:31:3-27 }
+ (UnchangedAnchor))
+ [(AddEpAnn AnnType (AR { DumpRenamedAst.hs:31:3-6 }))]
+ (EpaComments
+ []))
+ (FamEqn
+ (EpAnnNotUsed)
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:31:8 })
+ {Name: DumpRenamedAst.F})
+ (HsOuterImplicit
+ [{Name: b}])
+ [(HsValArg
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:31:10-12 })
+ (HsListTy
+ (EpAnn
+ (Anchor
+ { DumpRenamedAst.hs:31:10 }
+ (UnchangedAnchor))
+ (AnnParen
+ (AnnParensSquare)
+ (AR { DumpRenamedAst.hs:31:10 })
+ (AR { DumpRenamedAst.hs:31:12 }))
+ (EpaComments
+ []))
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:31:11 })
+ (HsTyVar
+ (EpAnnNotUsed)
+ (NotPromoted)
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:31:11 })
+ {Name: a}))))))
+ ,(HsValArg
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:31:14 })
+ (HsTyVar
+ (EpAnnNotUsed)
+ (NotPromoted)
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:31:14 })
+ {Name: b}))))]
+ (Prefix)
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:31:18-27 })
+ (HsAppTy
+ (NoExtField)
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:31:18-25 })
+ (HsAppTy
+ (NoExtField)
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:31:18-23 })
+ (HsTyVar
+ (EpAnnNotUsed)
+ (NotPromoted)
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:31:18-23 })
+ {Name: Data.Either.Either})))
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:31:25 })
+ (HsTyVar
+ (EpAnnNotUsed)
+ (NotPromoted)
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:31:25 })
+ {Name: a})))))
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:31:27 })
+ (HsTyVar
+ (EpAnnNotUsed)
+ (NotPromoted)
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:31:27 })
+ {Name: b}))))))))]
+ []
+ (Nothing))))])]
[]
[]
[]
@@ -1075,4 +1301,6 @@
(SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:8:19-22 })
{Name: GHC.Types.Type})))))])))))]
(Nothing)
- (Nothing))) \ No newline at end of file
+ (Nothing)))
+
+