diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index 60f3eef0806fd67928e3649e1e9ba96bc1f6894f..aa6b4e3c8e634c2239b6f0a256fa052627ba6bbc 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -13,7 +13,7 @@ module GHC.Parser.Annotation (
-- * In-tree Exact Print Annotations
AddEpAnn(..),
- EpaLocation(..), epaLocationRealSrcSpan,
+ EpaLocation, EpaLocation'(..), epaLocationRealSrcSpan,
TokenLocation(..),
getTokenSrcSpan,
DeltaPos(..), deltaPos, getDeltaLine,
@@ -26,7 +26,8 @@ module GHC.Parser.Annotation (
-- ** Comments in Annotations
- EpAnnComments(..), LEpaComment, emptyComments,
+ EpAnnComments(..), LEpaComment, NoCommentsLocation, NoComments(..), emptyComments,
+ epaToNoCommentsLocation, noCommentsToEpaLocation,
getFollowingComments, setFollowingComments, setPriorComments,
EpAnnCO,
@@ -402,9 +403,26 @@ data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq)
-- in the @'EpaDelta'@ variant captures any comments between the prior
-- output and the thing being marked here, since we cannot otherwise
-- sort the relative order.
-data EpaLocation = EpaSpan !SrcSpan
- | EpaDelta !DeltaPos ![LEpaComment]
- deriving (Data,Eq,Show)
+
+data EpaLocation' a = EpaSpan !SrcSpan
+ | EpaDelta !DeltaPos !a
+ deriving (Data,Eq,Show)
+
+type EpaLocation = EpaLocation' [LEpaComment]
+
+type NoCommentsLocation = EpaLocation' NoComments
+
+data NoComments = NoComments
+ deriving (Data,Eq,Ord,Show)
+
+epaToNoCommentsLocation :: EpaLocation -> NoCommentsLocation
+epaToNoCommentsLocation (EpaSpan ss) = EpaSpan ss
+epaToNoCommentsLocation (EpaDelta dp []) = EpaDelta dp NoComments
+epaToNoCommentsLocation (EpaDelta _ _ ) = panic "epaToNoCommentsLocation"
+
+noCommentsToEpaLocation :: NoCommentsLocation -> EpaLocation
+noCommentsToEpaLocation (EpaSpan ss) = EpaSpan ss
+noCommentsToEpaLocation (EpaDelta dp NoComments) = EpaDelta dp []
-- | Tokens embedded in the AST have an EpaLocation, unless they come from
-- generated code (e.g. by TH).
@@ -454,7 +472,10 @@ epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan
epaLocationRealSrcSpan (EpaSpan (RealSrcSpan r _)) = r
epaLocationRealSrcSpan _ = panic "epaLocationRealSrcSpan"
-instance Outputable EpaLocation where
+instance Outputable NoComments where
+ ppr NoComments = text "NoComments"
+
+instance (Outputable a) => Outputable (EpaLocation' a) where
ppr (EpaSpan r) = text "EpaSpan" <+> ppr r
ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs
@@ -517,18 +538,18 @@ data EpAnn ann
-- that relationship is tracked in the 'anchor_op' instead.
type Anchor = EpaLocation -- Transitional
-anchor :: Anchor -> RealSrcSpan
+anchor :: (EpaLocation' a) -> RealSrcSpan
anchor (EpaSpan (RealSrcSpan r _)) = r
anchor _ = panic "anchor"
-spanAsAnchor :: SrcSpan -> Anchor
+spanAsAnchor :: SrcSpan -> (EpaLocation' a)
spanAsAnchor ss = EpaSpan ss
-realSpanAsAnchor :: RealSrcSpan -> Anchor
+realSpanAsAnchor :: RealSrcSpan -> (EpaLocation' a)
realSpanAsAnchor s = EpaSpan (RealSrcSpan s Strict.Nothing)
-noSpanAnchor :: Anchor
-noSpanAnchor = EpaDelta (SameLine 0) []
+noSpanAnchor :: (NoAnn a) => (EpaLocation' a)
+noSpanAnchor = EpaDelta (SameLine 0) noAnn
-- ---------------------------------------------------------------------
@@ -546,7 +567,7 @@ data EpAnnComments = EpaComments
, followingComments :: ![LEpaComment] }
deriving (Data, Eq)
-type LEpaComment = GenLocated Anchor EpaComment
+type LEpaComment = GenLocated NoCommentsLocation EpaComment
emptyComments :: EpAnnComments
emptyComments = EpaComments []
@@ -1333,7 +1354,7 @@ instance Outputable DeltaPos where
ppr (SameLine c) = text "SameLine" <+> ppr c
ppr (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c
-instance Outputable (GenLocated Anchor EpaComment) where
+instance Outputable (GenLocated NoCommentsLocation EpaComment) where
ppr (L l c) = text "L" <+> ppr l <+> ppr c
instance Outputable EpAnnComments where
diff --git a/testsuite/tests/printer/Test20297.stdout b/testsuite/tests/printer/Test20297.stdout
index 564ed735d36983f56324514781d915d77d68823d..234e36b3f9dea8957545adde376c8e7db0eb7ad5 100644
--- a/testsuite/tests/printer/Test20297.stdout
+++ b/testsuite/tests/printer/Test20297.stdout
@@ -17,7 +17,8 @@
{ Test20297.hs:11:22-26 })))
(EpaCommentsBalanced
[(L
- (EpaSpan { Test20297.hs:1:1-33 })
+ (EpaSpan
+ { Test20297.hs:1:1-33 })
(EpaComment
(EpaBlockComment
"{-# OPTIONS -ddump-parsed-ast #-}")
@@ -114,7 +115,8 @@
(AddEpAnn AnnEqual (EpaSpan { Test20297.hs:5:5 })))
(EpaComments
[(L
- (EpaSpan { Test20297.hs:6:3-13 })
+ (EpaSpan
+ { Test20297.hs:6:3-13 })
(EpaComment
(EpaLineComment
"-- comment0")
@@ -162,7 +164,8 @@
[])
(EpaComments
[(L
- (EpaSpan { Test20297.hs:7:9-19 })
+ (EpaSpan
+ { Test20297.hs:7:9-19 })
(EpaComment
(EpaLineComment
"-- comment1")
@@ -267,7 +270,8 @@
[])
(EpaComments
[(L
- (EpaSpan { Test20297.hs:10:9-19 })
+ (EpaSpan
+ { Test20297.hs:10:9-19 })
(EpaComment
(EpaLineComment
"-- comment2")
@@ -436,7 +440,8 @@
{ Test20297.ppr.hs:9:20-24 })))
(EpaCommentsBalanced
[(L
- (EpaSpan { Test20297.ppr.hs:1:1-33 })
+ (EpaSpan
+ { Test20297.ppr.hs:1:1-33 })
(EpaComment
(EpaBlockComment
"{-# OPTIONS -ddump-parsed-ast #-}")
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index a647f2c5266ed7c7d004034fe7f6165a37baaf19..ffb48ee27bc2e1245f557b52fe0098af207aa1ee 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -619,7 +619,7 @@ annotationsToComments (EpAnn anc a cs) l kws = do
go :: ([Comment], [AddEpAnn]) -> [AddEpAnn] -> ([Comment], [AddEpAnn])
go acc [] = acc
go (cs',ans) ((AddEpAnn k ss) : ls)
- | Set.member k keywords = go ((mkKWComment k ss):cs', ans) ls
+ | Set.member k keywords = go ((mkKWComment k (epaToNoCommentsLocation ss)):cs', ans) ls
| otherwise = go (cs', (AddEpAnn k ss):ans) ls
-- ---------------------------------------------------------------------
@@ -677,7 +677,7 @@ printStringAtRsC capture pa str = do
NoCaptureComments -> return []
debugM $ "printStringAtRsC:cs'=" ++ show cs'
debugM $ "printStringAtRsC:p'=" ++ showAst p'
- debugM $ "printStringAtRsC: (EpaDelta p' [])=" ++ showAst (EpaDelta p' [])
+ debugM $ "printStringAtRsC: (EpaDelta p' [])=" ++ showAst (EpaDelta p' NoComments)
debugM $ "printStringAtRsC: (EpaDelta p' (map comment2LEpaComment cs'))=" ++ showAst (EpaDelta p' (map comment2LEpaComment cs'))
return (EpaDelta p' (map comment2LEpaComment cs'))
@@ -1365,14 +1365,14 @@ printCommentsBefore :: (Monad m, Monoid w) => RealSrcSpan -> EP w m ()
printCommentsBefore ss = do
cs <- commentAllocationBefore ss
debugM $ "printCommentsBefore: (ss): " ++ showPprUnsafe (rs2range ss)
- -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentAnchor cs)
+ -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentLoc cs)
mapM_ printOneComment cs
printCommentsIn :: (Monad m, Monoid w) => RealSrcSpan -> EP w m ()
printCommentsIn ss = do
cs <- commentAllocationIn ss
debugM $ "printCommentsIn: (ss): " ++ showPprUnsafe (rs2range ss)
- -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentAnchor cs)
+ -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentLoc cs)
mapM_ printOneComment cs
debugM $ "printCommentsIn:done"
@@ -1423,12 +1423,12 @@ updateAndApplyComment (Comment str anc pp mo) dp = do
_ -> dp''
op' = case dp' of
SameLine n -> if n >= 0
- then EpaDelta dp' []
- else EpaDelta dp []
- _ -> EpaDelta dp' []
- anc' = if str == "" && op' == EpaDelta (SameLine 0) [] -- EOF comment
- then EpaDelta dp []
- else EpaDelta dp []
+ then EpaDelta dp' NoComments
+ else EpaDelta dp NoComments
+ _ -> EpaDelta dp' NoComments
+ anc' = if str == "" && op' == EpaDelta (SameLine 0) NoComments -- EOF comment
+ then EpaDelta dp NoComments
+ else EpaDelta dp NoComments
-- ---------------------------------------------------------------------
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index 899582c4a77c3e98e15d6aba0b0d16155950c7a1..36e486d272f12b95f08870b27164bddd61cb8c1d 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -68,6 +68,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl4.hs" (Just addLocaLDecl4)
-- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl5.hs" (Just addLocaLDecl5)
-- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl6.hs" (Just addLocaLDecl6)
+ -- "../../testsuite/tests/ghc-api/exactprint/AddClassMethod.hs" (Just addClassMethod)
-- "../../testsuite/tests/ghc-api/exactprint/RmDecl1.hs" (Just rmDecl1)
-- "../../testsuite/tests/ghc-api/exactprint/RmDecl2.hs" (Just rmDecl2)
-- "../../testsuite/tests/ghc-api/exactprint/RmDecl3.hs" (Just rmDecl3)
diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs
index ffe0f7c0b88209a634d911d3925366b42b0872bd..4d70d06933bccc51e2a21f5f2aa9ddd7b3410562 100644
--- a/utils/check-exact/Transform.hs
+++ b/utils/check-exact/Transform.hs
@@ -283,8 +283,9 @@ setEntryDP (L (EpAnn (EpaDelta d csd) an cs) a) dp
(dp0,c') = go h
in
(dp0, c':t, EpaCommentsBalanced [] ts)
+ go :: GenLocated NoCommentsLocation e -> (DeltaPos, GenLocated NoCommentsLocation e)
go (L (EpaDelta _ c0) c) = (d, L (EpaDelta dp c0) c)
- go (L (EpaSpan _) c) = (d, L (EpaDelta dp []) c)
+ go (L (EpaSpan _) c) = (d, L (EpaDelta dp NoComments) c)
setEntryDP (L (EpAnn (EpaSpan (RealSrcSpan r _)) an cs) a) dp
= case sortEpaComments (priorComments cs) of
[] ->
@@ -293,7 +294,7 @@ setEntryDP (L (EpAnn (EpaSpan (RealSrcSpan r _)) an cs) a) dp
L (EpAnn (EpaDelta edp csd) an cs'') a
where
cs'' = setPriorComments cs []
- csd = L (EpaDelta dp []) c:cs'
+ csd = L (EpaDelta dp NoComments) c:cs'
lc = last $ (L ca c:cs')
delta = case getLoc lc of
EpaSpan (RealSrcSpan rr _) -> ss2delta (ss2pos rr) r
diff --git a/utils/check-exact/Types.hs b/utils/check-exact/Types.hs
index 381d157e8b444e9fc195b8dc0a2d5389b250c5af..6b529a3cc27a726f10ec21b17780557867660ee6 100644
--- a/utils/check-exact/Types.hs
+++ b/utils/check-exact/Types.hs
@@ -31,7 +31,7 @@ data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show)
data Comment = Comment
{
commentContents :: !String -- ^ The contents of the comment including separators
- , commentAnchor :: !Anchor
+ , commentLoc :: !NoCommentsLocation
, commentPriorTok :: !RealSrcSpan
, commentOrigin :: !(Maybe AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly.
}
diff --git a/utils/check-exact/Utils.hs b/utils/check-exact/Utils.hs
index ba5e8b20d78d89d8c58b999cf0931128b135e4af..89f8aecbc093d34ecdbe6c5d15d324daeb32d22c 100644
--- a/utils/check-exact/Utils.hs
+++ b/utils/check-exact/Utils.hs
@@ -186,7 +186,7 @@ isPointSrcSpan ss = spanLength ss == 0
-- does not already have one.
commentOrigDelta :: LEpaComment -> LEpaComment
commentOrigDelta (L (EpaSpan (RealSrcSpan la _)) (GHC.EpaComment t pp))
- = (L (EpaDelta dp []) (GHC.EpaComment t pp))
+ = (L (EpaDelta dp NoComments) (GHC.EpaComment t pp))
`debug` ("commentOrigDelta: (la, pp, r,c, dp)=" ++ showAst (la, pp, r,c, dp))
where
(r,c) = ss2posEnd pp
@@ -253,7 +253,7 @@ ghcCommentText (L _ (GHC.EpaComment (EpaBlockComment s) _)) = s
tokComment :: LEpaComment -> [Comment]
tokComment t@(L lt c) =
case c of
- (GHC.EpaComment (EpaDocComment dc) pt) -> hsDocStringComments lt pt dc
+ (GHC.EpaComment (EpaDocComment dc) pt) -> hsDocStringComments (noCommentsToEpaLocation lt) pt dc
_ -> [mkComment (normaliseCommentText (ghcCommentText t)) lt (ac_prior_tok c)]
hsDocStringComments :: Anchor -> RealSrcSpan -> GHC.HsDocString -> [Comment]
@@ -268,9 +268,9 @@ hsDocStringComments _ pt (MultiLineDocString dec (x :| xs)) =
in
(Comment str (spanAsAnchor lx) pt Nothing : docChunk (rs lx) (map dedentDocChunk xs))
hsDocStringComments anc pt (NestedDocString dec@(HsDocStringNamed _) (L _ chunk))
- = [Comment ("{- " ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ]
+ = [Comment ("{- " ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") (epaToNoCommentsLocation anc) pt Nothing ]
hsDocStringComments anc pt (NestedDocString dec (L _ chunk))
- = [Comment ("{-" ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ]
+ = [Comment ("{-" ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") (epaToNoCommentsLocation anc) pt Nothing ]
hsDocStringComments _ _ (GeneratedDocString _) = [] -- Should not appear in user-written code
@@ -301,11 +301,11 @@ mkEpaComments priorCs postCs
comment2LEpaComment :: Comment -> LEpaComment
comment2LEpaComment (Comment s anc r _mk) = mkLEpaComment s anc r
-mkLEpaComment :: String -> Anchor -> RealSrcSpan -> LEpaComment
-mkLEpaComment s anc r = (L anc (GHC.EpaComment (EpaLineComment s) r))
+mkLEpaComment :: String -> NoCommentsLocation -> RealSrcSpan -> LEpaComment
+mkLEpaComment s loc r = (L loc (GHC.EpaComment (EpaLineComment s) r))
-mkComment :: String -> Anchor -> RealSrcSpan -> Comment
-mkComment c anc r = Comment c anc r Nothing
+mkComment :: String -> NoCommentsLocation -> RealSrcSpan -> Comment
+mkComment c loc r = Comment c loc r Nothing
-- Windows comments include \r in them from the lexer.
normaliseCommentText :: String -> String
@@ -328,11 +328,11 @@ sortEpaComments cs = sortBy cmp cs
cmp (L l1 _) (L l2 _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2)
-- | Makes a comment which originates from a specific keyword.
-mkKWComment :: AnnKeywordId -> EpaLocation -> Comment
+mkKWComment :: AnnKeywordId -> NoCommentsLocation -> Comment
mkKWComment kw (EpaSpan (RealSrcSpan ss mb))
= Comment (keywordToString kw) (EpaSpan (RealSrcSpan ss mb)) ss (Just kw)
mkKWComment kw (EpaSpan (UnhelpfulSpan _))
- = Comment (keywordToString kw) (EpaDelta (SameLine 0) []) placeholderRealSpan (Just kw)
+ = Comment (keywordToString kw) (EpaDelta (SameLine 0) NoComments) placeholderRealSpan (Just kw)
mkKWComment kw (EpaDelta dp cs)
= Comment (keywordToString kw) (EpaDelta dp cs) placeholderRealSpan (Just kw)
@@ -481,7 +481,7 @@ hsDeclsClassDecl dec = case dec of
tcdATs = ats, tcdATDefs = at_defs
} -> map snd decls
where
- srs :: (HasLoc a) => a -> RealSrcSpan
+ srs :: EpAnn a -> RealSrcSpan
srs a = realSrcSpan $ locA a
decls
= orderedDecls sortKey $ Map.fromList
diff --git a/utils/haddock b/utils/haddock
index f9f25507bf48a8b05f21759744eddc93741fd10a..a7eae7da6868b22dc7109142475b228c60509812 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit f9f25507bf48a8b05f21759744eddc93741fd10a
+Subproject commit a7eae7da6868b22dc7109142475b228c60509812