prettyprinter-1.7.1/0000755000000000000000000000000007346545000012644 5ustar0000000000000000prettyprinter-1.7.1/CHANGELOG.md0000644000000000000000000001304107346545000014454 0ustar0000000000000000# [1.7.1] - [Deprecate the `Data.Text.Prettyprint.*` modules](https://github.com/quchen/prettyprinter/pull/203) * Users should migrate to the new `Prettyprinter` module hierarchy. * The old modules will be removed no sooner than September 2022. - [Make `text` an optional dependency:](https://github.com/quchen/prettyprinter/pull/202) * When built with `-f-text`, any `text`-based APIs will operate on `String`s instead. - Documentation improvements: * [#194](https://github.com/quchen/prettyprinter/pull/194) * [`1f0bffe`](https://github.com/quchen/prettyprinter/commit/1f0bffe5eb53874d1ba46b0a80bda67c02365f1b) [1.7.1]: https://github.com/quchen/prettyprinter/compare/v1.7.0...v1.7.1 # [1.7.0] ## Breaking changes - [Fix `layoutPretty` and `layoutSmart` so they don't produce trailing whitespace as a result of indenting empty lines.](https://github.com/quchen/prettyprinter/pull/139) * Users of `removeTrailingWhitespace` should check whether it is still needed. - [Use `floor` instead of `round` to compute ribbon width.](https://github.com/quchen/prettyprinter/pull/160) - [Remove deprecated `Data.Text.Prettyprint.Doc.Render.ShowS` module.](https://github.com/quchen/prettyprinter/pull/173) - [Add optimized implementation of `stimes` for `Doc`.](https://github.com/quchen/prettyprinter/pull/135) - [Generalize the type of `layoutCompact` to clarify that it doesn't preserve annotations.](https://github.com/quchen/prettyprinter/pull/183) - [Add strictness annotations in `SimpleDocStream` and `PageWidth`.](https://github.com/quchen/prettyprinter/pull/129) ## Non-breaking changes - [Add shallower `Prettyprinter` module hierarchy exposing the same API.](https://github.com/quchen/prettyprinter/pull/174) * The current plan for the existing `Data.Text.Prettyprint.Doc*` modules is: * Start deprecation in early 2021. * Remove the modules after a deprecation period of at least one year. - [Fix build with GHC 7.4.](https://github.com/quchen/prettyprinter/pull/187) - Various documentation improvements. [1.7.0]: https://github.com/quchen/prettyprinter/compare/v1.6.2...v1.7.0 # 1.6.2 - Speed up rendering to lazy and strict `Text`. - Documentation improvements for `group` and `flatAlt`. - Internal refactoring of the `layoutWadlerLeijen`-based layouters. # 1.6.1 - Slightly reduce the scope of the fitting predicates for some edge cases. - Use an export list in `Data.Text.Prettyprint.Doc.Internal`. - Improve `group` for `Union` and `FlatAlt`. - Speed up `removeTrailingWhitespace`. - Improve generating spaces for indentation and `spaces`. - Simplify some `Doc` constants by defining them as `Doc` literals. - Enable `-O2`. - Various documentation fixes and improvements. # 1.6.0 ## Breaking changes - Fix `fuse`'s handling of annotated documents: - Don't remove annotations on empty documents. - Apply fusion within annotations. - Fix layouting of hard linebreaks with `Unbounded` page widths. ## Non-breaking changes - Speed up `group` for documents containing linebreaks and previously `group`ed documents. - Add debugging helpers in `Data.Text.Prettyprint.Doc.Internal.Debug` - Documentation improvements and fixes # 1.5.1 - Removing trailing whitespace sometimes restored necessary whitespace in the wrong spot # 1.5 - Fix inconsistent formatting within align and wide sub-docs on narrow layouts # 1.4 - Add fixity declaration to `<+>`, matching `<>` - Fix removal of trailing 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 - 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. prettyprinter-1.7.1/LICENSE.md0000644000000000000000000000244307346545000014253 0ustar0000000000000000Copyright 2008, Daan Leijen and Max Bolingbroke, 2016 David Luposchainsky. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. This software is provided by the copyright holders "as is" and any express or implied warranties, including, but not limited to, the implied warranties of merchantability and fitness for a particular purpose are disclaimed. In no event shall the copyright holders be liable for any direct, indirect, incidental, special, exemplary, or consequential damages (including, but not limited to, procurement of substitute goods or services; loss of use, data, or profits; or business interruption) however caused and on any theory of liability, whether in contract, strict liability, or tort (including negligence or otherwise) arising in any way out of the use of this software, even if advised of the possibility of such damage. prettyprinter-1.7.1/README.md0000644000000000000000000001630407346545000014127 0ustar0000000000000000 A modern Wadler/Leijen Prettyprinter ==================================== [![](https://img.shields.io/hackage/v/prettyprinter.svg?style=flat-square&label=Hackage&colorB=0a7bbb)](https://hackage.haskell.org/package/prettyprinter) tl;dr ----- A prettyprinter/text rendering engine. Easy to use, well-documented, ANSI terminal backend exists, HTML backend is trivial to implement, no name clashes, `Text`-based, extensible. ```haskell let prettyType = align . sep . zipWith (<+>) ("::" : repeat "->") prettySig name ty = pretty name <+> prettyType ty in prettySig "example" ["Int", "Bool", "Char", "IO ()"] ``` ```haskell -- Output for wide enough formats: example :: Int -> Bool -> Char -> IO () -- Output for narrow formats: example :: Int -> Bool -> Char -> IO () ``` Longer; want to read -------------------- This package defines a prettyprinter to format text in a flexible and convenient way. The idea is to combine a document out of many small components, then using a layouter to convert it to an easily renderable simple document, which can then be rendered to a variety of formats, for example plain `Text`, or Markdown. *What you are reading right now was generated by this library (see `GenerateReadme.hs`).* Why another prettyprinter? -------------------------- Haskell, more specifically Hackage, has a zoo of Wadler/Leijen based prettyprinters already. Each of them addresses a different concern with the classic `wl-pprint` package. This package solves *all* these issues, and then some. ### `Text` instead of `String` `String` has exactly one use, and that’s showing Hello World in tutorials. For all other uses, `Text` is what people should be using. The prettyprinter uses no `String` definitions anywhere; using a `String` means an immediate conversion to the internal `Text`-based format. ### Extensive documentation The library is stuffed with runnable examples, showing use cases for the vast majority of exported values. Many things reference related definitions, *everything* comes with at least a sentence explaining its purpose. ### No name clashes Many prettyprinters use the legacy API of the first Wadler/Leijen prettyprinter, which used e.g. `(<$>)` to separate lines, which clashes with the ubiquitous synonym for `fmap` that’s been in Base for ages. These definitions were either removed or renamed, so there are no name clashes with standard libraries anymore. ### Annotation support Text is not all letters and newlines. Often, we want to add more information, the simplest kind being some form of styling. An ANSI terminal supports coloring, a web browser a plethora of different formattings. More complex uses of annotations include e.g. adding type annotations for mouse-over hovers when printing a syntax tree, adding URLs to documentation, or adding source locations to show where a certain piece of output comes from. [Idris](https://github.com/idris-lang/Idris-dev) is a project that makes extensive use of such a feature. Special care has been applied to make annotations unobtrusive, so that if you don’t need or care about them there is no overhead, neither in terms of usability nor performance. ### Extensible backends A document can be rendered in many different ways, for many different clients. There is plain text, there is the ANSI terminal, there is the browser. Each of these speak different languages, and the backend is responsible for the translation to those languages. Backends should be readily available, or easy to implement if a custom solution is desired. As a result, each backend requires only minimal dependencies; if you don’t want to print to an ANSI terminal for example, there is no need to have a dependency on a terminal library. ### Performance Rendering large documents should be done efficiently, and the library should make it easy to optimize common use cases for the programmer. ### Open implementation The type of documents is abstract in most of the other Wadler/Leijen prettyprinters, making it hard to impossible to write adaptors from one library to another. The type should be exposed for such purposes so it is possible to write adaptors from library to library, or each of them is doomed to live on its own small island of incompatibility. For this reason, the `Doc` type is fully exposed in a semi-internal module for this specific use case. The prettyprinter family ------------------------ The `prettyprinter` family of packages consists of: - `prettyprinter` is the core package. It defines the language to generate nicely laid out documents, which can then be given to renderers to display them in various ways, e.g. HTML, or plain text. - `prettyprinter-ansi-terminal` provides a renderer suitable for ANSI terminal output including colors (at the cost of a dependency more). - `prettyprinter-compat-wl-pprint` provides a drop-in compatibility layer for previous users of the `wl-pprint` package. Use it for easy adaption of the new `prettyprinter`, but don't develop anything new with it. - `prettyprinter-compat-ansi-wl-pprint` is the same, but for previous users of `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. Differences to the old Wadler/Leijen prettyprinters --------------------------------------------------- The library originally started as a fork of `ansi-wl-pprint` until every line had been touched. The result is still in the same spirit as its predecessors, but modernized to match the current ecosystem and needs. The most significant changes are: 1. `(<$>)` is removed as an operator, since it clashes with the common alias for `fmap`. 2. All but the essential `<>` and `<+>` operators were removed or replaced by ordinary names. 3. Everything extensively documented, with references to other functions and runnable code examples. 4. Use of `Text` instead of `String`. 5. A `fuse` function to optimize often-used documents before rendering for efficiency. 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. Historical notes ---------------- This module is based on previous work by Daan Leijen and Max Bolingbroke, who implemented and significantly extended the prettyprinter given by a [paper by Phil Wadler in his 1997 paper »A Prettier Printer«](https://homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf), by adding lots of convenience functions, styling, and new functionality. Their package, ansi-wl-pprint is widely used in the Haskell ecosystem, and is at the time of writing maintained by Edward Kmett. prettyprinter-1.7.1/Setup.lhs0000644000000000000000000000011407346545000014450 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain prettyprinter-1.7.1/app/0000755000000000000000000000000007346545000013424 5ustar0000000000000000prettyprinter-1.7.1/app/GenerateReadme.hs0000644000000000000000000002553707346545000016644 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module Main (main) where import Prelude hiding (words) import qualified Data.List as L import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import Prettyprinter import Prettyprinter.Render.Text import MultilineTh main :: IO () main = (T.putStrLn . renderStrict . layoutPretty layoutOptions) readmeContents where layoutOptions = LayoutOptions { layoutPageWidth = AvailablePerLine 80 1 } readmeContents :: Doc ann readmeContents = (mconcat . L.intersperse vspace) [ htmlComment "This file was auto-generated by the 'scripts/generate_readme' program." , h1 "A modern Wadler/Leijen Prettyprinter" , vcat [ "[![](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)" ] , h2 "tl;dr" , paragraph [multiline| A prettyprinter/text rendering engine. Easy to use, well-documented, ANSI terminal backend exists, HTML backend is trivial to implement, no name clashes, `Text`-based, extensible. |] , (pretty . T.unlines) [ "```haskell" , "let prettyType = align . sep . zipWith (<+>) (\"::\" : repeat \"->\")" , " prettySig name ty = pretty name <+> prettyType ty" , "in prettySig \"example\" [\"Int\", \"Bool\", \"Char\", \"IO ()\"]" , "```" , "" , "```haskell" , "-- Output for wide enough formats:" , "example :: Int -> Bool -> Char -> IO ()" , "" , "-- Output for narrow formats:" , "example :: Int" , " -> Bool" , " -> Char" , " -> IO ()" , "```" ] , h2 "Longer; want to read" , paragraph [multiline| This package defines a prettyprinter to format text in a flexible and convenient way. The idea is to combine a document out of many small components, then using a layouter to convert it to an easily renderable simple document, which can then be rendered to a variety of formats, for example plain `Text`, or Markdown. *What you are reading right now was generated by this library (see `GenerateReadme.hs`).* |] , h2 "Why another prettyprinter?" , paragraph [multiline| Haskell, more specifically Hackage, has a zoo of Wadler/Leijen based prettyprinters already. Each of them addresses a different concern with the classic `wl-pprint` package. This package solves *all* these issues, and then some. |] , h3 "`Text` instead of `String`" , paragraph [multiline| `String` has exactly one use, and that’s showing Hello World in tutorials. For all other uses, `Text` is what people should be using. The prettyprinter uses no `String` definitions anywhere; using a `String` means an immediate conversion to the internal `Text`-based format. |] , h3 "Extensive documentation" , paragraph [multiline| The library is stuffed with runnable examples, showing use cases for the vast majority of exported values. Many things reference related definitions, *everything* comes with at least a sentence explaining its purpose. |] , h3 "No name clashes" , paragraph [multiline| Many prettyprinters use the legacy API of the first Wadler/Leijen prettyprinter, which used e.g. `(<$>)` to separate lines, which clashes with the ubiquitous synonym for `fmap` that’s been in Base for ages. These definitions were either removed or renamed, so there are no name clashes with standard libraries anymore. |] , h3 "Annotation support" , paragraph [multiline| Text is not all letters and newlines. Often, we want to add more information, the simplest kind being some form of styling. An ANSI terminal supports coloring, a web browser a plethora of different formattings. |] , paragraph [multiline| More complex uses of annotations include e.g. adding type annotations for mouse-over hovers when printing a syntax tree, adding URLs to documentation, or adding source locations to show where a certain piece of output comes from. [Idris](https://github.com/idris-lang/Idris-dev) is a project that makes extensive use of such a feature. |] , paragraph [multiline| Special care has been applied to make annotations unobtrusive, so that if you don’t need or care about them there is no overhead, neither in terms of usability nor performance. |] , h3 "Extensible backends" , paragraph [multiline| A document can be rendered in many different ways, for many different clients. There is plain text, there is the ANSI terminal, there is the browser. Each of these speak different languages, and the backend is responsible for the translation to those languages. Backends should be readily available, or easy to implement if a custom solution is desired. |] , paragraph [multiline| As a result, each backend requires only minimal dependencies; if you don’t want to print to an ANSI terminal for example, there is no need to have a dependency on a terminal library. |] , h3 "Performance" , paragraph [multiline| Rendering large documents should be done efficiently, and the library should make it easy to optimize common use cases for the programmer. |] , h3 "Open implementation" , paragraph [multiline| The type of documents is abstract in most of the other Wadler/Leijen prettyprinters, making it hard to impossible to write adaptors from one library to another. The type should be exposed for such purposes so it is possible to write adaptors from library to library, or each of them is doomed to live on its own small island of incompatibility. For this reason, the `Doc` type is fully exposed in a semi-internal module for this specific use case. |] , h2 "The prettyprinter family" , paragraph "The `prettyprinter` family of packages consists of:" , (indent 2 . unorderedList . map paragraph) [ [multiline| `prettyprinter` is the core package. It defines the language to generate nicely laid out documents, which can then be given to renderers to display them in various ways, e.g. HTML, or plain text.|] , [multiline| `prettyprinter-ansi-terminal` provides a renderer suitable for ANSI terminal output including colors (at the cost of a dependency more).|] , [multiline| `prettyprinter-compat-wl-pprint` provides a drop-in compatibility layer for previous users of the `wl-pprint` package. Use it for easy adaption of the new `prettyprinter`, but don't develop anything new with it.|] , [multiline| `prettyprinter-compat-ansi-wl-pprint` is the same, but for 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" , paragraph [multiline| The library originally started as a fork of `ansi-wl-pprint` until every line had been touched. The result is still in the same spirit as its predecessors, but modernized to match the current ecosystem and needs. |] , paragraph "The most significant changes are:" , (indent 2 . orderedList . map paragraph) [ [multiline| `(<$>)` is removed as an operator, since it clashes with the common alias for `fmap`. |] , [multiline| All but the essential `<>` and `<+>` operators were removed or replaced by ordinary names. |] , [multiline| Everything extensively documented, with references to other functions and runnable code examples. |] , [multiline| Use of `Text` instead of `String`. |] , [multiline| A `fuse` function to optimize often-used documents before rendering for efficiency. |] , [multiline| SimpleDoc was renamed `SimpleDocStream`, to contrast the 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. |] ] , h2 "Historical notes" , paragraph [multiline| This module is based on previous work by Daan Leijen and Max Bolingbroke, who implemented and significantly extended the prettyprinter given by a [paper by Phil Wadler in his 1997 paper »A Prettier Printer«](https://homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf), by adding lots of convenience functions, styling, and new functionality. Their package, ansi-wl-pprint is widely used in the Haskell ecosystem, and is at the time of writing maintained by Edward Kmett.|] ] paragraph :: Text -> Doc ann paragraph = align . fillSep . map pretty . T.words vspace :: Doc ann vspace = hardline <> hardline h1 :: Doc ann -> Doc ann h1 x = vspace <> underlineWith "=" x h2 :: Doc ann -> Doc ann h2 x = vspace <> underlineWith "-" x h3 :: Doc ann -> Doc ann h3 x = vspace <> "###" <+> x underlineWith :: Text -> Doc ann -> Doc ann underlineWith symbol x = align (width x (\w -> hardline <> pretty (T.take w (T.replicate w symbol)))) orderedList :: [Doc ann] -> Doc ann orderedList = align . vsep . zipWith (\i x -> pretty i <> dot <+> align x) [1::Int ..] unorderedList :: [Doc ann] -> Doc ann unorderedList = align . vsep . map ("-" <+>) htmlComment :: Doc ann -> Doc ann htmlComment = enclose "" prettyprinter-1.7.1/app/MultilineTh.hs0000644000000000000000000000121407346545000016214 0ustar0000000000000000module MultilineTh (multiline) where import qualified Data.Text as T import Language.Haskell.TH import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Prelude multiline :: QuasiQuoter multiline = QuasiQuoter { quoteExp = quoteUnlines , quotePat = const badUse , quoteType = const badUse , quoteDec = const badUse } where badUse = fail "multiline quasiquoter can only be used as an expression" quoteUnlines :: String -> Q Exp quoteUnlines = liftString . T.unpack . T.unwords . filter (not . T.null) . T.words . T.pack prettyprinter-1.7.1/bench/0000755000000000000000000000000007346545000013723 5ustar0000000000000000prettyprinter-1.7.1/bench/FasterUnsafeText.hs0000644000000000000000000000166307346545000017520 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Main (main) where import Gauge.Main import Data.Char import Data.Text (Text) import qualified Data.Text as T import Prettyprinter.Internal -- The old implementation. Performance isn’t much worse to be honest, mostly -- well within a σ. alternative :: Text -> Doc ann alternative t = case T.length t of 0 -> Empty 1 -> Char (T.head t) n -> Text n t current :: Text -> Doc ann current = unsafeTextWithoutNewlines main :: IO () main = defaultMain [ benchText (letters n) | n <- [0,1,2,3,5,10,50,100] ] letters :: Int -> Text letters n = T.pack (take n (filter isAlpha [minBound ..])) benchText :: Text -> Benchmark benchText input = bgroup (show (pretty (T.length input) <+> plural "letter" "letters" (T.length input))) [ bench "alternative" (whnf alternative input) , bench "current" (whnf current input) ] prettyprinter-1.7.1/bench/Fusion.hs0000644000000000000000000000666207346545000015534 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} #include "version-compatibility-macros.h" module Main (main) where import Control.Monad import Control.Monad.State import Gauge.Main import Data.Text (Text) import qualified Data.Text as T import System.Random import Prettyprinter import Prettyprinter.Render.Text import qualified Text.PrettyPrint.ANSI.Leijen as WL #if !(APPLICATIVE_MONAD) import Control.Applicative #endif main :: IO () main = defaultMain [ benchOptimize , benchWLComparison ] benchOptimize :: Benchmark benchOptimize = env randomShortWords benchmark_ where benchmark_ = \shortWords -> let doc = hsep (map pretty shortWords) in bgroup "Many small words" [ bench "Unoptimized" (nf renderLazy (layoutPretty defaultLayoutOptions doc)) , bench "Shallowly fused" (nf renderLazy (layoutPretty defaultLayoutOptions (fuse Shallow doc))) , bench "Deeply fused" (nf renderLazy (layoutPretty defaultLayoutOptions (fuse Deep doc))) ] randomShortWords :: Applicative m => m [Text] randomShortWords = pure (evalState (randomShortWords' 100) (mkStdGen 0)) randomShortWords' :: Int -> State StdGen [Text] randomShortWords' n = replicateM n randomShortWord randomShortWord :: State StdGen Text randomShortWord = do g <- get let (l, g') = randomR (0, 5) g (gNew, gFree) = split g' xs = take l (randoms gFree) put gNew pure (T.pack xs) benchWLComparison :: Benchmark benchWLComparison = bgroup "vs. other libs" [ bgroup "renderPretty" [ bench "this, unoptimized" (nf (renderLazy . layoutPretty defaultLayoutOptions) doc) , bench "this, shallowly fused" (nf (renderLazy . layoutPretty defaultLayoutOptions) (fuse Shallow doc)) , bench "this, deeply fused" (nf (renderLazy . layoutPretty defaultLayoutOptions) (fuse Deep doc)) , bench "ansi-wl-pprint" (nf (\d -> WL.displayS (WL.renderPretty 0.4 80 d) "") wlDoc) ] , bgroup "renderSmart" [ bench "this, unoptimized" (nf (renderLazy . layoutSmart defaultLayoutOptions) doc) , bench "this, shallowly fused" (nf (renderLazy . layoutSmart defaultLayoutOptions) (fuse Shallow doc)) , bench "this, deeply fused" (nf (renderLazy . layoutSmart defaultLayoutOptions) (fuse Deep doc)) , bench "ansi-wl-pprint" (nf (\d -> WL.displayS (WL.renderSmart 0.4 80 d) "") wlDoc) ] , bgroup "renderCompact" [ bench "this, unoptimized" (nf (renderLazy . layoutCompact) doc) , bench "this, shallowly fused" (nf (renderLazy . layoutCompact) (fuse Shallow doc)) , bench "this, deeply fused" (nf (renderLazy . layoutCompact) (fuse Deep doc)) , bench "ansi-wl-pprint" (nf (\d -> WL.displayS (WL.renderCompact d) "") wlDoc) ] ] where doc :: Doc ann doc = let fun x = "fun" <> parens (softline <> x) funnn = chain 10 fun in funnn (sep (take 48 (cycle ["hello", "world"]))) wlDoc :: WL.Doc wlDoc = let fun x = "fun" WL.<> WL.parens (WL.softline WL.<> x) funnn = chain 10 fun in funnn (WL.sep (take 48 (cycle ["hello", "world"]))) chain n f = foldr (.) id (replicate n f) prettyprinter-1.7.1/bench/LargeOutput.hs0000644000000000000000000002000307346545000016525 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where import Prelude () import Prelude.Compat import Control.DeepSeq import Control.Monad.Compat import Gauge import Data.Char import Data.Map (Map) import qualified Data.Map as M 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 Prettyprinter import Prettyprinter.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 = \expr -> case expr of 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 = \expr -> case expr of 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) let renderWith :: (Doc ann -> SimpleDocStream ann) -> Program -> TL.Text renderWith f = renderLazy . f . pretty let _80ColumnsLayoutOptions = defaultLayoutOptions { layoutPageWidth = AvailablePerLine 80 0.5 } unboundedLayoutOptions = defaultLayoutOptions { layoutPageWidth = Unbounded } rnf prog `seq` T.putStrLn "Starting benchmark…" defaultMain [ bgroup "80 characters, 50% ribbon" [ bgroup "prettyprinter" [ bench "layoutPretty" (nf (renderWith (layoutPretty _80ColumnsLayoutOptions)) prog) , bench "layoutSmart" (nf (renderWith (layoutSmart _80ColumnsLayoutOptions)) prog) , bench "layoutCompact" (nf (renderWith layoutCompact ) prog) ] , bench "ansi-wl-pprint" (nf (($ "") . WL.displayS . WL.renderPretty 0.5 80 . WL.pretty) prog) ] , bgroup "Infinite/large page width" [ bgroup "prettyprinter" [ bench "layoutPretty" (nf (renderWith (layoutPretty unboundedLayoutOptions)) prog) , bench "layoutSmart" (nf (renderWith (layoutSmart unboundedLayoutOptions)) prog) , bench "layoutCompact" (nf (renderWith layoutCompact ) prog) ] , bench "ansi-wl-pprint" (nf (($ "") . WL.displayS . WL.renderPretty 1 (fromIntegral progWidth + 10) . WL.pretty) prog) ] ] prettyprinter-1.7.1/misc/0000755000000000000000000000000007346545000013577 5ustar0000000000000000prettyprinter-1.7.1/misc/version-compatibility-macros.h0000644000000000000000000000150707346545000021571 0ustar0000000000000000#ifndef VERSION_COMPATIBILITY_MACROS #define VERSION_COMPATIBILITY_MACROS #ifndef MIN_VERSION_base #error "MIN_VERSION_base macro not defined!" #endif -- These macros allow writing CPP compatibility hacks in a way that makes their -- purpose much clearer than just demanding a specific version of a library. #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 SEMIGROUP_MONOID_SUPERCLASS MIN_VERSION_base(4,11,0) #define FAIL_IN_MONAD !(MIN_VERSION_base(4,13,0)) #endif prettyprinter-1.7.1/prettyprinter.cabal0000644000000000000000000001551307346545000016570 0ustar0000000000000000name: prettyprinter version: 1.7.1 cabal-version: >= 1.10 category: User Interfaces, Text 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, Simon Jakobi maintainer: Simon Jakobi , David Luposchainsky bug-reports: http://github.com/quchen/prettyprinter/issues homepage: http://github.com/quchen/prettyprinter build-type: Simple tested-with: GHC==9.0.1, GHC==8.10.4, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 source-repository head type: git location: git://github.com/quchen/prettyprinter.git library exposed-modules: Prettyprinter , Prettyprinter.Internal , Prettyprinter.Internal.Debug , Prettyprinter.Internal.Type , Prettyprinter.Render.String , Prettyprinter.Render.Text , Prettyprinter.Render.Tutorials.StackMachineTutorial , Prettyprinter.Render.Tutorials.TreeRenderingTutorial , Prettyprinter.Render.Util.Panic , Prettyprinter.Render.Util.SimpleDocTree , Prettyprinter.Render.Util.StackMachine , Prettyprinter.Util , Prettyprinter.Symbols.Unicode , Prettyprinter.Symbols.Ascii , Data.Text.Prettyprint.Doc , Data.Text.Prettyprint.Doc.Internal , Data.Text.Prettyprint.Doc.Internal.Debug , Data.Text.Prettyprint.Doc.Internal.Type , 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 , Data.Text.Prettyprint.Doc.Render.Util.Panic , Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree , Data.Text.Prettyprint.Doc.Render.Util.StackMachine , Data.Text.Prettyprint.Doc.Util , Data.Text.Prettyprint.Doc.Symbols.Unicode , Data.Text.Prettyprint.Doc.Symbols.Ascii ghc-options: -Wall -O2 hs-source-dirs: src include-dirs: misc default-language: Haskell2010 other-extensions: BangPatterns , CPP , OverloadedStrings , DefaultSignatures , ScopedTypeVariables build-depends: base >= 4.5 && < 5 if flag(text) build-depends: text >= 1.2 else -- A fake text package, emulating the same API, but backed by String hs-source-dirs: src-text other-modules: Data.Text , Data.Text.IO , Data.Text.Lazy , Data.Text.Lazy.Builder if !impl(ghc >= 7.6) build-depends: ghc-prim if impl(ghc >= 8.0) ghc-options: -Wcompat if !impl(ghc >= 8.0) build-depends: semigroups >= 0.17 build-depends: fail >= 4.9.0.0 && <4.10 if !impl(ghc >= 7.10) build-depends: void >=0.4 && <0.8 Flag buildReadme Description: Build the readme generator Default: False Flag text Description: While it's a core value of @prettyprinter@ to use @Text@, there are rare circumstances (mostly when @prettyprinter@ arises as a dependency of test suites of packages like @bytestring@ or @text@ themselves) when this is inconvenient. In this case one can disable this flag, so that @prettyprinter@ fallbacks to @String@. Default: True executable generate_readme hs-source-dirs: app main-is: GenerateReadme.hs build-depends: base >= 4.7 && < 5 , prettyprinter , text , template-haskell >= 2.9 default-language: Haskell2010 other-modules: MultilineTh other-extensions: OverloadedStrings , TemplateHaskell , QuasiQuotes if flag(buildReadme) && flag(text) buildable: True else buildable: False test-suite doctest type: exitcode-stdio-1.0 hs-source-dirs: test/Doctest main-is: Main.hs 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) buildable: False -- Doctest does not support searching through directories in old versions test-suite testsuite type: exitcode-stdio-1.0 hs-source-dirs: test/Testsuite main-is: Main.hs other-modules: StripTrailingSpace build-depends: base , prettyprinter , pgp-wordlist >= 0.1 , bytestring , quickcheck-instances >= 0.3 , 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 if !flag(text) buildable: False benchmark fusion type: exitcode-stdio-1.0 hs-source-dirs: bench main-is: Fusion.hs build-depends: base >= 4.5 && < 5 , prettyprinter , gauge >= 0.2 , mtl >= 2.1 , random >= 1.0 , text , transformers >= 0.3 , ansi-wl-pprint >= 0.6 ghc-options: -Wall -rtsopts default-language: Haskell2010 other-extensions: OverloadedStrings if !flag(text) buildable: False benchmark faster-unsafe-text build-depends: base >= 4.5 && < 5 , prettyprinter , gauge >= 0.2 , text hs-source-dirs: bench main-is: FasterUnsafeText.hs ghc-options: -rtsopts -Wall default-language: Haskell2010 type: exitcode-stdio-1.0 if !flag(text) buildable: False benchmark large-output build-depends: base >= 4.5 && < 5 , base-compat >=0.9.3 && <0.12 , prettyprinter , ansi-wl-pprint , gauge >= 0.2 , QuickCheck >= 2.7 , containers , text , deepseq hs-source-dirs: bench main-is: LargeOutput.hs ghc-options: -rtsopts -Wall default-language: Haskell2010 type: exitcode-stdio-1.0 if !impl(ghc >= 7.6) build-depends: ghc-prim if !impl(ghc >= 8.0) build-depends: semigroups if !flag(text) buildable: False prettyprinter-1.7.1/src-text/Data/0000755000000000000000000000000007346545000015266 5ustar0000000000000000prettyprinter-1.7.1/src-text/Data/Text.hs0000644000000000000000000000234207346545000016547 0ustar0000000000000000-- Provide a fake API, mimicking Data.Text from text package, -- but actually backed by type Text = String. It is used only in rare -- circumstances, when prettyprinter is built with -text flag. -- {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Data.Text where import Prelude hiding (head, length, null, replicate) import qualified Data.Char import qualified Data.List type Text = String cons = (:) dropWhileEnd = Data.List.dropWhileEnd head = Data.List.head intercalate = Data.List.intercalate length = Data.List.length :: [Char] -> Int lines = Data.List.lines map = Data.List.map null = Data.List.null :: [Char] -> Bool pack = id replicate = (Data.List.concat .) . Data.List.replicate singleton = (:[]) snoc xs x = xs ++ [x] stripEnd = dropWhileEnd Data.Char.isSpace unlines = Data.List.unlines unpack = id words = Data.List.words uncons :: Text -> Maybe (Char, Text) uncons [] = Nothing uncons (x : xs) = Just (x, xs) splitOn :: Text -> Text -> [Text] splitOn pat src | null pat = error "splitOn: empty pattern" | otherwise = go [] src where go acc [] = [reverse acc] go acc xs@(y : ys) | pat `Data.List.isPrefixOf` xs = reverse acc : go [] (drop (length pat) xs) | otherwise = go (y : acc) ys prettyprinter-1.7.1/src-text/Data/Text/0000755000000000000000000000000007346545000016212 5ustar0000000000000000prettyprinter-1.7.1/src-text/Data/Text/IO.hs0000644000000000000000000000055507346545000017062 0ustar0000000000000000-- Provide a fake API, mimicking Data.Text.IO from text package, -- but actually backed by type Text = String. It is used only in rare -- circumstances, when prettyprinter is built with -text flag. -- {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Data.Text.IO where import qualified System.IO hPutStr = System.IO.hPutStr putStrLn = System.IO.putStrLn prettyprinter-1.7.1/src-text/Data/Text/Lazy.hs0000644000000000000000000000056507346545000017473 0ustar0000000000000000-- Provide a fake API, mimicking Data.Text.Lazy from text package, -- but actually backed by type Text = String. It is used only in rare -- circumstances, when prettyprinter is built with -text flag. -- {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Data.Text.Lazy where import Data.Text as T type Text = T.Text length = T.length lines = T.lines toStrict = id prettyprinter-1.7.1/src-text/Data/Text/Lazy/0000755000000000000000000000000007346545000017131 5ustar0000000000000000prettyprinter-1.7.1/src-text/Data/Text/Lazy/Builder.hs0000644000000000000000000000056407346545000021060 0ustar0000000000000000-- Provide a fake API, mimicking Data.Text.Lazy.Builder from text package, -- but actually backed by type Builder = String. It is used only in rare -- circumstances, when prettyprinter is built with -text flag. -- {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Data.Text.Lazy.Builder where type Builder = String fromText = id singleton = (:[]) toLazyText = id prettyprinter-1.7.1/src/Data/Text/Prettyprint/0000755000000000000000000000000007346545000017574 5ustar0000000000000000prettyprinter-1.7.1/src/Data/Text/Prettyprint/Doc.hs0000644000000000000000000000021607346545000020634 0ustar0000000000000000module Data.Text.Prettyprint.Doc {-# DEPRECATED "Use \"Prettyprinter\" instead." #-} ( module Prettyprinter ) where import Prettyprinter prettyprinter-1.7.1/src/Data/Text/Prettyprint/Doc/0000755000000000000000000000000007346545000020301 5ustar0000000000000000prettyprinter-1.7.1/src/Data/Text/Prettyprint/Doc/Internal.hs0000644000000000000000000000026207346545000022411 0ustar0000000000000000module Data.Text.Prettyprint.Doc.Internal {-# DEPRECATED "Use \"Prettyprinter.Internal\" instead." #-} ( module Prettyprinter.Internal ) where import Prettyprinter.Internal prettyprinter-1.7.1/src/Data/Text/Prettyprint/Doc/Internal/0000755000000000000000000000000007346545000022055 5ustar0000000000000000prettyprinter-1.7.1/src/Data/Text/Prettyprint/Doc/Internal/Debug.hs0000644000000000000000000000031207346545000023433 0ustar0000000000000000module Data.Text.Prettyprint.Doc.Internal.Debug {-# DEPRECATED "Use \"Prettyprinter.Internal.Debug\" instead." #-} ( module Prettyprinter.Internal.Debug ) where import Prettyprinter.Internal.Debug prettyprinter-1.7.1/src/Data/Text/Prettyprint/Doc/Internal/Type.hs0000644000000000000000000000031107346545000023325 0ustar0000000000000000module Data.Text.Prettyprint.Doc.Internal.Type {-# DEPRECATED "Use \"Prettyprinter.Internal.Type\" instead." #-} ( module Prettyprinter.Internal.Type ) where import Prettyprinter.Internal.Type prettyprinter-1.7.1/src/Data/Text/Prettyprint/Doc/Render/0000755000000000000000000000000007346545000021520 5ustar0000000000000000prettyprinter-1.7.1/src/Data/Text/Prettyprint/Doc/Render/String.hs0000644000000000000000000000030607346545000023321 0ustar0000000000000000module Data.Text.Prettyprint.Doc.Render.String {-# DEPRECATED "Use \"Prettyprinter.Render.String\" instead." #-} ( module Prettyprinter.Render.String ) where import Prettyprinter.Render.String prettyprinter-1.7.1/src/Data/Text/Prettyprint/Doc/Render/Text.hs0000644000000000000000000000027607346545000023005 0ustar0000000000000000module Data.Text.Prettyprint.Doc.Render.Text {-# DEPRECATED "Use \"Prettyprinter.Render.Text\" instead." #-} ( module Prettyprinter.Render.Text ) where import Prettyprinter.Render.Text prettyprinter-1.7.1/src/Data/Text/Prettyprint/Doc/Render/Tutorials/0000755000000000000000000000000007346545000023506 5ustar0000000000000000prettyprinter-1.7.1/src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs0000644000000000000000000000066607346545000030130 0ustar0000000000000000module Data.Text.Prettyprint.Doc.Render.Tutorials.StackMachineTutorial {-# DEPRECATED "Use \"Prettyprinter.Render.Tutorials.StackMachineTutorial\" instead." #-} ( module Prettyprinter.Render.Tutorials.StackMachineTutorial ) where -- Yeah, this produces a deprecation warning. It's hard to disable it while -- staying compatible with GHC < 8.0 though. Don't waste your time. import Prettyprinter.Render.Tutorials.StackMachineTutorial prettyprinter-1.7.1/src/Data/Text/Prettyprint/Doc/Render/Tutorials/TreeRenderingTutorial.hs0000644000000000000000000000045207346545000030324 0ustar0000000000000000module Data.Text.Prettyprint.Doc.Render.Tutorials.TreeRenderingTutorial {-# DEPRECATED "Use \"Prettyprinter.Render.Tutorials.TreeRenderingTutorial\" instead." #-} ( module Prettyprinter.Render.Tutorials.TreeRenderingTutorial ) where import Prettyprinter.Render.Tutorials.TreeRenderingTutorial prettyprinter-1.7.1/src/Data/Text/Prettyprint/Doc/Render/Util/0000755000000000000000000000000007346545000022435 5ustar0000000000000000prettyprinter-1.7.1/src/Data/Text/Prettyprint/Doc/Render/Util/Panic.hs0000644000000000000000000000032607346545000024024 0ustar0000000000000000module Data.Text.Prettyprint.Doc.Render.Util.Panic {-# DEPRECATED "Use \"Prettyprinter.Render.Util.Panic\" instead." #-} ( module Prettyprinter.Render.Util.Panic ) where import Prettyprinter.Render.Util.Panic prettyprinter-1.7.1/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs0000644000000000000000000000036607346545000025475 0ustar0000000000000000module Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree {-# DEPRECATED "Use \"Prettyprinter.Render.Util.SimpleDocTree\" instead." #-} ( module Prettyprinter.Render.Util.SimpleDocTree ) where import Prettyprinter.Render.Util.SimpleDocTree prettyprinter-1.7.1/src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs0000644000000000000000000000036507346545000025327 0ustar0000000000000000module Data.Text.Prettyprint.Doc.Render.Util.StackMachine {-# DEPRECATED "Use \"Prettyprinter.Render.Util.StackMachine\" instead." #-} ( module Prettyprinter.Render.Util.StackMachine ) where import Prettyprinter.Render.Util.StackMachine prettyprinter-1.7.1/src/Data/Text/Prettyprint/Doc/Symbols/0000755000000000000000000000000007346545000021731 5ustar0000000000000000prettyprinter-1.7.1/src/Data/Text/Prettyprint/Doc/Symbols/Ascii.hs0000644000000000000000000000030607346545000023314 0ustar0000000000000000module Data.Text.Prettyprint.Doc.Symbols.Ascii {-# DEPRECATED "Use \"Prettyprinter.Symbols.Ascii\" instead." #-} ( module Prettyprinter.Symbols.Ascii ) where import Prettyprinter.Symbols.Ascii prettyprinter-1.7.1/src/Data/Text/Prettyprint/Doc/Symbols/Unicode.hs0000644000000000000000000000031607346545000023653 0ustar0000000000000000module Data.Text.Prettyprint.Doc.Symbols.Unicode {-# DEPRECATED "Use \"Prettyprinter.Symbols.Unicode\" instead." #-} ( module Prettyprinter.Symbols.Unicode ) where import Prettyprinter.Symbols.Unicode prettyprinter-1.7.1/src/Data/Text/Prettyprint/Doc/Util.hs0000644000000000000000000000024507346545000021553 0ustar0000000000000000module Data.Text.Prettyprint.Doc.Util {-# DEPRECATED "Use \"Prettyprinter.Util\" instead." #-} ( module Prettyprinter.Util ) where import Prettyprinter.Util prettyprinter-1.7.1/src/0000755000000000000000000000000007346545000013433 5ustar0000000000000000prettyprinter-1.7.1/src/Prettyprinter.hs0000644000000000000000000003576407346545000016701 0ustar0000000000000000{-# LANGUAGE CPP #-} #include "version-compatibility-macros.h" -- | -- Module : Prettyprinter -- Copyright : Daan Leijen (c) 2000, http://www.cs.uu.nl/~daan -- Max Bolingbroke (c) 2008, http://blog.omega-prime.co.uk -- David Luposchainsky (c) 2016, http://github.com/quchen -- License : BSD-style (see the file LICENSE.md) -- Maintainer : David Luposchainsky -- Stability : experimental -- Portability : portable -- -- = Overview -- -- This module defines a prettyprinter to format text in a flexible and -- convenient way. The idea is to combine a 'Doc'ument out of many small -- components, then using a layouter to convert it to an easily renderable -- 'SimpleDocStream', which can then be rendered to a variety of formats, for -- example plain 'Text'. -- -- The documentation consists of several parts: -- -- 1. Just below is some general information about the library. -- 2. The actual library with extensive documentation and examples -- 3. Migration guide for users familiar with (ansi-)wl-pprint -- -- == Starting out -- -- As a reading list for starters, some of the most commonly used functions in -- this module include '<>', 'hsep', '<+>', 'vsep', 'align', 'hang'. These cover -- many use cases already, and many other functions are variations or -- combinations of these. -- -- = Simple example -- -- Let’s prettyprint a simple Haskell type definition. First, intersperse @->@ -- and add a leading @::@, -- -- >>> :{ -- >>> prettyprintType :: [Doc x] -> Doc x -- >>> prettyprintType = align . sep . zipWith (<+>) ("::" : repeat "->") -- >>> :} -- -- The 'sep' function is one way of concatenating documents, there are multiple -- others, e.g. 'vsep', 'cat' and 'fillSep'. In our case, 'sep' space-separates -- all entries if there is space, and newlines if the remaining line is too -- short. -- -- Second, prepend the name to the type, -- -- >>> let prettyprintDeclaration n tys = pretty n <+> prettyprintType tys -- -- Now we can define a document that contains some type signature: -- -- >>> let doc = prettyprintDeclaration "example" ["Int", "Bool", "Char", "IO ()"] -- -- This document can now be printed, and it automatically adapts to available -- space. If the page is wide enough (80 characters in this case), the -- definitions are space-separated, -- -- >>> putDocW 80 doc -- example :: Int -> Bool -> Char -> IO () -- -- If we narrow the page width to only 20 characters, the /same document/ -- renders vertically aligned: -- -- >>> putDocW 20 doc -- example :: Int -- -> Bool -- -> Char -- -> IO () -- -- Speaking of alignment, had we not used 'align', the @->@ would be at the -- beginning of each line, and not beneath the @::@. -- -- The 'Prettyprinter.Util.putDocW' renderer used here is from -- "Prettyprinter.Util". -- -- = General workflow -- -- @ -- ╔══════════╗ -- ║ ║ ╭────────────────────╮ -- ║ ║ │ 'vsep', 'pretty', '<+>', │ -- ║ ║ │ 'nest', 'align', … │ -- ║ ║ ╰─────────┬──────────╯ -- ║ ║ │ -- ║ Create ║ │ -- ║ ║ │ -- ║ ║ ▽ -- ║ ║ ╭───────────────────╮ -- ║ ║ │ 'Doc' │ -- ╠══════════╣ │ (rich document) │ -- ║ ║ ╰─────────┬─────────╯ -- ║ ║ │ -- ║ ║ │ Layout algorithms -- ║ Layout ║ │ e.g. 'layoutPretty' -- ║ ║ ▽ -- ║ ║ ╭───────────────────╮ -- ║ ║ │ 'SimpleDocStream' │ -- ╠══════════╣ │ (simple document) │ -- ║ ║ ╰─────────┬─────────╯ -- ║ ║ │ -- ║ ║ ├─────────────────────────────╮ -- ║ ║ │ │ 'Prettyprinter.Render.Util.SimpleDocTree.treeForm' -- ║ ║ │ ▽ -- ║ ║ │ ╭───────────────╮ -- ║ ║ │ │ 'Prettyprinter.Render.Util.SimpleDocTree.SimpleDocTree' │ -- ║ Render ║ │ ╰───────┬───────╯ -- ║ ║ │ │ -- ║ ║ ╭───────────────────┼─────────────────╮ ╭────────┴────────╮ -- ║ ║ │ │ │ │ │ -- ║ ║ ▽ ▽ ▽ ▽ ▽ -- ║ ║ ╭───────────────╮ ╭───────────────╮ ╭───────────────╮ ╭───────────────╮ -- ║ ║ │ ANSI terminal │ │ Plain 'Text' │ │ other/custom │ │ HTML │ -- ║ ║ ╰───────────────╯ ╰───────────────╯ ╰───────────────╯ ╰───────────────╯ -- ║ ║ -- ╚══════════╝ -- @ -- -- = How the layout works -- -- There are two key concepts to laying a document out: the available width, and -- 'group'ing. -- -- == Available width -- -- The page has a certain maximum width, which the layouter tries to not exceed, -- by inserting line breaks where possible. The functions given in this module -- make it fairly straightforward to specify where, and under what -- circumstances, such a line break may be inserted by the layouter, for example -- via the 'sep' function. -- -- There is also the concept of /ribbon width/. The ribbon is the part of a line -- that is printed, i.e. the line length without the leading indentation. The -- layouters take a ribbon fraction argument, which specifies how much of a line -- should be filled before trying to break it up. A ribbon width of 0.5 in a -- document of width 80 will result in the layouter to try to not exceed @0.5*80 = -- 40@ (ignoring current indentation depth). -- -- == Grouping -- -- A document can be 'group'ed, which tells the layouter that it should attempt -- to collapse it to a single line. If the result does not fit within the -- 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:/ 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 -- (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 Prettyprinter ( -- * Documents Doc, -- * Basic functionality Pretty(..), viaShow, unsafeViaShow, emptyDoc, nest, line, line', softline, softline', hardline, -- ** Primitives for alternative layouts group, flatAlt, -- * Alignment functions -- -- | The functions in this section cannot be described by Wadler's original -- functions. They align their output relative to the current output -- position - in contrast to @'nest'@ which always aligns to the current -- nesting level. This deprives these functions from being \'optimal\'. In -- practice however they prove to be very useful. The functions in this -- section should be used with care, since they are more expensive than the -- other functions. For example, @'align'@ shouldn't be used to pretty print -- all top-level declarations of a language, but using @'hang'@ for let -- expressions is fine. align, hang, indent, encloseSep, list, tupled, -- * Binary functions (<>), (<+>), -- * List functions -- | The 'sep' and 'cat' functions differ in one detail: when 'group'ed, the -- 'sep's replace newlines wich 'space's, while the 'cat's simply remove -- them. If you're not sure what you want, start with the 'sep's. concatWith, -- ** 'sep' family -- -- | When 'group'ed, these will replace newlines with spaces. hsep, vsep, fillSep, sep, -- ** 'cat' family -- -- | When 'group'ed, these will remove newlines. hcat, vcat, fillCat, cat, -- ** Others punctuate, -- * Reactive/conditional layouts -- -- | Lay documents out differently based on current position and the page -- layout. column, nesting, width, pageWidth, -- * Filler functions -- -- | Fill up available space fill, fillBreak, -- * General convenience -- -- | Useful helper functions. plural, enclose, surround, -- * Bracketing functions -- -- | Enclose documents in common ways. squotes, dquotes, parens, angles, brackets, braces, -- * Named characters -- -- | Convenience definitions for common characters lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket, squote, dquote, semi, colon, comma, space, dot, slash, backslash, equals, pipe, -- ** Annotations annotate, unAnnotate, reAnnotate, alterAnnotations, unAnnotateS, reAnnotateS, alterAnnotationsS, -- * Optimization -- -- Render documents faster fuse, FusionDepth(..), -- * Layout -- -- | Laying a 'Doc'ument out produces a straightforward 'SimpleDocStream' -- based on parameters such as page width and ribbon size, by evaluating how -- a 'Doc' fits these constraints the best. There are various ways to render -- a 'SimpleDocStream'. For the common case of rendering a 'SimpleDocStream' -- as plain 'Text' take a look at "Prettyprinter.Render.Text". SimpleDocStream(..), PageWidth(..), LayoutOptions(..), defaultLayoutOptions, layoutPretty, layoutCompact, layoutSmart, removeTrailingWhitespace, -- * Migration guide -- -- $migration ) where #if !(SEMIGROUP_MONOID_SUPERCLASS) import Data.Semigroup #endif import Prettyprinter.Internal import Prettyprinter.Symbols.Ascii -- $setup -- -- (Definitions for the doctests) -- -- >>> :set -XOverloadedStrings -- >>> import Prettyprinter.Render.Text -- >>> import Prettyprinter.Util -- $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: -- -- - @char@, @string@, @double@, … – these are all special cases of the -- overloaded @'pretty'@ function. -- - @\<$>@, @\<$$>@, @\@, @\@ are special cases of -- @'vsep'@, @'vcat'@, @'fillSep'@, @'fillCat'@ with only two documents. -- - If you need 'String' output, use the backends in the -- "Prettyprinter.Render.String" module. -- - The /display/ functions are moved to the rendering submodules, for -- example conversion to plain 'Text' is in the -- "Prettyprinter.Render.Text" module. -- - The /render/ functions are called /layout/ functions. -- - @SimpleDoc@ was renamed to @'SimpleDocStream'@, in order to make it -- 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, which can be found -- in the ANSI terminal specific @prettyprinter-ansi-terminal@ package. prettyprinter-1.7.1/src/Prettyprinter/0000755000000000000000000000000007346545000016326 5ustar0000000000000000prettyprinter-1.7.1/src/Prettyprinter/Internal.hs0000644000000000000000000022276407346545000020453 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_HADDOCK not-home #-} #include "version-compatibility-macros.h" -- | __Warning: internal module!__ This means that the API may change -- arbitrarily between versions without notice. Depending on this module may -- lead to unexpected breakages, so proceed with caution! -- -- For a stable API, use the non-internal modules. For the special case of -- writing adaptors to this library’s @'Doc'@ type, see -- "Prettyprinter.Internal.Type". module Prettyprinter.Internal ( -- * Documents Doc(..), -- * Basic functionality Pretty(..), viaShow, unsafeViaShow, unsafeTextWithoutNewlines, emptyDoc, nest, line, line', softline, softline', hardline, -- ** Primitives for alternative layouts group, flatAlt, -- * Alignment functions align, hang, indent, encloseSep, list, tupled, -- * Binary functions (<+>), -- * List functions concatWith, -- ** 'sep' family hsep, vsep, fillSep, sep, -- ** 'cat' family hcat, vcat, fillCat, cat, -- ** Others punctuate, -- * Reactive/conditional layouts column, nesting, width, pageWidth, -- * Filler functions fill, fillBreak, -- * General convenience plural, enclose, surround, -- ** Annotations annotate, unAnnotate, reAnnotate, alterAnnotations, unAnnotateS, reAnnotateS, alterAnnotationsS, -- * Optimization fuse, FusionDepth(..), -- * Layout SimpleDocStream(..), PageWidth(..), defaultPageWidth, LayoutOptions(..), defaultLayoutOptions, layoutPretty, layoutCompact, layoutSmart, removeTrailingWhitespace, -- * Rendering renderShowS, -- * Internal helpers textSpaces ) where import Control.Applicative import Data.Int import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe import Data.String (IsString (..)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as Lazy import Data.Typeable (Typeable) import Data.Void import Data.Word import GHC.Generics (Generic) -- Depending on the Cabal file, this might be from base, or for older builds, -- from the semigroups package. import Data.Semigroup #if NATURAL_IN_BASE import Numeric.Natural #endif #if !(FOLDABLE_TRAVERSABLE_IN_PRELUDE) import Data.Foldable (Foldable (..)) import Data.Traversable (Traversable (..)) import Prelude hiding (foldr, foldr1) #endif #if FUNCTOR_IDENTITY_IN_BASE import Data.Functor.Identity #endif import Prettyprinter.Render.Util.Panic -- | The abstract data type @'Doc' ann@ represents pretty documents that have -- been annotated with data of type @ann@. -- -- More specifically, a value of type @'Doc'@ represents a non-empty set of -- possible layouts of a document. The layout functions select one of these -- possibilities, taking into account things like the width of the output -- document. -- -- The annotation is an arbitrary piece of data associated with (part of) a -- document. Annotations may be used by the rendering backends in order to -- display output differently, such as -- -- - color information (e.g. when rendering to the terminal) -- - mouseover text (e.g. when rendering to rich HTML) -- - whether to show something or not (to allow simple or detailed versions) -- -- The simplest way to display a 'Doc' is via the 'Show' class. -- -- >>> putStrLn (show (vsep ["hello", "world"])) -- hello -- world data Doc ann = -- | Occurs when flattening a line. The layouter will reject this document, -- choosing a more suitable rendering. Fail -- | The empty document; conceptually the unit of 'Cat' | Empty -- | invariant: not '\n' | Char !Char -- | Invariants: at least two characters long, does not contain '\n'. For -- empty documents, there is @Empty@; for singleton documents, there is -- @Char@; newlines should be replaced by e.g. @Line@. -- -- Since the frequently used 'T.length' of 'Text' is /O(length)/, we cache -- it in this constructor. | Text !Int !Text -- | Hard line break | Line -- | Lay out the first 'Doc', but when flattened (via 'group'), prefer -- the second. -- -- The layout algorithms work under the assumption that the first -- alternative is less wide than the flattened second alternative. | FlatAlt (Doc ann) (Doc ann) -- | Concatenation of two documents | Cat (Doc ann) (Doc ann) -- | Document indented by a number of columns | Nest !Int (Doc ann) -- | Invariant: The first lines of first document should be longer than the -- first lines of the second one, so the layout algorithm can pick the one -- that fits best. Used to implement layout alternatives for 'group'. | Union (Doc ann) (Doc ann) -- | React on the current cursor position, see 'column' | Column (Int -> Doc ann) -- | React on the document's width, see 'pageWidth' | WithPageWidth (PageWidth -> Doc ann) -- | React on the current nesting level, see 'nesting' | Nesting (Int -> Doc ann) -- | Add an annotation to the enclosed 'Doc'. Can be used for example to add -- styling directives or alt texts that can then be used by the renderer. | Annotated ann (Doc ann) deriving (Generic, Typeable) -- | -- @ -- x '<>' y = 'hcat' [x, y] -- @ -- -- >>> "hello" <> "world" :: Doc ann -- helloworld instance Semigroup (Doc ann) where (<>) = Cat sconcat (x :| xs) = hcat (x:xs) stimes n x | n <= 0 = Empty | n == 1 = x | otherwise = let n' = fromIntegral n nx = hcat (replicate n' x) in case x of Fail -> Fail Empty -> Empty Char c -> Text n' (T.replicate n' (T.singleton c)) Text l t -> Text (n' * l) (T.replicate n' t) Line -> nx FlatAlt{} -> nx Cat{} -> nx Nest{} -> nx Union{} -> nx Column{} -> nx WithPageWidth{} -> nx Nesting{} -> nx Annotated{} -> nx -- | -- @ -- 'mempty' = 'emptyDoc' -- 'mconcat' = 'hcat' -- @ -- -- >>> mappend "hello" "world" :: Doc ann -- helloworld instance Monoid (Doc ann) where mempty = emptyDoc mappend = (<>) mconcat = hcat -- | >>> pretty ("hello\nworld") -- hello -- world -- -- This instance uses the 'Pretty' 'Text' instance, and uses the same newline to -- 'line' conversion. instance IsString (Doc ann) where fromString = pretty . T.pack -- | Alter the document’s annotations. -- -- This instance makes 'Doc' more flexible (because it can be used in -- 'Functor'-polymorphic values), but @'fmap'@ is much less readable compared to -- using @'reAnnotate'@ in code that only works for @'Doc'@ anyway. Consider -- using the latter when the type does not matter. instance Functor Doc where fmap = reAnnotate -- | Overloaded conversion to 'Doc'. -- -- Laws: -- -- 1. output should be pretty. :-) class Pretty a where -- | >>> pretty 1 <+> pretty "hello" <+> pretty 1.234 -- 1 hello 1.234 pretty :: a -> Doc ann default pretty :: Show a => a -> Doc ann pretty = viaShow -- | @'prettyList'@ is only used to define the @instance -- 'Pretty' a => 'Pretty' [a]@. In normal circumstances only the @'pretty'@ -- function is used. -- -- >>> prettyList [1, 23, 456] -- [1, 23, 456] prettyList :: [a] -> Doc ann prettyList = align . list . map pretty {-# MINIMAL pretty #-} -- $ -- Issue #67: Nested lists were not aligned with »pretty«, leading to non-pretty -- output, violating the Pretty class law. -- -- >>> pretty (replicate 2 (replicate 4 (1, replicate 8 2))) -- [ [ (1, [2, 2, 2, 2, 2, 2, 2, 2]) -- , (1, [2, 2, 2, 2, 2, 2, 2, 2]) -- , (1, [2, 2, 2, 2, 2, 2, 2, 2]) -- , (1, [2, 2, 2, 2, 2, 2, 2, 2]) ] -- , [ (1, [2, 2, 2, 2, 2, 2, 2, 2]) -- , (1, [2, 2, 2, 2, 2, 2, 2, 2]) -- , (1, [2, 2, 2, 2, 2, 2, 2, 2]) -- , (1, [2, 2, 2, 2, 2, 2, 2, 2]) ] ] 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 pretty = prettyList instance Pretty a => Pretty (NonEmpty a) where pretty (x:|xs) = prettyList (x:xs) -- | >>> pretty () -- () -- -- The argument is not used: -- -- >>> pretty (error "Strict?" :: ()) -- () instance Pretty () where pretty _ = "()" -- | >>> pretty True -- True instance Pretty Bool where pretty True = "True" pretty False = "False" -- | Instead of @('pretty' '\n')@, consider using @'line'@ as a more readable -- alternative. -- -- >>> pretty 'f' <> pretty 'o' <> pretty 'o' -- foo -- >>> pretty ("string" :: String) -- string instance Pretty Char where pretty '\n' = line pretty c = Char c #ifdef MIN_VERSION_text prettyList = pretty . (id :: Text -> Text) . fromString #else prettyList = vsep . map unsafeTextWithoutNewlines . T.splitOn "\n" #endif -- | Convenience function to convert a 'Show'able value to a 'Doc'. If the -- 'String' does not contain newlines, consider using the more performant -- 'unsafeViaShow'. viaShow :: Show a => a -> Doc ann viaShow = pretty . T.pack . show -- | Convenience function to convert a 'Show'able value /that must not contain -- newlines/ to a 'Doc'. If there may be newlines, use 'viaShow' instead. unsafeViaShow :: Show a => a -> Doc ann unsafeViaShow = unsafeTextWithoutNewlines . T.pack . show -- | >>> pretty (123 :: Int) -- 123 instance Pretty Int where pretty = unsafeViaShow instance Pretty Int8 where pretty = unsafeViaShow instance Pretty Int16 where pretty = unsafeViaShow instance Pretty Int32 where pretty = unsafeViaShow instance Pretty Int64 where pretty = unsafeViaShow instance Pretty Word where pretty = unsafeViaShow instance Pretty Word8 where pretty = unsafeViaShow instance Pretty Word16 where pretty = unsafeViaShow instance Pretty Word32 where pretty = unsafeViaShow instance Pretty Word64 where pretty = unsafeViaShow -- | >>> pretty (2^123 :: Integer) -- 10633823966279326983230456482242756608 instance Pretty Integer where pretty = unsafeViaShow #if NATURAL_IN_BASE instance Pretty Natural where pretty = unsafeViaShow #endif -- | >>> pretty (pi :: Float) -- 3.1415927 instance Pretty Float where pretty = unsafeViaShow -- | >>> pretty (exp 1 :: Double) -- 2.71828182845904... instance Pretty Double where pretty = unsafeViaShow -- | >>> pretty (123, "hello") -- (123, hello) instance (Pretty a1, Pretty a2) => Pretty (a1,a2) where pretty (x1,x2) = tupled [pretty x1, pretty x2] -- | >>> pretty (123, "hello", False) -- (123, hello, False) instance (Pretty a1, Pretty a2, Pretty a3) => Pretty (a1,a2,a3) where pretty (x1,x2,x3) = tupled [pretty x1, pretty x2, pretty x3] -- -- | >>> pretty (123, "hello", False, ()) -- -- (123, hello, False, ()) -- instance (Pretty a1, Pretty a2, Pretty a3, Pretty a4) => Pretty (a1,a2,a3,a4) where -- pretty (x1,x2,x3,x4) = tupled [pretty x1, pretty x2, pretty x3, pretty x4] -- -- -- | >>> pretty (123, "hello", False, (), 3.14) -- -- (123, hello, False, (), 3.14) -- instance (Pretty a1, Pretty a2, Pretty a3, Pretty a4, Pretty a5) => Pretty (a1,a2,a3,a4,a5) where -- pretty (x1,x2,x3,x4,x5) = tupled [pretty x1, pretty x2, pretty x3, pretty x4, pretty x5] -- -- -- | >>> pretty (123, "hello", False, (), 3.14, Just 2.71) -- -- ( 123 -- -- , hello -- -- , False -- -- , () -- -- , 3.14 -- -- , 2.71 ) -- instance (Pretty a1, Pretty a2, Pretty a3, Pretty a4, Pretty a5, Pretty a6) => Pretty (a1,a2,a3,a4,a5,a6) where -- pretty (x1,x2,x3,x4,x5,x6) = tupled [pretty x1, pretty x2, pretty x3, pretty x4, pretty x5, pretty x6] -- -- -- | >>> pretty (123, "hello", False, (), 3.14, Just 2.71, [1,2,3]) -- -- ( 123 -- -- , hello -- -- , False -- -- , () -- -- , 3.14 -- -- , 2.71 -- -- , [1, 2, 3] ) -- instance (Pretty a1, Pretty a2, Pretty a3, Pretty a4, Pretty a5, Pretty a6, Pretty a7) => Pretty (a1,a2,a3,a4,a5,a6,a7) where -- pretty (x1,x2,x3,x4,x5,x6,x7) = tupled [pretty x1, pretty x2, pretty x3, pretty x4, pretty x5, pretty x6, pretty x7] -- | Ignore 'Nothing's, print 'Just' contents. -- -- >>> pretty (Just True) -- True -- >>> braces (pretty (Nothing :: Maybe Bool)) -- {} -- -- >>> pretty [Just 1, Nothing, Just 3, Nothing] -- [1, 3] instance Pretty a => Pretty (Maybe a) where pretty = maybe mempty pretty prettyList = prettyList . catMaybes #ifdef MIN_VERSION_text -- | Automatically converts all newlines to @'line'@. -- -- >>> pretty ("hello\nworld" :: Text) -- hello -- world -- -- Note that @'line'@ can be undone by @'group'@: -- -- >>> group (pretty ("hello\nworld" :: Text)) -- hello world -- -- Manually use @'hardline'@ if you /definitely/ want newlines. instance Pretty Text where pretty = vsep . map unsafeTextWithoutNewlines . T.splitOn "\n" -- | (lazy 'Text' instance, identical to the strict version) instance Pretty Lazy.Text where pretty = pretty . Lazy.toStrict #endif -- | Finding a good example for printing something that does not exist is hard, -- so here is an example of printing a list full of nothing. -- -- >>> pretty ([] :: [Void]) -- [] instance Pretty Void where pretty = absurd -- | @(unsafeTextWithoutNewlines s)@ contains the literal string @s@. -- -- The string must not contain any newline characters, since this is an -- invariant of the 'Text' constructor. unsafeTextWithoutNewlines :: Text -> Doc ann unsafeTextWithoutNewlines text = case T.uncons text of Nothing -> Empty Just (t,ext) | T.null ext -> Char t | otherwise -> Text (T.length text) text -- | The empty document behaves like @('pretty' "")@, so it has a height of 1. -- This may lead to surprising behaviour if we expect it to bear no weight -- inside e.g. 'vcat', where we get an empty line of output from it ('parens' -- for visibility only): -- -- >>> vsep ["hello", parens emptyDoc, "world"] -- hello -- () -- world -- -- Together with '<>', 'emptyDoc' forms the 'Monoid' 'Doc'. emptyDoc :: Doc ann emptyDoc = Empty -- | @('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 -- ipsum -- dolor -- sit -- amet -- -- 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 -> Doc ann nest 0 x = x -- Optimization nest i x = Nest i x -- | The @'line'@ document advances to the next line and indents to the current -- nesting level. -- -- >>> let doc = "lorem ipsum" <> line <> "dolor sit amet" -- >>> doc -- lorem ipsum -- dolor sit amet -- -- @'line'@ behaves like @'space'@ if the line break is undone by 'group': -- -- >>> group doc -- lorem ipsum dolor sit amet line :: Doc ann line = FlatAlt Line (Char ' ') -- | @'line''@ is like @'line'@, but behaves like @'mempty'@ if the line break -- is undone by 'group' (instead of @'space'@). -- -- >>> let doc = "lorem ipsum" <> line' <> "dolor sit amet" -- >>> doc -- lorem ipsum -- dolor sit amet -- >>> group doc -- lorem ipsumdolor sit amet line' :: Doc ann line' = FlatAlt Line mempty -- | @softline@ behaves like @'space'@ if the resulting output fits the page, -- otherwise like @'line'@. -- -- Here, we have enough space to put everything in one line: -- -- >>> let doc = "lorem ipsum" <> softline <> "dolor sit amet" -- >>> putDocW 80 doc -- lorem ipsum dolor sit amet -- -- If we narrow the page to width 10, the layouter produces a line break: -- -- >>> putDocW 10 doc -- lorem ipsum -- dolor sit amet -- -- @ -- 'softline' = 'group' 'line' -- @ softline :: Doc ann softline = Union (Char ' ') Line -- | @'softline''@ is like @'softline'@, but behaves like @'mempty'@ if the -- resulting output does not fit on the page (instead of @'space'@). In other -- words, @'line'@ is to @'line''@ how @'softline'@ is to @'softline''@. -- -- With enough space, we get direct concatenation: -- -- >>> let doc = "ThisWord" <> softline' <> "IsWayTooLong" -- >>> putDocW 80 doc -- ThisWordIsWayTooLong -- -- If we narrow the page to width 10, the layouter produces a line break: -- -- >>> putDocW 10 doc -- ThisWord -- IsWayTooLong -- -- @ -- 'softline'' = 'group' 'line'' -- @ softline' :: Doc ann softline' = Union mempty Line -- | A @'hardline'@ is /always/ laid out as a line break, even when 'group'ed or -- when there is plenty of space. Note that it might still be simply discarded -- if it is part of a 'flatAlt' inside a 'group'. -- -- >>> let doc = "lorem ipsum" <> hardline <> "dolor sit amet" -- >>> putDocW 1000 doc -- lorem ipsum -- dolor sit amet -- -- >>> group doc -- lorem ipsum -- dolor sit amet hardline :: Doc ann hardline = Line -- | @('group' x)@ tries laying out @x@ into a single line by removing the -- contained line breaks; if this does not fit the page, or when a 'hardline' -- within @x@ prevents it from being flattened, @x@ is laid out without any -- changes. -- -- The 'group' function is key to layouts that adapt to available space nicely. -- -- See 'vcat', 'line', or 'flatAlt' for examples that are related, or make good -- use of it. group :: Doc ann -> Doc ann -- See note [Group: special flattening] group x = case x of Union{} -> x FlatAlt a b -> case changesUponFlattening b of Flattened b' -> Union b' a AlreadyFlat -> Union b a NeverFlat -> a _ -> case changesUponFlattening x of Flattened x' -> Union x' x AlreadyFlat -> x NeverFlat -> x -- Note [Group: special flattening] -- -- Since certain documents do not change under removal of newlines etc, there is -- no point in creating a 'Union' of the flattened and unflattened version – all -- this does is introducing two branches for the layout algorithm to take, -- resulting in potentially exponential behavior on deeply nested examples, such -- as -- -- pathological n = iterate (\x -> hsep [x, sep []] ) "foobar" !! n -- -- See https://github.com/quchen/prettyprinter/issues/22 for the corresponding -- ticket. data FlattenResult a = Flattened a -- ^ @a@ is likely flatter than the input. | AlreadyFlat -- ^ The input was already flat, e.g. a 'Text'. | NeverFlat -- ^ The input couldn't be flattened: It contained a 'Line' or 'Fail'. instance Functor FlattenResult where fmap f (Flattened a) = Flattened (f a) fmap _ AlreadyFlat = AlreadyFlat fmap _ NeverFlat = NeverFlat -- | Choose the first element of each @Union@, and discard the first field of -- all @FlatAlt@s. -- -- The result is 'Flattened' if the element might change depending on the layout -- algorithm (i.e. contains differently renderable sub-documents), and 'AlreadyFlat' -- if the document is static (e.g. contains only a plain 'Empty' node). -- 'NeverFlat' is returned when the document cannot be flattened because it -- contains a hard 'Line' or 'Fail'. -- See [Group: special flattening] for further explanations. changesUponFlattening :: Doc ann -> FlattenResult (Doc ann) changesUponFlattening = \doc -> case doc of FlatAlt _ y -> Flattened (flatten y) Line -> NeverFlat Union x _ -> Flattened x Nest i x -> fmap (Nest i) (changesUponFlattening x) Annotated ann x -> fmap (Annotated ann) (changesUponFlattening x) Column f -> Flattened (Column (flatten . f)) Nesting f -> Flattened (Nesting (flatten . f)) WithPageWidth f -> Flattened (WithPageWidth (flatten . f)) Cat x y -> case (changesUponFlattening x, changesUponFlattening y) of (NeverFlat , _ ) -> NeverFlat (_ , NeverFlat ) -> NeverFlat (Flattened x' , Flattened y') -> Flattened (Cat x' y') (Flattened x' , AlreadyFlat ) -> Flattened (Cat x' y) (AlreadyFlat , Flattened y') -> Flattened (Cat x y') (AlreadyFlat , AlreadyFlat ) -> AlreadyFlat Empty -> AlreadyFlat Char{} -> AlreadyFlat Text{} -> AlreadyFlat Fail -> NeverFlat where -- Flatten, but don’t report whether anything changes. flatten :: Doc ann -> Doc ann flatten = \doc -> case doc of FlatAlt _ y -> flatten y Cat x y -> Cat (flatten x) (flatten y) Nest i x -> Nest i (flatten x) Line -> Fail Union x _ -> flatten x Column f -> Column (flatten . f) WithPageWidth f -> WithPageWidth (flatten . f) Nesting f -> Nesting (flatten . f) Annotated ann x -> Annotated ann (flatten x) x@Fail -> x x@Empty -> x x@Char{} -> x x@Text{} -> x -- | By default, @('flatAlt' x y)@ renders as @x@. However when 'group'ed, -- @y@ will be preferred, with @x@ as the fallback for the case when @y@ -- doesn't fit. -- -- >>> let doc = flatAlt "a" "b" -- >>> putDoc doc -- a -- >>> putDoc (group doc) -- b -- >>> putDocW 0 (group doc) -- a -- -- 'flatAlt' is particularly useful for defining conditional separators such as -- -- @ -- softline = 'group' ('flatAlt' 'hardline' " ") -- @ -- -- >>> let hello = "Hello" <> softline <> "world!" -- >>> putDocW 12 hello -- Hello world! -- >>> putDocW 11 hello -- Hello -- world! -- -- === __Example: Haskell's do-notation__ -- -- We can use this to render Haskell's do-notation nicely: -- -- >>> let open = flatAlt "" "{ " -- >>> let close = flatAlt "" " }" -- >>> let separator = flatAlt "" "; " -- >>> let prettyDo xs = group ("do" <+> align (encloseSep open close separator xs)) -- >>> let statements = ["name:_ <- getArgs", "let greet = \"Hello, \" <> name", "putStrLn greet"] -- -- This is put into a single line with @{;}@ style if it fits: -- -- >>> putDocW 80 (prettyDo statements) -- do { name:_ <- getArgs; let greet = "Hello, " <> name; putStrLn greet } -- -- When there is not enough space the statements are broken up into lines -- nicely: -- -- >>> putDocW 10 (prettyDo statements) -- do name:_ <- getArgs -- let greet = "Hello, " <> name -- putStrLn greet -- -- === Notes -- -- Users should be careful to choose @x@ to be less wide than @y@. -- Otherwise, if @y@ turns out not to fit the page, we fall back on an even -- wider layout: -- -- >>> let ugly = group (flatAlt "even wider" "too wide") -- >>> putDocW 7 ugly -- even wider -- -- Also note that 'group' will flatten @y@: -- -- >>> putDoc (group (flatAlt "x" ("y" <> line <> "y"))) -- y y -- -- This also means that an "unflattenable" @y@ which contains a hard linebreak -- will /never/ be rendered: -- -- >>> putDoc (group (flatAlt "x" ("y" <> hardline <> "y"))) -- x flatAlt :: Doc ann -- ^ Default -> Doc ann -- ^ Preferred when 'group'ed -> Doc ann flatAlt = FlatAlt -- | @('align' x)@ lays out the document @x@ with the nesting level set to the -- current column. It is used for example to implement 'hang'. -- -- As an example, we will put a document right above another one, regardless of -- the current nesting level. Without 'align'ment, the second line is put simply -- below everything we've had so far: -- -- >>> "lorem" <+> vsep ["ipsum", "dolor"] -- lorem ipsum -- dolor -- -- If we add an 'align' to the mix, the @'vsep'@'s contents all start in the -- same column: -- -- >>> "lorem" <+> align (vsep ["ipsum", "dolor"]) -- lorem ipsum -- dolor align :: Doc ann -> Doc ann align d = column (\k -> nesting (\i -> nest (k - i) d)) -- nesting might be negative! -- | @('hang' i x)@ lays out the document @x@ with a nesting level set to the -- /current column/ plus @i@. Negative values are allowed, and decrease the -- nesting level accordingly. -- -- >>> let doc = reflow "Indenting these words with hang" -- >>> putDocW 24 ("prefix" <+> hang 4 doc) -- prefix Indenting these -- words with -- hang -- -- This differs from 'nest', which is based on the /current nesting level/ plus -- @i@. When you're not sure, try the more efficient 'nest' first. In our -- example, this would yield -- -- >>> let doc = reflow "Indenting these words with nest" -- >>> putDocW 24 ("prefix" <+> nest 4 doc) -- prefix Indenting these -- words with nest -- -- @ -- 'hang' i doc = 'align' ('nest' i doc) -- @ hang :: Int -- ^ Change of nesting level, relative to the start of the first line -> Doc ann -> Doc ann hang i d = align (nest i d) -- | @('indent' i x)@ indents document @x@ by @i@ columns, starting from the -- current cursor position. -- -- >>> let doc = reflow "The indent function indents these words!" -- >>> putDocW 24 ("prefix" <> indent 4 doc) -- prefix The indent -- function -- indents these -- words! -- -- @ -- 'indent' i d = 'hang' i ({i spaces} <> d) -- @ indent :: Int -- ^ Number of spaces to increase indentation by -> Doc ann -> Doc ann indent i d = hang i (spaces i <> d) -- | @('encloseSep' l r sep xs)@ concatenates the documents @xs@ separated by -- @sep@, and encloses the resulting document by @l@ and @r@. -- -- The documents are laid out horizontally if that fits the page: -- -- >>> let doc = "list" <+> align (encloseSep lbracket rbracket comma (map pretty [1,20,300,4000])) -- >>> putDocW 80 doc -- list [1,20,300,4000] -- -- If there is not enough space, then the input is split into lines entry-wise -- therwise they are laid out vertically, with separators put in the front: -- -- >>> putDocW 10 doc -- list [1 -- ,20 -- ,300 -- ,4000] -- -- Note that @doc@ contains an explicit call to 'align' so that the list items -- are aligned vertically. -- -- For putting separators at the end of entries instead, have a look at -- 'punctuate'. encloseSep :: Doc ann -- ^ left delimiter -> Doc ann -- ^ right delimiter -> Doc ann -- ^ separator -> [Doc ann] -- ^ input documents -> Doc ann encloseSep l r s ds = case ds of [] -> l <> r [d] -> l <> d <> r _ -> cat (zipWith (<>) (l : repeat s) ds) <> r -- | Haskell-inspired variant of 'encloseSep' with braces and comma as -- separator. -- -- >>> let doc = list (map pretty [1,20,300,4000]) -- -- >>> putDocW 80 doc -- [1, 20, 300, 4000] -- -- >>> putDocW 10 doc -- [ 1 -- , 20 -- , 300 -- , 4000 ] list :: [Doc ann] -> Doc ann list = group . encloseSep (flatAlt "[ " "[") (flatAlt " ]" "]") ", " -- | Haskell-inspired variant of 'encloseSep' with parentheses and comma as -- separator. -- -- >>> let doc = tupled (map pretty [1,20,300,4000]) -- -- >>> putDocW 80 doc -- (1, 20, 300, 4000) -- -- >>> putDocW 10 doc -- ( 1 -- , 20 -- , 300 -- , 4000 ) tupled :: [Doc ann] -> Doc ann tupled = group . encloseSep (flatAlt "( " "(") (flatAlt " )" ")") ", " -- | @(x '<+>' y)@ concatenates document @x@ and @y@ with a @'space'@ in -- between. -- -- >>> "hello" <+> "world" -- hello world -- -- @ -- x '<+>' y = x '<>' 'space' '<>' y -- @ (<+>) :: Doc ann -> Doc ann -> Doc ann x <+> y = x <> Char ' ' <> y infixr 6 <+> -- like <> -- | Concatenate all documents element-wise with a binary function. -- -- @ -- 'concatWith' _ [] = 'mempty' -- 'concatWith' (**) [x,y,z] = x ** y ** z -- @ -- -- Multiple convenience definitions based on 'concatWith' are already predefined, -- for example: -- -- @ -- 'hsep' = 'concatWith' ('<+>') -- 'fillSep' = 'concatWith' (\\x y -> x '<>' 'softline' '<>' y) -- @ -- -- This is also useful to define customized joiners: -- -- >>> concatWith (surround dot) ["Prettyprinter", "Render", "Text"] -- Prettyprinter.Render.Text concatWith :: Foldable t => (Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann concatWith f ds #if !(FOLDABLE_TRAVERSABLE_IN_PRELUDE) | foldr (\_ _ -> False) True ds = mempty #else | null ds = mempty #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. -- -- >>> let docs = Util.words "lorem ipsum dolor sit amet" -- -- >>> hsep docs -- lorem ipsum dolor sit amet -- -- @'hsep'@ does not introduce line breaks on its own, even when the page is too -- narrow: -- -- >>> putDocW 5 (hsep docs) -- lorem ipsum dolor sit amet -- -- For automatic line breaks, consider using 'fillSep' instead. hsep :: [Doc ann] -> Doc ann hsep = concatWith (<+>) -- | @('vsep' xs)@ concatenates all documents @xs@ above each other. If a -- 'group' undoes the line breaks inserted by @vsep@, the documents are -- separated with a 'space' instead. -- -- Using 'vsep' alone yields -- -- >>> "prefix" <+> vsep ["text", "to", "lay", "out"] -- prefix text -- to -- lay -- out -- -- 'group'ing a 'vsep' separates the documents with a 'space' if it fits the -- page (and does nothing otherwise). See the @'sep'@ convenience function for -- this use case. -- -- The 'align' function can be used to align the documents under their first -- element: -- -- >>> "prefix" <+> align (vsep ["text", "to", "lay", "out"]) -- prefix text -- to -- lay -- out -- -- Since 'group'ing a 'vsep' is rather common, 'sep' is a built-in for doing -- that. vsep :: [Doc ann] -> Doc ann vsep = concatWith (\x y -> x <> line <> y) -- | @('fillSep' xs)@ concatenates the documents @xs@ horizontally with @'<+>'@ -- as long as it fits the page, then inserts a @'line'@ and continues doing that -- for all documents in @xs@. (@'line'@ means that if 'group'ed, the documents -- are separated with a 'space' instead of newlines. Use 'fillCat' if you do not -- want a 'space'.) -- -- Let's print some words to fill the line: -- -- >>> let docs = take 20 (cycle ["lorem", "ipsum", "dolor", "sit", "amet"]) -- >>> putDocW 80 ("Docs:" <+> fillSep docs) -- Docs: lorem ipsum dolor sit amet lorem ipsum dolor sit amet lorem ipsum dolor -- sit amet lorem ipsum dolor sit amet -- -- The same document, printed at a width of only 40, yields -- -- >>> putDocW 40 ("Docs:" <+> fillSep docs) -- Docs: lorem ipsum dolor sit amet lorem -- ipsum dolor sit amet lorem ipsum dolor -- sit amet lorem ipsum dolor sit amet fillSep :: [Doc ann] -> Doc ann fillSep = concatWith (\x y -> x <> softline <> y) -- | @('sep' xs)@ tries laying out the documents @xs@ separated with 'space's, -- and if this does not fit the page, separates them with newlines. This is what -- differentiates it from 'vsep', which always lays out its contents beneath -- each other. -- -- >>> let doc = "prefix" <+> sep ["text", "to", "lay", "out"] -- >>> putDocW 80 doc -- prefix text to lay out -- -- With a narrower layout, the entries are separated by newlines: -- -- >>> putDocW 20 doc -- prefix text -- to -- lay -- out -- -- @ -- 'sep' = 'group' . 'vsep' -- @ sep :: [Doc ann] -> Doc ann sep = group . vsep -- | @('hcat' xs)@ concatenates all documents @xs@ horizontally with @'<>'@ -- (i.e. without any spacing). -- -- It is provided only for consistency, since it is identical to 'mconcat'. -- -- >>> let docs = Util.words "lorem ipsum dolor" -- >>> hcat docs -- loremipsumdolor hcat :: [Doc ann] -> Doc ann hcat = concatWith (<>) -- | @('vcat' xs)@ vertically concatenates the documents @xs@. If it is -- 'group'ed, the line breaks are removed. -- -- In other words @'vcat'@ is like @'vsep'@, with newlines removed instead of -- replaced by 'space's. -- -- >>> let docs = Util.words "lorem ipsum dolor" -- >>> vcat docs -- lorem -- ipsum -- dolor -- >>> group (vcat docs) -- loremipsumdolor -- -- Since 'group'ing a 'vcat' is rather common, 'cat' is a built-in shortcut for -- it. vcat :: [Doc ann] -> Doc ann vcat = concatWith (\x y -> x <> line' <> y) -- | @('fillCat' xs)@ concatenates documents @xs@ horizontally with @'<>'@ as -- long as it fits the page, then inserts a @'line''@ and continues doing that -- for all documents in @xs@. This is similar to how an ordinary word processor -- lays out the text if you just keep typing after you hit the maximum line -- length. -- -- (@'line''@ means that if 'group'ed, the documents are separated with nothing -- instead of newlines. See 'fillSep' if you want a 'space' instead.) -- -- Observe the difference between 'fillSep' and 'fillCat'. 'fillSep' -- concatenates the entries 'space'd when 'group'ed: -- -- >>> let docs = take 20 (cycle (["lorem", "ipsum", "dolor", "sit", "amet"])) -- >>> putDocW 40 ("Grouped:" <+> group (fillSep docs)) -- Grouped: lorem ipsum dolor sit amet -- lorem ipsum dolor sit amet lorem ipsum -- dolor sit amet lorem ipsum dolor sit -- amet -- -- On the other hand, 'fillCat' concatenates the entries directly when -- 'group'ed: -- -- >>> putDocW 40 ("Grouped:" <+> group (fillCat docs)) -- Grouped: loremipsumdolorsitametlorem -- ipsumdolorsitametloremipsumdolorsitamet -- loremipsumdolorsitamet fillCat :: [Doc ann] -> Doc ann fillCat = concatWith (\x y -> x <> softline' <> y) -- | @('cat' xs)@ tries laying out the documents @xs@ separated with nothing, -- and if this does not fit the page, separates them with newlines. This is what -- differentiates it from 'vcat', which always lays out its contents beneath -- each other. -- -- >>> let docs = Util.words "lorem ipsum dolor" -- >>> putDocW 80 ("Docs:" <+> cat docs) -- Docs: loremipsumdolor -- -- When there is enough space, the documents are put above one another: -- -- >>> putDocW 10 ("Docs:" <+> cat docs) -- Docs: lorem -- ipsum -- dolor -- -- @ -- 'cat' = 'group' . 'vcat' -- @ cat :: [Doc ann] -> Doc ann cat = group . vcat -- | @('punctuate' p xs)@ appends @p@ to all but the last document in @xs@. -- -- >>> let docs = punctuate comma (Util.words "lorem ipsum dolor sit amet") -- >>> putDocW 80 (hsep docs) -- lorem, ipsum, dolor, sit, amet -- -- The separators are put at the end of the entries, which we can see if we -- position the result vertically: -- -- >>> putDocW 20 (vsep docs) -- lorem, -- ipsum, -- dolor, -- sit, -- amet -- -- If you want put the commas in front of their elements instead of at the end, -- you should use 'tupled' or, in general, 'encloseSep'. punctuate :: Doc ann -- ^ Punctuation, e.g. 'comma' -> [Doc ann] -> [Doc ann] punctuate p = go where go [] = [] go [d] = [d] go (d:ds) = (d <> p) : go ds -- | Layout a document depending on which column it starts at. 'align' is -- implemented in terms of 'column'. -- -- >>> column (\l -> "Columns are" <+> pretty l <> "-based.") -- Columns are 0-based. -- -- >>> let doc = "prefix" <+> column (\l -> "| <- column" <+> pretty l) -- >>> vsep [indent n doc | n <- [0,4,8]] -- prefix | <- column 7 -- prefix | <- column 11 -- prefix | <- column 15 column :: (Int -> Doc ann) -> Doc ann column = Column -- | Layout a document depending on the current 'nest'ing level. 'align' is -- implemented in terms of 'nesting'. -- -- >>> let doc = "prefix" <+> nesting (\l -> brackets ("Nested:" <+> pretty l)) -- >>> vsep [indent n doc | n <- [0,4,8]] -- prefix [Nested: 0] -- prefix [Nested: 4] -- prefix [Nested: 8] nesting :: (Int -> Doc ann) -> Doc ann nesting = Nesting -- | @('width' doc f)@ lays out the document 'doc', and makes the column width -- of it available to a function. -- -- >>> let annotate doc = width (brackets doc) (\w -> " <- width:" <+> pretty w) -- >>> align (vsep (map annotate ["---", "------", indent 3 "---", vsep ["---", indent 4 "---"]])) -- [---] <- width: 5 -- [------] <- width: 8 -- [ ---] <- width: 8 -- [--- -- ---] <- width: 8 width :: Doc ann -> (Int -> Doc ann) -> Doc ann width doc f = column (\colStart -> doc <> column (\colEnd -> f (colEnd - colStart))) -- | Layout a document depending on the page width, if one has been specified. -- -- >>> let prettyPageWidth (AvailablePerLine l r) = "Width:" <+> pretty l <> ", ribbon fraction:" <+> pretty r -- >>> let doc = "prefix" <+> pageWidth (brackets . prettyPageWidth) -- >>> putDocW 32 (vsep [indent n doc | n <- [0,4,8]]) -- prefix [Width: 32, ribbon fraction: 1.0] -- prefix [Width: 32, ribbon fraction: 1.0] -- prefix [Width: 32, ribbon fraction: 1.0] pageWidth :: (PageWidth -> Doc ann) -> Doc ann pageWidth = WithPageWidth -- | @('fill' i x)@ lays out the document @x@. It then appends @space@s until -- the width is equal to @i@. If the width of @x@ is already larger, nothing is -- appended. -- -- This function is quite useful in practice to output a list of bindings: -- -- >>> let types = [("empty","Doc"), ("nest","Int -> Doc -> Doc"), ("fillSep","[Doc] -> Doc")] -- >>> let ptype (name, tp) = fill 5 (pretty name) <+> "::" <+> pretty tp -- >>> "let" <+> align (vcat (map ptype types)) -- let empty :: Doc -- nest :: Int -> Doc -> Doc -- fillSep :: [Doc] -> Doc fill :: Int -- ^ Append spaces until the document is at least this wide -> Doc ann -> Doc ann fill n doc = width doc (\w -> spaces (n - w)) -- | @('fillBreak' i x)@ first lays out the document @x@. It then appends @space@s -- until the width is equal to @i@. If the width of @x@ is already larger than -- @i@, the nesting level is increased by @i@ and a @line@ is appended. When we -- redefine @ptype@ in the example given in 'fill' to use @'fillBreak'@, we get -- a useful variation of the output: -- -- >>> let types = [("empty","Doc"), ("nest","Int -> Doc -> Doc"), ("fillSep","[Doc] -> Doc")] -- >>> let ptype (name, tp) = fillBreak 5 (pretty name) <+> "::" <+> pretty tp -- >>> "let" <+> align (vcat (map ptype types)) -- let empty :: Doc -- nest :: Int -> Doc -> Doc -- fillSep -- :: [Doc] -> Doc fillBreak :: Int -- ^ Append spaces until the document is at least this wide -> Doc ann -> Doc ann fillBreak f x = width x (\w -> if w > f then nest f line' else spaces (f - w)) -- | Insert a number of spaces. Negative values count as 0. spaces :: Int -> Doc ann spaces n | n <= 0 = Empty | n == 1 = Char ' ' | otherwise = Text n (textSpaces n) -- $ -- prop> \(NonNegative n) -> length (show (spaces n)) == n -- -- >>> case spaces 1 of Char ' ' -> True; _ -> False -- True -- -- >>> case spaces 0 of Empty -> True; _ -> False -- True -- -- prop> \(Positive n) -> case (spaces (-n)) of Empty -> True; _ -> False -- | @('plural' n one many)@ is @one@ if @n@ is @1@, and @many@ otherwise. A -- typical use case is adding a plural "s". -- -- >>> let things = [True] -- >>> let amount = length things -- >>> pretty things <+> "has" <+> pretty amount <+> plural "entry" "entries" amount -- [True] has 1 entry plural :: (Num amount, Eq amount) => doc -- ^ @1@ case -> doc -- ^ other cases -> amount -> doc plural one multiple n | n == 1 = one | otherwise = multiple -- | @('enclose' l r x)@ encloses document @x@ between documents @l@ and @r@ -- using @'<>'@. -- -- >>> enclose "A" "Z" "·" -- A·Z -- -- @ -- 'enclose' l r x = l '<>' x '<>' r -- @ enclose :: Doc ann -- ^ L -> Doc ann -- ^ R -> Doc ann -- ^ x -> Doc ann -- ^ LxR enclose l r x = l <> x <> r -- | @('surround' x l r)@ surrounds document @x@ with @l@ and @r@. -- -- >>> surround "·" "A" "Z" -- A·Z -- -- This is merely an argument reordering of @'enclose'@, but allows for -- definitions like -- -- >>> concatWith (surround dot) ["Prettyprinter", "Render", "Text"] -- Prettyprinter.Render.Text surround :: Doc ann -> Doc ann -> Doc ann -> Doc ann surround x l r = l <> x <> r -- | 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 -- "Prettyprinter.Render.Tutorials.StackMachineTutorial" or -- "Prettyprinter.Render.Tutorials.TreeRenderingTutorial" modules. -- -- This function is only relevant for custom formats with their own annotations, -- and not relevant for basic prettyprinting. The predefined renderers, e.g. -- "Prettyprinter.Render.Text", should be enough for the most common -- needs. annotate :: ann -> Doc ann -> Doc ann annotate = Annotated -- | Remove all annotations. -- -- Although 'unAnnotate' is idempotent with respect to rendering, -- -- @ -- 'unAnnotate' . 'unAnnotate' = 'unAnnotate' -- @ -- -- it should not be used without caution, for each invocation traverses the -- entire contained document. If possible, it is preferrable to unannotate after -- producing the layout by using 'unAnnotateS'. unAnnotate :: Doc ann -> Doc xxx unAnnotate = alterAnnotations (const []) -- | Change the annotation of a 'Doc'ument. -- -- Useful in particular to embed documents with one form of annotation in a more -- generally annotated document. -- -- Since this traverses the entire @'Doc'@ tree, including parts that are not -- rendered due to other layouts fitting better, it is preferrable to reannotate -- after producing the layout by using @'reAnnotateS'@. -- -- Since @'reAnnotate'@ has the right type and satisfies @'reAnnotate id = id'@, -- it is used to define the @'Functor'@ instance of @'Doc'@. reAnnotate :: (ann -> ann') -> Doc ann -> Doc ann' reAnnotate re = alterAnnotations (pure . re) -- | Change the annotations of a 'Doc'ument. Individual annotations can be -- removed, changed, or replaced by multiple ones. -- -- This is a general function that combines 'unAnnotate' and 'reAnnotate', and -- it is useful for mapping semantic annotations (such as »this is a keyword«) -- to display annotations (such as »this is red and underlined«), because some -- backends may not care about certain annotations, while others may. -- -- Annotations earlier in the new list will be applied earlier, i.e. returning -- @[Bold, Green]@ will result in a bold document that contains green text, and -- not vice-versa. -- -- Since this traverses the entire @'Doc'@ tree, including parts that are not -- rendered due to other layouts fitting better, it is preferrable to reannotate -- after producing the layout by using @'alterAnnotationsS'@. alterAnnotations :: (ann -> [ann']) -> Doc ann -> Doc ann' alterAnnotations re = go where go = \doc -> case doc of Fail -> Fail Empty -> Empty Char c -> Char c Text l t -> Text l t Line -> Line FlatAlt x y -> FlatAlt (go x) (go y) Cat x y -> Cat (go x) (go y) Nest i x -> Nest i (go x) Union x y -> Union (go x) (go y) Column f -> Column (go . f) WithPageWidth f -> WithPageWidth (go . f) Nesting f -> Nesting (go . f) Annotated ann x -> foldr Annotated (go x) (re ann) -- $ -- >>> let doc = "lorem" <+> annotate () "ipsum" <+> "dolor" -- >>> let re () = ["FOO", "BAR"] -- >>> layoutPretty defaultLayoutOptions (alterAnnotations re doc) -- SText 5 "lorem" (SChar ' ' (SAnnPush "FOO" (SAnnPush "BAR" (SText 5 "ipsum" (SAnnPop (SAnnPop (SChar ' ' (SText 5 "dolor" SEmpty)))))))) -- | Remove all annotations. 'unAnnotate' for 'SimpleDocStream'. unAnnotateS :: SimpleDocStream ann -> SimpleDocStream xxx unAnnotateS = go where go = \doc -> case doc of SFail -> SFail SEmpty -> SEmpty SChar c rest -> SChar c (go rest) SText l t rest -> SText l t (go rest) SLine l rest -> SLine l (go rest) SAnnPop rest -> go rest SAnnPush _ann rest -> go rest -- | Change the annotation of a document. 'reAnnotate' for 'SimpleDocStream'. reAnnotateS :: (ann -> ann') -> SimpleDocStream ann -> SimpleDocStream ann' reAnnotateS re = go where go = \doc -> case doc of SFail -> SFail SEmpty -> SEmpty SChar c rest -> SChar c (go rest) SText l t rest -> SText l t (go rest) SLine l rest -> SLine l (go rest) SAnnPop rest -> SAnnPop (go rest) SAnnPush ann rest -> SAnnPush (re ann) (go rest) data AnnotationRemoval = Remove | DontRemove deriving Typeable -- | Change the annotation of a document to a different annotation, or none at -- all. 'alterAnnotations' for 'SimpleDocStream'. -- -- Note that the 'Doc' version is more flexible, since it allows changing a -- single annotation to multiple ones. -- ('Prettyprinter.Render.Util.SimpleDocTree.SimpleDocTree' restores -- this flexibility again.) alterAnnotationsS :: (ann -> Maybe ann') -> SimpleDocStream ann -> SimpleDocStream ann' alterAnnotationsS re = go [] where -- We keep a stack of whether to remove a pop so that we can remove exactly -- the pops corresponding to annotations that mapped to Nothing. go stack = \sds -> case sds of SFail -> SFail SEmpty -> SEmpty SChar c rest -> SChar c (go stack rest) SText l t rest -> SText l t (go stack rest) SLine l rest -> SLine l (go stack rest) SAnnPush ann rest -> case re ann of Nothing -> go (Remove:stack) rest Just ann' -> SAnnPush ann' (go (DontRemove:stack) rest) SAnnPop rest -> case stack of [] -> panicPeekedEmpty DontRemove:stack' -> SAnnPop (go stack' rest) Remove:stack' -> go stack' rest -- | Fusion depth parameter, used by 'fuse'. data FusionDepth = -- | Do not dive deep into nested documents, fusing mostly concatenations of -- text nodes together. Shallow -- | Recurse into all parts of the 'Doc', including different layout -- alternatives, and location-sensitive values such as created by 'nesting' -- which cannot be fused before, but only during, the layout process. As a -- result, the performance cost of using deep fusion is often hard to -- predict, and depends on the interplay between page layout and document to -- prettyprint. -- -- This value should only be used if profiling shows it is significantly -- faster than using 'Shallow'. | Deep deriving (Eq, Ord, Show, Typeable) -- | @('fuse' depth doc)@ combines text nodes so they can be rendered more -- efficiently. A fused document is always laid out identical to its unfused -- version. -- -- When laying a 'Doc'ument out to a 'SimpleDocStream', every component of the -- input is translated directly to the simpler output format. This sometimes -- yields undesirable chunking when many pieces have been concatenated together. -- -- For example -- -- >>> "a" <> "b" <> pretty 'c' <> "d" -- abcd -- -- results in a chain of four entries in a 'SimpleDocStream', although this is fully -- equivalent to the tightly packed -- -- >>> "abcd" :: Doc ann -- abcd -- -- which is only a single 'SimpleDocStream' entry, and can be processed faster. -- -- It is therefore a good idea to run 'fuse' on concatenations of lots of small -- strings that are used many times: -- -- >>> let oftenUsed = fuse Shallow ("a" <> "b" <> pretty 'c' <> "d") -- >>> hsep (replicate 5 oftenUsed) -- abcd abcd abcd abcd abcd fuse :: FusionDepth -> Doc ann -> Doc ann fuse depth = go where go = \doc -> case doc of Cat Empty x -> go x Cat x Empty -> go x Cat (Char c1) (Char c2) -> Text 2 (T.singleton c1 <> T.singleton c2) Cat (Text lt t) (Char c) -> Text (lt+1) (T.snoc t c) Cat (Char c) (Text lt t) -> Text (1+lt) (T.cons c t) Cat (Text l1 t1) (Text l2 t2) -> Text (l1+l2) (t1 <> t2) Cat x@Char{} (Cat y@Char{} z) -> go (Cat (go (Cat x y)) z) Cat x@Text{} (Cat y@Char{} z) -> go (Cat (go (Cat x y)) z) Cat x@Char{} (Cat y@Text{} z) -> go (Cat (go (Cat x y)) z) Cat x@Text{} (Cat y@Text{} z) -> go (Cat (go (Cat x y)) z) Cat (Cat x y@Char{}) z -> go (Cat x (go (Cat y z))) Cat (Cat x y@Text{}) z -> go (Cat x (go (Cat y z))) Cat x y -> Cat (go x) (go y) Nest i (Nest j x) -> let !fused = Nest (i+j) x in go fused Nest _ x@Empty{} -> x Nest _ x@Text{} -> x Nest _ x@Char{} -> x Nest 0 x -> go x Nest i x -> Nest i (go x) Annotated ann x -> Annotated ann (go x) FlatAlt x1 x2 -> FlatAlt (go x1) (go x2) Union x1 x2 -> Union (go x1) (go x2) other | depth == Shallow -> other Column f -> Column (go . f) WithPageWidth f -> WithPageWidth (go . f) Nesting f -> Nesting (go . f) other -> other -- | The data type @SimpleDocStream@ represents laid out documents and is used -- by the display functions. -- -- A simplified view is that @'Doc' = ['SimpleDocStream']@, and the layout -- functions pick one of the 'SimpleDocStream's based on which one fits the -- layout constraints best. This means that 'SimpleDocStream' has all complexity -- contained in 'Doc' resolved, making it very easy to convert it to other -- formats, such as plain text or terminal output. -- -- To write your own @'Doc'@ to X converter, it is therefore sufficient to -- convert from @'SimpleDocStream'@. The »Render« submodules provide some -- built-in converters to do so, and helpers to create own ones. data SimpleDocStream ann = SFail | SEmpty | SChar !Char (SimpleDocStream ann) -- | 'T.length' is /O(n)/, so we cache it in the 'Int' field. | SText !Int !Text (SimpleDocStream ann) -- | @Int@ = indentation level for the (next) line | SLine !Int (SimpleDocStream ann) -- | Add an annotation to the remaining document. | SAnnPush ann (SimpleDocStream ann) -- | Remove a previously pushed annotation. | SAnnPop (SimpleDocStream ann) deriving (Eq, Ord, Show, Generic, Typeable) -- | 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. -- -- /Historical note:/ Since v1.7.0, 'layoutPretty' and 'layoutSmart' avoid -- producing the trailing whitespace that was the original motivation for -- creating 'removeTrailingWhitespace'. -- See for some background -- info. removeTrailingWhitespace :: SimpleDocStream ann -> SimpleDocStream ann removeTrailingWhitespace = go (RecordedWhitespace [] 0) where commitWhitespace :: [Int] -- Withheld lines -> Int -- Withheld spaces -> SimpleDocStream ann -> SimpleDocStream ann commitWhitespace is !n sds = case is of [] -> case n of 0 -> sds 1 -> SChar ' ' sds _ -> SText n (textSpaces n) sds (i:is') -> let !end = SLine (i + n) sds in prependEmptyLines is' end prependEmptyLines :: [Int] -> SimpleDocStream ann -> SimpleDocStream ann prependEmptyLines is sds0 = foldr (\_ sds -> SLine 0 sds) sds0 is go :: WhitespaceStrippingState -> SimpleDocStream ann -> SimpleDocStream ann -- 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 | 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 -> prependEmptyLines withheldLines SEmpty SChar c rest | c == ' ' -> go (RecordedWhitespace withheldLines (withheldSpaces+1)) rest | otherwise -> commitWhitespace 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 (RecordedWhitespace withheldLines (withheldSpaces + textLength)) rest else commitWhitespace withheldLines withheldSpaces (SText strippedLength stripped (go (RecordedWhitespace [] trailingLength) rest)) SLine i rest -> go (RecordedWhitespace (i:withheldLines) 0) rest SAnnPush ann rest -> commitWhitespace 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 = AnnotationLevel !Int | RecordedWhitespace [Int] !Int -- ^ [Newline with indentation i] Spaces deriving Typeable -- $ -- >>> import qualified Data.Text.IO as T -- >>> doc = "lorem" <> hardline <> hardline <> pretty "ipsum" -- >>> go = T.putStrLn . renderStrict . removeTrailingWhitespace . layoutPretty defaultLayoutOptions -- >>> go doc -- lorem -- -- ipsum -- | Alter the document’s annotations. -- -- This instance makes 'SimpleDocStream' more flexible (because it can be used in -- 'Functor'-polymorphic values), but @'fmap'@ is much less readable compared to -- using @'reAnnotateST'@ in code that only works for @'SimpleDocStream'@ anyway. -- Consider using the latter when the type does not matter. instance Functor SimpleDocStream where fmap = reAnnotateS -- | Collect all annotations from a document. instance Foldable SimpleDocStream where foldMap f = go where go = \sds -> case sds of SFail -> mempty SEmpty -> mempty SChar _ rest -> go rest SText _ _ rest -> go rest SLine _ rest -> go rest SAnnPush ann rest -> f ann `mappend` go rest SAnnPop rest -> go rest -- | Transform a document based on its annotations, possibly leveraging -- 'Applicative' effects. instance Traversable SimpleDocStream where traverse f = go where go = \sds -> case sds of SFail -> pure SFail SEmpty -> pure SEmpty SChar c rest -> SChar c <$> go rest SText l t rest -> SText l t <$> go rest SLine i rest -> SLine i <$> go rest SAnnPush ann rest -> SAnnPush <$> f ann <*> go rest SAnnPop rest -> SAnnPop <$> go rest -- | Decide whether a 'SimpleDocStream' fits the constraints given, namely -- -- - original indentation of the current line -- - current column -- - initial indentation of the alternative 'SimpleDocStream' if it -- starts with a line break (used by 'layoutSmart') -- - width in which to fit the first line newtype FittingPredicate ann = FittingPredicate (Int -> Int -> Maybe Int -> SimpleDocStream ann -> Bool) deriving Typeable -- | List of nesting level/document pairs yet to be laid out. data LayoutPipeline ann = Nil | Cons !Int (Doc ann) (LayoutPipeline ann) | UndoAnn (LayoutPipeline ann) deriving Typeable -- | Maximum number of characters that fit in one line. The layout algorithms -- will try not to exceed the set limit by inserting line breaks when applicable -- (e.g. via 'softline''). data PageWidth = AvailablePerLine !Int !Double -- ^ Layouters should not exceed the specified space per line. -- -- - The 'Int' is the number of characters, including whitespace, that -- fit in a line. A typical value is 80. -- -- - The 'Double' is the ribbon with, i.e. the fraction of the total -- page width that can be printed on. This allows limiting the length -- of printable text per line. Values must be between 0 and 1, and -- 0.4 to 1 is typical. | Unbounded -- ^ Layouters should not introduce line breaks on their own. deriving (Eq, Ord, Show, Typeable) defaultPageWidth :: PageWidth defaultPageWidth = AvailablePerLine 80 1 -- | The remaining width on the current line. remainingWidth :: Int -> Double -> Int -> Int -> Int remainingWidth lineLength ribbonFraction lineIndent currentColumn = min columnsLeftInLine columnsLeftInRibbon where columnsLeftInLine = lineLength - currentColumn columnsLeftInRibbon = lineIndent + ribbonWidth - currentColumn ribbonWidth = (max 0 . min lineLength . floor) (fromIntegral lineLength * ribbonFraction) -- $ Test to avoid surprising behaviour -- >>> Unbounded > AvailablePerLine maxBound 1 -- True -- | Options to influence the layout algorithms. newtype LayoutOptions = LayoutOptions { layoutPageWidth :: PageWidth } deriving (Eq, Ord, Show, Typeable) -- | The default layout options, suitable when you just want some output, and -- don’t particularly care about the details. Used by the 'Show' instance, for -- example. -- -- >>> defaultLayoutOptions -- LayoutOptions {layoutPageWidth = AvailablePerLine 80 1.0} defaultLayoutOptions :: LayoutOptions defaultLayoutOptions = LayoutOptions { layoutPageWidth = defaultPageWidth } -- | This is the default layout algorithm, and it is used by 'show', 'putDoc' -- and 'hPutDoc'. -- -- @'layoutPretty'@ commits to rendering something in a certain way if the next -- element fits the layout constraints; in other words, it has one -- 'SimpleDocStream' element lookahead when rendering. Consider using the -- smarter, but a bit less performant, @'layoutSmart'@ algorithm if the results -- seem to run off to the right before having lots of line breaks. layoutPretty :: LayoutOptions -> Doc ann -> SimpleDocStream ann layoutPretty (LayoutOptions pageWidth_@(AvailablePerLine lineLength ribbonFraction)) = layoutWadlerLeijen (FittingPredicate (\lineIndent currentColumn _initialIndentY sdoc -> fits (remainingWidth lineLength ribbonFraction lineIndent currentColumn) sdoc)) pageWidth_ where fits :: Int -- ^ Width in which to fit the first line -> SimpleDocStream ann -> Bool fits w _ | w < 0 = False fits _ SFail = False fits _ SEmpty = True fits w (SChar _ x) = fits (w - 1) x fits w (SText l _t x) = fits (w - l) x fits _ SLine{} = True fits w (SAnnPush _ x) = fits w x fits w (SAnnPop x) = fits w x layoutPretty (LayoutOptions Unbounded) = layoutUnbounded -- | A layout algorithm with more lookahead than 'layoutPretty', that introduces -- line breaks earlier if the content does not (or will not, rather) fit into -- one line. -- -- Consider the following python-ish document, -- -- >>> let fun x = hang 2 ("fun(" <> softline' <> x) <> ")" -- >>> let doc = (fun . fun . fun . fun . fun) (align (list ["abcdef", "ghijklm"])) -- -- which we’ll be rendering using the following pipeline (where the layout -- algorithm has been left open): -- -- >>> import Data.Text.IO as T -- >>> import Prettyprinter.Render.Text -- >>> let hr = pipe <> pretty (replicate (26-2) '-') <> pipe -- >>> let go layouter x = (T.putStrLn . renderStrict . layouter (LayoutOptions (AvailablePerLine 26 1))) (vsep [hr, x, hr]) -- -- If we render this using 'layoutPretty' with a page width of 26 characters -- per line, all the @fun@ calls fit into the first line so they will be put -- there: -- -- >>> go layoutPretty doc -- |------------------------| -- fun(fun(fun(fun(fun( -- [ abcdef -- , ghijklm ]))))) -- |------------------------| -- -- Note that this exceeds the desired 26 character page width. The same -- document, rendered with @'layoutSmart'@, fits the layout contstraints: -- -- >>> go layoutSmart doc -- |------------------------| -- fun( -- fun( -- fun( -- fun( -- fun( -- [ abcdef -- , ghijklm ]))))) -- |------------------------| -- -- The key difference between 'layoutPretty' and 'layoutSmart' is that the -- latter will check the potential document until it encounters a line with the -- same indentation or less than the start of the document. Any line encountered -- earlier is assumed to belong to the same syntactic structure. -- 'layoutPretty' checks only the first line. -- -- Consider for example the question of whether the @A@s fit into the document -- below: -- -- > 1 A -- > 2 A -- > 3 A -- > 4 B -- > 5 B -- -- 'layoutPretty' will check only line 1, ignoring whether e.g. line 2 might -- already be too wide. -- By contrast, 'layoutSmart' stops only once it reaches line 4, where the @B@ -- has the same indentation as the first @A@. layoutSmart :: LayoutOptions -> Doc ann -> SimpleDocStream ann layoutSmart (LayoutOptions pageWidth_@(AvailablePerLine lineLength ribbonFraction)) = layoutWadlerLeijen (FittingPredicate fits) pageWidth_ where -- Why doesn't layoutSmart simply check the entire document? -- -- 1. That would be very expensive. -- 2. In that case the layout of a particular part of a document would -- depend on the fit of completely unrelated parts of the same document. -- See https://github.com/quchen/prettyprinter/issues/83 for a related -- bug. fits :: Int -> Int -> Maybe Int -> SimpleDocStream ann -> Bool fits lineIndent currentColumn initialIndentY = go availableWidth where go w _ | w < 0 = False go _ SFail = False go _ SEmpty = True go w (SChar _ x) = go (w - 1) x go w (SText l _t x) = go (w - l) x go _ (SLine i x) | minNestingLevel < i = go (lineLength - i) x -- TODO: Take ribbon width into account?! (#142) | otherwise = True go w (SAnnPush _ x) = go w x go w (SAnnPop x) = go w x availableWidth = remainingWidth lineLength ribbonFraction lineIndent currentColumn minNestingLevel = -- See the Note -- [Choosing the right minNestingLevel for consistent smart layouts] case initialIndentY of Just i -> -- y could be a (less wide) hanging layout. If so, let's -- check x a bit more thoroughly so we don't miss a potentially -- better fitting y. min i currentColumn Nothing -> -- y definitely isn't a hanging layout. Let's check x with the -- same minNestingLevel that any subsequent lines with the same -- indentation use. currentColumn layoutSmart (LayoutOptions Unbounded) = layoutUnbounded -- | Layout a document with @Unbounded@ page width. layoutUnbounded :: Doc ann -> SimpleDocStream ann layoutUnbounded = layoutWadlerLeijen (FittingPredicate (\_lineIndent _currentColumn _initialIndentY sdoc -> not (failsOnFirstLine sdoc))) Unbounded where -- See the Note [Detecting failure with Unbounded page width]. failsOnFirstLine :: SimpleDocStream ann -> Bool failsOnFirstLine = go where go sds = case sds of SFail -> True SEmpty -> False SChar _ s -> go s SText _ _ s -> go s SLine _ _ -> False SAnnPush _ s -> go s SAnnPop s -> go s -- | The Wadler/Leijen layout algorithm layoutWadlerLeijen :: forall ann. FittingPredicate ann -> PageWidth -> Doc ann -> SimpleDocStream ann layoutWadlerLeijen (FittingPredicate fits) pageWidth_ doc = best 0 0 (Cons 0 doc Nil) where -- * current column >= current nesting level -- * current column - current indentaion = number of chars inserted in line best :: Int -- Current nesting level -> Int -- Current column, i.e. "where the cursor is" -> LayoutPipeline ann -- Documents remaining to be handled (in order) -> SimpleDocStream ann best !_ !_ Nil = SEmpty best nl cc (UndoAnn ds) = SAnnPop (best nl cc ds) best nl cc (Cons i d ds) = case d of Fail -> SFail Empty -> best nl cc ds Char c -> let !cc' = cc+1 in SChar c (best nl cc' ds) Text l t -> let !cc' = cc+l in SText l t (best nl cc' ds) Line -> let x = best i i ds -- Don't produce indentation if there's no -- following text on the same line. -- This prevents trailing whitespace. i' = case x of SEmpty -> 0 SLine{} -> 0 _ -> i in SLine i' x FlatAlt x _ -> best nl cc (Cons i x ds) Cat x y -> best nl cc (Cons i x (Cons i y ds)) Nest j x -> let !ij = i+j in best nl cc (Cons ij x ds) Union x y -> let x' = best nl cc (Cons i x ds) y' = best nl cc (Cons i y ds) in selectNicer nl cc x' y' Column f -> best nl cc (Cons i (f cc) ds) WithPageWidth f -> best nl cc (Cons i (f pageWidth_) ds) Nesting f -> best nl cc (Cons i (f i) ds) Annotated ann x -> SAnnPush ann (best nl cc (Cons i x (UndoAnn ds))) -- Select the better fitting of two documents: -- Choice A if it fits, otherwise choice B. -- -- The fit of choice B is /not/ checked! It is ultimately the user's -- responsibility to provide an alternative that can fit the page even when -- choice A doesn't. selectNicer :: Int -- ^ Current nesting level -> Int -- ^ Current column -> SimpleDocStream ann -- ^ Choice A. -> SimpleDocStream ann -- ^ Choice B. Should fit more easily -- (== be less wide) than choice A. -> SimpleDocStream ann -- ^ Choice A if it fits, otherwise B. selectNicer lineIndent currentColumn x y | fits lineIndent currentColumn (initialIndentation y) x = x | otherwise = y initialIndentation :: SimpleDocStream ann -> Maybe Int initialIndentation sds = case sds of SLine i _ -> Just i SAnnPush _ s -> initialIndentation s SAnnPop s -> initialIndentation s _ -> Nothing {- Note [Choosing the right minNestingLevel for consistent smart layouts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this document: doc = "Groceries: " <> align (cat [ sep ["pommes", "de", "terre"] , "apples" , "Donaudampfschifffahrtskapitänskajütenmülleimer" ] ) ... and assume we want to fit it into 40 columns as nicely as possible: opts = LayoutOptions (AvailablePerLine 40 1) We already have bad luck with the last item – it's longer than 40 characters on its own! We'd still like the first item, pommes de terre, to be laid out nicely, that is, on one line, since it's not too wide. This is what we'd like to see: Groceries: pommes de terre apples Donaudampfschifffahrtskapitänskajütenmülleimer Before #83 was fixed, that wasn't what we got! Instead we got this: > renderIO stdout $ layoutSmart opts doc Groceries: pommes de terre apples Donaudampfschifffahrtskapitänskajütenmülleimer Why? minNestingLevel was effectively defined as minNestingLevel = lineIndent The lineIndent for "pommes de terre" is 0. The FittingPredicate for layoutSmart will continue to check the rest of the document until it finds a line where the indentation <= minNestingLevel. In this case this meant that layoutSmart would traverse all the items, and note that the last item, Donaudampfschifffahrtskapitänskajütenmülleimer, doesn't fit into the available space! The "flatter" version of the document has failed, so "pommes de terre" gets spread over several lines! Obviously this would be an inconsistency with the layout of the other items. Their lineIndent is 11 each, so for them, the FittingPredicate stops already on the next line. The obvious solution is to change the definition of minNestingLevel: minNestingLevel = currentColumn This however breaks the "python-ish" document from the documentation for layoutSmart: expected: |------------------------| fun( fun( fun( fun( fun( [ abcdef , ghijklm ]))))) |------------------------| but got: |------------------------| fun( fun( fun( fun( fun([ abcdef , ghijklm ]))))) |------------------------| We now accept the worse layout because the problematic last line has the same indentation as the current column of "[ abcdef", so we don't check it! The solution we went with in the end is a bit of a hack: We check whether the alternative, "high" layout is a (potentially less wide) hanging layout, and in that case pick its indentation as the minNestingLevel. This way we achieve the optimal layout in both scenarios. See https://github.com/quchen/prettyprinter/issues/83 for the bug that lead to the current solution. Note [Detecting failure with Unbounded page width] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ To understand why it is sufficient to check the first line of the SimpleDocStream, trace how an SFail ends up there: 1. We group a Doc containing a hard linebreak (hardline), producing a (Union x y) where x contains Fail. 2. In layoutWadlerLeijen.best, any Unions are handled recursively, rejecting any alternatives that would result in SFail. So once a SimpleDocStream reaches selectNicer, any SFail in it must appear before the first linebreak – any other SFail would have been detected and rejected in a previous iteration. -} -- | @(layoutCompact x)@ lays out the document @x@ without adding any -- indentation and without preserving annotations. -- Since no \'pretty\' printing is involved, this layouter is very -- fast. The resulting output contains fewer characters than a prettyprinted -- version and can be used for output that is read by other programs. -- -- >>> let doc = hang 4 (vsep ["lorem", "ipsum", hang 4 (vsep ["dolor", "sit"])]) -- >>> doc -- lorem -- ipsum -- dolor -- sit -- -- >>> let putDocCompact = renderIO System.IO.stdout . layoutCompact -- >>> putDocCompact doc -- lorem -- ipsum -- dolor -- sit layoutCompact :: Doc ann1 -> SimpleDocStream ann2 layoutCompact doc = scan 0 [doc] where scan _ [] = SEmpty scan !col (d:ds) = case d of Fail -> SFail Empty -> scan col ds Char c -> SChar c (scan (col+1) ds) Text l t -> let !col' = col+l in SText l t (scan col' ds) FlatAlt x _ -> scan col (x:ds) Line -> SLine 0 (scan 0 ds) Cat x y -> scan col (x:y:ds) Nest _ x -> scan col (x:ds) Union _ y -> scan col (y:ds) Column f -> scan col (f col:ds) WithPageWidth f -> scan col (f Unbounded : ds) Nesting f -> scan col (f 0 : ds) Annotated _ x -> scan col (x:ds) -- | @('show' doc)@ prettyprints document @doc@ with 'defaultLayoutOptions', -- ignoring all annotations. instance Show (Doc ann) where showsPrec _ doc = renderShowS (layoutPretty defaultLayoutOptions doc) -- | Render a 'SimpleDocStream' to a 'ShowS', useful to write 'Show' instances -- based on the prettyprinter. -- -- @ -- instance 'Show' MyType where -- 'showsPrec' _ = 'renderShowS' . 'layoutPretty' 'defaultLayoutOptions' . 'pretty' -- @ renderShowS :: SimpleDocStream ann -> ShowS renderShowS = \sds -> case sds of SFail -> panicUncaughtFail SEmpty -> id SChar c x -> showChar c . renderShowS x SText _l t x -> showString (T.unpack t) . renderShowS x SLine i x -> showString ('\n' : replicate i ' ') . renderShowS x SAnnPush _ x -> renderShowS x SAnnPop x -> renderShowS x -- | A utility for producing indentation etc. -- -- >>> textSpaces 3 -- " " -- -- This produces much better Core than the equivalent -- -- > T.replicate n " " -- -- (See .) textSpaces :: Int -> Text textSpaces n = T.replicate n (T.singleton ' ') -- $setup -- -- (Definitions for the doctests) -- -- >>> :set -XOverloadedStrings -- >>> import Prettyprinter.Render.Text -- >>> import Prettyprinter.Symbols.Ascii -- >>> import Prettyprinter.Util as Util -- >>> import Test.QuickCheck.Modifiers prettyprinter-1.7.1/src/Prettyprinter/Internal/0000755000000000000000000000000007346545000020102 5ustar0000000000000000prettyprinter-1.7.1/src/Prettyprinter/Internal/Debug.hs0000644000000000000000000000562307346545000021472 0ustar0000000000000000-- | __Warning: internal module!__ This means that the API may change -- arbitrarily between versions without notice. Depending on this module may -- lead to unexpected breakages, so proceed with caution! -- -- This module provides debugging helpers for inspecting 'Doc's. -- -- Use the @pretty-simple@ package to get a nicer layout for 'show'n -- 'Diag's: -- -- > > Text.Pretty.Simple.pPrintNoColor . diag $ align (vcat ["foo", "bar"]) -- > Column -- > [ -- > ( 10 -- > , Nesting -- > [ -- > ( 10 -- > , Cat ( Text 3 "foo" ) -- > ( Cat ( FlatAlt Line Empty ) ( Text 3 "bar" ) ) -- > ) -- > ] -- > ) -- > ] module Prettyprinter.Internal.Debug where import Data.Text (Text) import Prettyprinter.Internal (PageWidth, Doc) import qualified Prettyprinter.Internal as Doc -- | A variant of 'Doc' for debugging. -- -- Unlike in the 'Doc' type, the 'Column', 'WithPageWidth' and 'Nesting' -- constructors don't contain functions but are \"sampled\" to allow -- simple inspection with 'show'. data Diag ann = Fail | Empty | Char !Char | Text !Int !Text | Line | FlatAlt (Diag ann) (Diag ann) | Cat (Diag ann) (Diag ann) | Nest !Int (Diag ann) | Union (Diag ann) (Diag ann) | Column [(Int, Diag ann)] -- ^ 'Doc': @(Int -> Diag ann)@ | WithPageWidth [(PageWidth, Diag ann)] -- ^ 'Doc': @(PageWidth -> Diag ann)@ | Nesting [(Int, Diag ann)] -- ^ 'Doc': @(Int -> Diag ann)@ | Annotated ann (Diag ann) deriving Show -- | Convert a 'Doc' to its diagnostic representation. -- -- The functions in the 'Column', 'WithPageWidth' and 'Nesting' constructors are -- sampled with some default values. -- -- Use `diag'` to control the function inputs yourself. -- -- >>> diag $ Doc.align (Doc.vcat ["foo", "bar"]) -- Column [(10,Nesting [(10,Cat (Text 3 "foo") (Cat (FlatAlt Line Empty) (Text 3 "bar")))])] diag :: Doc ann -> Diag ann diag = diag' [10] [Doc.defaultPageWidth] [10] diag' :: [Int] -- ^ Cursor positions for the 'Column' constructor -> [PageWidth] -- ^ For 'WithPageWidth' -> [Int] -- ^ Nesting levels for 'Nesting' -> Doc ann -> Diag ann diag' columns pageWidths nestings = go where go doc = case doc of Doc.Fail -> Fail Doc.Empty -> Empty Doc.Char c -> Char c Doc.Text l t -> Text l t Doc.Line -> Line Doc.FlatAlt a b -> FlatAlt (go a) (go b) Doc.Cat a b -> Cat (go a) (go b) Doc.Nest i d -> Nest i (go d) Doc.Union a b -> Union (go a) (go b) Doc.Column f -> Column (apply f columns) Doc.WithPageWidth f -> WithPageWidth (apply f pageWidths) Doc.Nesting f -> Nesting (apply f nestings) Doc.Annotated ann d -> Annotated ann (go d) apply :: (a -> Doc ann) -> [a] -> [(a, Diag ann)] apply f = map (\x -> (x, go (f x))) prettyprinter-1.7.1/src/Prettyprinter/Internal/Type.hs0000644000000000000000000000106307346545000021357 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} -- | __Internal module with stability guarantees__ -- -- This module exposes the internals of the @'Doc'@ type so other libraries can -- write adaptors to/from it. For all other uses, please use only the API -- provided by non-internal modules. -- -- Although this module is internal, it follows the usual package versioning -- policy, AKA Haskell’s version of semantic versioning. In other words, this -- module is as stable as the public API. module Prettyprinter.Internal.Type (Doc(..)) where import Prettyprinter.Internal prettyprinter-1.7.1/src/Prettyprinter/Render/0000755000000000000000000000000007346545000017545 5ustar0000000000000000prettyprinter-1.7.1/src/Prettyprinter/Render/String.hs0000644000000000000000000000041607346545000021350 0ustar0000000000000000module Prettyprinter.Render.String ( renderString, renderShowS, ) where import Prettyprinter.Internal (SimpleDocStream, renderShowS) -- | Render a 'SimpleDocStream' to a 'String'. renderString :: SimpleDocStream ann -> String renderString s = renderShowS s "" prettyprinter-1.7.1/src/Prettyprinter/Render/Text.hs0000644000000000000000000000723007346545000021027 0ustar0000000000000000{-# LANGUAGE CPP #-} #include "version-compatibility-macros.h" -- | Render an unannotated 'SimpleDocStream' as plain 'Text'. module Prettyprinter.Render.Text ( #ifdef MIN_VERSION_text -- * Conversion to plain 'Text' renderLazy, renderStrict, #endif -- * Render to a 'Handle' renderIO, -- ** Convenience functions putDoc, hPutDoc ) where import Data.Text (Text) import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB import System.IO import Prettyprinter import Prettyprinter.Internal import Prettyprinter.Render.Util.Panic #if !(SEMIGROUP_IN_BASE) import Data.Semigroup #endif #if !(APPLICATIVE_MONAD) import Control.Applicative #endif -- $setup -- -- (Definitions for the doctests) -- -- >>> :set -XOverloadedStrings -- >>> import qualified Data.Text.IO as T -- >>> import qualified Data.Text.Lazy.IO as TL -- | @('renderLazy' sdoc)@ takes the output @sdoc@ from a rendering function -- and transforms it to lazy text. -- -- >>> let render = TL.putStrLn . renderLazy . layoutPretty defaultLayoutOptions -- >>> let doc = "lorem" <+> align (vsep ["ipsum dolor", parens "foo bar", "sit amet"]) -- >>> render doc -- lorem ipsum dolor -- (foo bar) -- sit amet renderLazy :: SimpleDocStream ann -> TL.Text renderLazy = TLB.toLazyText . go where go x = case x of SFail -> panicUncaughtFail SEmpty -> mempty SChar c rest -> TLB.singleton c <> go rest SText _l t rest -> TLB.fromText t <> go rest SLine i rest -> TLB.singleton '\n' <> (TLB.fromText (textSpaces i) <> go rest) SAnnPush _ann rest -> go rest SAnnPop rest -> go rest -- | @('renderStrict' sdoc)@ takes the output @sdoc@ from a rendering function -- and transforms it to strict text. renderStrict :: SimpleDocStream ann -> Text renderStrict = TL.toStrict . renderLazy -- | @('renderIO' h sdoc)@ writes @sdoc@ to the file @h@. -- -- >>> 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 = go where go :: SimpleDocStream ann -> IO () go = \sds -> case sds of 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 (textSpaces n) go rest SAnnPush _ann rest -> go rest SAnnPop rest -> go rest -- | @('putDoc' doc)@ prettyprints document @doc@ to standard output. Uses the -- 'defaultLayoutOptions'. -- -- >>> putDoc ("hello" <+> "world") -- hello world -- -- @ -- 'putDoc' = 'hPutDoc' 'stdout' -- @ putDoc :: Doc ann -> IO () putDoc = hPutDoc stdout -- | Like 'putDoc', but instead of using 'stdout', print to a user-provided -- handle, e.g. a file or a socket. Uses the 'defaultLayoutOptions'. -- -- @ -- main = 'withFile' filename (\h -> 'hPutDoc' h doc) -- where -- doc = 'vcat' ["vertical", "text"] -- filename = "someFile.txt" -- @ -- -- @ -- 'hPutDoc' h doc = 'renderIO' h ('layoutPretty' 'defaultLayoutOptions' doc) -- @ hPutDoc :: Handle -> Doc ann -> IO () hPutDoc h doc = renderIO h (layoutPretty defaultLayoutOptions doc) prettyprinter-1.7.1/src/Prettyprinter/Render/Tutorials/0000755000000000000000000000000007346545000021533 5ustar0000000000000000prettyprinter-1.7.1/src/Prettyprinter/Render/Tutorials/StackMachineTutorial.hs0000644000000000000000000001357107346545000026154 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} #include "version-compatibility-macros.h" -- | This module shows how to write a custom prettyprinter backend, based on -- directly converting a 'SimpleDocStream' to an output format using a stack -- machine. For a tree serialization approach, which may be more suitable for -- certain output formats, see -- "Prettyprinter.Render.Tutorials.TreeRenderingTutorial". -- -- Rendering to ANSI terminal with colors is an important use case for stack -- machine based rendering. -- -- The module is written to be readable top-to-bottom in both Haddock and raw -- source form. module Prettyprinter.Render.Tutorials.StackMachineTutorial {-# DEPRECATED "Writing your own stack machine is probably more efficient and customizable; also consider using »renderSimplyDecorated(A)« instead" #-} where import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB import Prettyprinter import Prettyprinter.Internal import Prettyprinter.Render.Util.Panic import Prettyprinter.Render.Util.StackMachine #if !(APPLICATIVE_MONAD) import Control.Applicative #endif -- * The type of available markup -- -- $standalone-text -- -- First, we define a set of valid annotations must be defined, with the goal of -- defining a @'Doc' 'SimpleHtml'@. We will later define how to convert this to -- the output format ('TL.Text'). data SimpleHtml = Bold | Italics | Color Color | Paragraph | Headline data Color = Red | Green | Blue -- ** Convenience definitions bold, italics, paragraph, headline :: Doc SimpleHtml -> Doc SimpleHtml bold = annotate Bold italics = annotate Italics paragraph = annotate Paragraph headline = annotate Headline color :: Color -> Doc SimpleHtml -> Doc SimpleHtml color c = annotate (Color c) -- * The rendering algorithm -- -- $standalone-text -- -- With the annotation definitions out of the way, we can now define a -- conversion function from 'SimpleDocStream' annotated with our 'SimpleHtml' to the -- final 'TL.Text' representation. -- -- There are two ways to render this; the simpler one is just using -- 'renderSimplyDecorated'. However, some output formats require more -- complicated functionality, so we explore this explicitly with a simple -- example below. An example for something more complicated is ANSI terminal -- rendering, where on popping we need to regenerate the previous style, -- requiring a pop (discard current style) followed by a peek (regenerate -- previous style). -- | The 'StackMachine' type defines a stack machine suitable for many rendering -- needs. It has two auxiliary parameters: the type of the end result, and the -- type of the document’s annotations. -- -- Most 'StackMachine' creations will look like this definition: a recursive -- walk through the 'SimpleDocStream', pushing styles on the stack and popping -- them off again, and writing raw output. -- -- The equivalent to this in the tree based rendering approach is -- 'Prettyprinter.Render.Tutorials.TreeRenderingTutorial.renderTree'. renderStackMachine :: SimpleDocStream SimpleHtml -> StackMachine TLB.Builder SimpleHtml () renderStackMachine = \sds -> case sds of SFail -> panicUncaughtFail SEmpty -> pure () SChar c x -> do writeOutput (TLB.singleton c) renderStackMachine x SText _l t x -> do writeOutput (TLB.fromText t) renderStackMachine x SLine i x -> do writeOutput (TLB.singleton '\n') writeOutput (TLB.fromText (textSpaces i)) renderStackMachine x SAnnPush s x -> do pushStyle s writeOutput (fst (htmlTag s)) renderStackMachine x SAnnPop x -> do s <- unsafePopStyle writeOutput (snd (htmlTag s)) renderStackMachine x -- | Convert a 'SimpleHtml' annotation to a pair of opening and closing tags. -- This is where the translation of style to raw output happens. htmlTag :: SimpleHtml -> (TLB.Builder, TLB.Builder) htmlTag = \sh -> case sh of Bold -> ("", "") Italics -> ("", "") Color c -> (" hexCode c <> "\">", "") Paragraph -> ("

", "

") Headline -> ("

", "

") where hexCode :: Color -> TLB.Builder hexCode = \c -> case c of Red -> "#f00" Green -> "#0f0" Blue -> "#00f" -- | We can now wrap our stack machine definition from 'renderStackMachine' in a -- nicer interface; on successful conversion, we run the builder to give us the -- final 'TL.Text', and before we do that we check that the style stack is empty -- (i.e. there are no unmatched style applications) after the machine is run. -- -- This function does only a bit of plumbing around 'renderStackMachine', and is -- the main API function of a stack machine renderer. The tree renderer -- equivalent to this is -- 'Prettyprinter.Render.Tutorials.TreeRenderingTutorial.render'. render :: SimpleDocStream SimpleHtml -> TL.Text render doc = let (resultBuilder, remainingStyles) = execStackMachine [] (renderStackMachine doc) in if null remainingStyles then TLB.toLazyText resultBuilder else error ("There are " <> show (length remainingStyles) <> " unpaired styles! Please report this as a bug.") -- * Example invocation -- -- $standalone-text -- -- We can now render an example document using our definitions: -- -- >>> :set -XOverloadedStrings -- >>> import qualified Data.Text.Lazy.IO as TL -- >>> :{ -- >>> let go = TL.putStrLn . render . layoutPretty defaultLayoutOptions -- >>> in go (vsep -- >>> [ headline "Example document" -- >>> , paragraph ("This is a" <+> color Red "paragraph" <> comma) -- >>> , paragraph ("and" <+> bold "this text is bold.") -- >>> ]) -- >>> :} --

Example document

--

This is a paragraph,

--

and this text is bold.

prettyprinter-1.7.1/src/Prettyprinter/Render/Tutorials/TreeRenderingTutorial.hs0000644000000000000000000001134407346545000026353 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} #include "version-compatibility-macros.h" -- | This module shows how to write a custom prettyprinter backend, based on a -- tree representation of a 'SimpleDocStream'. For a stack machine approach, which -- may be more suitable for certain output formats, see -- "Prettyprinter.Render.Tutorials.StackMachineTutorial". -- -- Rendering to HTML, particularly using libraries such as blaze-html or lucid, -- is one important use case of tree-based rendering. -- -- The module is written to be readable top-to-bottom in both Haddock and raw -- source form. module Prettyprinter.Render.Tutorials.TreeRenderingTutorial where import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB import Prettyprinter import Prettyprinter.Internal import Prettyprinter.Render.Util.SimpleDocTree #if !(FOLDABLE_TRAVERSABLE_IN_PRELUDE) import Data.Foldable (foldMap) #endif #if !(SEMIGROUP_MONOID_SUPERCLASS) import Data.Semigroup #endif -- * The type of available markup -- -- $standalone-text -- -- First, we define a set of valid annotations must be defined, with the goal of -- defining a @'Doc' 'SimpleHtml'@. We will later define how to convert this to -- the output format ('TL.Text'). data SimpleHtml = Bold | Italics | Color Color | Paragraph | Headline data Color = Red | Green | Blue -- ** Convenience definitions bold, italics, paragraph, headline :: Doc SimpleHtml -> Doc SimpleHtml bold = annotate Bold italics = annotate Italics paragraph = annotate Paragraph headline = annotate Headline color :: Color -> Doc SimpleHtml -> Doc SimpleHtml color c = annotate (Color c) -- * The rendering algorithm -- -- $standalone-text -- -- With the annotation definitions out of the way, we can now define a -- conversion function from 'SimpleDocStream' (annotated with our 'SimpleHtml') -- to the tree-shaped 'SimpleDocTree', which is easily convertible to a -- HTML/'Text' representation. -- -- There are two ways to render this; the simpler one is just using -- 'renderSimplyDecorated'. However, some output formats require more -- complicated functionality, so we explore this explicitly with a simple -- example below. An example for something more complicated is e.g. an XHTML -- renderer, where a newline may not simply be a newline character followed by a -- certain number of spaces, but e.g. involve adding a @
@ tag. -- | To render the HTML, we first convert the 'SimpleDocStream' to the -- 'SimpleDocTree' format, which makes enveloping sub-documents in markup -- easier. -- -- This function is the entry main API function of the renderer; as such, it is -- only glue for the internal functions. This is similar to -- 'Prettyprinter.Render.Tutorials.StackMachineTutorial.render' from -- the stack machine tutorial in its purpose. render :: SimpleDocStream SimpleHtml -> TL.Text render = TLB.toLazyText . renderTree . treeForm -- | Render a 'SimpleDocTree' to a 'TLB.Builder'; this is the workhorse of the -- tree-based rendering approach, and equivalent to -- 'Prettyprinter.Render.Tutorials.StackMachineTutorial.renderStackMachine' -- in the stack machine rendering tutorial. renderTree :: SimpleDocTree SimpleHtml -> TLB.Builder renderTree sds = case sds of STEmpty -> mempty STChar c -> TLB.singleton c STText _ t -> TLB.fromText t STLine i -> "\n" <> TLB.fromText (textSpaces i) STAnn ann content -> encloseInTagFor ann (renderTree content) STConcat contents -> foldMap renderTree contents -- | Convert a 'SimpleHtml' to a function that encloses a 'TLB.Builder' in HTML -- tags. This is where the translation of style to raw output happens. encloseInTagFor :: SimpleHtml -> TLB.Builder -> TLB.Builder encloseInTagFor sh = case sh of Bold -> \x -> "" <> x <> "" Italics -> \x -> "" <> x <> "" Color c -> \x -> " hexCode c <> "\">" <> x <> "" Paragraph -> \x -> "

" <> x <> "

" Headline -> \x -> "

" <> x <> "

" where hexCode :: Color -> TLB.Builder hexCode c = case c of Red -> "#f00" Green -> "#0f0" Blue -> "#00f" -- * Example invocation -- -- $standalone-text -- -- We can now render an example document using our definitions: -- -- >>> :set -XOverloadedStrings -- >>> import qualified Data.Text.Lazy.IO as TL -- >>> :{ -- >>> let go = TL.putStrLn . render . layoutPretty defaultLayoutOptions -- >>> in go (vsep -- >>> [ headline "Example document" -- >>> , paragraph ("This is a" <+> color Red "paragraph" <> comma) -- >>> , paragraph ("and" <+> bold "this text is bold.") -- >>> ]) -- >>> :} --

Example document

--

This is a paragraph,

--

and this text is bold.

prettyprinter-1.7.1/src/Prettyprinter/Render/Util/0000755000000000000000000000000007346545000020462 5ustar0000000000000000prettyprinter-1.7.1/src/Prettyprinter/Render/Util/Panic.hs0000644000000000000000000000312707346545000022053 0ustar0000000000000000module Prettyprinter.Render.Util.Panic ( panicUncaughtFail, panicUnpairedPop, panicSimpleDocTreeConversionFailed, panicInputNotFullyConsumed, panicPeekedEmpty, panicPoppedEmpty, ) where -- | Raise a hard 'error' if there is a 'Prettyprinter.SFail' in a -- 'Prettyprinter.SimpleDocStream'. panicUncaughtFail :: void panicUncaughtFail = error ("»SFail« must not appear in a rendered »SimpleDocStream«. This is a bug in the layout algorithm! " ++ report) -- | Raise a hard 'error' when an annotation terminator is encountered in an -- unannotated region. panicUnpairedPop :: void panicUnpairedPop = error ("An unpaired style terminator was encountered. This is a bug in the layout algorithm! " ++ report) -- | Raise a hard generic 'error' when the -- 'Prettyprinter.SimpleDocStream' to -- 'Prettyprinter.Render.Util.SimpleDocTree.SimpleDocTree' conversion fails. panicSimpleDocTreeConversionFailed :: void panicSimpleDocTreeConversionFailed = error ("Conversion from SimpleDocStream to SimpleDocTree failed! " ++ report) -- | Raise a hard 'error' when the »to -- 'Prettyprinter.Render.Util.SimpleDocTree.SimpleDocTree'« parser finishes -- without consuming the full input. panicInputNotFullyConsumed :: void panicInputNotFullyConsumed = error ("Conversion from SimpleDocStream to SimpleDocTree left unconsumed input! " ++ report) report :: String report = "Please report this as a bug" panicPeekedEmpty, panicPoppedEmpty :: void (panicPeekedEmpty, panicPoppedEmpty) = (mkErr "Peeked", mkErr "Popped") where mkErr x = error (x ++ " an empty style stack! Please report this as a bug.") prettyprinter-1.7.1/src/Prettyprinter/Render/Util/SimpleDocTree.hs0000644000000000000000000002246707346545000023530 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} #include "version-compatibility-macros.h" -- | Conversion of the linked-list-like 'SimpleDocStream' to a tree-like -- 'SimpleDocTree'. module Prettyprinter.Render.Util.SimpleDocTree ( -- * Type and conversion SimpleDocTree(..), treeForm, -- * Manipulating annotations unAnnotateST, reAnnotateST, alterAnnotationsST, -- * Common use case shortcut definitions renderSimplyDecorated, renderSimplyDecoratedA, ) where import Control.Applicative import Data.Text (Text) import qualified Data.Text as T import Data.Typeable (Typeable) import GHC.Generics import Prettyprinter import Prettyprinter.Internal import Prettyprinter.Render.Util.Panic import qualified Control.Monad.Fail as Fail #if !(MONOID_IN_PRELUDE) import Data.Monoid (Monoid (..)) #endif #if !(FOLDABLE_TRAVERSABLE_IN_PRELUDE) import Data.Foldable (Foldable (..)) import Data.Traversable (Traversable (..)) #endif -- $setup -- -- (Definitions for the doctests) -- -- >>> import Prettyprinter hiding ((<>)) -- >>> import qualified Data.Text.IO as T -- | Simplest possible tree-based renderer. -- -- For example, here is a document annotated with @()@, and the behaviour is to -- surround annotated regions with »>>>« and »<<<«: -- -- >>> let doc = "hello" <+> annotate () "world" <> "!" -- >>> let stdoc = treeForm (layoutPretty defaultLayoutOptions doc) -- >>> T.putStrLn (renderSimplyDecorated id (\() x -> ">>>" <> x <> "<<<") stdoc) -- hello >>>world<< (Text -> out) -- ^ Render plain 'Text' -> (ann -> out -> out) -- ^ How to modify an element with an annotation -> SimpleDocTree ann -> out renderSimplyDecorated text renderAnn = go where go = \sdt -> case sdt of STEmpty -> mempty STChar c -> text (T.singleton c) STText _ t -> text t STLine i -> text (T.singleton '\n') `mappend` text (textSpaces i) STAnn ann rest -> renderAnn ann (go rest) STConcat xs -> foldMap go xs {-# INLINE renderSimplyDecorated #-} -- | Version of 'renderSimplyDecoratedA' that allows for 'Applicative' effects. renderSimplyDecoratedA :: (Applicative f, Monoid out) => (Text -> f out) -- ^ Render plain 'Text' -> (ann -> f out -> f out) -- ^ How to modify an element with an annotation -> SimpleDocTree ann -> f out renderSimplyDecoratedA text renderAnn = go where go = \sdt -> case sdt of STEmpty -> pure mempty STChar c -> text (T.singleton c) STText _ t -> text t STLine i -> text (T.cons '\n' (textSpaces i)) STAnn ann rest -> renderAnn ann (go rest) STConcat xs -> fmap mconcat (traverse go xs) {-# INLINE renderSimplyDecoratedA #-} -- | A type for parsers of unique results. Token stream »s«, results »a«. -- -- Hand-written to avoid a dependency on a parser lib. newtype UniqueParser s a = UniqueParser { runParser :: s -> Maybe (a, s) } deriving Typeable instance Functor (UniqueParser s) where fmap f (UniqueParser mx) = UniqueParser (\s -> fmap (\(x,s') -> (f x, s')) (mx s)) instance Applicative (UniqueParser s) where pure x = UniqueParser (\rest -> Just (x, rest)) UniqueParser mf <*> UniqueParser mx = UniqueParser (\s -> do (f, s') <- mf s (x, s'') <- mx s' pure (f x, s'') ) instance Monad (UniqueParser s) where UniqueParser p >>= f = UniqueParser (\s -> do (a', s') <- p s let UniqueParser p' = f a' p' s' ) #if !(APPLICATIVE_MONAD) return = pure #endif #if FAIL_IN_MONAD fail = Fail.fail #endif instance Fail.MonadFail (UniqueParser s) where fail _err = empty instance Alternative (UniqueParser s) where empty = UniqueParser (const empty) UniqueParser p <|> UniqueParser q = UniqueParser (\s -> p s <|> q s) data SimpleDocTok ann = TokEmpty | TokChar Char | TokText !Int Text | TokLine Int | TokAnnPush ann | TokAnnPop deriving (Eq, Ord, Show, Typeable) -- | A 'SimpleDocStream' is a linked list of different annotated cons cells -- ('SText' and then some further 'SimpleDocStream', 'SLine' and then some -- further 'SimpleDocStream', …). This format is very suitable as a target for a -- layout engine, but not very useful for rendering to a structured format such -- as HTML, where we don’t want to do a lookahead until the end of some markup. -- These formats benefit from a tree-like structure that explicitly marks its -- contents as annotated. 'SimpleDocTree' is that format. data SimpleDocTree ann = STEmpty | STChar Char -- | 'Data.Text.length' is /O(n)/, so we cache it in the 'Int' field. | 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, Typeable) -- | Alter the document’s annotations. -- -- This instance makes 'SimpleDocTree' more flexible (because it can be used in -- 'Functor'-polymorphic values), but @'fmap'@ is much less readable compared to -- using @'reAnnotateST'@ in code that only works for @'SimpleDocTree'@ anyway. -- Consider using the latter when the type does not matter. instance Functor SimpleDocTree where fmap = reAnnotateST -- | Get the next token, consuming it in the process. nextToken :: UniqueParser (SimpleDocStream ann) (SimpleDocTok ann) nextToken = UniqueParser (\sds -> case sds of SFail -> panicUncaughtFail SEmpty -> empty SChar c rest -> Just (TokChar c , rest) SText l t rest -> Just (TokText l t , rest) SLine i rest -> Just (TokLine i , rest) SAnnPush ann rest -> Just (TokAnnPush ann , rest) SAnnPop rest -> Just (TokAnnPop , rest) ) sdocToTreeParser :: UniqueParser (SimpleDocStream ann) (SimpleDocTree ann) sdocToTreeParser = fmap wrap (many contentPiece) where wrap :: [SimpleDocTree ann] -> SimpleDocTree ann wrap = \sdts -> case sdts of [] -> STEmpty [x] -> x xs -> STConcat xs contentPiece = nextToken >>= \tok -> case tok of TokEmpty -> pure STEmpty TokChar c -> pure (STChar c) TokText l t -> pure (STText l t) TokLine i -> pure (STLine i) TokAnnPop -> empty TokAnnPush ann -> do annotatedContents <- sdocToTreeParser TokAnnPop <- nextToken pure (STAnn ann annotatedContents) -- | Convert a 'SimpleDocStream' to its 'SimpleDocTree' representation. treeForm :: SimpleDocStream ann -> SimpleDocTree ann treeForm sdoc = case runParser sdocToTreeParser sdoc of Nothing -> panicSimpleDocTreeConversionFailed Just (sdoct, SEmpty) -> sdoct Just (_, _unconsumed) -> panicInputNotFullyConsumed -- $ -- -- >>> :set -XOverloadedStrings -- >>> treeForm (layoutPretty defaultLayoutOptions ("lorem" <+> "ipsum" <+> annotate True ("TRUE" <+> annotate False "FALSE") <+> "dolor")) -- STConcat [STText 5 "lorem",STChar ' ',STText 5 "ipsum",STChar ' ',STAnn True (STConcat [STText 4 "TRUE",STChar ' ',STAnn False (STText 5 "FALSE")]),STChar ' ',STText 5 "dolor"] -- | Remove all annotations. 'unAnnotate' for 'SimpleDocTree'. unAnnotateST :: SimpleDocTree ann -> SimpleDocTree xxx unAnnotateST = alterAnnotationsST (const []) -- | Change the annotation of a document. 'reAnnotate' for 'SimpleDocTree'. reAnnotateST :: (ann -> ann') -> SimpleDocTree ann -> SimpleDocTree ann' reAnnotateST f = alterAnnotationsST (pure . f) -- | Change the annotation of a document to a different annotation, or none at -- all. 'alterAnnotations' for 'SimpleDocTree'. -- -- Note that this is as powerful as 'alterAnnotations', allowing one annotation -- to become multiple ones, contrary to 'alterAnnotationsS', which cannot do -- this. alterAnnotationsST :: (ann -> [ann']) -> SimpleDocTree ann -> SimpleDocTree ann' alterAnnotationsST re = go where go = \sdt -> case sdt of STEmpty -> STEmpty STChar c -> STChar c STText l t -> STText l t STLine i -> STLine i STConcat xs -> STConcat (map go xs) STAnn ann rest -> Prelude.foldr STAnn (go rest) (re ann) -- | Collect all annotations from a document. instance Foldable SimpleDocTree where foldMap f = go where go = \sdt -> case sdt of STEmpty -> mempty STChar _ -> mempty STText _ _ -> mempty STLine _ -> mempty STAnn ann rest -> f ann `mappend` go rest STConcat xs -> mconcat (map go xs) -- | Transform a document based on its annotations, possibly leveraging -- 'Applicative' effects. instance Traversable SimpleDocTree where traverse f = go where go = \sdt -> case sdt of STEmpty -> pure STEmpty STChar c -> pure (STChar c) STText l t -> pure (STText l t) STLine i -> pure (STLine i) STAnn ann rest -> STAnn <$> f ann <*> go rest STConcat xs -> STConcat <$> traverse go xs prettyprinter-1.7.1/src/Prettyprinter/Render/Util/StackMachine.hs0000644000000000000000000001417107346545000023354 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} #include "version-compatibility-macros.h" -- | Definitions to write renderers based on looking at a 'SimpleDocStream' as -- an instruction tape for a stack machine: text is written, annotations are -- added (pushed) and later removed (popped). module Prettyprinter.Render.Util.StackMachine ( -- * Simple, pre-defined stack machines -- -- | These cover most basic use cases where there is not too much special -- logic, and all that’s important is how to render text, and how to -- add/remove an annotation. renderSimplyDecorated, renderSimplyDecoratedA, -- * General stack machine -- -- | These definitions allow defining a full-blown stack machine renderer, -- allowing for arbitrary peeking, popping and what not. StackMachine, execStackMachine, pushStyle, unsafePopStyle, unsafePeekStyle, writeOutput, ) where import Control.Applicative import Data.Text (Text) import qualified Data.Text as T import Prettyprinter.Internal import Prettyprinter.Render.Util.Panic #if !(SEMIGROUP_MONOID_SUPERCLASS) import Data.Monoid #endif -- $setup -- -- (Definitions for the doctests) -- -- >>> import Prettyprinter hiding ((<>)) -- >>> import qualified Data.Text.IO as T -- | Simplest possible stack-based renderer. -- -- For example, here is a document annotated with @()@, and the behaviour is to -- write »>>>« at the beginning, and »<<<« at the end of the annotated region: -- -- >>> let doc = "hello" <+> annotate () "world" <> "!" -- >>> let sdoc = layoutPretty defaultLayoutOptions doc -- >>> T.putStrLn (renderSimplyDecorated id (\() -> ">>>") (\() -> "<<<") sdoc) -- hello >>>world<< (Text -> out) -- ^ Render plain 'Text' -> (ann -> out) -- ^ How to render an annotation -> (ann -> out) -- ^ How to render the removed annotation -> SimpleDocStream ann -> out renderSimplyDecorated text push pop = go [] where go _ SFail = panicUncaughtFail go [] SEmpty = mempty 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') <> text (textSpaces 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 :: (Applicative f, Monoid out) => (Text -> f out) -- ^ Render plain 'Text' -> (ann -> f out) -- ^ How to render an annotation -> (ann -> f out) -- ^ How to render the removed annotation -> SimpleDocStream ann -> f out renderSimplyDecoratedA text push pop = go [] where go _ SFail = panicUncaughtFail go [] SEmpty = pure mempty 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') <++> text (textSpaces 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 #-} -- | @WriterT output StateT [style] a@, but with a strict Writer value. -- -- The @output@ type is used to append data chunks to, the @style@ is the member -- of a stack of styles to model nested styles with. newtype StackMachine output style a = StackMachine ([style] -> (a, output, [style])) {-# DEPRECATED StackMachine "Writing your own stack machine is probably more efficient and customizable; also consider using »renderSimplyDecorated(A)« instead" #-} instance Functor (StackMachine output style) where fmap f (StackMachine r) = StackMachine (\s -> let (x1, w1, s1) = r s in (f x1, w1, s1)) instance Monoid output => Applicative (StackMachine output style) where pure x = StackMachine (\s -> (x, mempty, s)) StackMachine f <*> StackMachine x = StackMachine (\s -> let (f1, w1, s1) = f s (x2, w2, s2) = x s1 !w12 = w1 <> w2 in (f1 x2, w12, s2)) instance Monoid output => Monad (StackMachine output style) where #if !(APPLICATIVE_MONAD) return = pure #endif StackMachine r >>= f = StackMachine (\s -> let (x1, w1, s1) = r s StackMachine r1 = f x1 (x2, w2, s2) = r1 s1 !w12 = w1 <> w2 in (x2, w12, s2)) -- | Add a new style to the style stack. pushStyle :: Monoid output => style -> StackMachine output style () pushStyle style = StackMachine (\styles -> ((), mempty, style : styles)) -- | Get the topmost style. -- -- If the stack is empty, this raises an 'error'. unsafePopStyle :: Monoid output => StackMachine output style style unsafePopStyle = StackMachine (\stack -> case stack of x:xs -> (x, mempty, xs) [] -> panicPoppedEmpty ) -- | View the topmost style, but do not modify the stack. -- -- If the stack is empty, this raises an 'error'. unsafePeekStyle :: Monoid output => StackMachine output style style unsafePeekStyle = StackMachine (\styles -> case styles of x:_ -> (x, mempty, styles) [] -> panicPeekedEmpty ) -- | Append a value to the output end. writeOutput :: output -> StackMachine output style () writeOutput w = StackMachine (\styles -> ((), w, styles)) -- | Run the renderer and retrive the writing end execStackMachine :: [styles] -> StackMachine output styles a -> (output, [styles]) execStackMachine styles (StackMachine r) = let (_, w, s) = r styles in (w, s) prettyprinter-1.7.1/src/Prettyprinter/Symbols/0000755000000000000000000000000007346545000017756 5ustar0000000000000000prettyprinter-1.7.1/src/Prettyprinter/Symbols/Ascii.hs0000644000000000000000000000427007346545000021345 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} #include "version-compatibility-macros.h" -- | Common symbols composed out of the ASCII subset of Unicode. For non-ASCII -- symbols, see "Prettyprinter.Symbols.Unicode". module Prettyprinter.Symbols.Ascii where import Prettyprinter.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 = Char '\'' -- | >>> dquote -- " dquote :: Doc ann dquote = Char '"' -- | >>> lparen -- ( lparen :: Doc ann lparen = Char '(' -- | >>> rparen -- ) rparen :: Doc ann rparen = Char ')' -- | >>> langle -- < langle :: Doc ann langle = Char '<' -- | >>> rangle -- > rangle :: Doc ann rangle = Char '>' -- | >>> lbracket -- [ lbracket :: Doc ann lbracket = Char '[' -- | >>> rbracket -- ] rbracket :: Doc ann rbracket = Char ']' -- | >>> lbrace -- { lbrace :: Doc ann lbrace = Char '{' -- | >>> rbrace -- } rbrace :: Doc ann rbrace = Char '}' -- | >>> semi -- ; semi :: Doc ann semi = Char ';' -- | >>> colon -- : colon :: Doc ann colon = Char ':' -- | >>> comma -- , comma :: Doc ann comma = Char ',' -- | >>> "a" <> space <> "b" -- a b -- -- This is mostly used via @'<+>'@, -- -- >>> "a" <+> "b" -- a b space :: Doc ann space = Char ' ' -- | >>> dot -- . dot :: Doc ann dot = Char '.' -- | >>> slash -- / slash :: Doc ann slash = Char '/' -- | >>> backslash -- \\ backslash :: Doc ann backslash = "\\" -- | >>> equals -- = equals :: Doc ann equals = Char '=' -- | >>> pipe -- | pipe :: Doc ann pipe = Char '|' -- $setup -- -- (Definitions for the doctests) -- -- >>> :set -XOverloadedStrings -- >>> import Data.Semigroup -- >>> import Prettyprinter.Render.Text -- >>> import Prettyprinter.Util prettyprinter-1.7.1/src/Prettyprinter/Symbols/Unicode.hs0000644000000000000000000000760607346545000021711 0ustar0000000000000000-- | A collection of predefined Unicode values outside of ASCII range. For -- ASCII, see "Prettyprinter.Symbols.Ascii". module Prettyprinter.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 Prettyprinter.Internal -- | 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 = Char '„' -- | Top “66” style double quotes. -- -- >>> putDoc t66dquote -- “ t66dquote :: Doc ann t66dquote = Char '“' -- | Top “99” style double quotes. -- -- >>> putDoc t99dquote -- ” t99dquote :: Doc ann t99dquote = Char '”' -- | Bottom ‚9‘ style single quote. -- -- >>> putDoc b9quote -- ‚ b9quote :: Doc ann b9quote = Char '‚' -- | Top ‘66’ style single quote. -- -- >>> putDoc t6quote -- ‘ t6quote :: Doc ann t6quote = Char '‘' -- | Top ‘9’ style single quote. -- -- >>> putDoc t9quote -- ’ t9quote :: Doc ann t9quote = Char '’' -- | Right-pointing double guillemets -- -- >>> putDoc rdGuillemet -- » rdGuillemet :: Doc ann rdGuillemet = Char '»' -- | Left-pointing double guillemets -- -- >>> putDoc ldGuillemet -- « ldGuillemet :: Doc ann ldGuillemet = Char '«' -- | Right-pointing single guillemets -- -- >>> putDoc rsGuillemet -- › rsGuillemet :: Doc ann rsGuillemet = Char '›' -- | Left-pointing single guillemets -- -- >>> putDoc lsGuillemet -- ‹ lsGuillemet :: Doc ann lsGuillemet = Char '‹' -- | >>> putDoc bullet -- • bullet :: Doc ann bullet = Char '•' -- | >>> putDoc endash -- – endash :: Doc ann endash = Char '–' -- | >>> putDoc euro -- € euro :: Doc ann euro = Char '€' -- | >>> putDoc cent -- ¢ cent :: Doc ann cent = Char '¢' -- | >>> putDoc yen -- ¥ yen :: Doc ann yen = Char '¥' -- | >>> putDoc pound -- £ pound :: Doc ann pound = Char '£' -- $setup -- -- (Definitions for the doctests) -- -- >>> :set -XOverloadedStrings -- >>> import Prettyprinter.Render.Text -- >>> import Prettyprinter.Util prettyprinter-1.7.1/src/Prettyprinter/Util.hs0000644000000000000000000000347707346545000017612 0ustar0000000000000000-- | Frequently useful definitions for working with general prettyprinters. module Prettyprinter.Util ( module Prettyprinter.Util ) where import Data.Text (Text) import qualified Data.Text as T import Prettyprinter.Render.Text import Prelude hiding (words) import System.IO import Prettyprinter -- | Split an input into word-sized 'Doc's. -- -- >>> putDoc (tupled (words "Lorem ipsum dolor")) -- (Lorem, ipsum, dolor) words :: Text -> [Doc ann] words = map pretty . T.words -- | Insert soft linebreaks between words, so that text is broken into multiple -- lines when it exceeds the available width. -- -- >>> putDocW 32 (reflow "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.") -- Lorem ipsum dolor sit amet, -- consectetur adipisicing elit, -- sed do eiusmod tempor incididunt -- ut labore et dolore magna -- aliqua. -- -- @ -- 'reflow' = 'fillSep' . 'words' -- @ reflow :: Text -> Doc ann reflow = fillSep . words -- | Render a document with a certain width. Useful for quick-and-dirty testing -- of layout behaviour. Used heavily in the doctests of this package, for -- example. -- -- >>> let doc = reflow "Lorem ipsum dolor sit amet, consectetur adipisicing elit" -- >>> putDocW 20 doc -- Lorem ipsum dolor -- sit amet, -- consectetur -- adipisicing elit -- >>> putDocW 30 doc -- Lorem ipsum dolor sit amet, -- consectetur adipisicing elit putDocW :: Int -> Doc ann -> IO () putDocW w doc = renderIO System.IO.stdout (layoutPretty layoutOptions (unAnnotate doc)) where layoutOptions = LayoutOptions { layoutPageWidth = AvailablePerLine w 1 } -- $setup -- -- (Definitions for the doctests) -- -- >>> :set -XOverloadedStrings prettyprinter-1.7.1/test/Doctest/0000755000000000000000000000000007346545000015230 5ustar0000000000000000prettyprinter-1.7.1/test/Doctest/Main.hs0000644000000000000000000000014007346545000016443 0ustar0000000000000000module Main (main) where import Test.DocTest main :: IO () main = doctest [ "src" , "-Imisc"] prettyprinter-1.7.1/test/Testsuite/0000755000000000000000000000000007346545000015614 5ustar0000000000000000prettyprinter-1.7.1/test/Testsuite/Main.hs0000644000000000000000000003575707346545000017055 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #include "version-compatibility-macros.h" module Main (main) where import Control.Exception (evaluate) import qualified Data.ByteString.Lazy as BSL import qualified Data.Text as T import Data.Text.PgpWordlist import Data.Word import System.Timeout (timeout) import Prettyprinter import Prettyprinter.Internal.Debug import Prettyprinter.Render.Text import Prettyprinter.Render.Util.StackMachine (renderSimplyDecorated) import Test.QuickCheck.Instances.Text () import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import StripTrailingSpace #if !(APPLICATIVE_MONAD) import Control.Applicative #endif #if !(MONOID_IN_PRELUDE) import Data.Monoid (mconcat) #endif main :: IO () main = defaultMain tests tests :: TestTree tests = testGroup "Tests" [ testGroup "Fusion" [ testProperty "Shallow fusion does not change rendering" (fusionDoesNotChangeRendering Shallow) , testProperty "Deep fusion does not change rendering" (fusionDoesNotChangeRendering Deep) ] , testStripTrailingSpace , testGroup "Performance tests" [ testCase "Grouping performance" groupingPerformance , testCase "fillSep performance" fillSepPerformance ] , testGroup "Regression tests" [ testCase "layoutSmart: softline behaves like a newline (#49)" regressionLayoutSmartSoftline , testCase "alterAnnotationsS causes panic when removing annotations (#50)" regressionAlterAnnotationsS , testCase "Bad fallback handling with align (#83)" badFallbackAlign , 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 ] , testGroup "removeTrailingWhitespace restores indentation in the wrong spot (#93)" [ testCase "Don't restore indentation in the wrong spot" removeTrailingWhitespaceDontRestoreIndentationInTheWrongSpot , testCase "Preserve leading indentation" removeTrailingWhitespacePreserveIndentation ] , testGroup "Unbounded layout of hard linebreak within `group` fails (#91)" [ testCase "Line" regressionUnboundedGroupedLine , testCase "Line within align" regressionUnboundedGroupedLineWithinAlign ] , testCase "Indentation on otherwise empty lines results in trailing whitespace (#139)" indentationShouldntCauseTrailingWhitespaceOnOtherwiseEmptyLines , testCase "Ribbon width should be computed with `floor` instead of `round` (#157)" computeRibbonWidthWithFloor ] ] fusionDoesNotChangeRendering :: FusionDepth -> Property fusionDoesNotChangeRendering depth = forAllShow (arbitrary :: Gen (Doc Int)) (show . diag) (\doc -> forAll arbitrary (\layouter -> let tShow = T.pack . show render = renderSimplyDecorated id tShow tShow . layout layouter rendered = render doc renderedFused = render (fuse depth doc) in counterexample (mkCounterexample rendered renderedFused) (render doc == render (fuse depth doc)) )) where mkCounterexample rendered renderedFused = (T.unpack . renderStrict . layoutPretty defaultLayoutOptions . vsep) [ "Unfused and fused documents render differently!" , "Unfused:" , indent 4 (pretty rendered) , "Fused:" , indent 4 (pretty renderedFused) ] instance Arbitrary ann => Arbitrary (Doc ann) where arbitrary = document shrink = genericShrink -- Possibly not a good idea, may break invariants document :: Arbitrary ann => Gen (Doc ann) document = (dampen . frequency) [ (20, content) , (1, newlines) , (1, nestingAndAlignment) , (1, grouping) , (20, concatenationOfTwo) , (5, concatenationOfMany) , (1, enclosingOfOne) , (1, enclosingOfMany) , (1, annotated) ] annotated :: Arbitrary ann => Gen (Doc ann) annotated = annotate <$> arbitrary <*> document content :: Gen (Doc ann) content = frequency [ (1, pure emptyDoc) , (10, do word <- choose (minBound, maxBound :: Word8) let pgp8Word = toText (BSL.singleton word) pure (pretty pgp8Word) ) , (1, (fmap pretty . elements . mconcat) [ ['a'..'z'] , ['A'..'Z'] , ['0'..'9'] , "…_[]^!<>=&@:-()?*}{/\\#$|~`+%\"';" ] ) ] newlines :: Gen (Doc ann) newlines = frequency [ (1, pure line) , (1, pure line') , (1, pure softline) , (1, pure softline') , (1, pure hardline) ] nestingAndAlignment :: Arbitrary ann => Gen (Doc ann) nestingAndAlignment = frequency [ (1, nest <$> arbitrary <*> concatenationOfMany) , (1, group <$> document) , (1, hang <$> arbitrary <*> concatenationOfMany) , (1, indent <$> arbitrary <*> concatenationOfMany) ] grouping :: Arbitrary ann => Gen (Doc ann) grouping = frequency [ (1, align <$> document) , (1, flatAlt <$> document <*> document) ] concatenationOfTwo :: Arbitrary ann => Gen (Doc ann) concatenationOfTwo = frequency [ (1, (<>) <$> document <*> document) , (1, (<+>) <$> document <*> document) ] concatenationOfMany :: Arbitrary ann => Gen (Doc ann) concatenationOfMany = frequency [ (1, hsep <$> listOf document) , (1, vsep <$> listOf document) , (1, fillSep <$> listOf document) , (1, sep <$> listOf document) , (1, hcat <$> listOf document) , (1, vcat <$> listOf document) , (1, fillCat <$> listOf document) , (1, cat <$> listOf document) ] enclosingOfOne :: Arbitrary ann => Gen (Doc ann) enclosingOfOne = frequency [ (1, squotes <$> document) , (1, dquotes <$> document) , (1, parens <$> document) , (1, angles <$> document) , (1, brackets <$> document) , (1, braces <$> document) ] enclosingOfMany :: Arbitrary ann => Gen (Doc ann) enclosingOfMany = frequency [ (1, encloseSep <$> document <*> document <*> pure ", " <*> listOf document) , (1, list <$> listOf document) , (1, tupled <$> listOf document) ] -- A 'show'able type representing a layout algorithm. data Layouter ann = LayoutPretty LayoutOptions | LayoutSmart LayoutOptions | LayoutCompact -- LayoutWadlerLeijen (FittingPredicate ann) LayoutOptions deriving Show instance Arbitrary (Layouter ann) where arbitrary = oneof [ LayoutPretty <$> arbitrary , LayoutSmart <$> arbitrary , pure LayoutCompact -- This produces inconsistent layouts that break the fusionDoesNotChangeRendering test -- , LayoutWadlerLeijen <$> arbitrary <*> arbitrary ] {- instance Show (FittingPredicate ann) where show _ = "" instance Arbitrary (FittingPredicate ann) where arbitrary = FittingPredicate <$> arbitrary -} layout :: Layouter ann -> Doc ann -> SimpleDocStream ann layout (LayoutPretty opts) = layoutPretty opts layout (LayoutSmart opts) = layoutSmart opts layout LayoutCompact = layoutCompact -- layout (LayoutWadlerLeijen fp opts) = layoutWadlerLeijen fp opts instance Arbitrary LayoutOptions where arbitrary = LayoutOptions <$> oneof [ AvailablePerLine <$> arbitrary <*> arbitrary , pure Unbounded ] instance CoArbitrary (SimpleDocStream ann) where coarbitrary s0 = case s0 of SFail -> variant' 0 SEmpty -> variant' 1 SChar _c s -> variant' 2 . coarbitrary s SText l _t s -> variant' 3 . coarbitrary (l, s) SLine i s -> variant' 4 . coarbitrary (i, s) SAnnPush _a s -> variant' 5 . coarbitrary s SAnnPop s -> variant' 6 . coarbitrary s instance CoArbitrary PageWidth where coarbitrary (AvailablePerLine a b) = variant' 0 . coarbitrary (a, b) coarbitrary Unbounded = variant' 1 -- | Silences type defaulting warnings for 'variant' variant' :: Int -> Gen a -> Gen a variant' = variant -- QuickCheck 2.8 does not have 'scale' yet, so for compatibility with older -- releases we hand-code it here 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) >>= \doc' -> case doc' of 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 groupingPerformance :: Assertion groupingPerformance = docPerformanceTest (pathological 1000) where pathological :: Int -> Doc ann pathological n = iterate (\x -> hsep [x, sep []] ) "foobar" !! n -- 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 regressionLayoutSmartSoftline :: Assertion regressionLayoutSmartSoftline = let doc = "a" <> softline <> "b" layouted :: SimpleDocStream () layouted = layoutSmart (defaultLayoutOptions { layoutPageWidth = Unbounded }) doc in assertEqual "softline should be rendered as space page width is unbounded" (SChar 'a' (SChar ' ' (SChar 'b' SEmpty))) layouted -- Removing annotations with alterAnnotationsS used to remove pushes, but not -- pops, leading to imbalanced SimpleDocStreams. regressionAlterAnnotationsS :: Assertion regressionAlterAnnotationsS = let sdoc, sdoc' :: SimpleDocStream Int 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)) sdoc' = SLine 2 (SChar 'x' SEmpty) in assertEqual "" sdoc' (removeTrailingWhitespace sdoc) doNotRemoveLeadingWhitespaceChar :: Assertion doNotRemoveLeadingWhitespaceChar = let sdoc :: SimpleDocStream () sdoc = SLine 0 (SChar ' ' (SChar 'x' SEmpty)) sdoc' = SLine 1 (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 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) badFallbackAlign :: Assertion badFallbackAlign = let x = group (flatAlt "Default" "Fallback") doc = "/" <> align (cat [x, x, "Too wide!!!!!"]) actual = renderStrict (layoutSmart (LayoutOptions (AvailablePerLine 12 1)) doc) expected = "/Fallback\n Fallback\n Too wide!!!!!" in assertEqual "" expected actual removeTrailingWhitespaceDontRestoreIndentationInTheWrongSpot :: Assertion removeTrailingWhitespaceDontRestoreIndentationInTheWrongSpot = let sdoc :: SimpleDocStream () sdoc = SLine 2 (SLine 0 (SChar 'x' SEmpty)) sdoc' = SLine 0 (SLine 0 (SChar 'x' SEmpty)) in assertEqual "" sdoc' (removeTrailingWhitespace sdoc) removeTrailingWhitespacePreserveIndentation :: Assertion removeTrailingWhitespacePreserveIndentation = let sdoc :: SimpleDocStream () sdoc = SLine 2 (SChar 'x' SEmpty) in assertEqual "" sdoc (removeTrailingWhitespace sdoc) regressionUnboundedGroupedLine :: Assertion regressionUnboundedGroupedLine = let sdoc :: SimpleDocStream () sdoc = layoutPretty (LayoutOptions Unbounded) (group hardline) in assertEqual "" (SLine 0 SEmpty) sdoc regressionUnboundedGroupedLineWithinAlign :: Assertion regressionUnboundedGroupedLineWithinAlign = let doc :: Doc () doc = group (align ("x" <> hardline <> "y")) sdoc = layoutPretty (LayoutOptions Unbounded) doc expected = SChar 'x' (SLine 0 (SChar 'y' SEmpty)) in assertEqual "" expected sdoc indentationShouldntCauseTrailingWhitespaceOnOtherwiseEmptyLines :: Assertion indentationShouldntCauseTrailingWhitespaceOnOtherwiseEmptyLines = let doc :: Doc () doc = indent 1 ("x" <> hardline <> hardline <> "y" <> hardline) sdoc = layoutPretty (LayoutOptions Unbounded) doc expected = SChar ' ' (SChar 'x' (SLine 0 (SLine 1 (SChar 'y' (SLine 0 SEmpty))))) in assertEqual "" expected sdoc computeRibbonWidthWithFloor :: Assertion computeRibbonWidthWithFloor = let doc :: Doc () doc = "a" <> softline' <> "b" sdoc = layoutPretty (LayoutOptions (AvailablePerLine 3 0.5)) doc expected = SChar 'a' (SLine 0 (SChar 'b' SEmpty)) in assertEqual "" expected sdoc prettyprinter-1.7.1/test/Testsuite/StripTrailingSpace.hs0000644000000000000000000000726707346545000021733 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} #include "version-compatibility-macros.h" module StripTrailingSpace (testStripTrailingSpace) where import Data.Text (Text) import qualified Data.Text as T import Prettyprinter import Prettyprinter.Render.Util.StackMachine import Test.Tasty import Test.Tasty.HUnit #if !(APPLICATIVE_MONAD) import Control.Applicative #endif 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')