From ede3df271a931f3845b5a63fb29654b46bce620d Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Sun, 27 Aug 2023 10:53:50 +0100
Subject: [PATCH] EPA: Incorrect span for LWarnDec GhcPs
The code (from T23465.hs)
{-# WARNInG in "x-c" e "d" #-}
e = e
gives an incorrect span for the LWarnDecl GhcPs
Closes #23892
It also fixes the Test23465/Test23464 mixup
---
compiler/GHC/Hs/Decls.hs | 2 +-
compiler/GHC/Parser.y | 9 +++--
compiler/GHC/Parser/Annotation.hs | 4 +++
testsuite/tests/printer/Makefile | 8 ++---
testsuite/tests/printer/Test23464.hs | 4 ---
testsuite/tests/printer/Test23465.hs | 14 ++++++++
testsuite/tests/printer/all.T | 4 +--
utils/check-exact/ExactPrint.hs | 54 +++++++++++++++++++++-------
utils/check-exact/Main.hs | 2 +-
9 files changed, 73 insertions(+), 28 deletions(-)
delete mode 100644 testsuite/tests/printer/Test23464.hs
create mode 100644 testsuite/tests/printer/Test23465.hs
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 8c098c9be504..0c9fa7e8abe9 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -1268,7 +1268,7 @@ type instance XXWarnDecl (GhcPass _) = DataConCantHappen
instance OutputableBndrId p
=> Outputable (WarnDecls (GhcPass p)) where
ppr (Warnings ext decls)
- = ftext src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"
+ = ftext src <+> vcat (punctuate semi (map ppr decls)) <+> text "#-}"
where src = case ghcPass @p of
GhcPs | (_, SourceText src) <- ext -> src
GhcRn | SourceText src <- ext -> src
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 9536d1e33d07..963af26a9aaf 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -2002,8 +2002,8 @@ warnings :: { OrdList (LWarnDecl GhcPs) }
-- SUP: TEMPORARY HACK, not checking for `module Foo'
warning :: { OrdList (LWarnDecl GhcPs) }
: warning_category namelist strings
- {% fmap unitOL $ acsA (\cs -> sLL $2 $>
- (Warning (EpAnn (glR $2) (fst $ unLoc $3) cs) (unLoc $2)
+ {% fmap unitOL $ acsA (\cs -> L (comb3 $1 $2 $3)
+ (Warning (EpAnn (glMR $1 $2) (fst $ unLoc $3) cs) (unLoc $2)
(WarningTxt $1 NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) }
deprecations :: { OrdList (LWarnDecl GhcPs) }
@@ -4300,6 +4300,10 @@ glN = getLocA
glR :: Located a -> Anchor
glR la = Anchor (realSrcSpan $ getLoc la) UnchangedAnchor
+glMR :: Maybe (Located a) -> Located b -> Anchor
+glMR (Just la) _ = glR la
+glMR _ la = glR la
+
glAA :: Located a -> EpaLocation
glAA = srcSpan2e . getLoc
@@ -4554,5 +4558,4 @@ adaptWhereBinds (Just (L l (b, mc))) = L l (b, maybe emptyComments id mc)
combineHasLocs :: (HasLoc a, HasLoc b) => a -> b -> SrcSpan
combineHasLocs a b = combineSrcSpans (getHasLoc a) (getHasLoc b)
-
}
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index 0fb917b96b68..ae7dcd74315d 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -1029,6 +1029,10 @@ instance HasLoc (Located a) where
instance HasLoc (GenLocated (SrcSpanAnn' a) e) where
getHasLoc (L (SrcSpanAnn _ l) _) = l
+instance (HasLoc a) => (HasLoc (Maybe a)) where
+ getHasLoc (Just a) = getHasLoc a
+ getHasLoc Nothing = noSrcSpan
+
getHasLocList :: HasLoc a => [a] -> SrcSpan
getHasLocList [] = noSrcSpan
getHasLocList xs = foldl1' combineSrcSpans $ map getHasLoc xs
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index b82a65b56b3d..ea796268a460 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -796,12 +796,12 @@ Test22771:
$(CHECK_PPR) $(LIBDIR) Test22771.hs
$(CHECK_EXACT) $(LIBDIR) Test22771.hs
-.PHONY: Test23464
+.PHONY: Test23465
Test23465:
- $(CHECK_PPR) $(LIBDIR) Test23464.hs
- $(CHECK_EXACT) $(LIBDIR) Test23464.hs
+ $(CHECK_PPR) $(LIBDIR) Test23465.hs
+ $(CHECK_EXACT) $(LIBDIR) Test23465.hs
.PHONY: Test23887
-Test23465:
+Test23887:
$(CHECK_PPR) $(LIBDIR) Test23887.hs
$(CHECK_EXACT) $(LIBDIR) Test23887.hs
diff --git a/testsuite/tests/printer/Test23464.hs b/testsuite/tests/printer/Test23464.hs
deleted file mode 100644
index 885b41b9f3d8..000000000000
--- a/testsuite/tests/printer/Test23464.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-module T23465 {-# WaRNING in "x-a" "b" #-} where
-
-{-# WARNInG in "x-c" e "d" #-}
-e = e
diff --git a/testsuite/tests/printer/Test23465.hs b/testsuite/tests/printer/Test23465.hs
new file mode 100644
index 000000000000..dd4cd604f2e2
--- /dev/null
+++ b/testsuite/tests/printer/Test23465.hs
@@ -0,0 +1,14 @@
+module Test23465 {-# WaRNING in "x-a" "b" #-} where
+
+{-# WARNInG in "x-c" e "d" #-}
+e = e
+
+{-# WARNInG
+ in "x-f" f "fw" ;
+ in "x-f" g "gw"
+#-}
+f = f
+g = g
+
+{-# WARNinG h "hw" #-}
+h = h
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index 454b0724cfa0..acf497b863c1 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -191,5 +191,5 @@ test('T20531_red_ticks', extra_files(['T20531_defs.hs']), ghci_script, ['T20531_
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'])
+test('Test23465', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23465'])
+test('Test23887', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23887'])
\ No newline at end of file
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index ff0671611c66..189a0e294aba 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -617,6 +617,15 @@ markEpAnnLMS' (EpAnn anc a cs) l kw (Just str) = do
-- ---------------------------------------------------------------------
+markLToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok)
+ => Located (HsToken tok) -> EP w m (Located (HsToken tok))
+markLToken (L (RealSrcSpan aa mb) t) = do
+ epaLoc'<- printStringAtAA (EpaSpan aa mb) (symbolVal (Proxy @tok))
+ case epaLoc' of
+ EpaSpan aa' mb' -> return (L (RealSrcSpan aa' mb') t)
+ _ -> return (L (RealSrcSpan aa mb ) t)
+markLToken (L lt t) = return (L lt t)
+
markToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok)
=> LHsToken tok GhcPs -> EP w m (LHsToken tok GhcPs)
markToken (L NoTokenLoc t) = return (L NoTokenLoc t)
@@ -1411,11 +1420,12 @@ instance ExactPrint (LocatedP (WarningTxt GhcPs)) where
exact (L (SrcSpanAnn an l) (WarningTxt mb_cat src ws)) = do
an0 <- markAnnOpenP an src "{-# WARNING"
+ mb_cat' <- markAnnotated mb_cat
an1 <- markEpAnnL an0 lapr_rest AnnOpenS
ws' <- markAnnotated ws
an2 <- markEpAnnL an1 lapr_rest AnnCloseS
an3 <- markAnnCloseP an2
- return (L (SrcSpanAnn an3 l) (WarningTxt mb_cat src ws'))
+ return (L (SrcSpanAnn an3 l) (WarningTxt mb_cat' src ws'))
exact (L (SrcSpanAnn an l) (DeprecatedTxt src ws)) = do
an0 <- markAnnOpenP an src "{-# DEPRECATED"
@@ -1425,6 +1435,25 @@ instance ExactPrint (LocatedP (WarningTxt GhcPs)) where
an3 <- markAnnCloseP an2
return (L (SrcSpanAnn an3 l) (DeprecatedTxt src ws'))
+instance ExactPrint InWarningCategory where
+ getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ = a
+
+ exact (InWarningCategory tkIn source (L l wc)) = do
+ tkIn' <- markLToken tkIn
+ L _ (_,wc') <- markAnnotated (L l (source, wc))
+ return (InWarningCategory tkIn' source (L l wc'))
+
+instance ExactPrint (SourceText, WarningCategory) where
+ getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ = a
+
+ exact (st, WarningCategory wc) = do
+ case st of
+ NoSourceText -> printStringAdvance $ "\"" ++ (unpackFS wc) ++ "\""
+ SourceText src -> printStringAdvance $ (unpackFS src)
+ return (st, WarningCategory wc)
+
-- ---------------------------------------------------------------------
instance ExactPrint (ImportDecl GhcPs) where
@@ -1748,19 +1777,20 @@ instance ExactPrint (WarnDecl GhcPs) where
getAnnotationEntry (Warning an _ _) = fromAnn an
setAnnotationAnchor (Warning an a b) anc cs = Warning (setAnchorEpa an anc cs) a b
- exact (Warning an lns txt) = do
+ exact (Warning an lns (WarningTxt mb_cat src ls )) = do
+ mb_cat' <- markAnnotated mb_cat
lns' <- markAnnotated lns
an0 <- markEpAnnL an lidl AnnOpenS -- "["
- txt' <-
- case txt of
- WarningTxt mb_cat src ls -> do
- ls' <- markAnnotated ls
- return (WarningTxt mb_cat src ls')
- DeprecatedTxt src ls -> do
- ls' <- markAnnotated ls
- return (DeprecatedTxt src ls')
+ ls' <- markAnnotated ls
an1 <- markEpAnnL an0 lidl AnnCloseS -- "]"
- return (Warning an1 lns' txt')
+ return (Warning an1 lns' (WarningTxt mb_cat' src ls'))
+
+ exact (Warning an lns (DeprecatedTxt src ls)) = do
+ lns' <- markAnnotated lns
+ an0 <- markEpAnnL an lidl AnnOpenS -- "["
+ ls' <- markAnnotated ls
+ an1 <- markEpAnnL an0 lidl AnnCloseS -- "]"
+ return (Warning an1 lns' (DeprecatedTxt src ls'))
-- ---------------------------------------------------------------------
@@ -1783,7 +1813,6 @@ instance ExactPrint FastString where
-- exact fs = printStringAdvance (show (unpackFS fs))
exact fs = printStringAdvance (unpackFS fs) >> return fs
-
-- ---------------------------------------------------------------------
instance ExactPrint (RuleDecls GhcPs) where
@@ -3122,7 +3151,6 @@ instance (ExactPrint body)
-- ---------------------------------------------------------------------
--- instance ExactPrint (HsRecUpdField GhcPs q) where
instance (ExactPrint (LocatedA body))
=> ExactPrint (HsFieldBind (LocatedAn NoEpAnns (AmbiguousFieldOcc GhcPs)) (LocatedA body)) where
getAnnotationEntry x = fromAnn (hfbAnn x)
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index a149a978404a..9d9f321160a5 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -206,7 +206,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_buil
-- "../../testsuite/tests/printer/HsDocTy.hs" Nothing
-- "../../testsuite/tests/printer/Test22765.hs" Nothing
-- "../../testsuite/tests/printer/Test22771.hs" Nothing
- "../../testsuite/tests/typecheck/should_fail/T22560_fail_c.hs" Nothing
+ "../../testsuite/tests/printer/Test23465.hs" Nothing
-- cloneT does not need a test, function can be retired
--
GitLab