diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/app/GenerateReadme.hs b/app/GenerateReadme.hs --- a/app/GenerateReadme.hs +++ b/app/GenerateReadme.hs @@ -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" 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 @@ -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 diff --git a/prettyprinter.cabal b/prettyprinter.cabal --- a/prettyprinter.cabal +++ b/prettyprinter.cabal @@ -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 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 diff --git a/src/Data/Text/Prettyprint/Doc.hs b/src/Data/Text/Prettyprint/Doc.hs --- a/src/Data/Text/Prettyprint/Doc.hs +++ b/src/Data/Text/Prettyprint/Doc.hs @@ -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. 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 @@ -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. -- diff --git a/src/Data/Text/Prettyprint/Doc/Render/Text.hs b/src/Data/Text/Prettyprint/Doc/Render/Text.hs --- a/src/Data/Text/Prettyprint/Doc/Render/Text.hs +++ b/src/Data/Text/Prettyprint/Doc/Render/Text.hs @@ -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 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 @@ -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 #-} diff --git a/test/Testsuite/Main.hs b/test/Testsuite/Main.hs --- a/test/Testsuite/Main.hs +++ b/test/Testsuite/Main.hs @@ -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' diff --git a/test/Testsuite/StripTrailingSpace.hs b/test/Testsuite/StripTrailingSpace.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/StripTrailingSpace.hs @@ -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", "", ""]))) + , testCase "Multiple indented blank lines" + (testStripping (nest 4 (vcat ["Indented blank lines", "", "", "", ""]))) + , 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 "") (const "") . 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')