summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Hs/Utils.hs3
-rw-r--r--compiler/GHC/Parser/Annotation.hs44
-rw-r--r--compiler/GHC/Parser/PostProcess.hs21
-rw-r--r--testsuite/tests/parser/should_compile/KindSigs.stderr9
-rw-r--r--testsuite/tests/printer/Makefile5
-rw-r--r--testsuite/tests/printer/Test19784.hs5
-rw-r--r--testsuite/tests/printer/all.T2
-rw-r--r--utils/check-exact/ExactPrint.hs58
-rw-r--r--utils/check-exact/Main.hs5
9 files changed, 88 insertions, 64 deletions
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index bf37398347..43be3749ad 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -215,7 +215,8 @@ mkMatchGroup origin matches = MG { mg_ext = noExtField
, mg_alts = matches
, mg_origin = origin }
-mkLocatedList :: Semigroup a => [GenLocated (SrcSpanAnn' a) e2] -> LocatedAn an [GenLocated (SrcSpanAnn' a) e2]
+mkLocatedList :: Semigroup a
+ => [GenLocated (SrcAnn a) e2] -> LocatedAn an [GenLocated (SrcAnn a) e2]
mkLocatedList [] = noLocA []
mkLocatedList ms = L (noAnnSrcSpan $ locA $ combineLocsA (head ms) (last ms)) ms
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index f234c7c789..8dc12555a0 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -29,6 +29,7 @@ module GHC.Parser.Annotation (
-- ** Annotations in 'GenLocated'
LocatedA, LocatedL, LocatedC, LocatedN, LocatedAn, LocatedP,
SrcSpanAnnA, SrcSpanAnnL, SrcSpanAnnP, SrcSpanAnnC, SrcSpanAnnN, SrcSpanAnn'(..),
+ SrcAnn,
-- ** Annotation data types used in 'GenLocated'
@@ -76,7 +77,7 @@ module GHC.Parser.Annotation (
-- ** Working with comments in annotations
noComments, comment, addCommentsToSrcAnn, setCommentsSrcAnn,
addCommentsToEpAnn, setCommentsEpAnn,
- transferComments,
+ transferAnnsA, commentsOnlyA, removeCommentsA,
placeholderRealSpan,
) where
@@ -1010,12 +1011,15 @@ mapLocA f (L l a) = L (noAnnSrcSpan l) (f a)
-- AZ:TODO: move this somewhere sane
-combineLocsA :: Semigroup a => GenLocated (SrcSpanAnn' a) e1 -> GenLocated (SrcSpanAnn' a) e2 -> SrcSpanAnn' a
+combineLocsA :: Semigroup a => GenLocated (SrcAnn a) e1 -> GenLocated (SrcAnn a) e2 -> SrcAnn a
combineLocsA (L a _) (L b _) = combineSrcSpansA a b
-combineSrcSpansA :: Semigroup a => SrcSpanAnn' a -> SrcSpanAnn' a -> SrcSpanAnn' a
+combineSrcSpansA :: Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a
combineSrcSpansA (SrcSpanAnn aa la) (SrcSpanAnn ab lb)
- = SrcSpanAnn (aa <> ab) (combineSrcSpans la lb)
+ = case SrcSpanAnn (aa <> ab) (combineSrcSpans la lb) of
+ SrcSpanAnn EpAnnNotUsed l -> SrcSpanAnn EpAnnNotUsed l
+ SrcSpanAnn (EpAnn anc an cs) l ->
+ SrcSpanAnn (EpAnn (widenAnchorR anc (realSrcSpan l)) an cs) l
-- | Combine locations from two 'Located' things and add them to a third thing
addCLocA :: GenLocated (SrcSpanAnn' a) e1 -> GenLocated SrcSpan e2 -> e3 -> GenLocated (SrcAnn ann) e3
@@ -1096,14 +1100,30 @@ setCommentsEpAnn loc EpAnnNotUsed cs
= EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs
setCommentsEpAnn _ (EpAnn a an _) cs = EpAnn a an cs
--- | Transfer comments from the annotations in one 'SrcAnn' to those
--- in another. The originals are not changed. This is used when
--- manipulating an AST prior to exact printing,
-transferComments :: (Monoid ann)
- => SrcAnn ann -> SrcAnn ann -> (SrcAnn ann, SrcAnn ann)
-transferComments from@(SrcSpanAnn EpAnnNotUsed _) to = (from, to)
-transferComments (SrcSpanAnn (EpAnn a an cs) l) to
- = ((SrcSpanAnn (EpAnn a an emptyComments) l), addCommentsToSrcAnn to cs)
+-- | Transfer comments and trailing items from the annotations in the
+-- first 'SrcSpanAnnA' argument to those in the second.
+transferAnnsA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
+transferAnnsA from@(SrcSpanAnn EpAnnNotUsed _) to = (from, to)
+transferAnnsA (SrcSpanAnn (EpAnn a an cs) l) to
+ = ((SrcSpanAnn (EpAnn a mempty emptyComments) l), to')
+ where
+ to' = case to of
+ (SrcSpanAnn EpAnnNotUsed loc)
+ -> SrcSpanAnn (EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) an cs) loc
+ (SrcSpanAnn (EpAnn a an' cs') loc)
+ -> SrcSpanAnn (EpAnn a (an' <> an) (cs' <> cs)) loc
+
+-- | Remove the exact print annotations payload, leaving only the
+-- anchor and comments.
+commentsOnlyA :: Monoid ann => SrcAnn ann -> SrcAnn ann
+commentsOnlyA (SrcSpanAnn EpAnnNotUsed loc) = SrcSpanAnn EpAnnNotUsed loc
+commentsOnlyA (SrcSpanAnn (EpAnn a _ cs) loc) = (SrcSpanAnn (EpAnn a mempty cs) loc)
+
+-- | Remove the comments, leaving the exact print annotations payload
+removeCommentsA :: SrcAnn ann -> SrcAnn ann
+removeCommentsA (SrcSpanAnn EpAnnNotUsed loc) = SrcSpanAnn EpAnnNotUsed loc
+removeCommentsA (SrcSpanAnn (EpAnn a an _) loc)
+ = (SrcSpanAnn (EpAnn a an emptyComments) loc)
-- ---------------------------------------------------------------------
-- Semigroup instances, to allow easy combination of annotaion elements
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 0ffc3125e6..697161b564 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -531,13 +531,11 @@ getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1)
, fun_matches =
- MG { mg_alts = (L _ mtchs1) } }))
+ MG { mg_alts = (L _ m1@[L _ mtchs1]) } }))
binds
- | has_args mtchs1
- = go mtchs1 loc1 binds []
+ | has_args m1
+ = go [L (removeCommentsA loc1) mtchs1] (commentsOnlyA loc1) binds []
where
- -- TODO:AZ may have to preserve annotations. Although they should
- -- only be AnnSemi, and meaningless in this context?
go :: [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpanAnnA
-> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
-> (LHsBind GhcPs,[LHsDecl GhcPs]) -- AZ
@@ -547,7 +545,7 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1)
MG { mg_alts = (L _ [L lm2 mtchs2]) } })))
: binds) _
| f1 == f2 =
- let (loc2', lm2') = transferComments loc2 lm2
+ let (loc2', lm2') = transferAnnsA loc2 lm2
in go (L lm2' mtchs2 : mtchs)
(combineSrcSpansA loc loc2') binds []
go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls
@@ -1187,12 +1185,12 @@ checkValDef loc lhs (Just (sigAnn, sig)) grhss
>>= checkLPat
checkPatBind loc [] lhs' grhss
-checkValDef loc lhs Nothing g@(L l grhss)
+checkValDef loc lhs Nothing g
= do { mb_fun <- isFunLhs lhs
; case mb_fun of
Just (fun, is_infix, pats, ann) ->
- checkFunBind NoSrcStrict loc ann (getLocA lhs)
- fun is_infix pats (L l grhss)
+ checkFunBind NoSrcStrict loc ann
+ fun is_infix pats g
Nothing -> do
lhs' <- checkPattern lhs
checkPatBind loc [] lhs' g }
@@ -1200,15 +1198,14 @@ checkValDef loc lhs Nothing g@(L l grhss)
checkFunBind :: SrcStrictness
-> SrcSpan
-> [AddEpAnn]
- -> SrcSpan
-> LocatedN RdrName
-> LexicalFixity
-> [LocatedA (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBind GhcPs)
-checkFunBind strictness locF ann lhs_loc fun is_infix pats (L rhs_span grhss)
+checkFunBind strictness locF ann fun is_infix pats (L _ grhss)
= do ps <- runPV_hints param_hints (mapM checkLPat pats)
- let match_span = noAnnSrcSpan $ combineSrcSpans lhs_loc rhs_span
+ let match_span = noAnnSrcSpan $ locF
cs <- getCommentsFor locF
return (makeFunBind fun (L (noAnnSrcSpan $ locA match_span)
[L match_span (Match { m_ext = EpAnn (spanAsAnchor locF) ann cs
diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr
index f33f08312d..35c085acb9 100644
--- a/testsuite/tests/parser/should_compile/KindSigs.stderr
+++ b/testsuite/tests/parser/should_compile/KindSigs.stderr
@@ -841,7 +841,14 @@
(L
(SrcSpanAnn (EpAnnNotUsed) { KindSigs.hs:23:1-12 })
[(L
- (SrcSpanAnn (EpAnnNotUsed) { KindSigs.hs:23:1-12 })
+ (SrcSpanAnn (EpAnn
+ (Anchor
+ { KindSigs.hs:23:1-12 }
+ (UnchangedAnchor))
+ (AnnListItem
+ [])
+ (EpaComments
+ [])) { KindSigs.hs:23:1-12 })
(Match
(EpAnn
(Anchor
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index 6be7545752..3bd736b7a8 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -557,3 +557,8 @@ CommentsTest:
InTreeAnnotations1:
$(CHECK_PPR) $(LIBDIR) InTreeAnnotations1.hs
$(CHECK_EXACT) $(LIBDIR) InTreeAnnotations1.hs
+
+.PHONY: Test19784
+Test19784:
+ $(CHECK_PPR) $(LIBDIR) Test19784.hs
+ $(CHECK_EXACT) $(LIBDIR) Test19784.hs
diff --git a/testsuite/tests/printer/Test19784.hs b/testsuite/tests/printer/Test19784.hs
new file mode 100644
index 0000000000..b424c2cc6b
--- /dev/null
+++ b/testsuite/tests/printer/Test19784.hs
@@ -0,0 +1,5 @@
+module Test19784 where
+{
+a 0 = 1;
+a _ = 2;
+}
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index 5c0e3fbdfa..04d6d33acc 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -123,3 +123,5 @@ test('PprRecordDotSyntax4', ignore_stderr, makefile_test, ['PprRecordDotSyntax4'
test('PprRecordDotSyntaxA', ignore_stderr, makefile_test, ['PprRecordDotSyntaxA'])
test('CommentsTest', ignore_stderr, makefile_test, ['CommentsTest'])
test('InTreeAnnotations1', ignore_stderr, makefile_test, ['InTreeAnnotations1'])
+
+test('Test19784', ignore_stderr, makefile_test, ['Test19784']) \ No newline at end of file
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 79511e9d34..5be9b0e1e3 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -378,26 +378,13 @@ instance ExactPrint HsModule where
debugM $ "HsModule.AnnWhere coming"
setLayoutTopLevelP $ markEpAnn' an am_main AnnWhere
- setLayoutTopLevelP $ mapM_ markAddEpAnn (al_open $ am_decls $ anns an)
- -- markOptional GHC.AnnOpenC -- Possible '{'
- -- markManyOptional GHC.AnnSemi -- possible leading semis
- -- setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imports
- -- markListWithLayout imports
- markTopLevelList imports
+ markAnnList' False (am_decls $ anns an) $ do
- -- setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decls
- -- markListWithLayout decls
- -- setLayoutTopLevelP $ markAnnotated decls
- markTopLevelList decls
+ markTopLevelList imports
- setLayoutTopLevelP $ mapM_ markAddEpAnn (al_close $ am_decls $ anns an)
- -- markOptional GHC.AnnCloseC -- Possible '}'
+ markTopLevelList decls
- -- markEOF
- -- eof <- getEofPos
- -- debugM $ "eof pos:" ++ show (rs2range eof)
- -- setLayoutTopLevelP $ printStringAtKw' eof ""
-- ---------------------------------------------------------------------
@@ -599,23 +586,22 @@ markKwA kw aa = printStringAtAA aa (keywordToString (G kw))
-- ---------------------------------------------------------------------
-markAnnList :: EpAnn AnnList -> EPP () -> EPP ()
-markAnnList EpAnnNotUsed action = action
-markAnnList an@(EpAnn _ ann _) action = do
+markAnnList :: Bool -> EpAnn AnnList -> EPP () -> EPP ()
+markAnnList _ EpAnnNotUsed action = action
+markAnnList reallyTrail (EpAnn _ ann _) action = markAnnList' reallyTrail ann action
+
+markAnnList' :: Bool -> AnnList -> EPP () -> EPP ()
+markAnnList' reallyTrail ann action = do
p <- getPosP
- debugM $ "markAnnList : " ++ showPprUnsafe (p, an)
- markLocatedMAA an al_open
+ debugM $ "markAnnList : " ++ showPprUnsafe (p, ann)
+ mapM_ markAddEpAnn (al_open ann)
+ unless reallyTrail $ markTrailing (al_trailing ann) -- Only makes sense for HsModule.
action
- markLocatedMAA an al_close
+ debugM $ "markAnnList: calling markAddEpAnn on:" ++ showPprUnsafe (al_close ann)
+ mapM_ markAddEpAnn (al_close ann)
debugM $ "markAnnList: calling markTrailing with:" ++ showPprUnsafe (al_trailing ann)
- markTrailing (al_trailing ann)
-
--- ---------------------------------------------------------------------
+ when reallyTrail $ markTrailing (al_trailing ann) -- normal case
--- printTrailingComments :: EPP ()
--- printTrailingComments = do
--- cs <- getUnallocatedComments
--- mapM_ printOneComment cs
-- ---------------------------------------------------------------------
@@ -1450,7 +1436,7 @@ instance ExactPrint (HsLocalBinds GhcPs) where
markAnnotatedWithLayout valbinds
exact (HsIPBinds an bs)
- = markAnnList an (markLocatedAAL an al_rest AnnWhere >> markAnnotated bs)
+ = markAnnList True an (markLocatedAAL an al_rest AnnWhere >> markAnnotated bs)
exact (EmptyLocalBinds _) = return ()
@@ -1947,7 +1933,7 @@ instance ExactPrint (HsExpr GhcPs) where
exact (HsDo an do_or_list_comp stmts) = do
debugM $ "HsDo"
- markAnnList an $ exactDo an do_or_list_comp stmts
+ markAnnList True an $ exactDo an do_or_list_comp stmts
exact (ExplicitList an es) = do
debugM $ "ExplicitList start"
@@ -3458,7 +3444,7 @@ instance ExactPrint (LocatedL [LocatedA (IE GhcPs)]) where
markLocatedAAL ann al_rest AnnHiding
p <- getPosP
debugM $ "LocatedL [LIE:p=" ++ showPprUnsafe p
- markAnnList ann (markAnnotated ies)
+ markAnnList True ann (markAnnotated ies)
-- AZ:TODO: combine with next instance
instance ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))]) where
@@ -3488,7 +3474,7 @@ instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr Gh
getAnnotationEntry = entryFromLocatedA
exact (L (SrcSpanAnn an _) stmts) = do
debugM $ "LocatedL [ExprLStmt"
- markAnnList an $ do
+ markAnnList True an $ do
-- markLocatedMAA an al_open
case snocView stmts of
Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do
@@ -3512,13 +3498,13 @@ instance ExactPrint (LocatedL [LocatedA (ConDeclField GhcPs)]) where
getAnnotationEntry = entryFromLocatedA
exact (L (SrcSpanAnn an _) fs) = do
debugM $ "LocatedL [LConDeclField"
- markAnnList an (mapM_ markAnnotated fs) -- AZ:TODO get rid of mapM_
+ markAnnList True an (mapM_ markAnnotated fs) -- AZ:TODO get rid of mapM_
instance ExactPrint (LocatedL (BF.BooleanFormula (LocatedN RdrName))) where
getAnnotationEntry = entryFromLocatedA
exact (L (SrcSpanAnn an _) bf) = do
debugM $ "LocatedL [LBooleanFormula"
- markAnnList an (markAnnotated bf)
+ markAnnList True an (markAnnotated bf)
-- ---------------------------------------------------------------------
-- LocatedL instances end --
@@ -3637,7 +3623,7 @@ instance ExactPrint (Pat GhcPs) where
markEpAnn an AnnBang
markAnnotated pat
- exact (ListPat an pats) = markAnnList an (markAnnotated pats)
+ exact (ListPat an pats) = markAnnList True an (markAnnotated pats)
exact (TuplePat an pats boxity) = do
case boxity of
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index a9618be40b..a332cc5a8c 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -51,7 +51,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprin
-- "../../testsuite/tests/ghc-api/exactprint/LocToName.hs" (Just changeLocToName)
-- "../../testsuite/tests/ghc-api/exactprint/LetIn1.hs" (Just changeLetIn1)
-- "../../testsuite/tests/ghc-api/exactprint/WhereIn4.hs" (Just changeWhereIn4)
- "../../testsuite/tests/ghc-api/exactprint/AddDecl1.hs" (Just changeAddDecl1)
+ -- "../../testsuite/tests/ghc-api/exactprint/AddDecl1.hs" (Just changeAddDecl1)
-- "../../testsuite/tests/ghc-api/exactprint/AddDecl2.hs" (Just changeAddDecl2)
-- "../../testsuite/tests/ghc-api/exactprint/AddDecl3.hs" (Just changeAddDecl3)
-- "../../testsuite/tests/ghc-api/exactprint/LocalDecls.hs" (Just changeLocalDecls)
@@ -114,7 +114,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprin
-- "../../testsuite/tests/printer/Ppr026.hs" Nothing
-- "../../testsuite/tests/printer/Ppr027.hs" Nothing
-- "../../testsuite/tests/printer/Ppr028.hs" Nothing
- -- "../../testsuite/tests/printer/Ppr029.hs" Nothing
+ "../../testsuite/tests/printer/Ppr029.hs" Nothing
-- "../../testsuite/tests/printer/Ppr030.hs" Nothing
-- "../../testsuite/tests/printer/Ppr031.hs" Nothing
-- "../../testsuite/tests/printer/Ppr032.hs" Nothing
@@ -183,6 +183,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprin
-- "../../testsuite/tests/ghc-api/exactprint/LocalDecls2.expected.hs" Nothing
-- "../../testsuite/tests/ghc-api/exactprint/WhereIn3a.hs" Nothing
-- "../../testsuite/tests/ghc-api/exactprint/Windows.hs" Nothing
+ -- "../../testsuite/tests/printer/Test19784.hs" Nothing
-- cloneT does not need a test, function can be retired
View Lorry Controller Status