summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Hs/Expr.hs13
-rw-r--r--compiler/GHC/Hs/Utils.hs4
-rw-r--r--compiler/GHC/Parser.y19
-rw-r--r--compiler/GHC/Parser/PostProcess.hs2
-rw-r--r--testsuite/tests/printer/Makefile5
-rw-r--r--testsuite/tests/printer/Test19813.hs20
-rw-r--r--testsuite/tests/printer/all.T4
-rw-r--r--utils/check-exact/ExactPrint.hs18
-rw-r--r--utils/check-exact/Main.hs3
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
View Lorry Controller Status