EPA: properly capture semicolons between Matches in a FunBindwip/az/exactprint-19784

For the source

    module MatchSemis where
    {
    a 0 = 1;
    a _ = 2;
    }

Make sure that the AddSemiAnn entries for the two trailing semicolons
are attached to the component Match elements.

Closes #19784

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