diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md deleted file mode 100644 --- a/CONTRIBUTORS.md +++ /dev/null @@ -1,22 +0,0 @@ -# Contributors - -A list of people that have contributed to this library, be it code, ideas, or -even just as rubber ducks. :-) - -Ordered by earliest appearance in the git log. - -## `prettyprinter` library (this one) - -- David Luposchainsky, @quchen – current maintainer - -## `ansi-wl-pprint` (origin forked from) - -- Edward Kmett, @edwardk – maintainer of `ansi-wl-pprint` -- Herbert Valerio Riedel, @hvr -- Bradford Larsen -- Sebastian Witte -- Andrew Shulaev -- David Fox -- Max Bolingbroke -- Samir Jindel -- Bryan O'Sullivan, @bos diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ ==================================== [![](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/github/release/quchen/prettyprinter.svg?style=flat-square&label=Latest%20version&colorB=0a7bbb)](https://github.com/quchen/prettyprinter/releases) [![](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&label=Stackage&colorB=0a7bbb)](https://www.stackage.org/package/prettyprinter) +[![](https://img.shields.io/github/release/quchen/prettyprinter.svg?style=flat-square&label=Latest%20version&colorB=0a7bbb)](https://github.com/quchen/prettyprinter/releases) [![](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) @@ -153,6 +153,10 @@ `ansi-wl-pprint`. - `prettyprinter-compat-annotated-wl-pprint` is the same, but for previous users of `annotated-wl-pprint`. + - `prettyprinter-convert-ansi-wl-pprint` is a *converter*, not a drop-in + replacement, for documents generated by `ansi-wl-pprint`. Useful for + interfacing with other libraries that use the other format, like Trifecta + and Optparse-Applicative. diff --git a/app/GenerateReadme.hs b/app/GenerateReadme.hs --- a/app/GenerateReadme.hs +++ b/app/GenerateReadme.hs @@ -35,7 +35,8 @@ , hsep [ "[![](https://img.shields.io/github/release/quchen/prettyprinter.svg?style=flat-square&label=Latest%20version&colorB=0a7bbb)](https://github.com/quchen/prettyprinter/releases)" , "[![](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&label=Stackage&colorB=0a7bbb)](https://www.stackage.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 @@ -157,6 +158,10 @@ previous users of `ansi-wl-pprint`.|] , [multiline| `prettyprinter-compat-annotated-wl-pprint` is the same, but for previous users of `annotated-wl-pprint`.|] + , [multiline| `prettyprinter-convert-ansi-wl-pprint` is a *converter*, + not a drop-in replacement, for documents generated by `ansi-wl-pprint`. + Useful for interfacing with other libraries that use the other format, + like Trifecta and Optparse-Applicative. |] ] , h2 "Differences to the old Wadler/Leijen prettyprinters" diff --git a/bench/LargeOutput.hs b/bench/LargeOutput.hs new file mode 100644 --- /dev/null +++ b/bench/LargeOutput.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Main (main) where + + + +import Control.DeepSeq +import Control.Monad +import Criterion +import Criterion.Main +import Data.Char +import Data.Map (Map) +import qualified Data.Map as M +import Data.Semigroup +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Lazy as TL +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.Text +import GHC.Generics +import Test.QuickCheck +import Test.QuickCheck.Gen +import Test.QuickCheck.Random +import qualified Text.PrettyPrint.ANSI.Leijen as WL + + + +newtype Program = Program Binds deriving (Show, Generic) +newtype Binds = Binds (Map Text LambdaForm) deriving (Show, Generic) +data LambdaForm = LambdaForm ![Text] ![Text] !Expr deriving (Show, Generic) +data Expr + = Let Binds Expr + | Case Expr [Alt] + | AppF Text [Text] + | AppC Text [Text] + | AppP Text Text Text + | LitE Int + deriving (Show, Generic) +data Alt = Alt Text [Text] Expr deriving (Show, Generic) + +instance NFData Program +instance NFData Binds +instance NFData LambdaForm +instance NFData Expr +instance NFData Alt + +instance Arbitrary Program where arbitrary = fmap Program arbitrary +instance Arbitrary Binds where + arbitrary = do + NonEmpty xs <- arbitrary + pure (Binds (M.fromList xs)) +instance Arbitrary LambdaForm where + arbitrary = LambdaForm <$> fromTo 0 2 arbitrary <*> fromTo 0 2 arbitrary <*> arbitrary + +instance Arbitrary Expr where + arbitrary = (oneof . map scaled) + [ Let <$> arbitrary <*> arbitrary + , Case <$> arbitrary <*> (do NonEmpty xs <- arbitrary; pure xs) + , AppF <$> arbitrary <*> fromTo 0 3 arbitrary + , AppC <$> ucFirst arbitrary <*> fromTo 0 3 arbitrary + , AppP <$> arbitrary <*> arbitrary <*> arbitrary + , LitE <$> arbitrary ] +instance Arbitrary Alt where arbitrary = Alt <$> ucFirst arbitrary <*> fromTo 0 3 arbitrary <*> arbitrary +instance Arbitrary Text where + arbitrary = do + n <- choose (3,6) + str <- replicateM n (elements ['a'..'z']) + if str `elem` ["let", "in", "case", "of"] + then arbitrary + else pure (T.pack str) + +ucFirst :: Gen Text -> Gen Text +ucFirst gen = do + x <- gen + case T.uncons x of + Nothing -> pure x + Just (t,ext) -> pure (T.cons (toUpper t) ext) + +instance Pretty Program where pretty (Program binds) = pretty binds +instance Pretty Binds where + pretty (Binds bs) = align (vsep (map prettyBinding (M.assocs bs))) + where + prettyBinding (var, lambda) = pretty var <+> "=" <+> pretty lambda + +instance Pretty LambdaForm where + pretty (LambdaForm free bound body) = (prettyExp . (<+> "->") . prettyBound . prettyFree) "\\" + where + prettyFree | null free = id + | otherwise = (<> lparen <> hsep (map pretty free) <> rparen) + prettyBound | null bound = id + | null free = (<> hsep (map pretty bound)) + | otherwise = (<+> hsep (map pretty bound)) + prettyExp = (<+> pretty body) + +instance Pretty Expr where + pretty = \case + Let binds body -> + align (vsep [ "let" <+> align (pretty binds) + , "in" <+> pretty body ]) + + Case scrutinee alts -> vsep + [ "case" <+> pretty scrutinee <+> "of" + , indent 4 (align (vsep (map pretty alts))) ] + + AppF f [] -> pretty f + AppF f args -> pretty f <+> hsep (map pretty args) + + AppC c [] -> pretty c + AppC c args -> pretty c <+> hsep (map pretty args) + + AppP op x y -> pretty op <+> pretty x <+> pretty y + + LitE lit -> pretty lit + +instance Pretty Alt where + pretty (Alt con [] body) = pretty con <+> "->" <+> pretty body + pretty (Alt con args body) = pretty con <+> hsep (map pretty args) <+> "->" <+> pretty body + +instance WL.Pretty Program where pretty (Program binds) = WL.pretty binds +instance WL.Pretty Binds where + pretty (Binds bs) = WL.align (WL.vsep (map prettyBinding (M.assocs bs))) + where + prettyBinding (var, lambda) = WL.pretty var WL.<+> "=" WL.<+> WL.pretty lambda + +instance WL.Pretty Text where + pretty = WL.string . T.unpack + +instance WL.Pretty LambdaForm where + pretty (LambdaForm free bound body) = (prettyExp . (WL.<+> "->") . prettyBound . prettyFree) "\\" + where + prettyFree | null free = id + | otherwise = (<> WL.lparen <> WL.hsep (map WL.pretty free) <> WL.rparen) + prettyBound | null bound = id + | null free = (<> WL.hsep (map WL.pretty bound)) + | otherwise = (WL.<+> WL.hsep (map WL.pretty bound)) + prettyExp = (WL.<+> WL.pretty body) + +instance WL.Pretty Expr where + pretty = \case + Let binds body -> + WL.align (WL.vsep [ "let" WL.<+> WL.align (WL.pretty binds) + , "in" WL.<+> WL.pretty body ]) + + Case scrutinee alts -> WL.vsep + [ "case" WL.<+> WL.pretty scrutinee WL.<+> "of" + , WL.indent 4 (WL.align (WL.vsep (map WL.pretty alts))) ] + + AppF f [] -> WL.pretty f + AppF f args -> WL.pretty f WL.<+> WL.hsep (map WL.pretty args) + + AppC c [] -> WL.pretty c + AppC c args -> WL.pretty c WL.<+> WL.hsep (map WL.pretty args) + + AppP op x y -> WL.pretty op WL.<+> WL.pretty x WL.<+> WL.pretty y + + LitE lit -> WL.pretty lit + +instance WL.Pretty Alt where + pretty (Alt con [] body) = WL.text (T.unpack con) WL.<+> "->" WL.<+> WL.pretty body + pretty (Alt con args body) = WL.text (T.unpack con) WL.<+> WL.hsep (map WL.pretty args) WL.<+> "->" WL.<+> WL.pretty body + +scaled :: Gen a -> Gen a +scaled = scale (\n -> n * 2 `quot` 3) + +fromTo :: Int -> Int -> Gen b -> Gen b +fromTo a b gen = do + n <- choose (min a b, max a b) + resize n gen + +randomProgram + :: Int -- ^ Seed + -> Int -- ^ Generator size + -> Program +randomProgram seed size = let MkGen gen = arbitrary in gen (mkQCGen seed) size + +main :: IO () +main = do + let prog = randomProgram 1 60 + renderedProg = (renderLazy . layoutPretty defaultLayoutOptions { layoutPageWidth = Unbounded } . pretty) prog + (progLines, progWidth) = let l = TL.lines renderedProg in (length l, maximum (map TL.length l)) + putDoc ("Program size:" <+> pretty progLines <+> "lines, maximum width:" <+> pretty progWidth) + + rnf prog `seq` T.putStrLn "Staring benchmark…" + defaultMain + [ bgroup "80 characters, 50% ribbon" + [ bench "prettyprinter" (nf (renderLazy . layoutPretty defaultLayoutOptions { layoutPageWidth = AvailablePerLine 80 0.5 } . pretty) prog) + , bench "ansi-wl-pprint" (nf (($ "") . WL.displayS . WL.renderPretty 0.5 80 . WL.pretty) prog) ] + , bgroup "Infinite/large page width" + [ bench "prettyprinter" (nf (renderLazy . layoutPretty defaultLayoutOptions { layoutPageWidth = Unbounded } . pretty) prog) + , bench "ansi-wl-pprint" (nf (($ "") . WL.displayS . WL.renderPretty 1 (fromIntegral progWidth + 10) . WL.pretty) prog) ] + ] diff --git a/prettyprinter.cabal b/prettyprinter.cabal --- a/prettyprinter.cabal +++ b/prettyprinter.cabal @@ -1,5 +1,5 @@ name: prettyprinter -version: 1.1 +version: 1.1.0.1 cabal-version: >= 1.10 category: User Interfaces, Text synopsis: A modern, easy to use, well-documented, extensible prettyprinter. @@ -8,7 +8,6 @@ license-file: LICENSE.md extra-source-files: README.md , misc/version-compatibility-macros.h - , CONTRIBUTORS.md author: Phil Wadler, Daan Leijen, Max Bolingbroke, Edward Kmett, David Luposchainsky maintainer: David Luposchainsky bug-reports: http://github.com/quchen/prettyprinter/issues @@ -29,7 +28,7 @@ Data.Text.Prettyprint.Doc , Data.Text.Prettyprint.Doc.Internal , Data.Text.Prettyprint.Doc.Internal.Type - , Data.Text.Prettyprint.Doc.Render.ShowS + , Data.Text.Prettyprint.Doc.Render.String , Data.Text.Prettyprint.Doc.Render.Text , Data.Text.Prettyprint.Doc.Render.Tutorials.StackMachineTutorial , Data.Text.Prettyprint.Doc.Render.Tutorials.TreeRenderingTutorial @@ -37,8 +36,13 @@ , Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree , Data.Text.Prettyprint.Doc.Render.Util.StackMachine , Data.Text.Prettyprint.Doc.Util - -- Hidden for now, until I figure out where to put it: - -- , Data.Text.Prettyprint.Doc.Unicode + + , Data.Text.Prettyprint.Doc.Symbols.Unicode + , Data.Text.Prettyprint.Doc.Symbols.Ascii + + -- Deprecated + , Data.Text.Prettyprint.Doc.Render.ShowS + ghc-options: -Wall hs-source-dirs: src include-dirs: misc @@ -54,12 +58,12 @@ build-depends: base >= 4.7 && < 5 - , text == 1.2.* + , text >= 1.2 if impl(ghc >= 8.0) ghc-options: -Wcompat if impl(ghc < 8.0) - build-depends: semigroups >= 0.1 && < 0.19 + build-depends: semigroups >= 0.1 if impl(ghc < 7.10) build-depends: void @@ -77,8 +81,8 @@ base >= 4.7 && < 5 , prettyprinter - , text == 1.2.* - , template-haskell >= 2.9 && < 2.12 + , text + , template-haskell >= 2.9 default-language: Haskell2010 other-modules: MultilineTh other-extensions: OverloadedStrings @@ -96,8 +100,7 @@ main-is: Main.hs build-depends: base >= 4.7 && < 5 - , doctest >= 0.9 && < 0.12 - , QuickCheck >= 2.7 + , doctest >= 0.9 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 if impl (ghc < 7.10) @@ -112,17 +115,17 @@ base , prettyprinter - , pgp-wordlist == 0.1.* - , bytestring == 0.10.* - , tasty >= 0.10 && < 0.12 - , tasty-hunit == 0.9.* - , tasty-quickcheck == 0.8.* - , text == 1.2.* + , pgp-wordlist >= 0.1 + , bytestring >= 0.10 + , tasty >= 0.10 + , tasty-hunit >= 0.9 + , tasty-quickcheck >= 0.8 + , text ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall default-language: Haskell2010 if impl(ghc < 8.0) - build-depends: semigroups >= 0.6 && < 0.19 + build-depends: semigroups >= 0.6 @@ -134,12 +137,12 @@ base >= 4.7 && < 5 , prettyprinter - , criterion >= 1.1 && < 1.3 - , mtl >= 2.1 && < 2.3 - , random >= 1.0 && < 1.2 - , text == 1.2.* - , transformers >= 0.3 && < 0.6 - , ansi-wl-pprint == 0.6.* + , criterion >= 1.1 + , mtl >= 2.1 + , random >= 1.0 + , text + , transformers >= 0.3 + , ansi-wl-pprint >= 0.6 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 other-extensions: NumDecimals, OverloadedStrings @@ -149,11 +152,30 @@ base >= 4.7 && < 5 , prettyprinter - , criterion >= 1.1 && < 1.3 - , text == 1.2.* + , criterion >= 1.1 + , text hs-source-dirs: bench main-is: FasterUnsafeText.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + default-language: Haskell2010 + type: exitcode-stdio-1.0 + + +benchmark large-output + build-depends: + base >= 4.7 && < 5 + , prettyprinter + , ansi-wl-pprint + + , criterion >= 1.1 + , QuickCheck >= 2.7 + , containers + , text + , deepseq + + hs-source-dirs: bench + main-is: LargeOutput.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall default-language: Haskell2010 type: exitcode-stdio-1.0 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 @@ -83,18 +83,20 @@ -- │ 'SimpleDocStream' │ -- │ (simple document) │ -- ╰─────────┬─────────╯ --- ╭───────────────────┤ --- │ │ --- 'Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree.treeForm' │ │ --- ▽ │ Renderers --- ╭───────────────╮ │ --- │ 'Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree.SimpleDocTree' │ │ --- ╰───────┬───────╯ ├───────────────────┬───────────────────╮ --- │ │ │ │ --- ▽ ▽ ▽ ▽ --- ╭───────────────╮ ╭───────────────╮ ╭───────────────╮ ╭───────────────╮ --- │ HTML │ │ Plain 'Text' │ │ ANSI terminal │ │ other/custom │ --- ╰───────────────╯ ╰───────────────╯ ╰───────────────╯ ╰───────────────╯ +-- │ +-- ╭───────────────────┴───────────────────╮ +-- 'Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree.treeForm' │ │ +-- ▽ │ +-- ╭───────────────╮ │ +-- │ 'Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree.SimpleDocTree' │ Renderers │ +-- ╰───────┬───────╯ │ +-- │ │ +-- ├───────────────╮ ╭───────────────┼───────────────────╮ +-- │ │ │ │ │ +-- ▽ ▽ ▽ ▽ ▽ +-- ╭───────────────╮ ╭───────────────╮ ╭───────────────╮ ╭───────────────╮ +-- │ HTML │ │ other/custom │ │ Plain 'Text' │ │ ANSI terminal │ +-- ╰───────────────╯ ╰───────────────╯ ╰───────────────╯ ╰───────────────╯ -- @ -- -- = How the layout works @@ -124,6 +126,52 @@ -- constraints (given by page and ribbon widths), the document is rendered -- unaltered. This allows fallback definitions, so that we get nice results even -- when the original document would exceed the layout constraints. +-- +-- = Things the prettyprinter /cannot/ do +-- +-- Due to how the Wadler/Leijen algorithm is designed, a couple of things are +-- unsupported right now, with a high possibility of having no sensible +-- implementation without significantly changing the layout algorithm. In +-- particular, this includes +-- +-- * Leading symbols instead of just spaces for indentation, as used by the +-- Linux @tree@ tool for example +-- * Multi-column layouts, in particular tables with multiple cells of equal +-- width adjacent to each other +-- +-- = Some helpful tips +-- +-- == Which kind of annotation should I use? +-- +-- __Summary:__ Use semantic annotations for @'Doc'@, and after layouting map to +-- backend-specific ones. +-- +-- For example, suppose you want to prettyprint some programming language code. +-- If you want keywords to be red, you should annotate the @'Doc'@ with a type +-- that has a 'Keyword' field (without any notion of color), and then after +-- layouting convert the annotations to map @'Keyword'@ to e.g. @'Red'@ (using +-- @'reAnnotateS'@). The alternative that I /do not/ recommend is directly +-- annotating the @'Doc'@ with 'Red'. +-- +-- While both versions would superficially work equally well and would create +-- identical output, the recommended way has two significant advantages: +-- modularity and extensibility. +-- +-- /Modularity:/ To change the color of keywords later, you have to touch one +-- point, namely the mapping in @'reAnnotateS'@, where @'Keyword'@ is mapped to +-- 'Red'. If you have @'annotate Red …'@ everywher, you’ll have to do a full +-- 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 +-- 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 +-- (think of plain text or a website where red doesn’t work well with the rest +-- of the style), you’ll have to worry about what to map »redness« to, which has +-- no canonical answer. Should it be omitted? What does »red« mean anyway – +-- maybe keywords and variables are red, and you want to change only the color +-- of variables? module Data.Text.Prettyprint.Doc ( -- * Documents Doc, @@ -228,6 +276,7 @@ import Data.Semigroup import Data.Text.Prettyprint.Doc.Internal +import Data.Text.Prettyprint.Doc.Symbols.Ascii -- $setup -- @@ -241,6 +290,14 @@ -- $migration -- +-- There are 3 main ways to migrate: +-- +-- 1. Direct: just replace the previous package and fix the errors +-- 2. Using a drop-in replacement mimicing the API of the former module, see +-- the @prettyprinter-compat-@ packages +-- 3. Using a converter from the old @Doc@ type to the new one, see the +-- @prettyprinter-convert-@ packages +-- -- If you're already familiar with (ansi-)wl-pprint, you'll recognize many -- functions in this module, and they work just the same way. However, a couple -- of definitions are missing: @@ -249,7 +306,8 @@ -- overloaded @'pretty'@ function. -- - @\<$>@, @\<$$>@, @\@, @\@ are special cases of -- @'vsep'@, @'vcat'@, @'fillSep'@, @'fillCat'@ with only two documents. --- - If you need 'String' output, use 'T.unpack' on the generated renderings. +-- - If you need 'String' output, use the backends in the +-- "Data.Text.Prettyprint.Doc.Render.String" module. -- - The /display/ functions are moved to the rendering submodules, for -- example conversion to plain 'Text' is in the -- "Data.Text.Prettyprint.Doc.Render.Text" module. 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 @@ -195,6 +195,8 @@ prettyList :: [a] -> Doc ann prettyList = list . map pretty + {-# MINIMAL pretty #-} + -- | >>> pretty [1,2,3] -- [1, 2, 3] instance Pretty a => Pretty [a] where @@ -409,7 +411,7 @@ -- >>> group doc -- lorem ipsum dolor sit amet line :: Doc ann -line = FlatAlt Line space +line = FlatAlt Line (Char ' ') -- | @'line''@ is like @'line'@, but behaves like @'mempty'@ if the line break -- is undone by 'group' (instead of @'space'@). @@ -743,7 +745,7 @@ -- x '<+>' y = x '<>' 'space' '<>' y -- @ (<+>) :: Doc ann -> Doc ann -> Doc ann -x <+> y = x <> space <> y +x <+> y = x <> Char ' ' <> y @@ -775,6 +777,7 @@ #endif | otherwise = foldr1 f ds {-# INLINE concatWith #-} +{-# SPECIALIZE concatWith :: (Doc ann -> Doc ann -> Doc ann) -> [Doc ann] -> Doc ann #-} -- | @('hsep' xs)@ concatenates all documents @xs@ horizontally with @'<+>'@, -- i.e. it puts a space between all entries. @@ -1147,137 +1150,9 @@ --- | >>> squotes "·" --- '·' -squotes :: Doc ann -> Doc ann -squotes = enclose squote squote --- | >>> dquotes "·" --- "·" -dquotes :: Doc ann -> Doc ann -dquotes = enclose dquote dquote --- | >>> parens "·" --- (·) -parens :: Doc ann -> Doc ann -parens = enclose lparen rparen --- | >>> angles "·" --- <·> -angles :: Doc ann -> Doc ann -angles = enclose langle rangle - --- | >>> brackets "·" --- [·] -brackets :: Doc ann -> Doc ann -brackets = enclose lbracket rbracket - --- | >>> braces "·" --- {·} -braces :: Doc ann -> Doc ann -braces = enclose lbrace rbrace - --- | >>> squote --- ' -squote :: Doc ann -squote = "'" - --- | >>> dquote --- " -dquote :: Doc ann -dquote = "\"" - --- | >>> lparen --- ( -lparen :: Doc ann -lparen = "(" - --- | >>> rparen --- ) -rparen :: Doc ann -rparen = ")" - --- | >>> langle --- < -langle :: Doc ann -langle = "<" - --- | >>> rangle --- > -rangle :: Doc ann -rangle = ">" - --- | >>> lbracket --- [ -lbracket :: Doc ann -lbracket = "[" --- | >>> rbracket --- ] -rbracket :: Doc ann -rbracket = "]" - --- | >>> lbrace --- { -lbrace :: Doc ann -lbrace = "{" --- | >>> rbrace --- } -rbrace :: Doc ann -rbrace = "}" - --- | >>> semi --- ; -semi :: Doc ann -semi = ";" - --- | >>> colon --- : -colon :: Doc ann -colon = ":" - --- | >>> comma --- , -comma :: Doc ann -comma = "," - --- | >>> "a" <> space <> "b" --- a b --- --- This is mostly used via @'<+>'@, --- --- >>> "a" <+> "b" --- a b -space :: Doc ann -space = " " - --- | >>> dot --- . -dot :: Doc ann -dot = "." - --- | >>> slash --- / -slash :: Doc ann -slash = "/" - --- | >>> backslash --- \\ - -backslash :: Doc ann -backslash = "\\" - --- | >>> equals --- = -equals :: Doc ann -equals = "=" - --- | >>> pipe --- | -pipe :: Doc ann -pipe = "|" - - - -- | Add an annotation to a @'Doc'@. This annotation can then be used by the -- renderer to e.g. add color to certain parts of the output. For a full -- tutorial example on how to use it, see the @@ -1501,7 +1376,7 @@ -- constructor. | SText !Int Text (SimpleDocStream ann) - -- | @Int@ = indentation level for the line + -- | @Int@ = indentation level for the (next) line | SLine !Int (SimpleDocStream ann) -- | Add an annotation to the remaining document. @@ -1843,5 +1718,6 @@ -- -- >>> :set -XOverloadedStrings -- >>> import Data.Text.Prettyprint.Doc.Render.Text +-- >>> import Data.Text.Prettyprint.Doc.Symbols.Ascii -- >>> import Data.Text.Prettyprint.Doc.Util as Util -- >>> import Test.QuickCheck.Modifiers diff --git a/src/Data/Text/Prettyprint/Doc/Render/ShowS.hs b/src/Data/Text/Prettyprint/Doc/Render/ShowS.hs --- a/src/Data/Text/Prettyprint/Doc/Render/ShowS.hs +++ b/src/Data/Text/Prettyprint/Doc/Render/ShowS.hs @@ -1,4 +1,4 @@ -module Data.Text.Prettyprint.Doc.Render.ShowS ( +module Data.Text.Prettyprint.Doc.Render.ShowS {-# DEPRECATED "Use Data.Text.Prettyprint.Doc.Render.String instead" #-} ( renderShowS ) where diff --git a/src/Data/Text/Prettyprint/Doc/Render/String.hs b/src/Data/Text/Prettyprint/Doc/Render/String.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Prettyprint/Doc/Render/String.hs @@ -0,0 +1,10 @@ +module Data.Text.Prettyprint.Doc.Render.String ( + renderString, + renderShowS, +) where + +import Data.Text.Prettyprint.Doc.Internal (SimpleDocStream, renderShowS) + +-- | Render a 'SimpleDocStream' to a 'String'. +renderString :: SimpleDocStream ann -> String +renderString s = renderShowS s "" 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 @@ -1,4 +1,6 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} #include "version-compatibility-macros.h" @@ -17,12 +19,14 @@ import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB -import qualified Data.Text.Lazy.IO as TL import System.IO import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.Util.Panic import Data.Text.Prettyprint.Doc.Render.Util.StackMachine #if !(SEMIGROUP_IN_BASE) @@ -67,8 +71,26 @@ -- >>> renderIO System.IO.stdout (layoutPretty defaultLayoutOptions "hello\nworld") -- hello -- world +-- +-- This function is more efficient than @'T.hPutStr' h ('renderStrict' sdoc)@, +-- since it writes to the handle directly, skipping the intermediate 'Text' +-- representation. renderIO :: Handle -> SimpleDocStream ann -> IO () -renderIO h sdoc = TL.hPutStrLn h (renderLazy sdoc) +renderIO h = go + where + go :: SimpleDocStream ann -> IO () + go = \case + SFail -> panicUncaughtFail + SEmpty -> pure () + SChar c rest -> do hPutChar h c + go rest + SText _ t rest -> do T.hPutStr h t + go rest + SLine n rest -> do hPutChar h '\n' + T.hPutStr h (T.replicate n " ") + go rest + SAnnPush _ann rest -> go rest + SAnnPop rest -> go rest -- | @('putDoc' doc)@ prettyprints document @doc@ to standard output. Uses the -- 'defaultLayoutOptions'. 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 @@ -80,6 +80,7 @@ STLine i -> text (T.singleton '\n' <> T.replicate i " ") STAnn ann rest -> renderAnn ann (go rest) STConcat xs -> foldMap go xs +{-# INLINE renderSimplyDecorated #-} -- | Version of 'renderSimplyDecoratedA' that allows for 'Applicative' effects. renderSimplyDecoratedA @@ -97,6 +98,7 @@ STLine i -> text (T.singleton '\n' <> T.replicate i " ") STAnn ann rest -> renderAnn ann (go rest) STConcat xs -> fmap mconcat (traverse go xs) +{-# INLINE renderSimplyDecoratedA #-} @@ -155,9 +157,19 @@ data SimpleDocTree ann = STEmpty | STChar Char + + -- | Some layout algorithms use the Since the frequently used 'T.length' of + -- the 'Text', which scales linearly with its length, we cache it in this + -- constructor. | STText !Int Text + + -- | @Int@ = indentation level for the (next) line | STLine !Int + + -- | Annotate the contained document. | STAnn ann (SimpleDocTree ann) + + -- | Horizontal concatenation of multiple documents. | STConcat [SimpleDocTree ann] deriving (Eq, Ord, Show, Generic) diff --git a/src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs b/src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs --- a/src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs +++ b/src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs @@ -59,6 +59,8 @@ -- >>> let sdoc = layoutPretty defaultLayoutOptions doc -- >>> T.putStrLn (renderSimplyDecorated id (\() -> ">>>") (\() -> "<<<") sdoc) -- hello >>>world<< (Text -> out) -- ^ Render plain 'Text' @@ -73,10 +75,11 @@ go (_:_) SEmpty = panicInputNotFullyConsumed go stack (SChar c rest) = text (T.singleton c) <> go stack rest go stack (SText _l t rest) = text t <> go stack rest - go stack (SLine i rest) = text (T.singleton '\n' <> T.replicate i " ") <> go stack rest + go stack (SLine i rest) = text (T.singleton '\n') <> text (T.replicate i " ") <> go stack rest go stack (SAnnPush ann rest) = push ann <> go (ann : stack) rest go (ann:stack) (SAnnPop rest) = pop ann <> go stack rest go [] SAnnPop{} = panicUnpairedPop +{-# INLINE renderSimplyDecorated #-} -- | Version of 'renderSimplyDecoratedA' that allows for 'Applicative' effects. renderSimplyDecoratedA @@ -93,12 +96,13 @@ go (_:_) SEmpty = panicInputNotFullyConsumed go stack (SChar c rest) = text (T.singleton c) <++> go stack rest go stack (SText _l t rest) = text t <++> go stack rest - go stack (SLine i rest) = text (T.singleton '\n' <> T.replicate i " ") <++> go stack rest + go stack (SLine i rest) = text (T.singleton '\n') <++> text (T.replicate i " ") <++> go stack rest go stack (SAnnPush ann rest) = push ann <++> go (ann : stack) rest go (ann:stack) (SAnnPop rest) = pop ann <++> go stack rest go [] SAnnPop{} = panicUnpairedPop (<++>) = liftA2 mappend +{-# INLINE renderSimplyDecoratedA #-} diff --git a/src/Data/Text/Prettyprint/Doc/Symbols/Ascii.hs b/src/Data/Text/Prettyprint/Doc/Symbols/Ascii.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Prettyprint/Doc/Symbols/Ascii.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +#include "version-compatibility-macros.h" + +-- | Common symbols composed out of the ASCII subset of Unicode. For non-ASCII +-- symbols, see "Data.Text.Prettyprint.Doc.Symbols.Unicode". +module Data.Text.Prettyprint.Doc.Symbols.Ascii where + + + +import Data.Text.Prettyprint.Doc.Internal + + + +-- | >>> squotes "·" +-- '·' +squotes :: Doc ann -> Doc ann +squotes = enclose squote squote + +-- | >>> dquotes "·" +-- "·" +dquotes :: Doc ann -> Doc ann +dquotes = enclose dquote dquote + +-- | >>> parens "·" +-- (·) +parens :: Doc ann -> Doc ann +parens = enclose lparen rparen + +-- | >>> angles "·" +-- <·> +angles :: Doc ann -> Doc ann +angles = enclose langle rangle + +-- | >>> brackets "·" +-- [·] +brackets :: Doc ann -> Doc ann +brackets = enclose lbracket rbracket + +-- | >>> braces "·" +-- {·} +braces :: Doc ann -> Doc ann +braces = enclose lbrace rbrace + +-- | >>> squote +-- ' +squote :: Doc ann +squote = "'" + +-- | >>> dquote +-- " +dquote :: Doc ann +dquote = "\"" + +-- | >>> lparen +-- ( +lparen :: Doc ann +lparen = "(" + +-- | >>> rparen +-- ) +rparen :: Doc ann +rparen = ")" + +-- | >>> langle +-- < +langle :: Doc ann +langle = "<" + +-- | >>> rangle +-- > +rangle :: Doc ann +rangle = ">" + +-- | >>> lbracket +-- [ +lbracket :: Doc ann +lbracket = "[" +-- | >>> rbracket +-- ] +rbracket :: Doc ann +rbracket = "]" + +-- | >>> lbrace +-- { +lbrace :: Doc ann +lbrace = "{" +-- | >>> rbrace +-- } +rbrace :: Doc ann +rbrace = "}" + +-- | >>> semi +-- ; +semi :: Doc ann +semi = ";" + +-- | >>> colon +-- : +colon :: Doc ann +colon = ":" + +-- | >>> comma +-- , +comma :: Doc ann +comma = "," + +-- | >>> "a" <> space <> "b" +-- a b +-- +-- This is mostly used via @'<+>'@, +-- +-- >>> "a" <+> "b" +-- a b +space :: Doc ann +space = " " + +-- | >>> dot +-- . +dot :: Doc ann +dot = "." + +-- | >>> slash +-- / +slash :: Doc ann +slash = "/" + +-- | >>> backslash +-- \\ + +backslash :: Doc ann +backslash = "\\" + +-- | >>> equals +-- = +equals :: Doc ann +equals = "=" + +-- | >>> pipe +-- | +pipe :: Doc ann +pipe = "|" + + + +-- $setup +-- +-- (Definitions for the doctests) +-- +-- >>> :set -XOverloadedStrings +-- >>> import Data.Semigroup +-- >>> import Data.Text.Prettyprint.Doc.Render.Text +-- >>> import Data.Text.Prettyprint.Doc.Util diff --git a/src/Data/Text/Prettyprint/Doc/Symbols/Unicode.hs b/src/Data/Text/Prettyprint/Doc/Symbols/Unicode.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Prettyprint/Doc/Symbols/Unicode.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | A collection of predefined Unicode values outside of ASCII range. For +-- ASCII, see "Data.Text.Prettyprint.Doc.Symbols.Ascii". +module Data.Text.Prettyprint.Doc.Symbols.Unicode ( + -- * Quotes + + -- ** Enclosing + d9966quotes, + d6699quotes, + s96quotes, + s69quotes, + dGuillemetsOut, + dGuillemetsIn, + sGuillemetsOut, + sGuillemetsIn, + + -- ** Standalone + b99dquote, + t66dquote, + t99dquote, + b9quote, + t6quote, + t9quote, + + rdGuillemet, + ldGuillemet, + rsGuillemet, + lsGuillemet, + + -- * Various typographical symbols + bullet, + endash, + + -- * Currencies + euro, + cent, + yen, + pound, +) where + + + +import Data.Text.Prettyprint.Doc + + + +-- | Double „99-66“ quotes, as used in German typography. +-- +-- >>> putDoc (d9966quotes "·") +-- „·“ +d9966quotes :: Doc ann -> Doc ann +d9966quotes = enclose b99dquote t66dquote + +-- | Double “66-99” quotes, as used in English typography. +-- +-- >>> putDoc (d6699quotes "·") +-- “·” +d6699quotes :: Doc ann -> Doc ann +d6699quotes = enclose t66dquote t99dquote + +-- | Single ‚9-6‘ quotes, as used in German typography. +-- +-- >>> putDoc (s96quotes "·") +-- ‚·‘ +s96quotes :: Doc ann -> Doc ann +s96quotes = enclose b9quote t6quote + +-- | Single ‘6-9’ quotes, as used in English typography. +-- +-- >>> putDoc (s69quotes "·") +-- ‘·’ +s69quotes :: Doc ann -> Doc ann +s69quotes = enclose t6quote t9quote + +-- | Double «guillemets», pointing outwards (without adding any spacing). +-- +-- >>> putDoc (dGuillemetsOut "·") +-- «·» +dGuillemetsOut :: Doc ann -> Doc ann +dGuillemetsOut = enclose ldGuillemet rdGuillemet + +-- | Double »guillemets«, pointing inwards (without adding any spacing). +-- +-- >>> putDoc (dGuillemetsIn "·") +-- »·« +dGuillemetsIn :: Doc ann -> Doc ann +dGuillemetsIn = enclose rdGuillemet ldGuillemet + +-- | Single ‹guillemets›, pointing outwards (without adding any spacing). +-- +-- >>> putDoc (sGuillemetsOut "·") +-- ‹·› +sGuillemetsOut :: Doc ann -> Doc ann +sGuillemetsOut = enclose lsGuillemet rsGuillemet + +-- | Single ›guillemets‹, pointing inwards (without adding any spacing). +-- +-- >>> putDoc (sGuillemetsIn "·") +-- ›·‹ +sGuillemetsIn :: Doc ann -> Doc ann +sGuillemetsIn = enclose rsGuillemet lsGuillemet + +-- | Bottom „99“ style double quotes. +-- +-- >>> putDoc b99dquote +-- „ +b99dquote :: Doc ann +b99dquote = "„" + +-- | Top “66” style double quotes. +-- +-- >>> putDoc t66dquote +-- “ +t66dquote :: Doc ann +t66dquote = "“" + +-- | Top “99” style double quotes. +-- +-- >>> putDoc t99dquote +-- ” +t99dquote :: Doc ann +t99dquote = "”" + +-- | Bottom ‚9‘ style single quote. +-- +-- >>> putDoc b9quote +-- ‚ +b9quote :: Doc ann +b9quote = "‚" + +-- | Top ‘66’ style single quote. +-- +-- >>> putDoc t6quote +-- ‘ +t6quote :: Doc ann +t6quote = "‘" + +-- | Top ‘9’ style single quote. +-- +-- >>> putDoc t9quote +-- ’ +t9quote :: Doc ann +t9quote = "’" + +-- | Right-pointing double guillemets +-- +-- >>> putDoc rdGuillemet +-- » +rdGuillemet :: Doc ann +rdGuillemet = "»" + +-- | Left-pointing double guillemets +-- +-- >>> putDoc ldGuillemet +-- « +ldGuillemet :: Doc ann +ldGuillemet = "«" + +-- | Right-pointing single guillemets +-- +-- >>> putDoc rsGuillemet +-- › +rsGuillemet :: Doc ann +rsGuillemet = "›" + +-- | Left-pointing single guillemets +-- +-- >>> putDoc lsGuillemet +-- ‹ +lsGuillemet :: Doc ann +lsGuillemet = "‹" + +-- | >>> putDoc bullet +-- • +bullet :: Doc ann +bullet = "•" + +-- | >>> putDoc endash +-- – +endash :: Doc ann +endash = "–" + +-- | >>> putDoc euro +-- € +euro :: Doc ann +euro = "€" + +-- | >>> putDoc cent +-- ¢ +cent :: Doc ann +cent = "¢" + +-- | >>> putDoc yen +-- ¥ +yen :: Doc ann +yen = "¥" + +-- | >>> putDoc pound +-- £ +pound :: Doc ann +pound = "£" + + + +-- $setup +-- +-- (Definitions for the doctests) +-- +-- >>> :set -XOverloadedStrings +-- >>> import Data.Text.Prettyprint.Doc.Render.Text +-- >>> import Data.Text.Prettyprint.Doc.Util diff --git a/test/Testsuite/Main.hs b/test/Testsuite/Main.hs --- a/test/Testsuite/Main.hs +++ b/test/Testsuite/Main.hs @@ -42,9 +42,11 @@ , testProperty "Deep fusion does not change rendering" (fusionDoesNotChangeRendering Deep) ] - , testGroup "Regression tests" - [ testCase "Pathological grouping performance" - pathologicalGroupingPerformance + , testGroup "Performance tests" + [ testCase "Grouping performance" + groupingPerformance + , testCase "fillSep performance" + fillSepPerformance ] ] @@ -150,16 +152,30 @@ dampen :: Gen a -> Gen a dampen gen = sized (\n -> resize ((n*2) `quot` 3) gen) - +docPerformanceTest :: Doc ann -> Assertion +docPerformanceTest doc + = timeout 10000000 (forceDoc doc) >>= \case + Nothing -> assertFailure "Timeout!" + Just _success -> pure () + where + forceDoc :: Doc ann -> IO () + forceDoc = evaluate . foldr seq () . show -- Deeply nested group/flatten calls can result in exponential performance. -- -- See https://github.com/quchen/prettyprinter/issues/22 -pathologicalGroupingPerformance :: Assertion -pathologicalGroupingPerformance - = timeout 10000000 (poorMansForce (pathological 1000)) >>= \case - Nothing -> assertFailure "Timeout!" - Just _success -> pure () +groupingPerformance :: Assertion +groupingPerformance = docPerformanceTest (pathological 1000) where + pathological :: Int -> Doc ann pathological n = iterate (\x -> hsep [x, sep []] ) "foobar" !! n - poorMansForce = evaluate . length . show + +-- This test case was written because the `pretty` package had an issue with +-- this specific example. +-- +-- See https://github.com/haskell/pretty/issues/32 +fillSepPerformance :: Assertion +fillSepPerformance = docPerformanceTest (pathological 1000) + where + pathological :: Int -> Doc ann + pathological n = iterate (\x -> fillSep ["a", x <+> "b"] ) "foobar" !! n