prettyprinter 1.3.0 → 1.4.0
raw patch · 8 files changed
+159/−58 lines, 8 filesdep ~QuickCheckdep ~basedep ~fail
Dependency ranges changed: QuickCheck, base, fail
Files
- CHANGELOG.md +15/−0
- README.md +7/−5
- app/GenerateReadme.hs +7/−9
- misc/version-compatibility-macros.h +1/−1
- prettyprinter.cabal +6/−10
- src/Data/Text/Prettyprint/Doc/Internal.hs +54/−27
- src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs +6/−6
- test/Testsuite/Main.hs +63/−0
CHANGELOG.md view
@@ -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
README.md view
@@ -5,8 +5,10 @@ A modern Wadler/Leijen Prettyprinter ==================================== -[](https://travis-ci.org/quchen/prettyprinter) -[](https://hackage.haskell.org/package/prettyprinter) [](https://www.stackage.org/package/prettyprinter) [](https://www.stackage.org/package/prettyprinter)+[](https://travis-ci.org/quchen/prettyprinter)+[](https://hackage.haskell.org/package/prettyprinter)+[](https://www.stackage.org/package/prettyprinter)+[](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.
app/GenerateReadme.hs view
@@ -29,13 +29,11 @@ , h1 "A modern Wadler/Leijen Prettyprinter" - , mconcat+ , vcat [ "[](https://travis-ci.org/quchen/prettyprinter)"- , " " <> hardline -- Awkwardly enough, two trailing spaces are a small break in Markdown.- , hsep- [ "[](https://hackage.haskell.org/package/prettyprinter)"- , "[](https://www.stackage.org/package/prettyprinter)"- , "[](https://www.stackage.org/package/prettyprinter)" ]]+ , "[](https://hackage.haskell.org/package/prettyprinter)"+ , "[](https://www.stackage.org/package/prettyprinter)"+ , "[](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"
misc/version-compatibility-macros.h view
@@ -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
prettyprinter.cabal view
@@ -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)
src/Data/Text/Prettyprint/Doc/Internal.hs view
@@ -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
src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs view
@@ -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
test/Testsuite/Main.hs view
@@ -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)