prettyprinter 1.2.0.1 → 1.2.1
raw patch · 11 files changed
+299/−50 lines, 11 files
Files
- CHANGELOG.md +62/−0
- README.md +2/−1
- app/GenerateReadme.hs +2/−1
- misc/version-compatibility-macros.h +2/−1
- prettyprinter.cabal +11/−4
- src/Data/Text/Prettyprint/Doc.hs +41/−28
- src/Data/Text/Prettyprint/Doc/Internal.hs +72/−0
- src/Data/Text/Prettyprint/Doc/Render/Text.hs +2/−2
- src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs +10/−10
- test/Testsuite/Main.hs +7/−3
- test/Testsuite/StripTrailingSpace.hs +88/−0
+ CHANGELOG.md view
@@ -0,0 +1,62 @@+# 1.2.1++- Add function to trim trailing space in layouted `SimpleDocStream`,+ `removeTrailingWhitespace`+- Add `Pretty` instances for `Identity` and `Const`++# 1.2.0.1++- Fix `alterAnnotationsS` (and thus `unAnnotateS`), which removed pushing, but+ not popping, style frames. This led to them throwing errors in pretty much all+ use cases.++# 1.2++- `encloseSep` does no longer include an `align` wrapper; in other words,++ ```haskell+ encloseSep_old … = align (encloseSep_new …)+ ```+- Change the default ribbon fraction to 1 (was 0.4)+- Expose `viaShow` and `unsafeViaShow` from the public module+- Fix `layoutSmart` behaving as if there was no space left for unbounded pages++# 1.1.1++- Add `panicPeekedEmpty` and `panicPoppedEmpty` to the panic module++# 1.1.0.1++- Rendering directly to a handle is now more efficient in the `Text` renderer,+ since no intermediate `Text` is generated anymore.+- Remove upper version bounds from `.cabal` files++# 1.1++- Allow `alterAnnotations` to convert one annotation to multiple ones, to+ support e.g. `Keyword ---> Green+Bold`+- Remove `Pretty` instance for `Doc`: the implicit un-annotation done by it did+ more harm than good.++# 1.0.1++- Add `alterAnnotations`, which allows changing or removing annotations.+ `reAnnotate` and `unAnnotate` are now special cases of this.+- Fix »group« potentially taking exponential time, by making the (internal)+ `flatten` function detect whether it is going to have any effect inside+ `group`.+- Add proper version bounds for all dependencies and backport them to version 1+- Haddock: example for `Pretty Void`++# 1++- Add Foldable/Traversable instances for `SimpleDocTree`, `SimpleDocStream`+- Add Functor instances for `Doc`, `SimpleDocTree`, `SimpleDocStream`+- Add the simplified renderers `renderSimplyDecorated` and+ `renderSimplyDecoratedA` to the tree and stack renderer modules+- Lots of typo fixes and doc tweaks+- Add a changelog :-)++# 0.1++Initial release.
README.md view
@@ -182,7 +182,8 @@ `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.+ /colorDull/, /bgColor/, and /bgColorDull/ functions, which can be found in+ the ANSI terminal specific @prettyprinter-ansi-terminal@ package.
app/GenerateReadme.hs view
@@ -186,7 +186,8 @@ , [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. |]+ /bgColorDull/ functions, which can be found in the ANSI terminal+ specific @prettyprinter-ansi-terminal@ package. |] ] , h2 "Historical notes"
misc/version-compatibility-macros.h view
@@ -10,10 +10,11 @@ #define APPLICATIVE_MONAD MIN_VERSION_base(4,8,0) #define FOLDABLE_TRAVERSABLE_IN_PRELUDE MIN_VERSION_base(4,8,0)+#define FUNCTOR_IDENTITY_IN_BASE MIN_VERSION_base(4,8,0) #define MONOID_IN_PRELUDE MIN_VERSION_base(4,8,0) #define NATURAL_IN_BASE MIN_VERSION_base(4,8,0) -#define SEMIGROUP_IN_BASE MIN_VERSION_base(4,9,0) #define MONAD_FAIL MIN_VERSION_base(4,9,0)+#define SEMIGROUP_IN_BASE MIN_VERSION_base(4,9,0) #endif
prettyprinter.cabal view
@@ -1,19 +1,25 @@ name: prettyprinter-version: 1.2.0.1+version: 1.2.1 cabal-version: >= 1.10 category: User Interfaces, Text-synopsis: A modern, easy to use, well-documented, extensible prettyprinter.-description: See README.md+synopsis: A modern, easy to use, well-documented, extensible pretty-printer.+description: A modern, easy to use, well-documented, extensible pretty-printer. For more see README.md license: BSD2 license-file: LICENSE.md extra-source-files: README.md+ , CHANGELOG.md , misc/version-compatibility-macros.h author: Phil Wadler, Daan Leijen, Max Bolingbroke, Edward Kmett, David Luposchainsky maintainer: David Luposchainsky <dluposchainsky at google> 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+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 @@ -111,6 +117,7 @@ type: exitcode-stdio-1.0 hs-source-dirs: test/Testsuite main-is: Main.hs+ other-modules: StripTrailingSpace build-depends: base , prettyprinter
src/Data/Text/Prettyprint/Doc.hs view
@@ -71,32 +71,43 @@ -- = General workflow -- -- @--- ╭───────────────╮ ╭───────────────────╮--- │ 'vsep', 'pretty', │ │ 'Doc' │--- │ '<+>', 'nest', ├─────▷│ (rich document) │--- │ 'align', … │ ╰─────────┬─────────╯--- ╰───────────────╯ │--- │ Layout algorithms--- │ e.g. 'layoutPretty'--- ▽--- ╭───────────────────╮--- │ 'SimpleDocStream' │--- │ (simple document) │--- ╰─────────┬─────────╯--- │--- ╭───────────────────┴───────────────────╮--- 'Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree.treeForm' │ │--- ▽ │--- ╭───────────────╮ │--- │ 'Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree.SimpleDocTree' │ Renderers │--- ╰───────┬───────╯ │--- │ │--- ├───────────────╮ ╭───────────────┼───────────────────╮--- │ │ │ │ │--- ▽ ▽ ▽ ▽ ▽--- ╭───────────────╮ ╭───────────────╮ ╭───────────────╮ ╭───────────────╮--- │ HTML │ │ other/custom │ │ Plain 'Text' │ │ ANSI terminal │--- ╰───────────────╯ ╰───────────────╯ ╰───────────────╯ ╰───────────────╯+-- ╔══════════╗+-- ║ ║ ╭────────────────────╮+-- ║ ║ │ 'vsep', 'pretty', '<+>', │+-- ║ ║ │ 'nest', 'align', … │+-- ║ ║ ╰─────────┬──────────╯+-- ║ ║ │+-- ║ Create ║ │+-- ║ ║ │+-- ║ ║ ▽+-- ║ ║ ╭───────────────────╮+-- ║ ║ │ 'Doc' │+-- ╠══════════╣ │ (rich document) │+-- ║ ║ ╰─────────┬─────────╯+-- ║ ║ │+-- ║ ║ │ Layout algorithms+-- ║ Layout ║ │ e.g. 'layoutPretty'+-- ║ ║ ▽+-- ║ ║ ╭───────────────────╮+-- ║ ║ │ 'SimpleDocStream' │+-- ╠══════════╣ │ (simple document) │+-- ║ ║ ╰─────────┬─────────╯+-- ║ ║ │+-- ║ ║ ├─────────────────────────────╮+-- ║ ║ │ │ 'Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree.treeForm'+-- ║ ║ │ ▽+-- ║ ║ │ ╭───────────────╮+-- ║ ║ │ │ 'Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree.SimpleDocTree' │+-- ║ Render ║ │ ╰───────┬───────╯+-- ║ ║ │ │+-- ║ ║ ╭───────────────────┼─────────────────╮ ╭────────┴────────╮+-- ║ ║ │ │ │ │ │+-- ║ ║ ▽ ▽ ▽ ▽ ▽+-- ║ ║ ╭───────────────╮ ╭───────────────╮ ╭───────────────╮ ╭───────────────╮+-- ║ ║ │ ANSI terminal │ │ Plain 'Text' │ │ other/custom │ │ HTML │+-- ║ ║ ╰───────────────╯ ╰───────────────╯ ╰───────────────╯ ╰───────────────╯+-- ║ ║+-- ╚══════════╝ -- @ -- -- = How the layout works@@ -163,7 +174,7 @@ -- text replacement, producing a large diff and touching lots of places for a -- very small change. ----- /Extensibility:/ Addng a different backend in the recommended version is+-- /Extensibility:/ Adding a different backend in the recommended version is -- simply adding another @'reAnnotateS'@ to convert the @'Doc'@ annotation to -- something else. On the other hand, if you have @'Red'@ as an annotation in -- the @'Doc'@ already and the other backend does not support anything red@@ -267,6 +278,7 @@ SimpleDocStream(..), PageWidth(..), LayoutOptions(..), defaultLayoutOptions, layoutPretty, layoutCompact, layoutSmart,+ removeTrailingWhitespace, -- * Migration guide --@@ -317,4 +329,5 @@ -- clearer in the presence of @SimpleDocTree@. -- - Instead of providing an own colorization function for each -- color\/intensity\/layer combination, they have been combined in 'color',--- 'colorDull', 'bgColor', and 'bgColorDull' functions.+-- 'colorDull', 'bgColor', and 'bgColorDull' functions, which can be found+-- in the ANSI terminal specific @prettyprinter-ansi-terminal@ package.
src/Data/Text/Prettyprint/Doc/Internal.hs view
@@ -52,6 +52,10 @@ import Data.Monoid hiding ((<>)) #endif +#if FUNCTOR_IDENTITY_IN_BASE+import Data.Functor.Identity+#endif+ import Data.Text.Prettyprint.Doc.Render.Util.Panic @@ -197,6 +201,16 @@ {-# MINIMAL pretty #-} +instance Pretty a => Pretty (Const a b) where+ pretty = pretty . getConst++#if FUNCTOR_IDENTITY_IN_BASE+-- | >>> pretty (Identity 1)+-- 1+instance Pretty a => Pretty (Identity a) where+ pretty = pretty . runIdentity+#endif+ -- | >>> pretty [1,2,3] -- [1, 2, 3] instance Pretty a => Pretty [a] where@@ -1413,6 +1427,64 @@ -- | Remove a previously pushed annotation. | SAnnPop (SimpleDocStream ann) deriving (Eq, Ord, Show, Generic)++-- | Remove all trailing space characters.+--+-- This has some performance impact, because it does an entire additional pass+-- over the 'SimpleDocStream'.+--+-- No trimming will be done inside annotations, which are considered to contain+-- no (trimmable) whitespace, since the annotation might actually be /about/ the+-- 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 Nothing 0)+ where+ commitSpaces :: Maybe Int -> Int -> SimpleDocStream ann -> SimpleDocStream ann+ commitSpaces mWithheldNewline withheldSpaces = nl . sp+ where+ nl = case mWithheldNewline of+ Just withheldLine -> SLine withheldLine+ Nothing -> id+ sp = case withheldSpaces of+ 0 -> id+ 1 -> SChar ' '+ n -> SText n (T.replicate n " ")++ go :: WhitespaceStrippingState -> SimpleDocStream ann -> SimpleDocStream ann+ go annLevel@(WssAnnotationLevel annotationLevel) = \case+ 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)+ SAnnPop rest+ | annotationLevel > 1 -> SAnnPop (go (WssAnnotationLevel (annotationLevel-1)) rest)+ | otherwise -> SAnnPop (go (WssWithheldWhitespace Nothing 0) rest)+ go (WssWithheldWhitespace withheldLine withheldSpaces) = \case+ SFail -> SFail+ SEmpty -> SEmpty+ SChar c rest+ | c == ' ' -> go (WssWithheldWhitespace withheldLine (withheldSpaces+1)) rest+ | otherwise -> commitSpaces withheldLine withheldSpaces (SChar c (go (WssWithheldWhitespace Nothing 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 withheldLine (withheldSpaces + textLength)) rest+ else commitSpaces withheldLine withheldSpaces (SText strippedLength stripped (go (WssWithheldWhitespace Nothing trailingLength) rest))+ SLine i rest -> go (WssWithheldWhitespace (Just i) 0) rest+ SAnnPush ann rest -> commitSpaces withheldLine withheldSpaces (SAnnPush ann (go (WssAnnotationLevel 1) rest))+ SAnnPop _ -> error "Tried skipping spaces in unannotated data! Please report this as a bug in 'prettyprinter'."++data WhitespaceStrippingState+ = WssAnnotationLevel !Int+ | WssWithheldWhitespace (Maybe Int) !Int++ -- | Alter the document’s annotations. --
src/Data/Text/Prettyprint/Doc/Render/Text.hs view
@@ -59,8 +59,8 @@ renderLazy :: SimpleDocStream ann -> TL.Text renderLazy = TLB.toLazyText . renderSimplyDecorated TLB.fromText (pure mempty) (pure mempty) --- | @('renderLazy' sdoc)@ takes the output @sdoc@ from a rendering and--- transforms it to strict text.+-- | @('renderStrict' sdoc)@ takes the output @sdoc@ from a rendering function+-- and transforms it to strict text. renderStrict :: SimpleDocStream ann -> Text renderStrict = TL.toStrict . renderLazy
src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs view
@@ -74,12 +74,12 @@ renderSimplyDecorated text renderAnn = go where go = \case- STEmpty -> mempty- STChar c -> text (T.singleton c)- STText _ t -> text t- STLine i -> text (T.singleton '\n' <> T.replicate i " ")+ STEmpty -> mempty+ STChar c -> text (T.singleton c)+ STText _ t -> text t+ STLine i -> text (T.singleton '\n' <> T.replicate i " ") STAnn ann rest -> renderAnn ann (go rest)- STConcat xs -> foldMap go xs+ STConcat xs -> foldMap go xs {-# INLINE renderSimplyDecorated #-} -- | Version of 'renderSimplyDecoratedA' that allows for 'Applicative' effects.@@ -92,12 +92,12 @@ renderSimplyDecoratedA text renderAnn = go where go = \case- STEmpty -> pure mempty- STChar c -> text (T.singleton c)- STText _ t -> text t- STLine i -> text (T.singleton '\n' <> T.replicate i " ")+ STEmpty -> pure mempty+ STChar c -> text (T.singleton c)+ STText _ t -> text t+ STLine i -> text (T.singleton '\n' <> T.replicate i " ") STAnn ann rest -> renderAnn ann (go rest)- STConcat xs -> fmap mconcat (traverse go xs)+ STConcat xs -> fmap mconcat (traverse go xs) {-# INLINE renderSimplyDecoratedA #-}
test/Testsuite/Main.hs view
@@ -22,6 +22,8 @@ import Test.Tasty.HUnit import Test.Tasty.QuickCheck +import StripTrailingSpace+ #if !(APPLICATIVE_MONAD) import Control.Applicative #endif@@ -42,6 +44,7 @@ , testProperty "Deep fusion does not change rendering" (fusionDoesNotChangeRendering Deep) ]+ , testStripTrailingSpace , testGroup "Performance tests" [ testCase "Grouping performance" groupingPerformance@@ -199,6 +202,7 @@ -- pops, leading to imbalanced SimpleDocStreams. regressionAlterAnnotationsS :: Assertion regressionAlterAnnotationsS- = let sdoc :: SimpleDocStream ()- sdoc = alterAnnotationsS (const Nothing) (layoutSmart defaultLayoutOptions (annotate () "a"))- in assertEqual "" (SChar 'a' SEmpty) sdoc+ = let sdoc, sdoc' :: SimpleDocStream Int+ sdoc = layoutSmart defaultLayoutOptions (annotate 1 (annotate 2 (annotate 3 "a")))+ sdoc' = alterAnnotationsS (\case 2 -> Just 2; _ -> Nothing) sdoc+ in assertEqual "" (SAnnPush 2 (SChar 'a' (SAnnPop SEmpty))) sdoc'
+ test/Testsuite/StripTrailingSpace.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE OverloadedStrings #-}++module StripTrailingSpace (testStripTrailingSpace) where++++import Data.Text (Text)+import qualified Data.Text as T++import Data.Text.Prettyprint.Doc+import Data.Text.Prettyprint.Doc.Render.Util.StackMachine++import Test.Tasty+import Test.Tasty.HUnit++box :: Text -> Text+box singleLine = unlines'+ [ "┌─" <> T.replicate (T.length singleLine) "─" <> "─┐"+ , "│ " <> singleLine <> " │"+ , "└─" <> T.replicate (T.length singleLine) "─" <> "─┘"+ ]++bbox :: Text -> Text+bbox singleLine = unlines'+ [ "╔═" <> T.replicate (T.length singleLine) "═" <> "═╗"+ , "║ " <> singleLine <> " ║"+ , "╚═" <> T.replicate (T.length singleLine) "═" <> "═╝"+ ]++testStripTrailingSpace :: TestTree+testStripTrailingSpace = testGroup "Stripping trailing space"+ [ testCase "No trailing space"+ (testStripping "No trailing space at all")+ , testCase "Single trailing space character"+ (testStripping ("Single trailing character" <> " "))+ , testCase "Space character inside"+ (testStripping ("Space character" <> " " <> "inside"))+ , testCase "Obvious trailing spaces"+ (testStripping ("Obvious trailing space" <> " "))+ , testCase "Multiple spaces inside"+ (testStripping ("Multiple spaces" <> " " <> "inside"))+ , testCase "Whitespace inside text"+ (testStripping ("Whitespace inside text "))+ , testCase "Indented blank line"+ (testStripping (nest 4 (vcat ["Indented blank line", "", "<end>"])))+ , testCase "Multiple indented blank lines"+ (testStripping (nest 4 (vcat ["Indented blank lines", "", "", "", "<end>"])))+ , testCase "Annotation"+ (testStripping (annotate () "Annotation with trailing space "))+ , testCase "Document with annotation"+ (testStripping ("Here comes an" <> annotate () "annotation " <> "and some trailing space again " <> " "))+ , testCase "Nested annotations"+ (testStripping ("A " <> annotate () ("nested " <> annotate () "annotation ") <> "and some trailing space again " <> " "))+ , testCase "Stress test"+ (testStripping (nest 4 (vcat ["Stress test", "", "" <> annotate () "hello ", "", "world " <> " ", annotate () "", "", "end"])))+ ]++testStripping :: Doc ann -> Assertion+testStripping doc = case hasTrailingWhitespace (render removeTrailingWhitespace doc) of+ False -> pure ()+ True -> (assertFailure . T.unpack . T.unlines)+ [ bbox "Input is not stripped correctly!"+ , ""+ , box "Rendered/stripped:"+ , (revealSpaces . render removeTrailingWhitespace) doc+ , ""+ , box "Rendered/unstripped:"+ , (revealSpaces . render id) doc+ , ""+ , box "Rendered/unstripped, later stripped via Text API:"+ , (revealSpaces . removeTrailingSpaceText . render id) doc ]+ where++ render :: (SimpleDocStream ann -> SimpleDocStream ann) -> Doc ann -> Text+ render f = renderSimplyDecorated id (const "<ann>") (const "</ann>") . f . layoutPretty defaultLayoutOptions++ removeTrailingSpaceText :: Text -> Text+ removeTrailingSpaceText = unlines' . map T.stripEnd . T.lines++ hasTrailingWhitespace :: Text -> Bool+ hasTrailingWhitespace x = removeTrailingSpaceText x /= x++ revealSpaces :: Text -> Text+ revealSpaces = T.map (\x -> if x == ' ' then '␣' else x)++-- Text.unlines appends a trailing whitespace, so T.unlines . T.lines /= id+unlines' :: [Text] -> Text+unlines' = T.intercalate (T.singleton '\n')