prettyprinter 1.3.0 → 1.7.2
raw patch · 44 files changed
Files
- CHANGELOG.md +107/−0
- README.md +5/−8
- app/GenerateReadme.hs +10/−12
- bench/FasterUnsafeText.hs +4/−4
- bench/Fusion.hs +8/−10
- bench/LargeOutput.hs +23/−9
- misc/version-compatibility-macros.h +3/−7
- prettyprinter.cabal +74/−53
- src-text/Data/Text.hs +46/−0
- src-text/Data/Text/IO.hs +13/−0
- src-text/Data/Text/Lazy.hs +15/−0
- src-text/Data/Text/Lazy/Builder.hs +13/−0
- src/Data/Text/Prettyprint/Doc.hs +3/−337
- src/Data/Text/Prettyprint/Doc/Internal.hs +5/−1847
- src/Data/Text/Prettyprint/Doc/Internal/Debug.hs +5/−0
- src/Data/Text/Prettyprint/Doc/Internal/Type.hs +7/−11
- src/Data/Text/Prettyprint/Doc/Render/ShowS.hs +0/−5
- src/Data/Text/Prettyprint/Doc/Render/String.hs +3/−8
- src/Data/Text/Prettyprint/Doc/Render/Text.hs +3/−118
- src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs +5/−168
- src/Data/Text/Prettyprint/Doc/Render/Tutorials/TreeRenderingTutorial.hs +3/−135
- src/Data/Text/Prettyprint/Doc/Render/Util/Panic.hs +3/−36
- src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs +3/−275
- src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs +3/−164
- src/Data/Text/Prettyprint/Doc/Symbols/Ascii.hs +4/−153
- src/Data/Text/Prettyprint/Doc/Symbols/Unicode.hs +3/−210
- src/Data/Text/Prettyprint/Doc/Util.hs +3/−60
- src/Prettyprinter.hs +348/−0
- src/Prettyprinter/Internal.hs +2351/−0
- src/Prettyprinter/Internal/Debug.hs +95/−0
- src/Prettyprinter/Internal/Type.hs +14/−0
- src/Prettyprinter/Render/String.hs +10/−0
- src/Prettyprinter/Render/Text.hs +121/−0
- src/Prettyprinter/Render/Tutorials/StackMachineTutorial.hs +154/−0
- src/Prettyprinter/Render/Tutorials/TreeRenderingTutorial.hs +128/−0
- src/Prettyprinter/Render/Util/Panic.hs +38/−0
- src/Prettyprinter/Render/Util/SimpleDocTree.hs +265/−0
- src/Prettyprinter/Render/Util/StackMachine.hs +168/−0
- src/Prettyprinter/Symbols/Ascii.hs +154/−0
- src/Prettyprinter/Symbols/Unicode.hs +210/−0
- src/Prettyprinter/Util.hs +65/−0
- test/Doctest/Main.hs +4/−0
- test/Testsuite/Main.hs +214/−26
- test/Testsuite/StripTrailingSpace.hs +2/−6
CHANGELOG.md view
@@ -1,8 +1,115 @@+# [1.7.2] – April 2026++- [Add `PrettyAnn` type class](https://github.com/quchen/prettyprinter/pull/256)+- [Remove the MINIMAL pragma from `Pretty`](https://github.com/quchen/prettyprinter/pull/219)+- [Add instance `ann ~ Void => Pretty (Doc ann)`](https://github.com/quchen/prettyprinter/pull/234)+- [Add `Pretty` instances for 4-7 tuples](https://github.com/quchen/prettyprinter/pull/275)+- [Make it compile with MicroHs](https://github.com/quchen/prettyprinter/pull/270)+- [Drop support for GHC 7](https://github.com/quchen/prettyprinter/pull/278)+- [Remove compatibility code for GHC < 8](https://github.com/quchen/prettyprinter/pull/285)+- Documentation improvements:+ * [#229](https://github.com/quchen/prettyprinter/pull/229)+ * [#255](https://github.com/quchen/prettyprinter/pull/255)+ * [#273](https://github.com/quchen/prettyprinter/pull/273)++[1.7.2]: https://github.com/quchen/prettyprinter/compare/v1.7.1...v1.7.2++# [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
README.md view
@@ -5,10 +5,7 @@ A modern Wadler/Leijen Prettyprinter ==================================== -[](https://travis-ci.org/quchen/prettyprinter) -[](https://hackage.haskell.org/package/prettyprinter) [](https://www.stackage.org/package/prettyprinter) [](https://www.stackage.org/package/prettyprinter)--+[](https://hackage.haskell.org/package/prettyprinter) tl;dr -----@@ -90,7 +87,7 @@ 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.+coloring, a web browser a plethora of different formatting options. 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@@ -181,9 +178,9 @@ 6. SimpleDoc was renamed `SimpleDocStream`, to contrast the new `SimpleDocTree`. 7. In the ANSI backend, instead of providing an own colorization function for- each color/intensity/layer combination, they have been combined in /color/- /colorDull/, /bgColor/, and /bgColorDull/ functions, which can be found in- the ANSI terminal specific @prettyprinter-ansi-terminal@ package.+ each color/intensity/layer combination, they have been combined in `color`,+ `colorDull`, `bgColor`, and `bgColorDull` functions, which can be found in+ the ANSI terminal specific `prettyprinter-ansi-terminal` package.
app/GenerateReadme.hs view
@@ -11,8 +11,8 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T-import Data.Text.Prettyprint.Doc-import Data.Text.Prettyprint.Doc.Render.Text+import Prettyprinter+import Prettyprinter.Render.Text import MultilineTh @@ -29,13 +29,11 @@ , h1 "A modern Wadler/Leijen Prettyprinter" - , mconcat+ , vcat [ "[](https://travis-ci.org/quchen/prettyprinter)"- , " " <> hardline -- Awkwardly enough, two trailing spaces are a small break in Markdown.- , hsep- [ "[](https://hackage.haskell.org/package/prettyprinter)"- , "[](https://www.stackage.org/package/prettyprinter)"- , "[](https://www.stackage.org/package/prettyprinter)" ]]+ , "[](https://hackage.haskell.org/package/prettyprinter)"+ , "[](https://www.stackage.org/package/prettyprinter)"+ , "[](https://www.stackage.org/package/prettyprinter)" ] , h2 "tl;dr" , paragraph [multiline| A prettyprinter/text rendering engine. Easy to@@ -99,7 +97,7 @@ , 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. |]+ different formatting options. |] , paragraph [multiline| More complex uses of annotations include e.g. adding type annotations for mouse-over hovers when printing a syntax@@ -185,9 +183,9 @@ new `SimpleDocTree`. |] , [multiline| In the ANSI backend, instead of providing an own colorization function for each color/intensity/layer combination, they- have been combined in /color/ /colorDull/, /bgColor/, and- /bgColorDull/ functions, which can be found in the ANSI terminal- specific @prettyprinter-ansi-terminal@ package. |]+ have been combined in `color`, `colorDull`, `bgColor`, and+ `bgColorDull` functions, which can be found in the ANSI terminal+ specific `prettyprinter-ansi-terminal` package. |] ] , h2 "Historical notes"
bench/FasterUnsafeText.hs view
@@ -4,11 +4,11 @@ -import Criterion.Main import Data.Char-import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Prettyprint.Doc.Internal+import Data.Text (Text)+import qualified Data.Text as T+import Prettyprinter.Internal+import Test.Tasty.Bench
bench/Fusion.hs view
@@ -9,18 +9,14 @@ import Control.Monad import Control.Monad.State-import Criterion.Main import Data.Text (Text) import qualified Data.Text as T import System.Random--import Data.Text.Prettyprint.Doc-import Data.Text.Prettyprint.Doc.Render.Text-import qualified Text.PrettyPrint.ANSI.Leijen as WL+import Test.Tasty.Bench -#if !(APPLICATIVE_MONAD)-import Control.Applicative-#endif+import Prettyprinter+import Prettyprinter.Render.Text+import qualified Text.PrettyPrint.ANSI.Leijen as WL @@ -31,9 +27,9 @@ ] benchOptimize :: Benchmark-benchOptimize = env randomShortWords benchmark+benchOptimize = env randomShortWords benchmark_ where- benchmark = \shortWords ->+ benchmark_ = \shortWords -> let doc = hsep (map pretty shortWords) in bgroup "Many small words" [ bench "Unoptimized" (nf renderLazy (layoutPretty defaultLayoutOptions doc))@@ -47,6 +43,8 @@ randomShortWords' :: Int -> State StdGen [Text] randomShortWords' n = replicateM n randomShortWord + -- Note: 'split' is deprecated in random >= 1.2 in favor of 'splitGen'.+ -- We could use 'splitGen' when support for GHC < 9.0 is dropped. randomShortWord :: State StdGen Text randomShortWord = do g <- get
bench/LargeOutput.hs view
@@ -10,8 +10,6 @@ import Control.DeepSeq import Control.Monad.Compat-import Criterion-import Criterion.Main import Data.Char import Data.Map (Map) import qualified Data.Map as M@@ -19,12 +17,13 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL-import Data.Text.Prettyprint.Doc-import Data.Text.Prettyprint.Doc.Render.Text+import Prettyprinter+import Prettyprinter.Render.Text import GHC.Generics import Test.QuickCheck import Test.QuickCheck.Gen import Test.QuickCheck.Random+import Test.Tasty.Bench import qualified Text.PrettyPrint.ANSI.Leijen as WL @@ -184,12 +183,27 @@ (progLines, progWidth) = let l = TL.lines renderedProg in (length l, maximum (map TL.length l)) putDoc ("Program size:" <+> pretty progLines <+> "lines, maximum width:" <+> pretty progWidth) - rnf prog `seq` T.putStrLn "Staring benchmark…"+ 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"- [ bench "prettyprinter" (nf (renderLazy . layoutPretty defaultLayoutOptions { layoutPageWidth = AvailablePerLine 80 0.5 } . pretty) prog)- , bench "ansi-wl-pprint" (nf (($ "") . WL.displayS . WL.renderPretty 0.5 80 . WL.pretty) prog) ]+ [ bgroup "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 (\x -> (WL.displayS . WL.renderPretty 0.5 80 . WL.pretty) x "") prog) ] , bgroup "Infinite/large page width"- [ bench "prettyprinter" (nf (renderLazy . layoutPretty defaultLayoutOptions { layoutPageWidth = Unbounded } . pretty) prog)- , bench "ansi-wl-pprint" (nf (($ "") . WL.displayS . WL.renderPretty 1 (fromIntegral progWidth + 10) . WL.pretty) prog) ]+ [ 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 (\x -> (WL.displayS . WL.renderPretty 1 (fromIntegral progWidth + 10) . WL.pretty) x "") prog) ] ]
misc/version-compatibility-macros.h view
@@ -8,16 +8,12 @@ -- 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 FOLDABLE_TRAVERSABLE_IN_PRELUDE !defined(__MHS__) -#define SEMIGROUP_IN_BASE MIN_VERSION_base(4,9,0)+#define LIFTA2_IN_PRELUDE MIN_VERSION_base(4,18,0) #define SEMIGROUP_MONOID_SUPERCLASS MIN_VERSION_base(4,11,0) -#define NO_FAIL_IN_MONAD_MONAD_FAIL MIN_VERSION_base(4,13,0)+#define FAIL_IN_MONAD !(MIN_VERSION_base(4,13,0)) #endif
prettyprinter.cabal view
@@ -1,5 +1,5 @@ name: prettyprinter-version: 1.3.0+version: 1.7.2 cabal-version: >= 1.10 category: User Interfaces, Text synopsis: A modern, easy to use, well-documented, extensible pretty-printer.@@ -9,30 +9,39 @@ extra-source-files: README.md , CHANGELOG.md , misc/version-compatibility-macros.h-author: Phil Wadler, Daan Leijen, Max Bolingbroke, Edward Kmett, David Luposchainsky-maintainer: David Luposchainsky <dluposchainsky at google>+author: Phil Wadler, Daan Leijen, Max Bolingbroke, Edward Kmett, David Luposchainsky, Simon Jakobi+maintainer: Simon Jakobi <simon.jakobi@gmail.com>, David Luposchainsky <dluposchainsky at google> bug-reports: http://github.com/quchen/prettyprinter/issues homepage: http://github.com/quchen/prettyprinter build-type: Simple-tested-with: GHC == 7.8.4- , GHC == 7.10.2- , GHC == 7.10.3- , GHC == 8.0.1- , GHC == 8.0.2- , GHC == 8.2.2--+tested-with: GHC==9.14.1, GHC==9.12.2, GHC==9.10.3, GHC==9.8.4, GHC==9.6.7, GHC==9.4.8, GHC==9.2.8, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2 source-repository head type: git- location: git://github.com/quchen/prettyprinter.git-+ location: https://github.com/quchen/prettyprinter library exposed-modules:- Data.Text.Prettyprint.Doc+ 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@@ -46,10 +55,7 @@ , Data.Text.Prettyprint.Doc.Symbols.Unicode , Data.Text.Prettyprint.Doc.Symbols.Ascii - -- Deprecated- , Data.Text.Prettyprint.Doc.Render.ShowS-- ghc-options: -Wall+ ghc-options: -Wall -O2 -Wcompat hs-source-dirs: src include-dirs: misc default-language: Haskell2010@@ -61,32 +67,40 @@ , ScopedTypeVariables build-depends:- base >= 4.5 && < 5- , text >= 1.2-- 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.1- build-depends: fail >= 4.9.0.0- if !impl(ghc >= 7.10)- build-depends: void+ base >= 4.9 && < 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 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+ -- https://github.com/quchen/prettyprinter/issues/264+ Manual: True + executable generate_readme hs-source-dirs: app main-is: GenerateReadme.hs build-depends:- base >= 4.7 && < 5+ base >= 4.9 && < 5 , prettyprinter , text@@ -96,7 +110,7 @@ other-extensions: OverloadedStrings , TemplateHaskell , QuasiQuotes- if flag(buildReadme)+ if flag(buildReadme) && flag(text) buildable: True else buildable: False@@ -108,13 +122,12 @@ hs-source-dirs: test/Doctest main-is: Main.hs build-depends:- base >= 4.7 && < 5+ base >= 4.9 && < 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@@ -126,7 +139,8 @@ , prettyprinter , pgp-wordlist >= 0.1- , bytestring >= 0.10+ , bytestring+ , quickcheck-instances >= 0.3.17 , tasty >= 0.10 , tasty-hunit >= 0.9 , tasty-quickcheck >= 0.8@@ -134,9 +148,8 @@ 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@@ -144,55 +157,63 @@ hs-source-dirs: bench main-is: Fusion.hs build-depends:- base >= 4.5 && < 5+ base >= 4.9 && < 5 , prettyprinter - , criterion >= 1.1+ , tasty-bench >= 0.2 , mtl >= 2.1 , random >= 1.0 , text- , transformers >= 0.3 , ansi-wl-pprint >= 0.6- ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ 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+ base >= 4.9 && < 5 , prettyprinter - , criterion >= 1.1+ , tasty-bench >= 0.2 , text hs-source-dirs: bench main-is: FasterUnsafeText.hs- ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ 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.11+ base >= 4.9 && < 5+ , base-compat >=0.9.3 && <0.15 , prettyprinter , ansi-wl-pprint - , criterion >= 1.1- , QuickCheck >= 2.7+ , tasty-bench >= 0.2+ , QuickCheck >= 2.8 , containers , text , deepseq hs-source-dirs: bench main-is: LargeOutput.hs- ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ ghc-options: -rtsopts -Wall default-language: Haskell2010 type: exitcode-stdio-1.0 + -- For GHC.Generics if !impl(ghc >= 7.6) build-depends: ghc-prim if !impl(ghc >= 8.0) build-depends: semigroups++ if !flag(text)+ buildable: False
+ src-text/Data/Text.hs view
@@ -0,0 +1,46 @@+-- 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
+ src-text/Data/Text/IO.hs view
@@ -0,0 +1,13 @@+-- 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
+ src-text/Data/Text/Lazy.hs view
@@ -0,0 +1,15 @@+-- 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
+ src-text/Data/Text/Lazy/Builder.hs view
@@ -0,0 +1,13 @@+-- 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
src/Data/Text/Prettyprint/Doc.hs view
@@ -1,339 +1,5 @@-{-# LANGUAGE CPP #-}--#include "version-compatibility-macros.h"---- |--- Module : Data.Text.Prettyprint.Doc--- 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 <dluposchainsky (λ) google>--- 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 @::@,------ >>> let prettyType = 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 prettyDecl n tys = pretty n <+> prettyType tys------ Now we can define a document that contains some type signature:------ >>> let doc = prettyDecl "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 @::@.------ = General workflow------ @--- ╔══════════╗--- ║ ║ ╭────────────────────╮--- ║ ║ │ 'vsep', 'pretty', '<+>', │--- ║ ║ │ 'nest', 'align', … │--- ║ ║ ╰─────────┬──────────╯--- ║ ║ │--- ║ Create ║ │--- ║ ║ │--- ║ ║ ▽--- ║ ║ ╭───────────────────╮--- ║ ║ │ 'Doc' │--- ╠══════════╣ │ (rich document) │--- ║ ║ ╰─────────┬─────────╯--- ║ ║ │--- ║ ║ │ Layout algorithms--- ║ Layout ║ │ e.g. 'layoutPretty'--- ║ ║ ▽--- ║ ║ ╭───────────────────╮--- ║ ║ │ 'SimpleDocStream' │--- ╠══════════╣ │ (simple document) │--- ║ ║ ╰─────────┬─────────╯--- ║ ║ │--- ║ ║ ├─────────────────────────────╮--- ║ ║ │ │ 'Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree.treeForm'--- ║ ║ │ ▽--- ║ ║ │ ╭───────────────╮--- ║ ║ │ │ 'Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree.SimpleDocTree' │--- ║ Render ║ │ ╰───────┬───────╯--- ║ ║ │ │--- ║ ║ ╭───────────────────┼─────────────────╮ ╭────────┴────────╮--- ║ ║ │ │ │ │ │--- ║ ║ ▽ ▽ ▽ ▽ ▽--- ║ ║ ╭───────────────╮ ╭───────────────╮ ╭───────────────╮ ╭───────────────╮--- ║ ║ │ ANSI terminal │ │ Plain 'Text' │ │ other/custom │ │ HTML │--- ║ ║ ╰───────────────╯ ╰───────────────╯ ╰───────────────╯ ╰───────────────╯--- ║ ║--- ╚══════════╝--- @------ = How the layout works------ 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 Data.Text.Prettyprint.Doc (- -- * Documents- Doc,-- -- * Basic functionality- Pretty(..),- viaShow, unsafeViaShow,- emptyDoc, nest, line, line', softline, softline', hardline, 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 "Data.Text.Prettyprint.Doc.Render.Text".- SimpleDocStream(..),- PageWidth(..), LayoutOptions(..), defaultLayoutOptions,- layoutPretty, layoutCompact, layoutSmart,- removeTrailingWhitespace,-- -- * Migration guide- --- -- $migration+module Data.Text.Prettyprint.Doc {-# DEPRECATED "Use \"Prettyprinter\" instead." #-} (+ module Prettyprinter ) where ---#if !(SEMIGROUP_MONOID_SUPERCLASS)-import Data.Semigroup-#endif-import Data.Text.Prettyprint.Doc.Internal-import Data.Text.Prettyprint.Doc.Symbols.Ascii---- $setup------ (Definitions for the doctests)------ >>> :set -XOverloadedStrings--- >>> import Data.Text.Prettyprint.Doc.Render.Text--- >>> import Data.Text.Prettyprint.Doc.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-<former package>@ packages--- 3. Using a converter from the old @Doc@ type to the new one, see the--- @prettyprinter-convert-<former package>@ 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--- "Data.Text.Prettyprint.Doc.Render.String" module.--- - The /display/ functions are moved to the rendering submodules, for--- example conversion to plain 'Text' is in the--- "Data.Text.Prettyprint.Doc.Render.Text" module.--- - 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.+import Prettyprinter
src/Data/Text/Prettyprint/Doc/Internal.hs view
@@ -1,1847 +1,5 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--#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--- "Data.Text.Prettyprint.Doc.Internal.Type".-module Data.Text.Prettyprint.Doc.Internal (- module Data.Text.Prettyprint.Doc.Internal-) 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 !(MONOID_IN_PRELUDE)-import Data.Monoid hiding ((<>))-#endif--#if FUNCTOR_IDENTITY_IN_BASE-import Data.Functor.Identity-#endif--import Data.Text.Prettyprint.Doc.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'), fall back to- -- the second. The flattened version should in general be higher and- -- narrower than the fallback.- | 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)---- |--- @--- '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-- prettyList = pretty . (id :: Text -> Text) . fromString---- | 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---- | 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---- | 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 indentation level--- 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', 'align' and 'indent'.-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 = group 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' = group 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, @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 changesUponFlattening x of- Nothing -> x- Just x' -> Union x' 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.---- | Choose the first element of each @Union@, and discard the first field of--- all @FlatAlt@s.------ The result is 'Just' if the element might change depending on the layout--- algorithm (i.e. contains differently renderable sub-documents), and 'Nothing'--- if the document is static (e.g. contains only a plain 'Empty' node). See--- [Group: special flattening] for further explanations.-changesUponFlattening :: Doc ann -> Maybe (Doc ann)-changesUponFlattening = \doc -> case doc of- FlatAlt _ y -> Just (flatten y)- Line -> Just Fail- Union x _ -> changesUponFlattening x <|> Just x- Nest i x -> fmap (Nest i) (changesUponFlattening x)- Annotated ann x -> fmap (Annotated ann) (changesUponFlattening x)-- Column f -> Just (Column (flatten . f))- Nesting f -> Just (Nesting (flatten . f))- WithPageWidth f -> Just (WithPageWidth (flatten . f))-- Cat x y -> case (changesUponFlattening x, changesUponFlattening y) of- (Nothing, Nothing) -> Nothing- (Just x', Nothing) -> Just (Cat x' y )- (Nothing, Just y') -> Just (Cat x y')- (Just x', Just y') -> Just (Cat x' y')-- Empty -> Nothing- Char{} -> Nothing- Text{} -> Nothing- Fail -> Nothing- 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------ | @('flatAlt' x fallback)@ renders as @x@ by default, but falls back to--- @fallback@ when 'group'ed. Since the layout algorithms rely on 'group' having--- an effect of shortening the width of the contained text, careless usage of--- 'flatAlt' with wide fallbacks might lead to unappealingly long lines.------ 'flatAlt' is particularly useful for defining conditional separators such as------ @--- softHyphen = 'flatAlt' 'mempty' "-"--- softline = 'flatAlt' 'space' 'line'--- @------ 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-flatAlt- :: Doc ann -- ^ Default- -> Doc ann -- ^ Fallback 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@ with @i@ spaces, 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------ | 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 alredy predefined,--- for example------ @--- 'hsep' = 'concatWith' ('<+>')--- 'fillSep' = 'concatWith' (\\x y -> x '<>' 'softline' '<>' y)--- @------ This is also useful to define customized joiners,------ >>> concatWith (surround dot) ["Data", "Text", "Prettyprint", "Doc"]--- Data.Text.Prettyprint.Doc-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 = unsafeTextWithoutNewlines (T.replicate 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 ".") ["Data", "Text", "Prettyprint", "Doc"]--- Data.Text.Prettyprint.Doc-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--- "Data.Text.Prettyprint.Doc.Render.Tutorials.StackMachineTutorial" or--- "Data.Text.Prettyprint.Doc.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.--- "Data.Text.Prettyprint.Doc.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--- generlly 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.--- ('Data.Text.Prettyprint.Doc.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 _ Empty -> Empty-- 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)-- -- | Some layout algorithms use the Since the frequently used 'T.length' of- -- the 'Text', which scales linearly with its length, we cache it in this- -- constructor.- | 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.-removeTrailingWhitespace :: SimpleDocStream ann -> SimpleDocStream ann-removeTrailingWhitespace = go (WssWithheldWhitespace [] 0)- where- commitSpaces :: [Int] -> Int -> SimpleDocStream ann -> SimpleDocStream ann- commitSpaces [] 0 = id- commitSpaces [] 1 = SChar ' '- commitSpaces [] n = SText n (T.replicate n " ")- commitSpaces [i] _ = SLine i- commitSpaces (_:is) _ = SLine 0 . commitSpaces is 0-- go :: WhitespaceStrippingState -> SimpleDocStream ann -> SimpleDocStream ann- go annLevel@(WssAnnotationLevel annotationLevel) = \sds -> case sds of- SFail -> SFail- SEmpty -> SEmpty- SChar c rest -> SChar c (go annLevel rest)- SText textLength text rest -> SText textLength text (go annLevel rest)- SLine i rest -> SLine i (go annLevel rest)- SAnnPush ann rest -> SAnnPush ann (go (WssAnnotationLevel (annotationLevel+1)) rest)- SAnnPop rest- | annotationLevel > 1 -> SAnnPop (go (WssAnnotationLevel (annotationLevel-1)) rest)- | otherwise -> SAnnPop (go (WssWithheldWhitespace [] 0) rest)- go (WssWithheldWhitespace withheldLines withheldSpaces) = \sds -> case sds of- SFail -> SFail- SEmpty -> SEmpty- SChar c rest- | c == ' ' -> go (WssWithheldWhitespace withheldLines (withheldSpaces+1)) rest- | otherwise -> commitSpaces withheldLines withheldSpaces (SChar c (go (WssWithheldWhitespace [] 0) rest))- SText textLength text rest ->- let stripped = T.dropWhileEnd (== ' ') text- strippedLength = T.length stripped- trailingLength = textLength - strippedLength- isOnlySpace = strippedLength == 0- in if isOnlySpace- then go (WssWithheldWhitespace withheldLines (withheldSpaces + textLength)) rest- else commitSpaces withheldLines withheldSpaces (SText strippedLength stripped (go (WssWithheldWhitespace [] trailingLength) rest))- SLine i rest -> go (WssWithheldWhitespace (i:withheldLines) 0) rest- SAnnPush ann rest -> commitSpaces withheldLines withheldSpaces (SAnnPush ann (go (WssAnnotationLevel 1) rest))- SAnnPop _ -> error "Tried skipping spaces in unannotated data! Please report this as a bug in 'prettyprinter'."--data WhitespaceStrippingState- = WssAnnotationLevel !Int- | WssWithheldWhitespace [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--- <BLANKLINE>--- 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------ - page width--- - minimum nesting level to fit in--- - width in which to fit the first line; Nothing is unbounded-newtype FittingPredicate ann- = FittingPredicate (PageWidth- -> 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)---- $ 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 = AvailablePerLine 80 1 }---- | 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 = layoutWadlerLeijen- (FittingPredicate (\_pWidth _minNestingLevel maxWidth sdoc -> case maxWidth of- Nothing -> True- Just w -> fits w sdoc ))- 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---- | 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.------ Considre 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 Data.Text.Prettyprint.Doc.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 up to the end of the current--- indentation level, instead of just having one element lookahead.-layoutSmart- :: LayoutOptions- -> Doc ann- -> SimpleDocStream ann-layoutSmart = layoutWadlerLeijen- (FittingPredicate (\pWidth minNestingLevel maxWidth sdoc -> case maxWidth of- Nothing -> True- Just w -> fits pWidth minNestingLevel w sdoc ))- where- -- Search with more lookahead: assuming that nesting roughly corresponds to- -- syntactic depth, @fits@ checks that not only the current line fits, but- -- the entire syntactic structure being formatted at this level of- -- indentation fits. If we were to remove the second case for @SLine@, we- -- would check that not only the current structure fits, but also the rest- -- of the document, which would be slightly more intelligent but would have- -- exponential runtime (and is prohibitively expensive in practice).- fits :: PageWidth- -> Int -- ^ Minimum nesting level to fit in- -> Int -- ^ Width in which to fit the first line- -> SimpleDocStream ann- -> Bool- fits _ _ w _ | w < 0 = False- fits _ _ _ SFail = False- fits _ _ _ SEmpty = True- fits pw m w (SChar _ x) = fits pw m (w - 1) x- fits pw m w (SText l _t x) = fits pw m (w - l) x- fits pw m _ (SLine i x)- | m < i, AvailablePerLine cpl _ <- pw = fits pw m (cpl - i) x- | otherwise = True- fits pw m w (SAnnPush _ x) = fits pw m w x- fits pw m w (SAnnPop x) = fits pw m w x---- | The Wadler/Leijen layout algorithm-layoutWadlerLeijen- :: forall ann. FittingPredicate ann- -> LayoutOptions- -> Doc ann- -> SimpleDocStream ann-layoutWadlerLeijen- fittingPredicate- LayoutOptions { layoutPageWidth = pWidth }- 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 -> SLine i (best i i ds)- 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 fittingPredicate nl cc x' y'- Column f -> best nl cc (Cons i (f cc) ds)- WithPageWidth f -> best nl cc (Cons i (f pWidth) ds)- Nesting f -> best nl cc (Cons i (f i) ds)- Annotated ann x -> SAnnPush ann (best nl cc (Cons i x (UndoAnn ds)))-- selectNicer- :: FittingPredicate ann- -> Int -- ^ Current nesting level- -> Int -- ^ Current column- -> SimpleDocStream ann -- ^ Choice A. Invariant: first lines should not be longer than B's.- -> SimpleDocStream ann -- ^ Choice B.- -> SimpleDocStream ann -- ^ Choice A if it fits, otherwise B.- selectNicer (FittingPredicate fits) lineIndent currentColumn x y- | fits pWidth minNestingLevel availableWidth x = x- | otherwise = y- where- minNestingLevel = min lineIndent currentColumn- ribbonWidth = case pWidth of- AvailablePerLine lineLength ribbonFraction ->- (Just . max 0 . min lineLength . round)- (fromIntegral lineLength * ribbonFraction)- Unbounded -> Nothing- availableWidth = do- columnsLeftInLine <- case pWidth of- AvailablePerLine cpl _ribbonFrac -> Just (cpl - currentColumn)- Unbounded -> Nothing- columnsLeftInRibbon <- do- li <- Just lineIndent- rw <- ribbonWidth- cc <- Just currentColumn- Just (li + rw - cc)- Just (min columnsLeftInLine columnsLeftInRibbon)---- | @(layoutCompact x)@ lays out the document @x@ without adding any--- indentation. 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 ann -> SimpleDocStream ann-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------ $setup------ (Definitions for the doctests)------ >>> :set -XOverloadedStrings--- >>> import Data.Text.Prettyprint.Doc.Render.Text--- >>> import Data.Text.Prettyprint.Doc.Symbols.Ascii--- >>> import Data.Text.Prettyprint.Doc.Util as Util--- >>> import Test.QuickCheck.Modifiers+module Data.Text.Prettyprint.Doc.Internal {-# DEPRECATED "Use \"Prettyprinter.Internal\" instead." #-} (+ module Prettyprinter.Internal+) where++import Prettyprinter.Internal
+ src/Data/Text/Prettyprint/Doc/Internal/Debug.hs view
@@ -0,0 +1,5 @@+module Data.Text.Prettyprint.Doc.Internal.Debug {-# DEPRECATED "Use \"Prettyprinter.Internal.Debug\" instead." #-} (+ module Prettyprinter.Internal.Debug+) where++import Prettyprinter.Internal.Debug
src/Data/Text/Prettyprint/Doc/Internal/Type.hs view
@@ -1,12 +1,8 @@--- | __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 Data.Text.Prettyprint.Doc.Internal.Type (Doc(..)) where+module Data.Text.Prettyprint.Doc.Internal.Type {-# DEPRECATED "Use \"Prettyprinter.Internal.Type\" instead." #-} (+ module Prettyprinter.Internal.Type+) where -import Data.Text.Prettyprint.Doc.Internal+import Prettyprinter.Internal.Type+++
− src/Data/Text/Prettyprint/Doc/Render/ShowS.hs
@@ -1,5 +0,0 @@-module Data.Text.Prettyprint.Doc.Render.ShowS {-# DEPRECATED "Use Data.Text.Prettyprint.Doc.Render.String instead" #-} (- renderShowS-) where--import Data.Text.Prettyprint.Doc.Internal (renderShowS)
src/Data/Text/Prettyprint/Doc/Render/String.hs view
@@ -1,10 +1,5 @@-module Data.Text.Prettyprint.Doc.Render.String (- renderString,- renderShowS,+module Data.Text.Prettyprint.Doc.Render.String {-# DEPRECATED "Use \"Prettyprinter.Render.String\" instead." #-} (+ module Prettyprinter.Render.String ) where -import Data.Text.Prettyprint.Doc.Internal (SimpleDocStream, renderShowS)---- | Render a 'SimpleDocStream' to a 'String'.-renderString :: SimpleDocStream ann -> String-renderString s = renderShowS s ""+import Prettyprinter.Render.String
src/Data/Text/Prettyprint/Doc/Render/Text.hs view
@@ -1,120 +1,5 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}--#include "version-compatibility-macros.h"---- | Render an unannotated 'SimpleDocStream' as plain 'Text'.-module Data.Text.Prettyprint.Doc.Render.Text (- -- * Conversion to plain 'Text'- renderLazy, renderStrict,-- -- * Render to a 'Handle'- renderIO,-- -- ** Convenience functions- putDoc, hPutDoc+module Data.Text.Prettyprint.Doc.Render.Text {-# DEPRECATED "Use \"Prettyprinter.Render.Text\" instead." #-} (+ module Prettyprinter.Render.Text ) where ---import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.IO as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TLB-import System.IO--import Data.Text.Prettyprint.Doc-import Data.Text.Prettyprint.Doc.Render.Util.Panic-import Data.Text.Prettyprint.Doc.Render.Util.StackMachine--#if !(SEMIGROUP_IN_BASE)-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 . renderSimplyDecorated TLB.fromText (pure mempty) (pure mempty)---- | @('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 (T.replicate n " ")- go rest- SAnnPush _ann rest -> go rest- SAnnPop rest -> go rest---- | @('putDoc' doc)@ prettyprints document @doc@ to standard output. Uses the--- 'defaultLayoutOptions'.------ >>> 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)+import Prettyprinter.Render.Text
src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs view
@@ -1,170 +1,7 @@-{-# 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--- "Data.Text.Prettyprint.Doc.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 Data.Text.Prettyprint.Doc.Render.Tutorials.StackMachineTutorial- {-# DEPRECATED "Writing your own stack machine is probably more efficient and customizable; also consider using »renderSimplyDecorated(A)« instead" #-}- (- module Data.Text.Prettyprint.Doc.Render.Tutorials.StackMachineTutorial+module Data.Text.Prettyprint.Doc.Render.Tutorials.StackMachineTutorial {-# DEPRECATED "Use \"Prettyprinter.Render.Tutorials.StackMachineTutorial\" instead." #-} (+ module Prettyprinter.Render.Tutorials.StackMachineTutorial ) where ---import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TLB--import Data.Text.Prettyprint.Doc-import Data.Text.Prettyprint.Doc.Render.Util.Panic-import Data.Text.Prettyprint.Doc.Render.Util.StackMachine--#if !(APPLICATIVE_MONAD)-import Control.Applicative-#endif------ $standalone-text------ = The type of available markup------ 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------ $standalone-text------ == Conveinence 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)------ $standalone-text------ = The rendering algorithm------ 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--- 'Data.Text.Prettyprint.Doc.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 (T.replicate 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 -> ("<strong>", "</strong>")- Italics -> ("<em>", "</em>")- Color c -> ("<span style=\"color: " <> hexCode c <> "\">", "</span>")- Paragraph -> ("<p>", "</p>")- Headline -> ("<h1>", "</h1>")- 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--- 'Data.Text.Prettyprint.Doc.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.")---- $standalone-text------ = Example invocation------ 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.")--- >>> ])--- >>> :}--- <h1>Example document</h1>--- <p>This is a <span style="color: #f00">paragraph</span>,</p>--- <p>and <strong>this text is bold.</strong></p>+-- 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
src/Data/Text/Prettyprint/Doc/Render/Tutorials/TreeRenderingTutorial.hs view
@@ -1,137 +1,5 @@-{-# 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--- "Data.Text.Prettyprint.Doc.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 Data.Text.Prettyprint.Doc.Render.Tutorials.TreeRenderingTutorial (- module Data.Text.Prettyprint.Doc.Render.Tutorials.TreeRenderingTutorial+module Data.Text.Prettyprint.Doc.Render.Tutorials.TreeRenderingTutorial {-# DEPRECATED "Use \"Prettyprinter.Render.Tutorials.TreeRenderingTutorial\" instead." #-} (+ module Prettyprinter.Render.Tutorials.TreeRenderingTutorial ) where ---import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TLB--import Data.Text.Prettyprint.Doc-import Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree--#if !(FOLDABLE_TRAVERSABLE_IN_PRELUDE)-import Data.Foldable (foldMap)-#endif-#if !(SEMIGROUP_MONOID_SUPERCLASS)-import Data.Semigroup-#endif------ $standalone-text------ = The type of available markup------ 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------ $standalone-text------ == Conveinence 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------ 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 @<br/>@ 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--- 'Data.Text.Prettyprint.Doc.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--- 'Data.Text.Prettyprint.Doc.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 (T.replicate 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 -> "<strong>" <> x <> "</strong>"- Italics -> \x -> "<em>" <> x <> "</em>"- Color c -> \x -> "<span style=\"color: " <> hexCode c <> "\">" <> x <> "</span>"- Paragraph -> \x -> "<p>" <> x <> "</p>"- Headline -> \x -> "<h1>" <> x <> "</h1>"- where- hexCode :: Color -> TLB.Builder- hexCode c = case c of- Red -> "#f00"- Green -> "#0f0"- Blue -> "#00f"---- $standalone-text------ = Example invocation------ 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.")--- >>> ])--- >>> :}--- <h1>Example document</h1>--- <p>This is a <span style="color: #f00">paragraph</span>,</p>--- <p>and <strong>this text is bold.</strong></p>+import Prettyprinter.Render.Tutorials.TreeRenderingTutorial
src/Data/Text/Prettyprint/Doc/Render/Util/Panic.hs view
@@ -1,38 +1,5 @@-module Data.Text.Prettyprint.Doc.Render.Util.Panic (- panicUncaughtFail,- panicUnpairedPop,- panicSimpleDocTreeConversionFailed,- panicInputNotFullyConsumed,- panicPeekedEmpty,- panicPoppedEmpty,+module Data.Text.Prettyprint.Doc.Render.Util.Panic {-# DEPRECATED "Use \"Prettyprinter.Render.Util.Panic\" instead." #-} (+ module Prettyprinter.Render.Util.Panic ) where --- | Raise a hard 'error' if there is a 'Data.Text.Prettyprint.Doc.SFail' in a--- 'Data.Text.Prettyprint.Doc.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--- 'Data.Text.Prettyprint.Doc.SimpleDocStream' to--- 'Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree.SimpleDocTree' conversion fails.-panicSimpleDocTreeConversionFailed :: void-panicSimpleDocTreeConversionFailed = error ("Conversion from SimpleDocStream to SimpleDocTree failed! " ++ report)---- | Raise a hard 'error' when the »to--- 'Data.Text.Prettyprint.Doc.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.")+import Prettyprinter.Render.Util.Panic
src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs view
@@ -1,277 +1,5 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}--#include "version-compatibility-macros.h"---- | Conversion of the linked-list-like 'SimpleDocStream' to a tree-like--- 'SimpleDocTree'.-module Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree (-- -- * Type and conversion- SimpleDocTree(..),- treeForm,-- -- * Manipulating annotations- unAnnotateST,- reAnnotateST,- alterAnnotationsST,-- -- * Common use case shortcut definitions- renderSimplyDecorated,- renderSimplyDecoratedA,+module Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree {-# DEPRECATED "Use \"Prettyprinter.Render.Util.SimpleDocTree\" instead." #-} (+ module Prettyprinter.Render.Util.SimpleDocTree ) where ---import Control.Applicative-import Data.Text (Text)-import qualified Data.Text as T-import Data.Typeable (Typeable)-import GHC.Generics--import Data.Text.Prettyprint.Doc-import Data.Text.Prettyprint.Doc.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 Data.Text.Prettyprint.Doc 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<<<!-renderSimplyDecorated- :: Monoid out- => (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' <> T.replicate i " ")- STAnn ann rest -> renderAnn ann (go rest)- STConcat xs -> foldMap go xs-{-# INLINE renderSimplyDecorated #-}---- | Version of 'renderSimplyDecoratedA' that allows for 'Applicative' effects.-renderSimplyDecoratedA- :: (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.singleton '\n' <> T.replicate 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-#if !(APPLICATIVE_MONAD)- return = pure-#endif- UniqueParser p >>= f = UniqueParser (\s -> do- (a', s') <- p s- (a'', s'') <- runParser (f a') s'- pure (a'', s'') )--#if !(NO_FAIL_IN_MONAD_MONAD_FAIL)- 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-- -- | Some layout algorithms use the Since the frequently used 'T.length' of- -- the 'Text', which scales linearly with its length, we cache it in this- -- constructor.- | STText !Int Text-- -- | @Int@ = indentation level for the (next) line- | STLine !Int-- -- | Annotate the contained document.- | STAnn ann (SimpleDocTree ann)-- -- | Horizontal concatenation of multiple documents.- | STConcat [SimpleDocTree ann]- deriving (Eq, Ord, Show, Generic, 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+import Prettyprinter.Render.Util.SimpleDocTree
src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs view
@@ -1,169 +1,8 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}--#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 Data.Text.Prettyprint.Doc.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,+module Data.Text.Prettyprint.Doc.Render.Util.StackMachine {-# DEPRECATED "Use \"Prettyprinter.Render.Util.StackMachine\" instead." #-} (+ module Prettyprinter.Render.Util.StackMachine ) where ---import Control.Applicative-import Data.Text (Text)-import qualified Data.Text as T--import Data.Text.Prettyprint.Doc (SimpleDocStream (..))-import Data.Text.Prettyprint.Doc.Render.Util.Panic--#if !(SEMIGROUP_MONOID_SUPERCLASS)-import Data.Monoid-#endif----- $setup------ (Definitions for the doctests)------ >>> import Data.Text.Prettyprint.Doc 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<<<!------ The monoid will be concatenated in a /right associative/ fashion.-renderSimplyDecorated- :: Monoid out- => (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 (T.replicate i " ") <> go stack rest- go stack (SAnnPush ann rest) = push ann <> go (ann : stack) rest- go (ann:stack) (SAnnPop rest) = pop ann <> go stack rest- go [] SAnnPop{} = panicUnpairedPop-{-# INLINE renderSimplyDecorated #-}---- | Version of 'renderSimplyDecoratedA' that allows for 'Applicative' effects.-renderSimplyDecoratedA- :: (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 (T.replicate i " ") <++> go stack rest- go stack (SAnnPush ann rest) = push ann <++> go (ann : stack) rest- go (ann:stack) (SAnnPop rest) = pop ann <++> go stack rest- go [] SAnnPop{} = panicUnpairedPop-- (<++>) = liftA2 mappend-{-# INLINE renderSimplyDecoratedA #-}+import Prettyprinter.Render.Util.StackMachine --- | @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)
src/Data/Text/Prettyprint/Doc/Symbols/Ascii.hs view
@@ -1,154 +1,5 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}--#include "version-compatibility-macros.h"---- | Common symbols composed out of the ASCII subset of Unicode. For non-ASCII--- symbols, see "Data.Text.Prettyprint.Doc.Symbols.Unicode".-module Data.Text.Prettyprint.Doc.Symbols.Ascii where----import Data.Text.Prettyprint.Doc.Internal------ | >>> squotes "·"--- '·'-squotes :: Doc ann -> Doc ann-squotes = enclose squote squote---- | >>> dquotes "·"--- "·"-dquotes :: Doc ann -> Doc ann-dquotes = enclose dquote dquote---- | >>> parens "·"--- (·)-parens :: Doc ann -> Doc ann-parens = enclose lparen rparen---- | >>> angles "·"--- <·>-angles :: Doc ann -> Doc ann-angles = enclose langle rangle---- | >>> brackets "·"--- [·]-brackets :: Doc ann -> Doc ann-brackets = enclose lbracket rbracket---- | >>> braces "·"--- {·}-braces :: Doc ann -> Doc ann-braces = enclose lbrace rbrace---- | >>> squote--- '-squote :: Doc ann-squote = "'"---- | >>> dquote--- "-dquote :: Doc ann-dquote = "\""---- | >>> lparen--- (-lparen :: Doc ann-lparen = "("---- | >>> rparen--- )-rparen :: Doc ann-rparen = ")"---- | >>> langle--- <-langle :: Doc ann-langle = "<"---- | >>> rangle--- >-rangle :: Doc ann-rangle = ">"---- | >>> lbracket--- [-lbracket :: Doc ann-lbracket = "["--- | >>> rbracket--- ]-rbracket :: Doc ann-rbracket = "]"---- | >>> lbrace--- {-lbrace :: Doc ann-lbrace = "{"--- | >>> rbrace--- }-rbrace :: Doc ann-rbrace = "}"---- | >>> semi--- ;-semi :: Doc ann-semi = ";"---- | >>> colon--- :-colon :: Doc ann-colon = ":"---- | >>> comma--- ,-comma :: Doc ann-comma = ","---- | >>> "a" <> space <> "b"--- a b------ This is mostly used via @'<+>'@,------ >>> "a" <+> "b"--- a b-space :: Doc ann-space = " "---- | >>> dot--- .-dot :: Doc ann-dot = "."---- | >>> slash--- /-slash :: Doc ann-slash = "/"---- | >>> backslash--- \\--backslash :: Doc ann-backslash = "\\"---- | >>> equals--- =-equals :: Doc ann-equals = "="---- | >>> pipe--- |-pipe :: Doc ann-pipe = "|"--+module Data.Text.Prettyprint.Doc.Symbols.Ascii {-# DEPRECATED "Use \"Prettyprinter.Symbols.Ascii\" instead." #-} (+ module Prettyprinter.Symbols.Ascii+) where --- $setup------ (Definitions for the doctests)------ >>> :set -XOverloadedStrings--- >>> import Data.Semigroup--- >>> import Data.Text.Prettyprint.Doc.Render.Text--- >>> import Data.Text.Prettyprint.Doc.Util+import Prettyprinter.Symbols.Ascii
src/Data/Text/Prettyprint/Doc/Symbols/Unicode.hs view
@@ -1,212 +1,5 @@-{-# LANGUAGE OverloadedStrings #-}---- | A collection of predefined Unicode values outside of ASCII range. For--- ASCII, see "Data.Text.Prettyprint.Doc.Symbols.Ascii".-module Data.Text.Prettyprint.Doc.Symbols.Unicode (- -- * Quotes-- -- ** Enclosing- d9966quotes,- d6699quotes,- s96quotes,- s69quotes,- dGuillemetsOut,- dGuillemetsIn,- sGuillemetsOut,- sGuillemetsIn,-- -- ** Standalone- b99dquote,- t66dquote,- t99dquote,- b9quote,- t6quote,- t9quote,-- rdGuillemet,- ldGuillemet,- rsGuillemet,- lsGuillemet,-- -- * Various typographical symbols- bullet,- endash,-- -- * Currencies- euro,- cent,- yen,- pound,+module Data.Text.Prettyprint.Doc.Symbols.Unicode {-# DEPRECATED "Use \"Prettyprinter.Symbols.Unicode\" instead." #-} (+ module Prettyprinter.Symbols.Unicode ) where ---import Data.Text.Prettyprint.Doc------ | Double „99-66“ quotes, as used in German typography.------ >>> putDoc (d9966quotes "·")--- „·“-d9966quotes :: Doc ann -> Doc ann-d9966quotes = enclose b99dquote t66dquote---- | Double “66-99” quotes, as used in English typography.------ >>> putDoc (d6699quotes "·")--- “·”-d6699quotes :: Doc ann -> Doc ann-d6699quotes = enclose t66dquote t99dquote---- | Single ‚9-6‘ quotes, as used in German typography.------ >>> putDoc (s96quotes "·")--- ‚·‘-s96quotes :: Doc ann -> Doc ann-s96quotes = enclose b9quote t6quote---- | Single ‘6-9’ quotes, as used in English typography.------ >>> putDoc (s69quotes "·")--- ‘·’-s69quotes :: Doc ann -> Doc ann-s69quotes = enclose t6quote t9quote---- | Double «guillemets», pointing outwards (without adding any spacing).------ >>> putDoc (dGuillemetsOut "·")--- «·»-dGuillemetsOut :: Doc ann -> Doc ann-dGuillemetsOut = enclose ldGuillemet rdGuillemet---- | Double »guillemets«, pointing inwards (without adding any spacing).------ >>> putDoc (dGuillemetsIn "·")--- »·«-dGuillemetsIn :: Doc ann -> Doc ann-dGuillemetsIn = enclose rdGuillemet ldGuillemet---- | Single ‹guillemets›, pointing outwards (without adding any spacing).------ >>> putDoc (sGuillemetsOut "·")--- ‹·›-sGuillemetsOut :: Doc ann -> Doc ann-sGuillemetsOut = enclose lsGuillemet rsGuillemet---- | Single ›guillemets‹, pointing inwards (without adding any spacing).------ >>> putDoc (sGuillemetsIn "·")--- ›·‹-sGuillemetsIn :: Doc ann -> Doc ann-sGuillemetsIn = enclose rsGuillemet lsGuillemet---- | Bottom „99“ style double quotes.------ >>> putDoc b99dquote--- „-b99dquote :: Doc ann-b99dquote = "„"---- | Top “66” style double quotes.------ >>> putDoc t66dquote--- “-t66dquote :: Doc ann-t66dquote = "“"---- | Top “99” style double quotes.------ >>> putDoc t99dquote--- ”-t99dquote :: Doc ann-t99dquote = "”"---- | Bottom ‚9‘ style single quote.------ >>> putDoc b9quote--- ‚-b9quote :: Doc ann-b9quote = "‚"---- | Top ‘66’ style single quote.------ >>> putDoc t6quote--- ‘-t6quote :: Doc ann-t6quote = "‘"---- | Top ‘9’ style single quote.------ >>> putDoc t9quote--- ’-t9quote :: Doc ann-t9quote = "’"---- | Right-pointing double guillemets------ >>> putDoc rdGuillemet--- »-rdGuillemet :: Doc ann-rdGuillemet = "»"---- | Left-pointing double guillemets------ >>> putDoc ldGuillemet--- «-ldGuillemet :: Doc ann-ldGuillemet = "«"---- | Right-pointing single guillemets------ >>> putDoc rsGuillemet--- ›-rsGuillemet :: Doc ann-rsGuillemet = "›"---- | Left-pointing single guillemets------ >>> putDoc lsGuillemet--- ‹-lsGuillemet :: Doc ann-lsGuillemet = "‹"---- | >>> putDoc bullet--- •-bullet :: Doc ann-bullet = "•"---- | >>> putDoc endash--- –-endash :: Doc ann-endash = "–"---- | >>> putDoc euro--- €-euro :: Doc ann-euro = "€"---- | >>> putDoc cent--- ¢-cent :: Doc ann-cent = "¢"---- | >>> putDoc yen--- ¥-yen :: Doc ann-yen = "¥"---- | >>> putDoc pound--- £-pound :: Doc ann-pound = "£"------ $setup------ (Definitions for the doctests)------ >>> :set -XOverloadedStrings--- >>> import Data.Text.Prettyprint.Doc.Render.Text--- >>> import Data.Text.Prettyprint.Doc.Util+import Prettyprinter.Symbols.Unicode
src/Data/Text/Prettyprint/Doc/Util.hs view
@@ -1,65 +1,8 @@--- | Frequently useful definitions for working with general prettyprinters.-module Data.Text.Prettyprint.Doc.Util (- module Data.Text.Prettyprint.Doc.Util+module Data.Text.Prettyprint.Doc.Util {-# DEPRECATED "Use \"Prettyprinter.Util\" instead." #-} (+ module Prettyprinter.Util ) where ---import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Prettyprint.Doc.Render.Text-import Prelude hiding (words)-import System.IO--import Data.Text.Prettyprint.Doc------ | 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 }+import Prettyprinter.Util --- $setup------ (Definitions for the doctests)------ >>> :set -XOverloadedStrings
+ src/Prettyprinter.hs view
@@ -0,0 +1,348 @@+{-# 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 <dluposchainsky (λ) google>+-- 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 …'@ everywhere, 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(..), PrettyAnn(..),+ 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 which '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 mimicking the API of the former module, see+-- the @prettyprinter-compat-<former package>@ packages+-- 3. Using a converter from the old @Doc@ type to the new one, see the+-- @prettyprinter-convert-<former package>@ 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.
+ src/Prettyprinter/Internal.hs view
@@ -0,0 +1,2351 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++{-# 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(..), PrettyAnn(..),+ 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.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++import Numeric.Natural++#if !(FOLDABLE_TRAVERSABLE_IN_PRELUDE)+import Data.Foldable (Foldable (..))+import Data.Traversable (Traversable (..))+import Prelude hiding (null, foldr, foldr1)+#endif++import Data.Functor.Identity++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++-- |+-- @+-- 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++-- $+-- 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]) ] ]++-- | @since 1.7.2+instance ann ~ Void => Pretty (Doc ann) where+ pretty = vacuous++instance Pretty a => Pretty (Const a b) where+ pretty = pretty . getConst++-- | >>> pretty (Identity 1)+-- 1+instance Pretty a => Pretty (Identity a) where+ pretty = pretty . runIdentity++-- | >>> 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++-- | This class is similar to 'Pretty', but allows you to embed annotations in+-- the 'Doc'.+--+-- @since 1.7.2+class PrettyAnn ann a where++ prettyAnn :: a -> Doc ann++ default prettyAnn :: Show a => a -> Doc ann+ prettyAnn = viaShow++ prettyAnnList :: [a] -> Doc ann+ prettyAnnList = align . list . map prettyAnn++-- | @since 1.7.2+instance PrettyAnn ann (Doc ann) where+ prettyAnn = id++-- | @since 1.7.2+instance PrettyAnn ann a => PrettyAnn ann (Const a b) where+ prettyAnn = prettyAnn . getConst++-- | @since 1.7.2+instance PrettyAnn ann a => PrettyAnn ann (Identity a) where+ prettyAnn = prettyAnn . runIdentity++-- | @since 1.7.2+instance PrettyAnn ann a => PrettyAnn ann [a] where+ prettyAnn = prettyAnnList++-- | @since 1.7.2+instance PrettyAnn ann a => PrettyAnn ann (NonEmpty a) where+ prettyAnn (x:|xs) = prettyAnnList (x:xs)++-- | @since 1.7.2+instance PrettyAnn ann () where prettyAnn = pretty++-- | @since 1.7.2+instance PrettyAnn ann Bool where prettyAnn = pretty++-- | @since 1.7.2+instance PrettyAnn ann Char where+ prettyAnn = pretty+ prettyAnnList = prettyList++-- | 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++instance Pretty Natural where pretty = unsafeViaShow++-- | >>> 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, ())+--+-- @since 1.7.2+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)+--+-- @since 1.7.2+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)+--+-- @since 1.7.2+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])+--+-- @since 1.7.2+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++-- | @since 1.7.2+instance PrettyAnn ann Int where prettyAnn = pretty+-- | @since 1.7.2+instance PrettyAnn ann Int8 where prettyAnn = pretty+-- | @since 1.7.2+instance PrettyAnn ann Int16 where prettyAnn = pretty+-- | @since 1.7.2+instance PrettyAnn ann Int32 where prettyAnn = pretty+-- | @since 1.7.2+instance PrettyAnn ann Int64 where prettyAnn = pretty+-- | @since 1.7.2+instance PrettyAnn ann Word where prettyAnn = pretty+-- | @since 1.7.2+instance PrettyAnn ann Word8 where prettyAnn = pretty+-- | @since 1.7.2+instance PrettyAnn ann Word16 where prettyAnn = pretty+-- | @since 1.7.2+instance PrettyAnn ann Word32 where prettyAnn = pretty+-- | @since 1.7.2+instance PrettyAnn ann Word64 where prettyAnn = pretty++-- | @since 1.7.2+instance PrettyAnn ann Integer where prettyAnn = pretty++-- | @since 1.7.2+instance PrettyAnn ann Natural where prettyAnn = pretty++-- | @since 1.7.2+instance PrettyAnn ann Float where prettyAnn = pretty++-- | @since 1.7.2+instance PrettyAnn ann Double where prettyAnn = pretty++-- | @since 1.7.2+instance (PrettyAnn ann a1, PrettyAnn ann a2) => PrettyAnn ann (a1,a2) where+ prettyAnn (x1,x2) = tupled [prettyAnn x1, prettyAnn x2]++-- | @since 1.7.2+instance (PrettyAnn ann a1, PrettyAnn ann a2, PrettyAnn ann a3) => PrettyAnn ann (a1,a2,a3) where+ prettyAnn (x1,x2,x3) = tupled [prettyAnn x1, prettyAnn x2, prettyAnn x3]++-- | @since 1.7.2+instance (PrettyAnn ann a1, PrettyAnn ann a2, PrettyAnn ann a3, PrettyAnn ann a4) => PrettyAnn ann (a1,a2,a3,a4) where+ prettyAnn (x1,x2,x3,x4) = tupled [prettyAnn x1, prettyAnn x2, prettyAnn x3, prettyAnn x4]++-- | @since 1.7.2+instance (PrettyAnn ann a1, PrettyAnn ann a2, PrettyAnn ann a3, PrettyAnn ann a4, PrettyAnn ann a5) => PrettyAnn ann (a1,a2,a3,a4,a5) where+ prettyAnn (x1,x2,x3,x4,x5) = tupled [prettyAnn x1, prettyAnn x2, prettyAnn x3, prettyAnn x4, prettyAnn x5]++-- | @since 1.7.2+instance (PrettyAnn ann a1, PrettyAnn ann a2, PrettyAnn ann a3, PrettyAnn ann a4, PrettyAnn ann a5, PrettyAnn ann a6) => PrettyAnn ann (a1,a2,a3,a4,a5,a6) where+ prettyAnn (x1,x2,x3,x4,x5,x6) = tupled [prettyAnn x1, prettyAnn x2, prettyAnn x3, prettyAnn x4, prettyAnn x5, prettyAnn x6]++-- | @since 1.7.2+instance (PrettyAnn ann a1, PrettyAnn ann a2, PrettyAnn ann a3, PrettyAnn ann a4, PrettyAnn ann a5, PrettyAnn ann a6, PrettyAnn ann a7) => PrettyAnn ann (a1,a2,a3,a4,a5,a6,a7) where+ prettyAnn (x1,x2,x3,x4,x5,x6,x7) = tupled [prettyAnn x1, prettyAnn x2, prettyAnn x3, prettyAnn x4, prettyAnn x5, prettyAnn x6, prettyAnn x7]++-- | @since 1.7.2+instance PrettyAnn ann a => PrettyAnn ann (Maybe a) where+ prettyAnn = maybe mempty prettyAnn+ prettyAnnList = prettyAnnList . catMaybes++#ifdef MIN_VERSION_text+-- | @since 1.7.2+instance PrettyAnn ann Text where prettyAnn = pretty++-- | @since 1.7.2+instance PrettyAnn ann Lazy.Text where prettyAnn = pretty+#endif++-- | @since 1.7.2+instance PrettyAnn ann Void where prettyAnn = 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+-- otherwise 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 preferable 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 preferable 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 preferable 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++-- | 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)++-- | @('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)++-- | 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 <https://github.com/quchen/prettyprinter/pull/139> 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++++-- $+-- >>> import qualified Data.Text.IO as T+-- >>> doc = "lorem" <> hardline <> hardline <> pretty "ipsum"+-- >>> go = T.putStrLn . renderStrict . removeTrailingWhitespace . layoutPretty defaultLayoutOptions+-- >>> go doc+-- lorem+-- <BLANKLINE>+-- 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)++-- | List of nesting level/document pairs yet to be laid out.+data LayoutPipeline ann =+ Nil+ | Cons !Int (Doc ann) (LayoutPipeline ann)+ | UndoAnn (LayoutPipeline ann)++-- | 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)++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)++-- | 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+-- remainder of the current line fits the layout constraints; in other words,+-- it has up to one line of 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 within+-- the page width.+--+-- 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 constraints:+--+-- >>> 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 indentation = 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 <https://github.com/quchen/prettyprinter/issues/131>.)+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
+ src/Prettyprinter/Internal/Debug.hs view
@@ -0,0 +1,95 @@+-- | __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)))+
+ src/Prettyprinter/Internal/Type.hs view
@@ -0,0 +1,14 @@+{-# 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
+ src/Prettyprinter/Render/String.hs view
@@ -0,0 +1,10 @@+module 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 ""
+ src/Prettyprinter/Render/Text.hs view
@@ -0,0 +1,121 @@+{-# 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++-- $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)
+ src/Prettyprinter/Render/Tutorials/StackMachineTutorial.hs view
@@ -0,0 +1,154 @@+{-# 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++-- * 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 -> ("<strong>", "</strong>")+ Italics -> ("<em>", "</em>")+ Color c -> ("<span style=\"color: " <> hexCode c <> "\">", "</span>")+ Paragraph -> ("<p>", "</p>")+ Headline -> ("<h1>", "</h1>")+ 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.")+-- >>> ])+-- >>> :}+-- <h1>Example document</h1>+-- <p>This is a <span style="color: #f00">paragraph</span>,</p>+-- <p>and <strong>this text is bold.</strong></p>
+ src/Prettyprinter/Render/Tutorials/TreeRenderingTutorial.hs view
@@ -0,0 +1,128 @@+{-# 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 @<br/>@ 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 -> "<strong>" <> x <> "</strong>"+ Italics -> \x -> "<em>" <> x <> "</em>"+ Color c -> \x -> "<span style=\"color: " <> hexCode c <> "\">" <> x <> "</span>"+ Paragraph -> \x -> "<p>" <> x <> "</p>"+ Headline -> \x -> "<h1>" <> x <> "</h1>"+ 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.")+-- >>> ])+-- >>> :}+-- <h1>Example document</h1>+-- <p>This is a <span style="color: #f00">paragraph</span>,</p>+-- <p>and <strong>this text is bold.</strong></p>
+ src/Prettyprinter/Render/Util/Panic.hs view
@@ -0,0 +1,38 @@+module 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.")
+ src/Prettyprinter/Render/Util/SimpleDocTree.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE CPP #-}+{-# 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 GHC.Generics++import Prettyprinter+import Prettyprinter.Internal+import Prettyprinter.Render.Util.Panic++import qualified Control.Monad.Fail as Fail++#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<<<!+renderSimplyDecorated+ :: Monoid out+ => (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) }++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 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)++-- | 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)++-- | 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
+ src/Prettyprinter/Render/Util/StackMachine.hs view
@@ -0,0 +1,168 @@+{-# 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 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++#if !(LIFTA2_IN_PRELUDE)+import Control.Applicative (liftA2)+#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<<<!+--+-- The monoid will be concatenated in a /right associative/ fashion.+renderSimplyDecorated+ :: Monoid out+ => (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+ 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 retrieve the writing end+execStackMachine :: [styles] -> StackMachine output styles a -> (output, [styles])+execStackMachine styles (StackMachine r) = let (_, w, s) = r styles in (w, s)
+ src/Prettyprinter/Symbols/Ascii.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++#include "version-compatibility-macros.h"++-- | Common symbols composed out of the ASCII subset of Unicode. For non-ASCII+-- symbols, see "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
+ src/Prettyprinter/Symbols/Unicode.hs view
@@ -0,0 +1,210 @@+-- | 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
+ src/Prettyprinter/Util.hs view
@@ -0,0 +1,65 @@+-- | 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
test/Doctest/Main.hs view
@@ -2,5 +2,9 @@ import Test.DocTest +-- Silence -Wunused-packages:+import Prettyprinter ()+import Test.QuickCheck ()+ main :: IO () main = doctest [ "src" , "-Imisc"]
test/Testsuite/Main.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} #include "version-compatibility-macros.h" @@ -14,24 +15,20 @@ import Data.Word import System.Timeout (timeout) -import Data.Text.Prettyprint.Doc-import Data.Text.Prettyprint.Doc.Render.Text+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 @@ -55,32 +52,66 @@ 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- = forAll document (\doc ->- let rendered = render doc+ = 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)) )+ (render doc == render (fuse depth doc)) )) where- render = renderStrict . layoutPretty defaultLayoutOptions mkCounterexample rendered renderedFused- = (T.unpack . render . vsep)+ = (T.unpack . renderStrict . layoutPretty defaultLayoutOptions . vsep) [ "Unfused and fused documents render differently!" , "Unfused:" , indent 4 (pretty rendered) , "Fused:" , indent 4 (pretty renderedFused) ] -newtype RandomDoc ann = RandomDoc (Doc ann)--instance Arbitrary (RandomDoc ann) where- arbitrary = fmap RandomDoc document+instance Arbitrary ann => Arbitrary (Doc ann) where+ arbitrary = document+ shrink = genericShrink -- Possibly not a good idea, may break invariants -document :: Gen (Doc ann)+document :: Arbitrary ann => Gen (Doc ann) document = (dampen . frequency) [ (20, content) , (1, newlines)@@ -89,8 +120,12 @@ , (20, concatenationOfTwo) , (5, concatenationOfMany) , (1, enclosingOfOne)- , (1, enclosingOfMany) ]+ , (1, enclosingOfMany)+ , (1, annotated) ] +annotated :: Arbitrary ann => Gen (Doc ann)+annotated = annotate <$> arbitrary <*> document+ content :: Gen (Doc ann) content = frequency [ (1, pure emptyDoc)@@ -112,24 +147,24 @@ , (1, pure softline') , (1, pure hardline) ] -nestingAndAlignment :: Gen (Doc ann)+nestingAndAlignment :: Arbitrary ann => Gen (Doc ann) nestingAndAlignment = frequency [ (1, nest <$> arbitrary <*> concatenationOfMany) , (1, group <$> document) , (1, hang <$> arbitrary <*> concatenationOfMany) , (1, indent <$> arbitrary <*> concatenationOfMany) ] -grouping :: Gen (Doc ann)+grouping :: Arbitrary ann => Gen (Doc ann) grouping = frequency [ (1, align <$> document) , (1, flatAlt <$> document <*> document) ] -concatenationOfTwo :: Gen (Doc ann)+concatenationOfTwo :: Arbitrary ann => Gen (Doc ann) concatenationOfTwo = frequency [ (1, (<>) <$> document <*> document) , (1, (<+>) <$> document <*> document) ] -concatenationOfMany :: Gen (Doc ann)+concatenationOfMany :: Arbitrary ann => Gen (Doc ann) concatenationOfMany = frequency [ (1, hsep <$> listOf document) , (1, vsep <$> listOf document)@@ -140,7 +175,7 @@ , (1, fillCat <$> listOf document) , (1, cat <$> listOf document) ] -enclosingOfOne :: Gen (Doc ann)+enclosingOfOne :: Arbitrary ann => Gen (Doc ann) enclosingOfOne = frequency [ (1, squotes <$> document) , (1, dquotes <$> document)@@ -149,12 +184,67 @@ , (1, brackets <$> document) , (1, braces <$> document) ] -enclosingOfMany :: Gen (Doc ann)+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 _ = "<fitting predicate>"++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@@ -205,3 +295,101 @@ 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
test/Testsuite/StripTrailingSpace.hs view
@@ -10,15 +10,11 @@ import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Prettyprint.Doc-import Data.Text.Prettyprint.Doc.Render.Util.StackMachine+import Prettyprinter+import Prettyprinter.Render.Util.StackMachine import Test.Tasty import Test.Tasty.HUnit--#if !(APPLICATIVE_MONAD)-import Control.Applicative-#endif