EPA: Use custom AnnsIf structure for HsIf and HsCmdIf

This clearly identifies the presence and location of optional
semicolons in an if statement.

Closes #19813

9 files changed, 72 insertions, 16 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index f812c66540..3cff120713 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -288,7 +288,7 @@ type instance XCase          GhcPs = EpAnn EpAnnHsCase
 type instance XCase          GhcRn = NoExtField
 type instance XCase          GhcTc = NoExtField
 
-type instance XIf            GhcPs = EpAnn [AddEpAnn]
+type instance XIf            GhcPs = EpAnn AnnsIf
 type instance XIf            GhcRn = NoExtField
 type instance XIf            GhcTc = NoExtField
 
@@ -388,6 +388,15 @@ data AnnProjection
       apClose :: EpaLocation  -- ^ ')'
       } deriving Data
 
+data AnnsIf
+  = AnnsIf {
+      aiIf       :: EpaLocation,
+      aiThen     :: EpaLocation,
+      aiElse     :: EpaLocation,
+      aiThenSemi :: Maybe EpaLocation,
+      aiElseSemi :: Maybe EpaLocation
+      } deriving Data
+
 -- ---------------------------------------------------------------------
 
 type instance XSCC           (GhcPass _) = EpAnn AnnPragma
@@ -1039,7 +1048,7 @@ type instance XCmdCase    GhcTc = NoExtField
 
 type instance XCmdLamCase (GhcPass _) = EpAnn [AddEpAnn]
 
-type instance XCmdIf      GhcPs = EpAnn [AddEpAnn]
+type instance XCmdIf      GhcPs = EpAnn AnnsIf
 type instance XCmdIf      GhcRn = NoExtField
 type instance XCmdIf      GhcTc = NoExtField
 
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 34120f56cd..3c152af242 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -364,12 +364,12 @@ mkHsCompAnns ctxt stmts expr anns = mkHsDoAnns ctxt (mkLocatedList (stmts ++ [la
     last_stmt = L (noAnnSrcSpan $ getLocA expr) $ mkLastStmt expr
 
 -- restricted to GhcPs because other phases might need a SyntaxExpr
-mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> EpAnn [AddEpAnn]
+mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> EpAnn AnnsIf
        -> HsExpr GhcPs
 mkHsIf c a b anns = HsIf anns c a b
 
 -- restricted to GhcPs because other phases might need a SyntaxExpr
-mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> EpAnn [AddEpAnn]
+mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> EpAnn AnnsIf
        -> HsCmd GhcPs
 mkHsCmdIf c a b anns = HsCmdIf anns noSyntaxExpr c a b
 
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 483fb06e97..f9a4d10a4d 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -2679,9 +2679,9 @@ exp10 :: { ECP }
         -- See Note [%shift: exp10 -> fexp]
         | fexp %shift                  { $1 }
 
-optSemi :: { ([Located Token],Bool) }
-        : ';'         { ([$1],True) }
-        | {- empty -} { ([],False) }
+optSemi :: { (Maybe EpaLocation,Bool) }
+        : ';'         { (msemim $1,True) }
+        | {- empty -} { (Nothing,False) }
 
 {- Note [Pragmas and operator fixity]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2801,10 +2801,12 @@ aexp    :: { ECP }
                               unECP $5 >>= \ $5 ->
                               unECP $8 >>= \ $8 ->
                               mkHsIfPV (comb2A $1 $>) $2 (snd $3) $5 (snd $6) $8
-                                    (mj AnnIf $1:mj AnnThen $4
-                                     :mj AnnElse $7
-                                     :(concatMap (\l -> mz AnnSemi l) (fst $3))
-                                    ++(concatMap (\l -> mz AnnSemi l) (fst $6))) }
+                                    (AnnsIf
+                                      { aiIf = glAA $1
+                                      , aiThen = glAA $4
+                                      , aiElse = glAA $7
+                                      , aiThenSemi = fst $3
+                                      , aiElseSemi = fst $6})}
 
         | 'if' ifgdpats                 {% hintMultiWayIf (getLoc $1) >>= \_ ->
                                            fmap ecpFromExp $
@@ -4161,6 +4163,9 @@ mz a l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (EpaSpan $ rs $ gl l
 msemi :: Located e -> [TrailingAnn]
 msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (EpaSpan $ rs $ gl l)]
 
+msemim :: Located e -> Maybe EpaLocation
+msemim l = if isZeroWidthSpan (gl l) then Nothing else Just (EpaSpan $ rs $ gl l)
+
 -- |Construct an AddEpAnn from the annotation keyword and the Located Token. If
 -- the token has a unicode equivalent and this has been used, provide the
 -- unicode variant of the annotation.
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 697161b564..8f9ba78b13 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -1450,7 +1450,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
          -> LocatedA b
          -> Bool  -- semicolon?
          -> LocatedA b
-         -> [AddEpAnn]
+         -> AnnsIf
          -> PV (LocatedA b)
   -- | Disambiguate "do { ... }" (do notation)
   mkHsDoPV ::
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index fe95e5a237..de71d64b78 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -567,3 +567,8 @@ Test19784:
 Test19798:
 	$(CHECK_PPR)   $(LIBDIR) Test19798.hs
 	$(CHECK_EXACT) $(LIBDIR) Test19798.hs
+
+.PHONY: Test19813
+Test19813:
+	# $(CHECK_PPR)   $(LIBDIR) Test19813.hs
+	$(CHECK_EXACT) $(LIBDIR) Test19813.hs
diff --git a/testsuite/tests/printer/Test19813.hs b/testsuite/tests/printer/Test19813.hs
new file mode 100644
index 0000000000..d15536c032
--- /dev/null
+++ b/testsuite/tests/printer/Test19813.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE Arrows #-}
+module Bar where
+
+import Control.Arrow
+import Data.Text as Text
+
+replace :: Text -> Text
+replace = Text.map (\c -> if c == '_' then '.'; else c)
+
+replace1 :: Text -> Text
+replace1 = Text.map (\c -> if c == '_' ; then '.' else c)
+
+replace2 :: Text -> Text
+replace2 = Text.map (\c -> if c == '_'; then '.'; else c)
+
+replace4 :: Text -> Text
+replace4 = Text.map (\c -> if c == '_' then '.' else c)
+
+addA f g = proc x -> if x == 0 ; then returnA -< x
+                               ; else returnA -< x
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index d73e82ad2a..d25cd2bf22 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -126,3 +126,7 @@ test('InTreeAnnotations1', ignore_stderr, makefile_test, ['InTreeAnnotations1'])
 
 test('Test19784', ignore_stderr, makefile_test, ['Test19784'])
 test('Test19798', ignore_stderr, makefile_test, ['Test19798'])
+
+# The exact printing manages the extra semicolons, normal ppr not, so
+# disabled in the Makefile for this test.
+test('Test19813', ignore_stderr, makefile_test, ['Test19813'])
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 3680405a0a..5047346111 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -1907,11 +1907,13 @@ instance ExactPrint (HsExpr GhcPs) where
 
   -- exact x@(HsCase EpAnnNotUsed   _ _) = withPpr x
   exact (HsIf an e1 e2 e3) = do
-    markEpAnn an AnnIf
+    markAnnKw an aiIf AnnIf
     markAnnotated e1
-    markEpAnn an AnnThen
+    markAnnKwM an aiThenSemi AnnSemi
+    markAnnKw an aiThen AnnThen
     markAnnotated e2
-    markEpAnn an AnnElse
+    markAnnKwM an aiElseSemi AnnSemi
+    markAnnKw an aiElse AnnElse
     markAnnotated e3
 
   exact (HsMultiIf an mg) = do
@@ -2399,6 +2401,16 @@ instance ExactPrint (HsCmd GhcPs) where
 --     mark GHC.AnnElse
 --     markLocated e3
 
+  exact (HsCmdIf an _ e1 e2 e3) = do
+    markAnnKw an aiIf AnnIf
+    markAnnotated e1
+    markAnnKwM an aiThenSemi AnnSemi
+    markAnnKw an aiThen AnnThen
+    markAnnotated e2
+    markAnnKwM an aiElseSemi AnnSemi
+    markAnnKw an aiElse AnnElse
+    markAnnotated e3
+
 --   markAST _ (GHC.HsCmdLet _ (GHC.L _ binds) e) = do
 --     mark GHC.AnnLet
 --     markOptional GHC.AnnOpenC
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index 27a24f1804..8a2622edcd 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -173,7 +173,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprin
  -- "../../testsuite/tests/printer/Test16236.hs" Nothing
  -- "../../testsuite/tests/printer/Test17519.hs" Nothing
  -- "../../testsuite/tests/printer/InTreeAnnotations1.hs" Nothing
- "../../testsuite/tests/printer/Test19798.hs" Nothing
+ -- "../../testsuite/tests/printer/Test19798.hs" Nothing
 
  -- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs" Nothing
  -- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs" Nothing
@@ -185,6 +185,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprin
  -- "../../testsuite/tests/ghc-api/exactprint/WhereIn3a.hs" Nothing
  -- "../../testsuite/tests/ghc-api/exactprint/Windows.hs" Nothing
  -- "../../testsuite/tests/printer/Test19784.hs" Nothing
+ "../../testsuite/tests/printer/Test19813.hs" Nothing
 
 -- cloneT does not need a test, function can be retired