EPA: Fix incorrect SrcSpan for FamDecl

The SrcSpan for a type family declaration did not include the family
equations.

Closes #19821

9 files changed, 37 insertions, 16 deletions

diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 23ba493df2..26f6e8b836 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -1253,7 +1253,7 @@ ty_decl :: { LTyClDecl GhcPs }
                           where_type_family
                 -- Note the use of type for the head; this allows
                 -- infix type constructors to be declared
-                {% mkFamDecl (comb4 $1 (reLoc $3) $4 $5) (snd $ unLoc $6) TopLevel $3
+                {% mkFamDecl (comb5 $1 (reLoc $3) $4 $5 $6) (snd $ unLoc $6) TopLevel $3
                                    (snd $ unLoc $4) (snd $ unLoc $5)
                            (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)
                            ++ (fst $ unLoc $5) ++ (fst $ unLoc $6))  }
diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
index d4956a81e4..106851f2e8 100644
--- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
@@ -173,12 +173,12 @@
   ,(L
     (SrcSpanAnn (EpAnn
                  (Anchor
-                  { DumpParsedAst.hs:10:1-39 }
+                  { DumpParsedAst.hs:(10,1)-(12,24) }
                   (UnchangedAnchor))
                  (AnnListItem
                   [])
                  (EpaComments
-                  [])) { DumpParsedAst.hs:10:1-39 })
+                  [])) { DumpParsedAst.hs:(10,1)-(12,24) })
     (TyClD
      (NoExtField)
      (FamDecl
@@ -186,7 +186,7 @@
       (FamilyDecl
        (EpAnn
         (Anchor
-         { DumpParsedAst.hs:10:1-45 }
+         { DumpParsedAst.hs:(10,1)-(12,24) }
          (UnchangedAnchor))
         [(AddEpAnn AnnType (EpaSpan { DumpParsedAst.hs:10:1-4 }))
         ,(AddEpAnn AnnFamily (EpaSpan { DumpParsedAst.hs:10:6-11 }))
@@ -619,12 +619,12 @@
   ,(L
     (SrcSpanAnn (EpAnn
                  (Anchor
-                  { DumpParsedAst.hs:17:1-48 }
+                  { DumpParsedAst.hs:(17,1)-(18,30) }
                   (UnchangedAnchor))
                  (AnnListItem
                   [])
                  (EpaComments
-                  [])) { DumpParsedAst.hs:17:1-48 })
+                  [])) { DumpParsedAst.hs:(17,1)-(18,30) })
     (TyClD
      (NoExtField)
      (FamDecl
@@ -632,7 +632,7 @@
       (FamilyDecl
        (EpAnn
         (Anchor
-         { DumpParsedAst.hs:17:1-54 }
+         { DumpParsedAst.hs:(17,1)-(18,30) }
          (UnchangedAnchor))
         [(AddEpAnn AnnType (EpaSpan { DumpParsedAst.hs:17:1-4 }))
         ,(AddEpAnn AnnFamily (EpaSpan { DumpParsedAst.hs:17:6-11 }))
diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
index c41d01d452..6ddf6dbf19 100644
--- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
@@ -168,12 +168,12 @@
      [(L
        (SrcSpanAnn (EpAnn
                     (Anchor
-                     { DumpRenamedAst.hs:12:1-39 }
+                     { DumpRenamedAst.hs:(12,1)-(14,24) }
                      (UnchangedAnchor))
                     (AnnListItem
                      [])
                     (EpaComments
-                     [])) { DumpRenamedAst.hs:12:1-39 })
+                     [])) { DumpRenamedAst.hs:(12,1)-(14,24) })
        (FamDecl
         (NoExtField)
         (FamilyDecl
@@ -807,12 +807,12 @@
      [(L
        (SrcSpanAnn (EpAnn
                     (Anchor
-                     { DumpRenamedAst.hs:24:1-48 }
+                     { DumpRenamedAst.hs:(24,1)-(25,30) }
                      (UnchangedAnchor))
                     (AnnListItem
                      [])
                     (EpaComments
-                     [])) { DumpRenamedAst.hs:24:1-48 })
+                     [])) { DumpRenamedAst.hs:(24,1)-(25,30) })
        (FamDecl
         (NoExtField)
         (FamilyDecl
diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr
index 35c085acb9..570a9d6650 100644
--- a/testsuite/tests/parser/should_compile/KindSigs.stderr
+++ b/testsuite/tests/parser/should_compile/KindSigs.stderr
@@ -63,12 +63,12 @@
   [(L
     (SrcSpanAnn (EpAnn
                  (Anchor
-                  { KindSigs.hs:11:1-17 }
+                  { KindSigs.hs:(11,1)-(12,21) }
                   (UnchangedAnchor))
                  (AnnListItem
                   [])
                  (EpaComments
-                  [])) { KindSigs.hs:11:1-17 })
+                  [])) { KindSigs.hs:(11,1)-(12,21) })
     (TyClD
      (NoExtField)
      (FamDecl
@@ -76,7 +76,7 @@
       (FamilyDecl
        (EpAnn
         (Anchor
-         { KindSigs.hs:11:1-23 }
+         { KindSigs.hs:(11,1)-(12,21) }
          (UnchangedAnchor))
         [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:11:1-4 }))
         ,(AddEpAnn AnnFamily (EpaSpan { KindSigs.hs:11:6-11 }))
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index 4b7e3eb3f6..653b9d3300 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -577,3 +577,9 @@ Test19813:
 Test19814:
 	$(CHECK_PPR)   $(LIBDIR) Test19814.hs
 	$(CHECK_EXACT) $(LIBDIR) Test19814.hs
+
+.PHONY: Test19821
+Test19821:
+	$(CHECK_PPR)   $(LIBDIR) Test19821.hs
+	$(CHECK_EXACT) $(LIBDIR) Test19821.hs
+
diff --git a/testsuite/tests/printer/Test19821.hs b/testsuite/tests/printer/Test19821.hs
new file mode 100644
index 0000000000..7123486812
--- /dev/null
+++ b/testsuite/tests/printer/Test19821.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE TypeFamilies #-}
+module Test19821 where
+
+type family F a b  = r | r -> a b where
+  F Float  IO      = Float
+  F Bool   IO      = Bool
+  F a      IO      = IO a   -- (1)
+  F Char   b       = b Int  -- (2)
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index 52a1befd37..51b63b880f 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -131,3 +131,5 @@ test('Test19798', ignore_stderr, makefile_test, ['Test19798'])
 # disabled in the Makefile for this test.
 test('Test19813', ignore_stderr, makefile_test, ['Test19813'])
 test('Test19814', ignore_stderr, makefile_test, ['Test19814'])
+test('Test19821', ignore_stderr, makefile_test, ['Test19821'])
+
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 454db7fce4..e4319bebf0 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -2778,7 +2778,11 @@ instance ExactPrint (FamilyDecl GhcPs) where
     exact_top_level
     exactVanillaDeclHead an ltycon tyvars fixity Nothing
     exact_kind
-    mapM_ markAnnotated mb_inj
+    case mb_inj of
+      Nothing -> return ()
+      Just inj -> do
+        markEpAnn an AnnVbar
+        markAnnotated inj
     case info of
       ClosedTypeFamily mb_eqns -> do
         markEpAnn an AnnWhere
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index 147747d560..f9883fee83 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -186,7 +186,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprin
  -- "../../testsuite/tests/ghc-api/exactprint/Windows.hs" Nothing
  -- "../../testsuite/tests/printer/Test19784.hs" Nothing
  -- "../../testsuite/tests/printer/Test19813.hs" Nothing
- "../../testsuite/tests/printer/Test19814.hs" Nothing
+ -- "../../testsuite/tests/printer/Test19814.hs" Nothing
+ "../../testsuite/tests/printer/Test19821.hs" Nothing
 
 -- cloneT does not need a test, function can be retired