diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,8 +1,23 @@ +# 1.4 + +- Add fixity declaration to `<+>`, matching `<>` +- Fix removal of trailing whitespace + - Keep very last newlines, Unix-style + - Do not trim leading whitespace + +# 1.3.0.1 + +- Support Stack 2 + # 1.3.0 - Add alignment to Pretty [a] instance - Fix removal of blank lines in `removeTrailingWhitespace` - Widened support for GHC versions 7.4–8.8 + +# 1.2.1.1 + +- Fix dependency of doctest suite # 1.2.1 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,8 +5,10 @@ A modern Wadler/Leijen Prettyprinter ==================================== -[![](https://img.shields.io/travis/quchen/prettyprinter/master.svg?style=flat-square&label=Master%20build)](https://travis-ci.org/quchen/prettyprinter) -[![](https://img.shields.io/hackage/v/prettyprinter.svg?style=flat-square&label=Hackage&colorB=0a7bbb)](https://hackage.haskell.org/package/prettyprinter) [![](https://www.stackage.org/package/prettyprinter/badge/lts?style=flat-square&colorB=0a7bbb)](https://www.stackage.org/package/prettyprinter) [![](https://www.stackage.org/package/prettyprinter/badge/nightly?style=flat-square&label=stackage%20nightly&colorB=0a7bbb)](https://www.stackage.org/package/prettyprinter) +[![](https://img.shields.io/travis/quchen/prettyprinter/master.svg?style=flat-square&label=Master%20build)](https://travis-ci.org/quchen/prettyprinter) +[![](https://img.shields.io/hackage/v/prettyprinter.svg?style=flat-square&label=Hackage&colorB=0a7bbb)](https://hackage.haskell.org/package/prettyprinter) +[![](https://www.stackage.org/package/prettyprinter/badge/lts?style=flat-square&colorB=0a7bbb)](https://www.stackage.org/package/prettyprinter) +[![](https://www.stackage.org/package/prettyprinter/badge/nightly?style=flat-square&label=stackage%20nightly&colorB=0a7bbb)](https://www.stackage.org/package/prettyprinter) @@ -181,9 +183,9 @@ 6. SimpleDoc was renamed `SimpleDocStream`, to contrast the new `SimpleDocTree`. 7. In the ANSI backend, instead of providing an own colorization function for - each color/intensity/layer combination, they have been combined in /color/ - /colorDull/, /bgColor/, and /bgColorDull/ functions, which can be found in - the ANSI terminal specific @prettyprinter-ansi-terminal@ package. + each color/intensity/layer combination, they have been combined in `color`, + `colorDull`, `bgColor`, and `bgColorDull` functions, which can be found in + the ANSI terminal specific `prettyprinter-ansi-terminal` package. diff --git a/app/GenerateReadme.hs b/app/GenerateReadme.hs --- a/app/GenerateReadme.hs +++ b/app/GenerateReadme.hs @@ -29,13 +29,11 @@ , h1 "A modern Wadler/Leijen Prettyprinter" - , mconcat + , vcat [ "[![](https://img.shields.io/travis/quchen/prettyprinter/master.svg?style=flat-square&label=Master%20build)](https://travis-ci.org/quchen/prettyprinter)" - , " " <> hardline -- Awkwardly enough, two trailing spaces are a small break in Markdown. - , hsep - [ "[![](https://img.shields.io/hackage/v/prettyprinter.svg?style=flat-square&label=Hackage&colorB=0a7bbb)](https://hackage.haskell.org/package/prettyprinter)" - , "[![](https://www.stackage.org/package/prettyprinter/badge/lts?style=flat-square&colorB=0a7bbb)](https://www.stackage.org/package/prettyprinter)" - , "[![](https://www.stackage.org/package/prettyprinter/badge/nightly?style=flat-square&label=stackage%20nightly&colorB=0a7bbb)](https://www.stackage.org/package/prettyprinter)" ]] + , "[![](https://img.shields.io/hackage/v/prettyprinter.svg?style=flat-square&label=Hackage&colorB=0a7bbb)](https://hackage.haskell.org/package/prettyprinter)" + , "[![](https://www.stackage.org/package/prettyprinter/badge/lts?style=flat-square&colorB=0a7bbb)](https://www.stackage.org/package/prettyprinter)" + , "[![](https://www.stackage.org/package/prettyprinter/badge/nightly?style=flat-square&label=stackage%20nightly&colorB=0a7bbb)](https://www.stackage.org/package/prettyprinter)" ] , h2 "tl;dr" , paragraph [multiline| A prettyprinter/text rendering engine. Easy to @@ -185,9 +183,9 @@ new `SimpleDocTree`. |] , [multiline| In the ANSI backend, instead of providing an own colorization function for each color/intensity/layer combination, they - have been combined in /color/ /colorDull/, /bgColor/, and - /bgColorDull/ functions, which can be found in the ANSI terminal - specific @prettyprinter-ansi-terminal@ package. |] + have been combined in `color`, `colorDull`, `bgColor`, and + `bgColorDull` functions, which can be found in the ANSI terminal + specific `prettyprinter-ansi-terminal` package. |] ] , h2 "Historical notes" diff --git a/misc/version-compatibility-macros.h b/misc/version-compatibility-macros.h --- a/misc/version-compatibility-macros.h +++ b/misc/version-compatibility-macros.h @@ -18,6 +18,6 @@ #define SEMIGROUP_MONOID_SUPERCLASS MIN_VERSION_base(4,11,0) -#define NO_FAIL_IN_MONAD_MONAD_FAIL MIN_VERSION_base(4,13,0) +#define FAIL_IN_MONAD !(MIN_VERSION_base(4,13,0)) #endif diff --git a/prettyprinter.cabal b/prettyprinter.cabal --- a/prettyprinter.cabal +++ b/prettyprinter.cabal @@ -1,5 +1,5 @@ name: prettyprinter -version: 1.3.0 +version: 1.4.0 cabal-version: >= 1.10 category: User Interfaces, Text synopsis: A modern, easy to use, well-documented, extensible pretty-printer. @@ -14,12 +14,6 @@ bug-reports: http://github.com/quchen/prettyprinter/issues homepage: http://github.com/quchen/prettyprinter build-type: Simple -tested-with: GHC == 7.8.4 - , GHC == 7.10.2 - , GHC == 7.10.3 - , GHC == 8.0.1 - , GHC == 8.0.2 - , GHC == 8.2.2 @@ -70,10 +64,10 @@ if impl(ghc >= 8.0) ghc-options: -Wcompat if !impl(ghc >= 8.0) - build-depends: semigroups >= 0.1 - build-depends: fail >= 4.9.0.0 + build-depends: semigroups >= 0.16.1 + build-depends: fail >= 4.9.0.0 && <4.10 if !impl(ghc >= 7.10) - build-depends: void + build-depends: void >=0.4 && <0.8 @@ -110,6 +104,8 @@ build-depends: base >= 4.7 && < 5 , doctest >= 0.9 + , prettyprinter + , QuickCheck >= 2.5 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 if impl (ghc < 7.10) diff --git a/src/Data/Text/Prettyprint/Doc/Internal.hs b/src/Data/Text/Prettyprint/Doc/Internal.hs --- a/src/Data/Text/Prettyprint/Doc/Internal.hs +++ b/src/Data/Text/Prettyprint/Doc/Internal.hs @@ -407,9 +407,9 @@ emptyDoc :: Doc ann emptyDoc = Empty --- | @('nest' i x)@ lays out the document @x@ with the current indentation level --- increased by @i@. Negative values are allowed, and decrease the nesting level --- accordingly. +-- | @('nest' i x)@ lays out the document @x@ with the current nesting level +-- (indentation of the following lines) increased by @i@. Negative values are +-- allowed, and decrease the nesting level accordingly. -- -- >>> vsep [nest 4 (vsep ["lorem", "ipsum", "dolor"]), "sit", "amet"] -- lorem @@ -418,7 +418,12 @@ -- sit -- amet -- --- See also 'hang', 'align' and 'indent'. +-- See also +-- +-- * 'hang' ('nest' relative to current cursor position instead of +-- current nesting level) +-- * 'align' (set nesting level to current cursor position) +-- * 'indent' (increase indentation on the spot, padding with spaces). nest :: Int -- ^ Change of nesting level -> Doc ann @@ -777,6 +782,7 @@ -- @ (<+>) :: Doc ann -> Doc ann -> Doc ann x <+> y = x <> Char ' ' <> y +infixr 6 <+> -- like <> @@ -1452,47 +1458,68 @@ -- whitespace, for example a renderer that colors the background of trailing -- whitespace, as e.g. @git diff@ can be configured to do. removeTrailingWhitespace :: SimpleDocStream ann -> SimpleDocStream ann -removeTrailingWhitespace = go (WssWithheldWhitespace [] 0) +removeTrailingWhitespace = go (RecordedWhitespace [] 0) where - commitSpaces :: [Int] -> Int -> SimpleDocStream ann -> SimpleDocStream ann + commitSpaces + :: [Int] -- Withheld lines + -> Int -- Withheld spaces + -> SimpleDocStream ann + -> SimpleDocStream ann commitSpaces [] 0 = id commitSpaces [] 1 = SChar ' ' commitSpaces [] n = SText n (T.replicate n " ") - commitSpaces [i] _ = SLine i - commitSpaces (_:is) _ = SLine 0 . commitSpaces is 0 + commitSpaces [i] n = SLine i . commitSpaces [] n + commitSpaces (_:is) n = SLine 0 . commitSpaces is n go :: WhitespaceStrippingState -> SimpleDocStream ann -> SimpleDocStream ann - go annLevel@(WssAnnotationLevel annotationLevel) = \sds -> case sds of - SFail -> SFail - SEmpty -> SEmpty - SChar c rest -> SChar c (go annLevel rest) - SText textLength text rest -> SText textLength text (go annLevel rest) - SLine i rest -> SLine i (go annLevel rest) - SAnnPush ann rest -> SAnnPush ann (go (WssAnnotationLevel (annotationLevel+1)) rest) + -- We do not strip whitespace inside annotated documents, since it might + -- actually be relevant there. + go annLevel@(AnnotationLevel annLvl) = \sds -> case sds of + SFail -> SFail + SEmpty -> SEmpty + SChar c rest -> SChar c (go annLevel rest) + SText l text rest -> SText l text (go annLevel rest) + SLine i rest -> SLine i (go annLevel rest) + SAnnPush ann rest -> let !annLvl' = annLvl+1 + in SAnnPush ann (go (AnnotationLevel annLvl') rest) SAnnPop rest - | annotationLevel > 1 -> SAnnPop (go (WssAnnotationLevel (annotationLevel-1)) rest) - | otherwise -> SAnnPop (go (WssWithheldWhitespace [] 0) rest) - go (WssWithheldWhitespace withheldLines withheldSpaces) = \sds -> case sds of + | annLvl > 1 -> let !annLvl' = annLvl-1 + in SAnnPop (go (AnnotationLevel annLvl') rest) + | otherwise -> SAnnPop (go (RecordedWhitespace [] 0) rest) + -- Record all spaces/lines encountered, and once proper text starts again, + -- release only the necessary ones. + go (RecordedWhitespace withheldLines withheldSpaces) = \sds -> case sds of SFail -> SFail - SEmpty -> SEmpty + SEmpty -> foldr (\_i sds' -> SLine 0 sds') SEmpty withheldLines SChar c rest - | c == ' ' -> go (WssWithheldWhitespace withheldLines (withheldSpaces+1)) rest - | otherwise -> commitSpaces withheldLines withheldSpaces (SChar c (go (WssWithheldWhitespace [] 0) rest)) + | c == ' ' -> go (RecordedWhitespace withheldLines (withheldSpaces+1)) rest + | otherwise -> commitSpaces + withheldLines + withheldSpaces + (SChar c (go (RecordedWhitespace [] 0) rest)) SText textLength text rest -> let stripped = T.dropWhileEnd (== ' ') text strippedLength = T.length stripped trailingLength = textLength - strippedLength isOnlySpace = strippedLength == 0 in if isOnlySpace - then go (WssWithheldWhitespace withheldLines (withheldSpaces + textLength)) rest - else commitSpaces withheldLines withheldSpaces (SText strippedLength stripped (go (WssWithheldWhitespace [] trailingLength) rest)) - SLine i rest -> go (WssWithheldWhitespace (i:withheldLines) 0) rest - SAnnPush ann rest -> commitSpaces withheldLines withheldSpaces (SAnnPush ann (go (WssAnnotationLevel 1) rest)) + then go (RecordedWhitespace withheldLines (withheldSpaces + textLength)) rest + else commitSpaces + withheldLines + withheldSpaces + (SText strippedLength + stripped + (go (RecordedWhitespace [] trailingLength) rest)) + SLine i rest -> go (RecordedWhitespace (i:withheldLines) 0) rest + SAnnPush ann rest -> commitSpaces + withheldLines + withheldSpaces + (SAnnPush ann (go (AnnotationLevel 1) rest)) SAnnPop _ -> error "Tried skipping spaces in unannotated data! Please report this as a bug in 'prettyprinter'." data WhitespaceStrippingState - = WssAnnotationLevel !Int - | WssWithheldWhitespace [Int] !Int + = AnnotationLevel !Int + | RecordedWhitespace [Int] !Int -- ^ [Newline with indentation i] Spaces deriving Typeable diff --git a/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs b/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs --- a/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs +++ b/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs @@ -118,15 +118,15 @@ pure (f x, s'') ) instance Monad (UniqueParser s) where -#if !(APPLICATIVE_MONAD) - return = pure -#endif UniqueParser p >>= f = UniqueParser (\s -> do (a', s') <- p s - (a'', s'') <- runParser (f a') s' - pure (a'', s'') ) + let UniqueParser p' = f a' + p' s' ) -#if !(NO_FAIL_IN_MONAD_MONAD_FAIL) +#if !(APPLICATIVE_MONAD) + return = pure +#endif +#if FAIL_IN_MONAD fail = Fail.fail #endif diff --git a/test/Testsuite/Main.hs b/test/Testsuite/Main.hs --- a/test/Testsuite/Main.hs +++ b/test/Testsuite/Main.hs @@ -55,6 +55,24 @@ regressionLayoutSmartSoftline , testCase "alterAnnotationsS causes panic when removing annotations (#50)" regressionAlterAnnotationsS + , testGroup "removeTrailingWhitespace removes leading whitespace (#84)" + [ testCase "Text node" + doNotRemoveLeadingWhitespaceText + , testCase "Char node" + doNotRemoveLeadingWhitespaceChar + , testCase "Text+Char nodes" + doNotRemoveLeadingWhitespaceTextChar + ] + , testGroup "removeTrailingWhitespace removes trailing line breaks (#86)" + [ testCase "Keep lonely single trailing newline" + removeTrailingWhitespaceKeepLonelyTrailingNewline + , testCase "Trailing newline with spaces" + removeTrailingNewlineWithSpaces + , testCase "Keep single trailing newline" + removeTrailingWhitespaceKeepTrailingNewline + , testCase "Reduce to single trailing newline" + removeTrailingWhitespaceInTrailingNewlines + ] ] ] @@ -205,3 +223,48 @@ sdoc = layoutSmart defaultLayoutOptions (annotate 1 (annotate 2 (annotate 3 "a"))) sdoc' = alterAnnotationsS (\ann -> case ann of 2 -> Just 2; _ -> Nothing) sdoc in assertEqual "" (SAnnPush 2 (SChar 'a' (SAnnPop SEmpty))) sdoc' + +doNotRemoveLeadingWhitespaceText :: Assertion +doNotRemoveLeadingWhitespaceText + = let sdoc :: SimpleDocStream () + sdoc = SLine 0 (SText 2 " " (SChar 'x' SEmpty)) + in assertEqual "" sdoc (removeTrailingWhitespace sdoc) + +doNotRemoveLeadingWhitespaceChar :: Assertion +doNotRemoveLeadingWhitespaceChar + = let sdoc :: SimpleDocStream () + sdoc = SLine 0 (SChar ' ' (SChar 'x' SEmpty)) + in assertEqual "" sdoc (removeTrailingWhitespace sdoc) + +doNotRemoveLeadingWhitespaceTextChar :: Assertion +doNotRemoveLeadingWhitespaceTextChar + = let sdoc :: SimpleDocStream () + sdoc = SLine 0 (SChar ' ' (SText 2 " " (SChar 'x' SEmpty))) + sdoc' = SLine 0 (SText 3 " " (SChar 'x' SEmpty)) + in assertEqual "" sdoc' (removeTrailingWhitespace sdoc) + +removeTrailingWhitespaceKeepTrailingNewline :: Assertion +removeTrailingWhitespaceKeepTrailingNewline + = let sdoc :: SimpleDocStream () + sdoc = SLine 0 SEmpty + in assertEqual "" sdoc (removeTrailingWhitespace sdoc) + +removeTrailingNewlineWithSpaces :: Assertion +removeTrailingNewlineWithSpaces + = let sdoc :: SimpleDocStream () + sdoc = SChar 'x' (SLine 2 (SText 2 " " SEmpty)) + sdoc' = SChar 'x' (SLine 0 SEmpty) + in assertEqual "" sdoc' (removeTrailingWhitespace sdoc) + +removeTrailingWhitespaceKeepLonelyTrailingNewline :: Assertion +removeTrailingWhitespaceKeepLonelyTrailingNewline + = let sdoc :: SimpleDocStream () + sdoc = SChar 'x' (SLine 0 SEmpty) + in assertEqual "" sdoc (removeTrailingWhitespace sdoc) + +removeTrailingWhitespaceInTrailingNewlines :: Assertion +removeTrailingWhitespaceInTrailingNewlines + = let sdoc :: SimpleDocStream () + sdoc = SChar 'x' (SLine 2 (SLine 2 SEmpty)) + sdoc' = SChar 'x' (SLine 0 (SLine 0 SEmpty)) + in assertEqual "" sdoc' (removeTrailingWhitespace sdoc)