EPA : Remove duplicate comments in DataFamInstD

The code

  data instance Method PGMigration = MigrationQuery Query
                                   -- ^ Run a query against the database
                                   | MigrationCode (Connection -> IO (Either String ()))
                                   -- ^ Run any arbitrary IO code

Resulted in two instances of the "-- ^ Run a query against the database"
comment appearing in the Exact Print Annotations when it was parsed.

Ensure only one is kept.

Closes #20239

10 files changed, 365 insertions, 27 deletions

diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 568783bdb5..c83a05256a 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -744,9 +744,7 @@ type instance XXClsInstDecl    (GhcPass _) = DataConCantHappen
 
 type instance XClsInstD     (GhcPass _) = NoExtField
 
-type instance XDataFamInstD GhcPs = EpAnn [AddEpAnn]
-type instance XDataFamInstD GhcRn = NoExtField
-type instance XDataFamInstD GhcTc = NoExtField
+type instance XDataFamInstD (GhcPass _) = NoExtField
 
 type instance XTyFamInstD   GhcPs = NoExtField
 type instance XTyFamInstD   GhcRn = NoExtField
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 845f7eb25c..17ea462f24 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -324,16 +324,32 @@ mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
               ksig data_cons (L _ maybe_deriv) anns
   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
        ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan
-       ; let anns' = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments
+       ; let fam_eqn_ans = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments
        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
-       ; return (L (noAnnSrcSpan loc) (DataFamInstD anns' (DataFamInstDecl
-                  (FamEqn { feqn_ext    = anns'
+       ; return (L (noAnnSrcSpan loc) (DataFamInstD noExtField (DataFamInstDecl
+                  (FamEqn { feqn_ext    = fam_eqn_ans
                           , feqn_tycon  = tc
                           , feqn_bndrs  = bndrs
                           , feqn_pats   = tparams
                           , feqn_fixity = fixity
                           , feqn_rhs    = defn })))) }
 
+-- mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
+--               ksig data_cons (L _ maybe_deriv) anns
+--   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
+--        ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan
+--        ; let anns' = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments
+--        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
+--        ; return (L (noAnnSrcSpan loc) (DataFamInstD anns' (DataFamInstDecl
+--                   (FamEqn { feqn_ext    = anns'
+--                           , feqn_tycon  = tc
+--                           , feqn_bndrs  = bndrs
+--                           , feqn_pats   = tparams
+--                           , feqn_fixity = fixity
+--                           , feqn_rhs    = defn })))) }
+
+
+
 mkTyFamInst :: SrcSpan
             -> TyFamInstEqn GhcPs
             -> [AddEpAnn]
diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs
index 72403ef018..ea9118a525 100644
--- a/compiler/GHC/Parser/PostProcess/Haddock.hs
+++ b/compiler/GHC/Parser/PostProcess/Haddock.hs
@@ -1511,7 +1511,7 @@ flattenBindsAndSigs (all_bs, all_ss, all_ts, all_tfis, all_dfis, all_docs) =
     mapLL (\s -> SigD noExtField s) all_ss,
     mapLL (\t -> TyClD noExtField (FamDecl noExtField t)) all_ts,
     mapLL (\tfi -> InstD noExtField (TyFamInstD noExtField tfi)) all_tfis,
-    mapLL (\dfi -> InstD noExtField (DataFamInstD noAnn dfi)) all_dfis,
+    mapLL (\dfi -> InstD noExtField (DataFamInstD noExtField dfi)) all_dfis,
     mapLL (\d -> DocD noExtField d) all_docs
   ]
 
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index a839822e40..401f8c8a1d 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -381,7 +381,7 @@ cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)
                                , dd_cons = cons', dd_derivs = derivs' }
 
        ; returnJustLA $ InstD noExtField $ DataFamInstD
-           { dfid_ext = noAnn
+           { dfid_ext = noExtField
            , dfid_inst = DataFamInstDecl { dfid_eqn =
                            FamEqn { feqn_ext = noAnn
                                   , feqn_tycon = tc'
@@ -401,7 +401,7 @@ cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)
                                , dd_kindSig = ksig'
                                , dd_cons = [con'], dd_derivs = derivs' }
        ; returnJustLA $ InstD noExtField $ DataFamInstD
-           { dfid_ext = noAnn
+           { dfid_ext = noExtField
            , dfid_inst = DataFamInstDecl { dfid_eqn =
                            FamEqn { feqn_ext = noAnn
                                   , feqn_tycon = tc'
diff --git a/testsuite/tests/ghc-api/exactprint/Test20239.hs b/testsuite/tests/ghc-api/exactprint/Test20239.hs
new file mode 100644
index 0000000000..4f7d1e6216
--- /dev/null
+++ b/testsuite/tests/ghc-api/exactprint/Test20239.hs
@@ -0,0 +1,7 @@
+module Test20239 where
+
+-- | Leading Haddock Comment
+data instance Method PGMigration = MigrationQuery Query
+                                 -- ^ Run a query against the database
+                                 | MigrationCode (Connection -> IO (Either String ()))
+                                 -- ^ Run any arbitrary IO code
diff --git a/testsuite/tests/ghc-api/exactprint/Test20239.stderr b/testsuite/tests/ghc-api/exactprint/Test20239.stderr
new file mode 100644
index 0000000000..bada9845ab
--- /dev/null
+++ b/testsuite/tests/ghc-api/exactprint/Test20239.stderr
@@ -0,0 +1,327 @@
+
+==================== Parser AST ====================
+
+(L
+ { Test20239.hs:1:1 }
+ (HsModule
+  (EpAnn
+   (Anchor
+    { Test20239.hs:1:1 }
+    (UnchangedAnchor))
+   (AnnsModule
+    [(AddEpAnn AnnModule (EpaSpan { Test20239.hs:1:1-6 }))
+    ,(AddEpAnn AnnWhere (EpaSpan { Test20239.hs:1:18-22 }))]
+    (AnnList
+     (Nothing)
+     (Nothing)
+     (Nothing)
+     []
+     []))
+   (EpaCommentsBalanced
+    [(L
+      (Anchor
+       { Test20239.hs:3:1-28 }
+       (UnchangedAnchor))
+      (EpaComment
+       (EpaLineComment
+        "-- | Leading Haddock Comment")
+       { Test20239.hs:1:18-22 }))]
+    [(L
+      (Anchor
+       { Test20239.hs:8:1 }
+       (UnchangedAnchor))
+      (EpaComment
+       (EpaEofComment)
+       { Test20239.hs:7:34-63 }))]))
+  (VirtualBraces
+   (1))
+  (Just
+   (L
+    (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:1:8-16 })
+    {ModuleName: Test20239}))
+  (Nothing)
+  []
+  [(L
+    (SrcSpanAnn (EpAnn
+                 (Anchor
+                  { Test20239.hs:(4,1)-(6,86) }
+                  (UnchangedAnchor))
+                 (AnnListItem
+                  [])
+                 (EpaComments
+                  [(L
+                    (Anchor
+                     { Test20239.hs:7:34-63 }
+                     (UnchangedAnchor))
+                    (EpaComment
+                     (EpaLineComment
+                      "-- ^ Run any arbitrary IO code")
+                     { Test20239.hs:6:86 }))])) { Test20239.hs:(4,1)-(6,86) })
+    (InstD
+     (NoExtField)
+     (DataFamInstD
+      (NoExtField)
+      (DataFamInstDecl
+       (FamEqn
+        (EpAnn
+         (Anchor
+          { Test20239.hs:(4,1)-(6,86) }
+          (UnchangedAnchor))
+         [(AddEpAnn AnnData (EpaSpan { Test20239.hs:4:1-4 }))
+         ,(AddEpAnn AnnInstance (EpaSpan { Test20239.hs:4:6-13 }))
+         ,(AddEpAnn AnnEqual (EpaSpan { Test20239.hs:4:34 }))]
+         (EpaComments
+          [(L
+            (Anchor
+             { Test20239.hs:5:34-70 }
+             (UnchangedAnchor))
+            (EpaComment
+             (EpaLineComment
+              "-- ^ Run a query against the database")
+             { Test20239.hs:4:51-55 }))]))
+        (L
+         (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:4:15-20 })
+         (Unqual
+          {OccName: Method}))
+        (HsOuterImplicit
+         (NoExtField))
+        [(HsValArg
+          (L
+           (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:4:22-32 })
+           (HsTyVar
+            (EpAnn
+             (Anchor
+              { Test20239.hs:4:22-32 }
+              (UnchangedAnchor))
+             []
+             (EpaComments
+              []))
+            (NotPromoted)
+            (L
+             (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:4:22-32 })
+             (Unqual
+              {OccName: PGMigration})))))]
+        (Prefix)
+        (HsDataDefn
+         (NoExtField)
+         (DataType)
+         (Nothing)
+         (Nothing)
+         (Nothing)
+         [(L
+           (SrcSpanAnn (EpAnn
+                        (Anchor
+                         { Test20239.hs:4:36-55 }
+                         (UnchangedAnchor))
+                        (AnnListItem
+                         [(AddVbarAnn
+                           (EpaSpan { Test20239.hs:6:34 }))])
+                        (EpaComments
+                         [])) { Test20239.hs:4:36-55 })
+           (ConDeclH98
+            (EpAnn
+             (Anchor
+              { Test20239.hs:4:36-55 }
+              (UnchangedAnchor))
+             []
+             (EpaComments
+              []))
+            (L
+             (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:4:36-49 })
+             (Unqual
+              {OccName: MigrationQuery}))
+            (False)
+            []
+            (Nothing)
+            (PrefixCon
+             []
+             [(HsScaled
+               (HsLinearArrow
+                (HsPct1
+                 (L
+                  (NoTokenLoc)
+                  (HsTok))
+                 (L
+                  (NoTokenLoc)
+                  (HsNormalTok))))
+               (L
+                (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:4:51-55 })
+                (HsTyVar
+                 (EpAnn
+                  (Anchor
+                   { Test20239.hs:4:51-55 }
+                   (UnchangedAnchor))
+                  []
+                  (EpaComments
+                   []))
+                 (NotPromoted)
+                 (L
+                  (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:4:51-55 })
+                  (Unqual
+                   {OccName: Query})))))])
+            (Nothing)))
+         ,(L
+           (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:36-86 })
+           (ConDeclH98
+            (EpAnn
+             (Anchor
+              { Test20239.hs:6:36-86 }
+              (UnchangedAnchor))
+             []
+             (EpaComments
+              []))
+            (L
+             (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:36-48 })
+             (Unqual
+              {OccName: MigrationCode}))
+            (False)
+            []
+            (Nothing)
+            (PrefixCon
+             []
+             [(HsScaled
+               (HsLinearArrow
+                (HsPct1
+                 (L
+                  (NoTokenLoc)
+                  (HsTok))
+                 (L
+                  (NoTokenLoc)
+                  (HsNormalTok))))
+               (L
+                (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:50-86 })
+                (HsParTy
+                 (EpAnn
+                  (Anchor
+                   { Test20239.hs:6:50 }
+                   (UnchangedAnchor))
+                  (AnnParen
+                   (AnnParens)
+                   (EpaSpan { Test20239.hs:6:50 })
+                   (EpaSpan { Test20239.hs:6:86 }))
+                  (EpaComments
+                   []))
+                 (L
+                  (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:51-85 })
+                  (HsFunTy
+                   (EpAnn
+                    (Anchor
+                     { Test20239.hs:6:51-60 }
+                     (UnchangedAnchor))
+                    (NoEpAnns)
+                    (EpaComments
+                     []))
+                   (HsUnrestrictedArrow
+                    (L
+                     (TokenLoc
+                      (EpaSpan { Test20239.hs:6:62-63 }))
+                     (HsNormalTok)))
+                   (L
+                    (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:51-60 })
+                    (HsTyVar
+                     (EpAnn
+                      (Anchor
+                       { Test20239.hs:6:51-60 }
+                       (UnchangedAnchor))
+                      []
+                      (EpaComments
+                       []))
+                     (NotPromoted)
+                     (L
+                      (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:51-60 })
+                      (Unqual
+                       {OccName: Connection}))))
+                   (L
+                    (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:65-85 })
+                    (HsAppTy
+                     (NoExtField)
+                     (L
+                      (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:65-66 })
+                      (HsTyVar
+                       (EpAnn
+                        (Anchor
+                         { Test20239.hs:6:65-66 }
+                         (UnchangedAnchor))
+                        []
+                        (EpaComments
+                         []))
+                       (NotPromoted)
+                       (L
+                        (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:65-66 })
+                        (Unqual
+                         {OccName: IO}))))
+                     (L
+                      (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:68-85 })
+                      (HsParTy
+                       (EpAnn
+                        (Anchor
+                         { Test20239.hs:6:68 }
+                         (UnchangedAnchor))
+                        (AnnParen
+                         (AnnParens)
+                         (EpaSpan { Test20239.hs:6:68 })
+                         (EpaSpan { Test20239.hs:6:85 }))
+                        (EpaComments
+                         []))
+                       (L
+                        (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:69-84 })
+                        (HsAppTy
+                         (NoExtField)
+                         (L
+                          (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:69-81 })
+                          (HsAppTy
+                           (NoExtField)
+                           (L
+                            (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:69-74 })
+                            (HsTyVar
+                             (EpAnn
+                              (Anchor
+                               { Test20239.hs:6:69-74 }
+                               (UnchangedAnchor))
+                              []
+                              (EpaComments
+                               []))
+                             (NotPromoted)
+                             (L
+                              (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:69-74 })
+                              (Unqual
+                               {OccName: Either}))))
+                           (L
+                            (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:76-81 })
+                            (HsTyVar
+                             (EpAnn
+                              (Anchor
+                               { Test20239.hs:6:76-81 }
+                               (UnchangedAnchor))
+                              []
+                              (EpaComments
+                               []))
+                             (NotPromoted)
+                             (L
+                              (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:76-81 })
+                              (Unqual
+                               {OccName: String}))))))
+                         (L
+                          (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:83-84 })
+                          (HsTupleTy
+                           (EpAnn
+                            (Anchor
+                             { Test20239.hs:6:83 }
+                             (UnchangedAnchor))
+                            (AnnParen
+                             (AnnParens)
+                             (EpaSpan { Test20239.hs:6:83 })
+                             (EpaSpan { Test20239.hs:6:84 }))
+                            (EpaComments
+                             []))
+                           (HsBoxedOrConstraintTuple)
+                           [])))))))))))))])
+            (Nothing)))]
+         []))))))]
+  (Nothing)
+  (Nothing)))
+
+
+
+Test20239.hs:4:15:
+    Not in scope: type constructor or class ‘Method’
diff --git a/testsuite/tests/ghc-api/exactprint/all.T b/testsuite/tests/ghc-api/exactprint/all.T
index 385b74a243..97d94b566c 100644
--- a/testsuite/tests/ghc-api/exactprint/all.T
+++ b/testsuite/tests/ghc-api/exactprint/all.T
@@ -36,3 +36,4 @@ test('RmTypeSig1',    ignore_stderr, makefile_test, ['RmTypeSig1'])
 test('RmTypeSig2',    ignore_stderr, makefile_test, ['RmTypeSig2'])
 test('AddHiding1',    ignore_stderr, makefile_test, ['AddHiding1'])
 test('AddHiding2',    ignore_stderr, makefile_test, ['AddHiding2'])
+test('Test20239',  normal, compile_fail, ['-dsuppress-uniques -ddump-parsed-ast -dkeep-comments'])
diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
index 3b0dd87fd3..089fe770c8 100644
--- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
@@ -1024,16 +1024,7 @@
     (InstD
      (NoExtField)
      (DataFamInstD
-      (EpAnn
-       (Anchor
-        { DumpParsedAst.hs:(21,1)-(22,45) }
-        (UnchangedAnchor))
-       [(AddEpAnn AnnNewtype (EpaSpan { DumpParsedAst.hs:21:1-7 }))
-       ,(AddEpAnn AnnInstance (EpaSpan { DumpParsedAst.hs:21:9-16 }))
-       ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:21:39-40 }))
-       ,(AddEpAnn AnnWhere (EpaSpan { DumpParsedAst.hs:21:62-66 }))]
-       (EpaComments
-        []))
+      (NoExtField)
       (DataFamInstDecl
        (FamEqn
         (EpAnn
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 2451354684..bda1647ccd 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -850,16 +850,14 @@ instance ExactPrint (HsDecl GhcPs) where
 -- ---------------------------------------------------------------------
 
 instance ExactPrint (InstDecl GhcPs) where
-  getAnnotationEntry (ClsInstD     _  _) = NoEntryVal
-  getAnnotationEntry (DataFamInstD an _) = fromAnn an
-  getAnnotationEntry (TyFamInstD   _  _) = NoEntryVal
-
+  getAnnotationEntry (ClsInstD     _ _) = NoEntryVal
+  getAnnotationEntry (DataFamInstD _ _) = NoEntryVal
+  getAnnotationEntry (TyFamInstD   _ _) = NoEntryVal
 
   exact (ClsInstD     _  cid) = markAnnotated cid
-  exact (DataFamInstD an decl) = do
-    exactDataFamInstDecl an TopLevel decl
+  exact (DataFamInstD _ decl) = do
+    exactDataFamInstDecl noAnn TopLevel decl
   exact (TyFamInstD _ eqn) = do
-    -- exactTyFamInstDecl an TopLevel eqn
     markAnnotated eqn
 
 -- ---------------------------------------------------------------------
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index b83cc9cd86..46e68d638a 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -198,7 +198,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_buil
  -- "../../testsuite/tests/printer/PprSemis.hs" Nothing
  -- "../../testsuite/tests/printer/PprEmptyMostly.hs" Nothing
  -- "../../testsuite/tests/parser/should_compile/DumpSemis.hs" Nothing
- "../../testsuite/tests/printer/Test20256.hs" Nothing
+ "../../testsuite/tests/ghc-api/exactprint/Test20239.hs" Nothing
 
 -- cloneT does not need a test, function can be retired