From 9062ca69faa703bba07bca1d8d59818c624d054b Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Thu, 6 May 2021 18:47:51 +0100 Subject: EPA: properly capture leading semicolons in statement lists For the fragment blah = do { ; print "a" ; print "b" } capture the leading semicolon before 'print "a"' in 'al_rest' in AnnList instead of in 'al_trailing'. Closes #19798 --- compiler/GHC/Parser.y | 10 +++++----- compiler/GHC/Parser/Annotation.hs | 4 +++- testsuite/tests/printer/Makefile | 5 +++++ testsuite/tests/printer/Test19798.hs | 6 ++++++ testsuite/tests/printer/all.T | 3 ++- utils/check-exact/ExactPrint.hs | 1 + utils/check-exact/Main.hs | 3 ++- 7 files changed, 24 insertions(+), 8 deletions(-) create mode 100644 testsuite/tests/printer/Test19798.hs diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index da5572dcef..483fb06e97 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -3289,9 +3289,9 @@ apats :: { [LPat GhcPs] } stmtlist :: { forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))]) } : '{' stmts '}' { $2 >>= \ $2 -> amsrl - (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) [] (fst $ unLoc $2)) } -- AZ:performance of reverse? + (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fst $ unLoc $2) []) } -- AZ:performance of reverse? | vocurly stmts close { $2 >>= \ $2 -> amsrl - (L (gl $2) (reverse $ snd $ unLoc $2)) (AnnList (Just $ glR $2) Nothing Nothing [] (fst $ unLoc $2)) } + (L (gl $2) (reverse $ snd $ unLoc $2)) (AnnList (Just $ glR $2) Nothing Nothing (fst $ unLoc $2) []) } -- do { ;; s ; s ; ; s ;; } -- The last Stmt should be an expression, but that's hard to enforce @@ -3299,11 +3299,11 @@ stmtlist :: { forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (Locat -- So we use BodyStmts throughout, and switch the last one over -- in ParseUtils.checkDo instead -stmts :: { forall b. DisambECP b => PV (Located ([TrailingAnn],[LStmt GhcPs (LocatedA b)])) } +stmts :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LStmt GhcPs (LocatedA b)])) } : stmts ';' stmt { $1 >>= \ $1 -> $3 >>= \ ($3 :: LStmt GhcPs (LocatedA b)) -> case (snd $ unLoc $1) of - [] -> return (sLL $1 (reLoc $>) ((msemi $2) ++ (fst $ unLoc $1) + [] -> return (sLL $1 (reLoc $>) ((mj AnnSemi $2) : (fst $ unLoc $1) ,$3 : (snd $ unLoc $1))) (h:t) -> do { h' <- addTrailingSemiA h (gl $2) @@ -3311,7 +3311,7 @@ stmts :: { forall b. DisambECP b => PV (Located ([TrailingAnn],[LStmt GhcPs (Loc | stmts ';' { $1 >>= \ $1 -> case (snd $ unLoc $1) of - [] -> return (sLL $1 $> ((msemi $2) ++ (fst $ unLoc $1),snd $ unLoc $1)) + [] -> return (sLL $1 $> ((mj AnnSemi $2) : (fst $ unLoc $1),snd $ unLoc $1)) (h:t) -> do { h' <- addTrailingSemiA h (gl $2) ; return $ sL1 $1 (fst $ unLoc $1,h':t) }} diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs index 8dc12555a0..8d47c699ba 100644 --- a/compiler/GHC/Parser/Annotation.hs +++ b/compiler/GHC/Parser/Annotation.hs @@ -689,7 +689,9 @@ data AnnList al_open :: Maybe AddEpAnn, al_close :: Maybe AddEpAnn, al_rest :: [AddEpAnn], -- ^ context, such as 'where' keyword - al_trailing :: [TrailingAnn] + al_trailing :: [TrailingAnn] -- ^ items appearing after the + -- list, such as '=>' for a + -- context } deriving (Data,Eq) -- --------------------------------------------------------------------- diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile index 3bd736b7a8..fe95e5a237 100644 --- a/testsuite/tests/printer/Makefile +++ b/testsuite/tests/printer/Makefile @@ -562,3 +562,8 @@ InTreeAnnotations1: Test19784: $(CHECK_PPR) $(LIBDIR) Test19784.hs $(CHECK_EXACT) $(LIBDIR) Test19784.hs + +.PHONY: Test19798 +Test19798: + $(CHECK_PPR) $(LIBDIR) Test19798.hs + $(CHECK_EXACT) $(LIBDIR) Test19798.hs diff --git a/testsuite/tests/printer/Test19798.hs b/testsuite/tests/printer/Test19798.hs new file mode 100644 index 0000000000..0b9e5162f1 --- /dev/null +++ b/testsuite/tests/printer/Test19798.hs @@ -0,0 +1,6 @@ +module Test19798 where + +blah = do { + ; print "a" + ; print "b" + } diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T index 04d6d33acc..d73e82ad2a 100644 --- a/testsuite/tests/printer/all.T +++ b/testsuite/tests/printer/all.T @@ -124,4 +124,5 @@ 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 +test('Test19784', ignore_stderr, makefile_test, ['Test19784']) +test('Test19798', ignore_stderr, makefile_test, ['Test19798']) diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index 4c8f3f27ac..3680405a0a 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -596,6 +596,7 @@ markAnnList' reallyTrail ann action = do debugM $ "markAnnList : " ++ showPprUnsafe (p, ann) mapM_ markAddEpAnn (al_open ann) unless reallyTrail $ markTrailing (al_trailing ann) -- Only makes sense for HsModule. + mark (sort $ al_rest ann) AnnSemi action debugM $ "markAnnList: calling markAddEpAnn on:" ++ showPprUnsafe (al_close ann) mapM_ markAddEpAnn (al_close ann) diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs index a332cc5a8c..27a24f1804 100644 --- a/utils/check-exact/Main.hs +++ b/utils/check-exact/Main.hs @@ -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 @@ -173,6 +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/qualifieddo/should_compile/qdocompile001.hs" Nothing -- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs" Nothing -- cgit v1.2.1