[Git][ghc/ghc][master] EPA: Incorrect locations for UserTyVar with '@'
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Sep 7 14:59:17 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
b34f8586 by Alan Zimmerman at 2023-09-07T10:58:38-04:00
EPA: Incorrect locations for UserTyVar with '@'
In T13343.hs, the location for the @ is not within the span of the
surrounding UserTyVar.
type Bad @v = (forall (v1 :: RuntimeRep) (a1 :: TYPE v). a1) :: TYPE v
Widen it so it is captured.
Closes #23887
- - - - -
7 changed files:
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/Test23887.hs
- testsuite/tests/printer/all.T
- utils/check-exact/Main.hs
Changes:
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -464,9 +464,12 @@ hsScopedKvs (L _ HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndr
hsScopedKvs _ = []
---------------------
+hsTyVarLName :: HsTyVarBndr flag (GhcPass p) -> LIdP (GhcPass p)
+hsTyVarLName (UserTyVar _ _ n) = n
+hsTyVarLName (KindedTyVar _ _ n _) = n
+
hsTyVarName :: HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
-hsTyVarName (UserTyVar _ _ (L _ n)) = n
-hsTyVarName (KindedTyVar _ _ (L _ n) _) = n
+hsTyVarName = unLoc . hsTyVarLName
hsLTyVarName :: LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName = hsTyVarName . unLoc
@@ -488,10 +491,12 @@ hsAllLTyVarNames (HsQTvs { hsq_ext = kvs
, hsq_explicit = tvs })
= kvs ++ hsLTyVarNames tvs
-hsLTyVarLocName :: LHsTyVarBndr flag (GhcPass p) -> LocatedN (IdP (GhcPass p))
-hsLTyVarLocName (L l a) = L (l2l l) (hsTyVarName a)
+hsLTyVarLocName :: Anno (IdGhcP p) ~ SrcSpanAnnN
+ => LHsTyVarBndr flag (GhcPass p) -> LocatedN (IdP (GhcPass p))
+hsLTyVarLocName (L _ a) = hsTyVarLName a
-hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))]
+hsLTyVarLocNames :: Anno (IdGhcP p) ~ SrcSpanAnnN
+ => LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))]
hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)
-- | Get the kind signature of a type, ignoring parentheses:
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -1039,7 +1039,7 @@ realSrcSpan :: SrcSpan -> RealSrcSpan
realSrcSpan (RealSrcSpan s _) = s
realSrcSpan _ = mkRealSrcSpan l l -- AZ temporary
where
- l = mkRealSrcLoc (fsLit "foo") (-1) (-1)
+ l = mkRealSrcLoc (fsLit "realSrcSpan") (-1) (-1)
srcSpan2e :: SrcSpan -> EpaLocation
srcSpan2e (RealSrcSpan s mb) = EpaSpan s mb
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -963,19 +963,30 @@ checkTyVars pp_what equals_or_where tc tparms
= let
an = (reverse ops) ++ cps
in
- return (L (widenLocatedAn (l Semi.<> annt) an)
- (KindedTyVar (addAnns (annk Semi.<> ann) an cs) bvis (L lv tv) k))
+ return (L (widenLocatedAn (l Semi.<> annt) (for_widening bvis:an))
+ (KindedTyVar (addAnns (annk Semi.<> ann Semi.<> for_widening_ann bvis) an cs)
+ bvis (L lv tv) k))
chk ops cps cs bvis (L l (HsTyVar ann _ (L ltv tv)))
| isRdrTyVar tv
= let
an = (reverse ops) ++ cps
in
- return (L (widenLocatedAn l an)
- (UserTyVar (addAnns ann an cs) bvis (L ltv tv)))
+ return (L (widenLocatedAn l (for_widening bvis:an))
+ (UserTyVar (addAnns (ann Semi.<> for_widening_ann bvis) an cs)
+ bvis (L ltv tv)))
chk _ _ _ _ t@(L loc _)
= addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
(PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where)
+ -- Return an AddEpAnn for use in widenLocatedAn. The AnnKeywordId is not used.
+ for_widening :: HsBndrVis GhcPs -> AddEpAnn
+ for_widening (HsBndrInvisible (L (TokenLoc loc) _)) = AddEpAnn AnnAnyclass loc
+ for_widening _ = AddEpAnn AnnAnyclass (EpaDelta (SameLine 0) [])
+
+ for_widening_ann :: HsBndrVis GhcPs -> EpAnn [AddEpAnn]
+ for_widening_ann (HsBndrInvisible (L (TokenLoc (EpaSpan r _mb)) _)) = EpAnn (realSpanAsAnchor r) [] emptyComments
+ for_widening_ann _ = EpAnnNotUsed
+
whereDots, equalsDots :: SDoc
-- Second argument to checkTyVars
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -800,3 +800,8 @@ Test22771:
Test23465:
$(CHECK_PPR) $(LIBDIR) Test23464.hs
$(CHECK_EXACT) $(LIBDIR) Test23464.hs
+
+.PHONY: Test23887
+Test23465:
+ $(CHECK_PPR) $(LIBDIR) Test23887.hs
+ $(CHECK_EXACT) $(LIBDIR) Test23887.hs
=====================================
testsuite/tests/printer/Test23887.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE PolyKinds #-}
+module Test23887 where
+-- based on T13343.hs
+import GHC.Exts
+
+type Bad :: forall v . TYPE v
+type Bad @v = (forall (v1 :: RuntimeRep) (a1 :: TYPE v). a1) :: TYPE v
+
+-- Note v /= v1.
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -192,3 +192,4 @@ test('HsDocTy', [ignore_stderr, req_ppr_deps], makefile_test, ['HsDocTy'])
test('Test22765', [ignore_stderr, req_ppr_deps], makefile_test, ['Test22765'])
test('Test22771', [ignore_stderr, req_ppr_deps], makefile_test, ['Test22771'])
test('Test23464', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23464'])
+test('Test23887', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23887'])
=====================================
utils/check-exact/Main.hs
=====================================
@@ -36,10 +36,10 @@ import GHC.Data.FastString
-- ---------------------------------------------------------------------
_tt :: IO ()
-_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_build/stage1/lib/"
+-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_build/stage1/lib/"
-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib/"
-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib"
--- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib"
+_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib"
-- "../../testsuite/tests/ghc-api/exactprint/RenameCase1.hs" (Just changeRenameCase1)
-- "../../testsuite/tests/ghc-api/exactprint/LayoutLet2.hs" (Just changeLayoutLet2)
@@ -205,7 +205,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
-- "../../testsuite/tests/printer/Test16279.hs" Nothing
-- "../../testsuite/tests/printer/HsDocTy.hs" Nothing
-- "../../testsuite/tests/printer/Test22765.hs" Nothing
- "../../testsuite/tests/printer/Test22771.hs" Nothing
+ -- "../../testsuite/tests/printer/Test22771.hs" Nothing
+ "../../testsuite/tests/typecheck/should_fail/T22560_fail_c.hs" Nothing
-- cloneT does not need a test, function can be retired
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b34f85865df279a7384dcccb767277d8265b375e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b34f85865df279a7384dcccb767277d8265b375e
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230907/bcb1b215/attachment-0001.html>
More information about the ghc-commits
mailing list