diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,23 @@ +Copyright 2008, Daan Leijen and Max Bolingbroke, 2016 David Luposchainsky. All +rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +This software is provided by the copyright holders "as is" and any express or +implied warranties, including, but not limited to, the implied warranties of +merchantability and fitness for a particular purpose are disclaimed. In no event +shall the copyright holders be liable for any direct, indirect, incidental, +special, exemplary, or consequential damages (including, but not limited to, +procurement of substitute goods or services; loss of use, data, or profits; or +business interruption) however caused and on any theory of liability, whether in +contract, strict liability, or tort (including negligence or otherwise) arising +in any way out of the use of this software, even if advised of the possibility +of such damage. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,173 @@ + + + + +A modern Wadler/Leijen Prettyprinter +==================================== + +[![status](https://img.shields.io/github/release/quchen/prettyprinter.svg?style=flat-square&label=Latest%20version)](https://github.com/quchen/prettyprinter/releases) +[![status](https://img.shields.io/travis/quchen/prettyprinter/master.svg?style=flat-square&label=Master%20build)](https://travis-ci.org/quchen/prettyprinter) + + + +tl;dr +----- + +A prettyprinter/text rendering engine. Easy to use, well-documented, ANSI +terminal backend exists, HTML backend is trivial to implement, no name clashes, +Text-based, extensible. + + + +Longer; want to read +-------------------- + +This package defines a prettyprinter to format text in a flexible and convenient +way. The idea is to combine a document out of many small components, then using +a layouter to convert it to an easily renderable simple document, which can then +be rendered to a variety of formats, for example plain `Text`, or Markdown. +*What you are reading right now was generated by this library (see +`GenerateReadme.hs`).* + + + +Why another prettyprinter? +-------------------------- + +Haskell, more specifically Hackage, has a zoo of Wadler/Leijen based +prettyprinters already. Each of them addresses a different concern with the +classic `wl-pprint` package. This package solves *all* these issues, and then +some. + + + +### `Text` instead of `String` + +`String` has exactly one use, and that’s showing Hello World in tutorials. For +all other uses, Text is what people should be using. The prettyprinter uses no +`String` definitions anywhere; using a `String` means an immediate conversion to +the internal `Text`-based format. + + + +### Extensive documentation + +The library is stuffed with runnable examples, showing use cases for the vast +majority of exported values. Many things reference related definitions, +*everything* comes with at least a sentence explaining its purpose. + + + +### No name clashes + +Many prettyprinters use the legacy API of the first Wadler/Leijen prettyprinter, +which used e.g. `(<$>)` to separate lines, which clashes with the ubiquitous +synonym for `fmap` that’s been in Base for ages. These definitions were either +removed or renamed, so there are no name clashes with standard libraries +anymore. + + + +### Annotation support + +Text is not all letters and newlines. Often, we want to add more information, +the simplest kind being some form of styling. An ANSI terminal supports +coloring, a web browser a plethora of different formattings. + +More complex uses of annotations include e.g. adding type annotations for +mouse-over hovers when printing a syntax tree, adding URLs to documentation, or +adding source locations to show where a certain piece of output comes from. +Idris is a project that makes extensive use of such a feature. + +Special care has been applied to make annotations unobtrusive, so that if you +don’t need or care about them there is no overhead, neither in terms of +usability nor performance. + + + +### Extensible backends + +A document can be rendered in many different ways, for many different clients. +There is plain text, there is the ANSI terminal, there is the browser. Each of +these speak different languages, and the backend is responsible for the +translation to those languages. Backends should be readily available, or easy to +implement if a custom solution is desired. + +As a result, each backend requires only minimal dependencies; if you don’t want +to print to an ANSI terminal for example, there is no need to have a dependency +on a terminal library. + + + +### Performance + +Rendering large documents should be done efficiently, and the library should +make it easy to optimize common use cases for the programmer. + + + +### Open implementation + +The type of documents is unanimously (!) abstract in the other Wadler/Leijen +prettyprinters, making it impossible to write adaptors from one library to +another. The type should be exposed for such purposes so it is possible to write +adaptors from library to library, or each of them is doomed to live on its own +small island of incompatibility. For this reason, the `Doc` type is fully +exposed in a semi-internal module for this specific use case. + + + +The prettyprinter family +------------------------ + +The `prettyprinter` family of packages consists of: + + - `prettyprinter` is the core package. It defines the language to generate + nicely laid out documents, which can then be given to renderers to display + them in various ways, e.g. HTML, or plain text. + - `prettyprinter-ansi-terminal` provides a renderer suitable for ANSI terminal + output including colors (at the cost of a dependency more). + - `prettyprinter-compat-wl-pprint` provides a drop-in compatibility layer for + previous users of the `wl-pprint` package. Use it for easy adaption of the + new `prettyprinter`, but don't develop anything new with it. + - `prettyprinter-compat-ansi-wl-pprint` is the same, but for previous users of + `ansi-wl-pprint`. + - `prettyprinter-compat-annotated-wl-pprint` is the same, but for previous + users of `annotated-wl-pprint`. + + + +Differences to the old Wadler/Leijen prettyprinters +--------------------------------------------------- + +The library originally started as a fork of `ansi-wl-pprint` until every line +had been touched. The result is still in the same spirit as its predecessors, +but modernized to match the current ecosystem and needs. + +The most significant changes are: + + 1. `(<$>)` is removed as an operator, since it clashes with the common alias + for `fmap`. + 2. All but the essential `<>` and `<+>` operators were removed or replaced by + ordinary names. + 3. Everything extensively documented, with references to other functions and + runnable code examples. + 4. Use of `Text` instead of `String`. + 5. A `fuse` function to optimize often-used documents before rendering for + efficiency. + 6. Instead of providing an own colorization function for each + color/intensity/layer combination, they have been combined in 'color' + 'colorDull', 'bgColor', and 'bgColorDull' functions. + + + +Historical notes +---------------- + +This module is based on previous work by Daan Leijen and Max Bolingbroke, who +implemented and significantly extended the prettyprinter given by a [paper by +Phil Wadler in his 1997 paper »A Prettier +Printer«](https://homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf), +by adding lots of convenience functions, styling, and new functionality. Their +package, ansi-wl-pprint is widely used in the Haskell ecosystem, and is at the +time of writing maintained by Edward Kmett. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/app/GenerateReadme.hs b/app/GenerateReadme.hs new file mode 100644 --- /dev/null +++ b/app/GenerateReadme.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Main (main) where + + + +import Prelude hiding (words) + +import qualified Data.List as L +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.Text + +import MultilineTh + + + +main :: IO () +main = (T.putStrLn . renderStrict . layoutPretty layoutOptions) readmeContents + where + layoutOptions = LayoutOptions { layoutPageWidth = AvailablePerLine 80 1 } + +readmeContents :: Doc ann +readmeContents = (mconcat . L.intersperse vspace) + [ htmlComment "This file was auto-generated by the 'scripts/generate_readme' program." + + , h1 "A modern Wadler/Leijen Prettyprinter" + + , cat + [ "[![status](https://img.shields.io/github/release/quchen/prettyprinter.svg?style=flat-square&label=Latest%20version)](https://github.com/quchen/prettyprinter/releases)" + , "[![status](https://img.shields.io/travis/quchen/prettyprinter/master.svg?style=flat-square&label=Master%20build)](https://travis-ci.org/quchen/prettyprinter)" + ] + + , h2 "tl;dr" + , paragraph [multiline| A prettyprinter/text rendering engine. Easy to + use, well-documented, ANSI terminal backend exists, HTML backend is + trivial to implement, no name clashes, Text-based, extensible. |] + + , h2 "Longer; want to read" + , paragraph [multiline| This package defines a prettyprinter to format + text in a flexible and convenient way. The idea is to combine a document + out of many small components, then using a layouter to convert it to an + easily renderable simple document, which can then be rendered to a + variety of formats, for example plain `Text`, or Markdown. *What you are + reading right now was generated by this library (see + `GenerateReadme.hs`).* |] + + , h2 "Why another prettyprinter?" + , paragraph [multiline| Haskell, more specifically Hackage, has a zoo of + Wadler/Leijen based prettyprinters already. Each of them addresses a + different concern with the classic `wl-pprint` package. This package + solves *all* these issues, and then some. |] + + , h3 "`Text` instead of `String`" + , paragraph [multiline| `String` has exactly one use, and that’s showing + Hello World in tutorials. For all other uses, Text is what people should + be using. The prettyprinter uses no `String` definitions anywhere; using + a `String` means an immediate conversion to the internal `Text`-based + format. |] + + , h3 "Extensive documentation" + , paragraph [multiline| The library is stuffed with runnable examples, + showing use cases for the vast majority of exported values. Many things + reference related definitions, *everything* comes with at least a + sentence explaining its purpose. |] + + , h3 "No name clashes" + , paragraph [multiline| Many prettyprinters use the legacy API of the + first Wadler/Leijen prettyprinter, which used e.g. `(<$>)` to separate + lines, which clashes with the ubiquitous synonym for `fmap` that’s been + in Base for ages. These definitions were either removed or renamed, so + there are no name clashes with standard libraries anymore. |] + + , h3 "Annotation support" + , paragraph [multiline| Text is not all letters and newlines. Often, we + want to add more information, the simplest kind being some form of + styling. An ANSI terminal supports coloring, a web browser a plethora of + different formattings. |] + + , paragraph [multiline| More complex uses of annotations include e.g. + adding type annotations for mouse-over hovers when printing a syntax + tree, adding URLs to documentation, or adding source locations to show + where a certain piece of output comes from. Idris is a project that + makes extensive use of such a feature. |] + + , paragraph [multiline| Special care has been applied to make + annotations unobtrusive, so that if you don’t need or care about them + there is no overhead, neither in terms of usability nor performance. |] + + , h3 "Extensible backends" + , paragraph [multiline| A document can be rendered in many different + ways, for many different clients. There is plain text, there is the ANSI + terminal, there is the browser. Each of these speak different languages, + and the backend is responsible for the translation to those languages. + Backends should be readily available, or easy to implement if a custom + solution is desired. |] + + , paragraph [multiline| As a result, each backend requires only minimal + dependencies; if you don’t want to print to an ANSI terminal for + example, there is no need to have a dependency on a terminal library. |] + + , h3 "Performance" + , paragraph [multiline| Rendering large documents should be done + efficiently, and the library should make it easy to optimize common use + cases for the programmer. |] + + , h3 "Open implementation" + , paragraph [multiline| The type of documents is unanimously (!) + abstract in the other Wadler/Leijen prettyprinters, making it impossible + to write adaptors from one library to another. The type should be + exposed for such purposes so it is possible to write adaptors from + library to library, or each of them is doomed to live on its own small + island of incompatibility. For this reason, the `Doc` type is fully + exposed in a semi-internal module for this specific use case. |] + + , h2 "The prettyprinter family" + , paragraph "The `prettyprinter` family of packages consists of:" + , (indent 2 . unorderedList . map paragraph) + [ [multiline| `prettyprinter` is the core package. It defines the + language to generate nicely laid out documents, which can then be + given to renderers to display them in various ways, e.g. HTML, or + plain text.|] + , [multiline| `prettyprinter-ansi-terminal` provides a renderer suitable + for ANSI terminal output including colors (at the cost of a + dependency more).|] + , [multiline| `prettyprinter-compat-wl-pprint` provides a drop-in + compatibility layer for previous users of the `wl-pprint` package. Use + it for easy adaption of the new `prettyprinter`, but don't develop + anything new with it.|] + , [multiline| `prettyprinter-compat-ansi-wl-pprint` is the same, but for + previous users of `ansi-wl-pprint`.|] + , [multiline| `prettyprinter-compat-annotated-wl-pprint` is the same, + but for previous users of `annotated-wl-pprint`.|] + ] + + , h2 "Differences to the old Wadler/Leijen prettyprinters" + + , paragraph [multiline| The library originally started as a fork of + `ansi-wl-pprint` until every line had been touched. The result is still in + the same spirit as its predecessors, but modernized to match the current + ecosystem and needs. |] + + , paragraph "The most significant changes are:" + , (indent 2 . orderedList . map paragraph) + [ [multiline| `(<$>)` is removed as an operator, since it clashes with + the common alias for `fmap`. |] + , [multiline| All but the essential `<>` and `<+>` operators were + removed or replaced by ordinary names. |] + , [multiline| Everything extensively documented, with references to + other functions and runnable code examples. |] + , [multiline| Use of `Text` instead of `String`. |] + , [multiline| A `fuse` function to optimize often-used documents before + rendering for efficiency. |] + , [multiline| Instead of providing an own colorization function for each + color/intensity/layer combination, they have been combined in 'color' + 'colorDull', 'bgColor', and 'bgColorDull' functions. |] + ] + + , h2 "Historical notes" + + , paragraph [multiline| This module is based on previous work by Daan + Leijen and Max Bolingbroke, who implemented and significantly extended + the prettyprinter given by a [paper by Phil Wadler in his 1997 paper »A + Prettier + Printer«](https://homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf), + by adding lots of convenience functions, styling, and new functionality. + Their package, ansi-wl-pprint is widely used in the Haskell ecosystem, + and is at the time of writing maintained by Edward Kmett.|] + + ] + +paragraph :: Text -> Doc ann +paragraph = align . fillSep . map pretty . T.words + +vspace :: Doc ann +vspace = hardline <> hardline + +h1 :: Doc ann -> Doc ann +h1 x = vspace <> underlineWith "=" x + +h2 :: Doc ann -> Doc ann +h2 x = vspace <> underlineWith "-" x + +h3 :: Doc ann -> Doc ann +h3 x = vspace <> "###" <+> x + +underlineWith :: Text -> Doc ann -> Doc ann +underlineWith symbol x = align (width x (\w -> + hardline <> pretty (T.take w (T.replicate w symbol)))) + +orderedList :: [Doc ann] -> Doc ann +orderedList = align . vsep . zipWith (\i x -> pretty i <> dot <+> align x) [1::Int ..] + +unorderedList :: [Doc ann] -> Doc ann +unorderedList = align . vsep . map ("-" <+>) + +htmlComment :: Doc ann -> Doc ann +htmlComment = enclose "" diff --git a/app/MultilineTh.hs b/app/MultilineTh.hs new file mode 100644 --- /dev/null +++ b/app/MultilineTh.hs @@ -0,0 +1,30 @@ +module MultilineTh (multiline) where + + + +import qualified Data.Text as T +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Language.Haskell.TH.Syntax +import Prelude + + + +multiline :: QuasiQuoter +multiline = QuasiQuoter + { quoteExp = quoteUnlines + , quotePat = const badUse + , quoteType = const badUse + , quoteDec = const badUse + } + where + badUse = fail "multiline quasiquoter can only be used as an expression" + +quoteUnlines :: String -> Q Exp +quoteUnlines = + liftString + . T.unpack + . T.unwords + . filter (not . T.null) + . T.words + . T.pack diff --git a/bench/FasterUnsafeText.hs b/bench/FasterUnsafeText.hs new file mode 100644 --- /dev/null +++ b/bench/FasterUnsafeText.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + + + +import Criterion.Main +import Data.Char +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Prettyprint.Doc.Internal + + + +-- The old implementation. Performance isn’t much worse to be honest, mostly +-- well within a σ. +alternative :: Text -> Doc ann +alternative t = case T.length t of + 0 -> Empty + 1 -> Char (T.head t) + n -> Text n t + +current :: Text -> Doc ann +current = unsafeText + +main :: IO () +main = defaultMain [ benchText (letters n) | n <- [0,1,2,3,5,10,50,100] ] + +letters :: Int -> Text +letters n = T.pack (take n (filter isAlpha [minBound ..])) + +benchText :: Text -> Benchmark +benchText input = bgroup (show (pretty (T.length input) <+> plural "letter" "letters" (T.length input))) + [ bench "alternative" (whnf alternative input) + , bench "current" (whnf current input) ] diff --git a/bench/Fusion.hs b/bench/Fusion.hs new file mode 100644 --- /dev/null +++ b/bench/Fusion.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +#include "version-compatibility-macros.h" + +module Main (main) where + + + +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 + +#if !(APPLICATIVE_MONAD) +import Control.Applicative +#endif + + + +main :: IO () +main = defaultMain + [ benchOptimize + , benchWLComparison + ] + +benchOptimize :: Benchmark +benchOptimize = env randomShortWords benchmark + where + benchmark = \shortWords -> + let doc = hsep (map pretty shortWords) + in bgroup "Many small words" + [ bench "Unoptimized" (nf renderLazy (layoutPretty defaultLayoutOptions doc)) + , bench "Shallowly fused" (nf renderLazy (layoutPretty defaultLayoutOptions (fuse Shallow doc))) + , bench "Deeply fused" (nf renderLazy (layoutPretty defaultLayoutOptions (fuse Deep doc))) + ] + + randomShortWords :: Applicative m => m [Text] + randomShortWords = pure (evalState (randomShortWords' 100) (mkStdGen 0)) + + randomShortWords' :: Int -> State StdGen [Text] + randomShortWords' n = replicateM n randomShortWord + + randomShortWord :: State StdGen Text + randomShortWord = do + g <- get + let (l, g') = randomR (0, 5) g + (gNew, gFree) = split g' + xs = take l (randoms gFree) + put gNew + pure (T.pack xs) + +benchWLComparison :: Benchmark +benchWLComparison = bgroup "vs. other libs" + [ bgroup "renderPretty" + [ bench "this, unoptimized" (nf (renderLazy . layoutPretty defaultLayoutOptions) doc) + , bench "this, shallowly fused" (nf (renderLazy . layoutPretty defaultLayoutOptions) (fuse Shallow doc)) + , bench "this, deeply fused" (nf (renderLazy . layoutPretty defaultLayoutOptions) (fuse Deep doc)) + , bench "ansi-wl-pprint" (nf (\d -> WL.displayS (WL.renderPretty 0.4 80 d) "") wlDoc) + ] + , bgroup "renderSmart" + [ bench "this, unoptimized" (nf (renderLazy . layoutSmart defaultLayoutOptions) doc) + , bench "this, shallowly fused" (nf (renderLazy . layoutSmart defaultLayoutOptions) (fuse Shallow doc)) + , bench "this, deeply fused" (nf (renderLazy . layoutSmart defaultLayoutOptions) (fuse Deep doc)) + , bench "ansi-wl-pprint" (nf (\d -> WL.displayS (WL.renderSmart 0.4 80 d) "") wlDoc) + ] + , bgroup "renderCompact" + [ bench "this, unoptimized" (nf (renderLazy . layoutCompact) doc) + , bench "this, shallowly fused" (nf (renderLazy . layoutCompact) (fuse Shallow doc)) + , bench "this, deeply fused" (nf (renderLazy . layoutCompact) (fuse Deep doc)) + , bench "ansi-wl-pprint" (nf (\d -> WL.displayS (WL.renderCompact d) "") wlDoc) + ] + ] + where + doc :: Doc ann + doc = let fun x = "fun" <> parens (softline <> x) + funnn = chain 10 fun + in funnn (sep (take 48 (cycle ["hello", "world"]))) + + wlDoc :: WL.Doc + wlDoc = let fun x = "fun" WL.<> WL.parens (WL.softline WL.<> x) + funnn = chain 10 fun + in funnn (WL.sep (take 48 (cycle ["hello", "world"]))) + + chain n f = foldr (.) id (replicate n f) diff --git a/misc/version-compatibility-macros.h b/misc/version-compatibility-macros.h new file mode 100644 --- /dev/null +++ b/misc/version-compatibility-macros.h @@ -0,0 +1,19 @@ +#ifndef VERSION_COMPATIBILITY_MACROS +#define VERSION_COMPATIBILITY_MACROS + +#ifndef MIN_VERSION_base +#error "MIN_VERSION_base macro not defined!" +#endif + +-- These macros allow writing CPP compatibility hacks in a way that makes their +-- purpose much clearer than just demanding a specific version of a library. + +#define APPLICATIVE_MONAD MIN_VERSION_base(4,8,0) +#define FOLDABLE_TRAVERSABLE_IN_PRELUDE MIN_VERSION_base(4,8,0) +#define MONOID_IN_PRELUDE MIN_VERSION_base(4,8,0) +#define NATURAL_IN_BASE MIN_VERSION_base(4,8,0) +#define SEMIGROUP_IN_BASE MIN_VERSION_base(4,8,0) + +#define MONAD_FAIL MIN_VERSION_base(4,9,0) + +#endif diff --git a/prettyprinter.cabal b/prettyprinter.cabal new file mode 100644 --- /dev/null +++ b/prettyprinter.cabal @@ -0,0 +1,147 @@ +name: prettyprinter +version: 0.1 +cabal-version: >= 1.10 +category: User Interfaces, Text +synopsis: A modern, extensible and well-documented prettyprinter. +description: See README.md +license: BSD2 +license-file: LICENSE.md +extra-source-files: README.md + , misc/version-compatibility-macros.h +author: Phil Wadler, Daan Leijen, Max Bolingbroke, Edward Kmett, David Luposchainsky +maintainer: David Luposchainsky +bug-reports: http://github.com/quchen/prettyprinter/issues +homepage: http://github.com/quchen/prettyprinter +build-type: Simple +tested-with: GHC==7.8.4, GHC==7.10.2, GHC==7.10.3, GHC==8.0.1, GHC==8.0.2 + + + +source-repository head + type: git + location: git://github.com/quchen/prettyprinter.git + + + +library + exposed-modules: + Data.Text.Prettyprint.Doc + , Data.Text.Prettyprint.Doc.Internal + , Data.Text.Prettyprint.Doc.Internal.Type + , Data.Text.Prettyprint.Doc.Render.ShowS + , Data.Text.Prettyprint.Doc.Render.Text + , Data.Text.Prettyprint.Doc.Render.Tutorials.StackMachineTutorial + , Data.Text.Prettyprint.Doc.Render.Tutorials.TreeRenderingTutorial + , Data.Text.Prettyprint.Doc.Render.Util.Panic + , Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree + , Data.Text.Prettyprint.Doc.Render.Util.StackMachine + , Data.Text.Prettyprint.Doc.Util + -- Hidden for now, until I figure out where to put it: + -- , Data.Text.Prettyprint.Doc.Unicode + ghc-options: -Wall + hs-source-dirs: src + include-dirs: misc + default-language: Haskell2010 + other-extensions: + BangPatterns + , CPP + , LambdaCase + , OverloadedStrings + , QuasiQuotes + , DefaultSignatures + , ScopedTypeVariables + + build-depends: + base < 127 + , text + + if impl(ghc >= 8.0) + ghc-options: -Wcompat + if impl(ghc < 8.0) + build-depends: semigroups >= 0.1 && < 0.19 + if impl(ghc < 7.10) + build-depends: void + + + +executable generate_readme + hs-source-dirs: app + main-is: GenerateReadme.hs + build-depends: + base < 127 + , prettyprinter + , text + , template-haskell + default-language: Haskell2010 + other-modules: MultilineTh + other-extensions: OverloadedStrings + , TemplateHaskell + if impl (ghc < 7.10) + buildable: False + + + +test-suite doctest + type: exitcode-stdio-1.0 + hs-source-dirs: test/Doctest + main-is: Main.hs + build-depends: + base < 127 + , doctest >= 0.9 + , QuickCheck >= 2.7 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + if impl (ghc < 7.10) + buildable: False + -- Doctest does not support searching through directories in old versions + +test-suite testsuite + type: exitcode-stdio-1.0 + hs-source-dirs: test/Testsuite + main-is: Main.hs + build-depends: + base + , prettyprinter + + , pgp-wordlist + , bytestring + , tasty + , tasty-quickcheck + , text + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + default-language: Haskell2010 + + if impl(ghc < 8.0) + build-depends: semigroups >= 0.1 && < 0.19 + + + +benchmark fusion + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Fusion.hs + build-depends: + base + , prettyprinter + + , criterion + , mtl + , random + , text + , transformers + , ansi-wl-pprint + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + other-extensions: NumDecimals, OverloadedStrings + +benchmark faster-unsafe-text + build-depends: base >= 4.7 && < 5 + , criterion + , text + , prettyprinter + + hs-source-dirs: bench + main-is: FasterUnsafeText.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + default-language: Haskell2010 + type: exitcode-stdio-1.0 diff --git a/src/Data/Text/Prettyprint/Doc.hs b/src/Data/Text/Prettyprint/Doc.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Prettyprint/Doc.hs @@ -0,0 +1,254 @@ +-- | +-- 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 +-- 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 +-- 'SimpleDoc', 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', │ │ 'Doc' │ +-- │ '<+>', 'nest', ├─────▷│ (rich document) │ +-- │ 'align', … │ ╰─────────┬─────────╯ +-- ╰───────────────╯ │ +-- │ Layout algorithms +-- │ e.g. 'layoutPretty' +-- ▽ +-- ╭───────────────────╮ +-- │ 'SimpleDoc' │ +-- │ (simple document) │ +-- ╰─────────┬─────────╯ +-- │ +-- │ Renderers +-- │ +-- ╭───────────────────┼───────────────────╮ +-- │ │ │ +-- ▽ ▽ ▽ +-- ╭───────────────╮ ╭───────────────╮ ╭───────────────╮ +-- │ Plain 'Text' │ │ ANSI terminal │ │ other/custom │ +-- ╰───────────────╯ ╰───────────────╯ ╰───────────────╯ +-- @ +-- +-- = 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. +module Data.Text.Prettyprint.Doc ( + -- * Documents + Doc, + + -- * Basic functionality + Pretty(..), + 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, + unAnnotateS, + reAnnotateS, + + -- * Optimization + -- + -- Render documents faster + fuse, FusionDepth(..), + + -- * Layout + -- + -- | Laying a 'Doc'ument out produces a straightforward 'SimpleDoc' 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 + -- 'SimpleDoc'. For the common case of rendering a 'SimpleDoc' as plain + -- 'Text' take a look at "Data.Text.Prettyprint.Doc.Render.Text". + SimpleDoc(..), + PageWidth(..), LayoutOptions(..), defaultLayoutOptions, + layoutPretty, layoutCompact, layoutSmart, + + -- * Migration guide + -- + -- $migration +) where + + + +import Data.Semigroup +import Data.Text.Prettyprint.Doc.Internal + +-- $setup +-- +-- (Definitions for the doctests) +-- +-- >>> :set -XOverloadedStrings +-- >>> import Data.Text.Prettyprint.Doc.Render.Text +-- >>> import Data.Text.Prettyprint.Doc.Util + + + +-- $migration +-- +-- 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 'T.unpack' on the generated renderings. +-- - 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. +-- - Instead of providing an own colorization function for each +-- color\/intensity\/layer combination, they have been combined in 'color', +-- 'colorDull', 'bgColor', and 'bgColorDull' functions. diff --git a/src/Data/Text/Prettyprint/Doc/Internal.hs b/src/Data/Text/Prettyprint/Doc/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Prettyprint/Doc/Internal.hs @@ -0,0 +1,1739 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# 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 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 + +-- 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 Prelude hiding (foldr, foldr1) +#endif +#if !(MONOID_IN_PRELUDE) +import Data.Monoid hiding ((<>)) +#endif + +import Data.Text.Prettyprint.Doc.Render.Util.Panic + + + +-- $setup +-- +-- (Definitions for the doctests) +-- +-- >>> :set -XOverloadedStrings +-- >>> import Data.Text.Prettyprint.Doc.Render.Text +-- >>> import Data.Text.Prettyprint.Doc.Util as Util +-- >>> import Test.QuickCheck.Modifiers + + + +-- | 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) +-- - metailed 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; unit of 'Cat' (observationally) + | Empty + + -- | invariant: char is 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 + + -- | 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: first lines of first '(Doc ann)' longer than the first lines of + -- the second one. 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) + +-- | +-- @ +-- 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 + +-- | Overloaded conversion to 'Doc'. +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 = list . map pretty + +-- | >>> 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) + +-- | Does not change the text, but removes all annotations. __Pitfall__: since +-- this un-annotates its argument, nesting it means multiple, potentially +-- costly, traversals over the 'Doc'. +-- +-- >>> pretty 123 +-- 123 +-- >>> pretty (pretty 123) +-- 123 +instance Pretty (Doc ann) where + pretty = unAnnotate + +-- | >>> pretty () +-- () +-- +-- The argument is not used, +-- +-- >>> pretty (error "Strict?" :: ()) +-- () +instance Pretty () where + pretty _ = "()" + +-- | >>> pretty True +-- True +instance Pretty Bool where + pretty = \case + True -> "True" + 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 + +-- | 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 + +-- | Convert a 'Show'able value /that must not contain newlines/ to a 'Doc'. +-- If there are newlines, use 'viaShow' instead. +unsafeViaShow :: Show a => a -> Doc ann +unsafeViaShow = unsafeText . 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.718281828459045 +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 unsafeText . T.splitOn "\n" + +-- | (lazy 'Text' instance, identical to the strict version) +instance Pretty Lazy.Text where pretty = pretty . Lazy.toStrict + +-- | I tried finding a good example to show here but could not find one +instance Pretty Void where pretty = absurd + + + +-- | The data type @SimpleDoc@ represents laid out documents and is used by the +-- display functions. +-- +-- A simplified view is that @'Doc' = ['SimpleDoc']@, and the layout functions +-- pick one of the 'SimpleDoc's. This means that 'SimpleDoc' 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 @'SimpleDoc'@. The »Render« submodules provide some built-in +-- converters to do so, and helpers to create own ones. +data SimpleDoc ann = + SFail + | SEmpty + | SChar Char (SimpleDoc 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 (SimpleDoc ann) + + -- | @Int@ = indentation level for the line + | SLine !Int (SimpleDoc ann) + + -- | Add an annotation to the remaining document. + | SAnnPush ann (SimpleDoc ann) + + -- | Remove a previously pushed annotation. + | SAnnPop (SimpleDoc ann) + deriving (Eq, Ord, Show) + + + +-- | @(unsafeText s)@ contains the literal string @s@. +-- +-- The string must not contain any newline characters, since this is an +-- invariant of the 'Text' constructor. +unsafeText :: Text -> Doc ann +unsafeText 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 = Nest + +-- | 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 space + +-- | @'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 +group x = Union (flatten x) x + +-- Choose the first element of each @Union@, and discard the first field of all +-- @FlatAlt@s. +flatten :: Doc ann -> Doc ann +flatten = \case + 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" <+> 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" <+> 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 aligned vertically, with separators put in the front: +-- +-- >>> putDocW 10 doc +-- list [1 +-- ,20 +-- ,300 +-- ,4000] +-- +-- 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 + _ -> align (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 <> space <> 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 #-} + +-- | @('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 layouts 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 +-- +-- 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 layouts 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 = unsafeText (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 +-- >>> "The list has" <+> pretty amount <+> plural "entry" "entries" amount +-- The list has 1 entry +plural + :: (Num amount, Eq amount) + => doc -- ^ @1@ case + -> doc -- ^ other cases + -> amount + -> doc +plural one many n + | n == 1 = one + | otherwise = many + +-- | @('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 + + + +-- | >>> squotes "·" +-- '·' +squotes :: Doc ann -> Doc ann +squotes = enclose squote squote + +-- | >>> dquotes "·" +-- "·" +dquotes :: Doc ann -> Doc ann +dquotes = enclose dquote dquote + +-- | >>> parens "·" +-- (·) +parens :: Doc ann -> Doc ann +parens = enclose lparen rparen + +-- | >>> angles "·" +-- <·> +angles :: Doc ann -> Doc ann +angles = enclose langle rangle + +-- | >>> brackets "·" +-- [·] +brackets :: Doc ann -> Doc ann +brackets = enclose lbracket rbracket + +-- | >>> braces "·" +-- {·} +braces :: Doc ann -> Doc ann +braces = enclose lbrace rbrace + +-- | >>> squote +-- ' +squote :: Doc ann +squote = "'" + +-- | >>> dquote +-- " +dquote :: Doc ann +dquote = "\"" + +-- | >>> lparen +-- ( +lparen :: Doc ann +lparen = "(" + +-- | >>> rparen +-- ) +rparen :: Doc ann +rparen = ")" + +-- | >>> langle +-- < +langle :: Doc ann +langle = "<" + +-- | >>> rangle +-- > +rangle :: Doc ann +rangle = ">" + +-- | >>> lbracket +-- [ +lbracket :: Doc ann +lbracket = "[" +-- | >>> rbracket +-- ] +rbracket :: Doc ann +rbracket = "]" + +-- | >>> lbrace +-- { +lbrace :: Doc ann +lbrace = "{" +-- | >>> rbrace +-- } +rbrace :: Doc ann +rbrace = "}" + +-- | >>> semi +-- ; +semi :: Doc ann +semi = ";" + +-- | >>> colon +-- : +colon :: Doc ann +colon = ":" + +-- | >>> comma +-- , +comma :: Doc ann +comma = "," + +-- | >>> "a" <> space <> "b" +-- a b +-- +-- This is mostly used via @'<+>'@, +-- +-- >>> "a" <+> "b" +-- a b +space :: Doc ann +space = " " + +-- | >>> dot +-- . +dot :: Doc ann +dot = "." + +-- | >>> slash +-- / +slash :: Doc ann +slash = "/" + +-- | >>> backslash +-- \\ + +backslash :: Doc ann +backslash = "\\" + +-- | >>> equals +-- = +equals :: Doc ann +equals = "=" + +-- | >>> pipe +-- | +pipe :: Doc ann +pipe = "|" + + + +-- | Add an annotation to a @'Doc'@. This annotation can then be used by the +-- renderer to e.g. add color to certain parts of the output. For a full +-- tutorial example on how to use it, see the +-- "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 = \case + Fail -> Fail + Empty -> Empty + Char c -> Char c + Text l t -> Text l t + Line -> Line + + FlatAlt x y -> FlatAlt (unAnnotate x) (unAnnotate y) + Cat x y -> Cat (unAnnotate x) (unAnnotate y) + Nest i x -> Nest i (unAnnotate x) + Union x y -> Union (unAnnotate x) (unAnnotate y) + Column f -> Column (unAnnotate . f) + WithPageWidth f -> WithPageWidth (unAnnotate . f) + Nesting f -> Nesting (unAnnotate . f) + Annotated _ x -> unAnnotate x + +-- | 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, it is preferrable to reannotate +-- after producing the layout by using 'reAnnotateS'. +-- +-- Technically 'reAnnotate' makes 'Doc' a 'Functor', but since reannotation is +-- hardly intuitive we omit the instance. +reAnnotate :: (ann -> ann') -> Doc ann -> Doc ann' +reAnnotate re = go + where + go = \case + 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 -> Annotated (re ann) (go x) + +-- | Remove all annotations. 'unAnnotate' for 'SimpleDoc'. +unAnnotateS :: SimpleDoc ann -> SimpleDoc xxx +unAnnotateS = go + where + go = \case + 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) + SAnnPush _ rest -> go rest + SAnnPop rest -> go rest + +-- | Change the annotation of a document. 'reAnnotate' for 'SimpleDoc'. +reAnnotateS :: (ann -> ann') -> SimpleDoc ann -> SimpleDoc ann' +reAnnotateS f = go + where + go = \case + 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) + SAnnPush ann rest -> SAnnPush (f ann) (go rest) + SAnnPop rest -> SAnnPop (go 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 'SimpleDoc', 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 'SimpleDoc', although this is fully +-- equivalent to the tightly packed +-- +-- >>> "abcd" :: Doc ann +-- abcd +-- +-- which is only a single 'SimpleDoc' 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 = \case + 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 + +-- | Decide whether a 'SimpleDoc' 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 = FP (PageWidth -> Int -> Maybe Int -> SimpleDoc 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) + +-- $ 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 0.4} +defaultLayoutOptions :: LayoutOptions +defaultLayoutOptions = LayoutOptions { layoutPageWidth = AvailablePerLine 80 0.4 } + +-- | 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 'SimpleDoc' +-- 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 + -> SimpleDoc ann +layoutPretty = layoutFits fits1 + where + -- | @fits1@ does 1 line lookahead. + fits1 :: FittingPredicate ann + fits1 = FP (\_p _m w -> go w) + where + go :: Maybe Int -- ^ Width in which to fit the first line; Nothing is infinite + -> SimpleDoc ann + -> Bool + go Nothing _ = True + go (Just w) _ | w < 0 = False + go _ SFail = False + go _ SEmpty = True + go (Just w) (SChar _ x) = go (Just (w - 1)) x + go (Just w) (SText l _t x) = go (Just (w - l)) x + go _ SLine{} = True + go (Just w) (SAnnPush _ x) = go (Just w) x + go (Just w) (SAnnPop x) = go (Just 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) (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 + -> SimpleDoc ann +layoutSmart = layoutFits fitsR + where + -- @fitsR@ has a little more lookahead: assuming that nesting roughly + -- corresponds to syntactic depth, @fitsR@ 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). + fitsR :: FittingPredicate ann + fitsR = FP go + where + go :: PageWidth + -> Int -- ^ Minimum nesting level to fit in + -> Maybe Int -- ^ Width in which to fit the first line + -> SimpleDoc ann + -> Bool + go _ _ Nothing _ = False + go _ _ (Just w) _ | w < 0 = False + go _ _ _ SFail = False + go _ _ _ SEmpty = True + go pw m (Just w) (SChar _ x) = go pw m (Just (w - 1)) x + go pw m (Just w) (SText l _t x) = go pw m (Just (w - l)) x + go pw m _ (SLine i x) + | m < i, AvailablePerLine cpl _ <- pw = go pw m (Just (cpl - i)) x + | otherwise = True + go pw m w (SAnnPush _ x) = go pw m w x + go pw m w (SAnnPop x) = go pw m w x + + + +layoutFits + :: forall ann. FittingPredicate ann + -> LayoutOptions + -> Doc ann + -> SimpleDoc ann +layoutFits + 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) + -> SimpleDoc 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 + -> SimpleDoc ann -- ^ Choice A. Invariant: first lines should not be longer than B's. + -> SimpleDoc ann -- ^ Choice B. + -> SimpleDoc ann -- ^ Choice A if it fits, otherwise B. + selectNicer (FP 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. +-- +-- This layout function does not add any colorisation information. +-- +-- >>> 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 -> SimpleDoc ann +layoutCompact doc = scan 0 [doc] + where + scan _ [] = SEmpty + scan !k (d:ds) = case d of + Fail -> SFail + Empty -> scan k ds + Char c -> SChar c (scan (k+1) ds) + Text l t -> let !k' = k+l in SText l t (scan k' ds) + FlatAlt x _ -> scan k (x:ds) + Line -> SLine 0 (scan 0 ds) + Cat x y -> scan k (x:y:ds) + Nest _ x -> scan k (x:ds) + Union _ y -> scan k (y:ds) + Column f -> scan k (f k:ds) + WithPageWidth f -> scan k (f Unbounded : ds) + Nesting f -> scan k (f 0 : ds) + Annotated _ x -> scan k (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 'SimpleDoc' to a 'ShowS', useful to write 'Show' instances based +-- on the prettyprinter. +-- +-- @ +-- instance 'Show' MyType where +-- 'showsPrec' _ = 'renderShowS' . 'layoutPretty' 'defaultLayoutOptions' . 'pretty' +-- @ +renderShowS :: SimpleDoc ann -> ShowS +renderShowS = \case + 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 diff --git a/src/Data/Text/Prettyprint/Doc/Internal/Type.hs b/src/Data/Text/Prettyprint/Doc/Internal/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Prettyprint/Doc/Internal/Type.hs @@ -0,0 +1,12 @@ +-- | __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 + +import Data.Text.Prettyprint.Doc.Internal diff --git a/src/Data/Text/Prettyprint/Doc/Render/ShowS.hs b/src/Data/Text/Prettyprint/Doc/Render/ShowS.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Prettyprint/Doc/Render/ShowS.hs @@ -0,0 +1,5 @@ +module Data.Text.Prettyprint.Doc.Render.ShowS ( + renderShowS +) where + +import Data.Text.Prettyprint.Doc.Internal diff --git a/src/Data/Text/Prettyprint/Doc/Render/Text.hs b/src/Data/Text/Prettyprint/Doc/Render/Text.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Prettyprint/Doc/Render/Text.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +#include "version-compatibility-macros.h" + +-- | Render an unannotated 'SimpleDoc' 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 +) where + + + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import qualified Data.Text.Lazy.IO as TL +import System.IO + +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.Util.Panic + +#if !(SEMIGROUP_IN_BASE) +import Data.Semigroup +#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 :: SimpleDoc ann -> TL.Text +renderLazy = TLB.toLazyText . build + where + build = \case + SFail -> panicUncaughtFail + SEmpty -> mempty + SChar c x -> TLB.singleton c <> build x + SText _l t x -> TLB.fromText t <> build x + SLine i x -> TLB.singleton '\n' <> TLB.fromText (T.replicate i " ") <> build x + SAnnPush _ x -> build x + SAnnPop x -> build x + +-- | @('renderLazy' sdoc)@ takes the output @sdoc@ from a rendering and +-- transforms it to strict text. +renderStrict :: SimpleDoc 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 +renderIO :: Handle -> SimpleDoc ann -> IO () +renderIO h sdoc = TL.hPutStrLn h (renderLazy sdoc) + +-- | @('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) diff --git a/src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs b/src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +#include "version-compatibility-macros.h" + +-- | This module shows how to write a custom prettyprinter backend, based on +-- directly converting a 'SimpleDoc' 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 ( + module Data.Text.Prettyprint.Doc.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 'SimpleDoc' annotated with our 'SimpleHtml' to the +-- final 'TL.Text' representation. + +-- | 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 'SimpleDoc', 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 :: SimpleDoc SimpleHtml -> StackMachine TLB.Builder SimpleHtml () +renderStackMachine = \case + 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 = \case + Bold -> ("", "") + Italics -> ("", "") + Color c -> (" hexCode c <> "\">", "") + Paragraph -> ("

", "

") + Headline -> ("

", "

") + where + hexCode :: Color -> TLB.Builder + hexCode = \case + 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 :: SimpleDoc 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.") +-- >>> ]) +-- >>> :} +--

Example document

+--

This is a paragraph,

+--

and this text is bold.

diff --git a/src/Data/Text/Prettyprint/Doc/Render/Tutorials/TreeRenderingTutorial.hs b/src/Data/Text/Prettyprint/Doc/Render/Tutorials/TreeRenderingTutorial.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Prettyprint/Doc/Render/Tutorials/TreeRenderingTutorial.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +#include "version-compatibility-macros.h" + +-- | This module shows how to write a custom prettyprinter backend, based on a +-- tree representation of a 'SimpleDoc'. 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 +) where + + + +import Data.Semigroup +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 + + + +-- $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 'SimpleDoc' (annotated with our 'SimpleHtml') to the +-- tree-shaped 'SimpleDocTree', which is easily convertible to a HTML/'Text' +-- representation. + +-- | To render the HTML, we first convert the 'SimpleDoc' 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 :: SimpleDoc 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 = \case + 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 = \case + Bold -> \x -> "" <> x <> "" + Italics -> \x -> "" <> x <> "" + Color c -> \x -> " hexCode c <> "\">" <> x <> "" + Paragraph -> \x -> "

" <> x <> "

" + Headline -> \x -> "

" <> x <> "

" + where + hexCode :: Color -> TLB.Builder + hexCode = \case + 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.") +-- >>> ]) +-- >>> :} +--

Example document

+--

This is a paragraph,

+--

and this text is bold.

diff --git a/src/Data/Text/Prettyprint/Doc/Render/Util/Panic.hs b/src/Data/Text/Prettyprint/Doc/Render/Util/Panic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Prettyprint/Doc/Render/Util/Panic.hs @@ -0,0 +1,31 @@ +module Data.Text.Prettyprint.Doc.Render.Util.Panic ( + panicUncaughtFail, + panicUnpairedPop, + panicSimpleDocTreeConversionFailed, + panicInputNotFullyConsumed, +) where + +-- | Raise a hard 'error' if there is a 'Data.Text.Prettyprint.Doc.SFail' in a +-- 'Data.Text.Prettyprint.Doc.SimpleDoc'. +panicUncaughtFail :: a +panicUncaughtFail = error ("»SFail« must not appear in a rendered »SimpleDoc«. This is a bug in the layout algorithm! " ++ report) + +-- | Raise a hard 'error' when an annotation terminator is encountered in an +-- unannotated region. +panicUnpairedPop :: a +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.SimpleDoc' to +-- 'Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree.SimpleDocTree' conversion fails. +panicSimpleDocTreeConversionFailed :: a +panicSimpleDocTreeConversionFailed = error ("Conversion from SimpleDoc 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 :: a +panicInputNotFullyConsumed = error ("Conversion from SimpleDoc to SimpleDocTree left unconsumed input! " ++ report) + +report :: String +report = "Please report this as a bug" diff --git a/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs b/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} + +#include "version-compatibility-macros.h" + +-- | Conversion of the linked-list-like 'SimpleDoc' to a tree-like +-- 'SimpleDocTree'. +module Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree ( + SimpleDocTree(..), + treeForm, + + unAnnotateST, + reAnnotateST, +) where + + + +import Control.Applicative +import Data.Text (Text) + +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.Util.Panic + +#if MONAD_FAIL +import Control.Monad.Fail +#endif + + + +-- | 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 +#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'') ) + + fail _err = empty + +#if MONAD_FAIL +instance MonadFail (UniqueParser s) where + fail _err = empty +#endif + +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 'SimpleDoc' is a linked list of different annotated cons cells ('SText' +-- and then some further 'SimpleDoc', 'SLine' and then some further 'SimpleDoc', …). +-- 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 + | STText !Int Text + | STLine !Int + | STAnn ann (SimpleDocTree ann) + | STConcat [SimpleDocTree ann] + deriving (Eq, Ord, Show) + +-- | Get the next token, consuming it in the process. +nextToken :: UniqueParser (SimpleDoc ann) (SimpleDocTok ann) +nextToken = UniqueParser (\case + 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 (SimpleDoc ann) (SimpleDocTree ann) +sdocToTreeParser = fmap wrap (many contentPiece) + + where + + wrap :: [SimpleDocTree ann] -> SimpleDocTree ann + wrap = \case + [] -> STEmpty + [x] -> x + xs -> STConcat xs + + contentPiece = nextToken >>= \case + 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 'SimpleDoc' to its 'SimpleDocTree' representation. +treeForm :: SimpleDoc 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 = \case + STEmpty -> STEmpty + STChar c -> STChar c + STText l t -> STText l t + STLine i -> STLine i + STAnn _ rest -> unAnnotateST rest + STConcat xs -> STConcat (map unAnnotateST xs) + +-- | Change the annotation of a document. 'reAnnotate' for 'SimpleDocTree'. +reAnnotateST :: (ann -> ann') -> SimpleDocTree ann -> SimpleDocTree ann' +reAnnotateST f = go + where + go = \case + STEmpty -> STEmpty + STChar c -> STChar c + STText l t -> STText l t + STLine i -> STLine i + STAnn ann rest -> STAnn (f ann) (go rest) + STConcat xs -> STConcat (map go xs) diff --git a/src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs b/src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +#include "version-compatibility-macros.h" + +-- | A strict State/Writer monad to implement a stack machine for rendering +-- 'SimpleDoc's. +module Data.Text.Prettyprint.Doc.Render.Util.StackMachine ( + StackMachine, + execStackMachine, + + pushStyle, + unsafePopStyle, + unsafePeekStyle, + writeOutput, +) where + + + +import Data.Monoid + +#if !(APPLICATIVE_MONAD) +import Control.Applicative +#endif + + + +-- | @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])) + +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 (\case + x:xs -> (x, mempty, xs) + [] -> error "Popped an empty style stack! Please report this as a bug.") + +-- | 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) + [] -> error "Peeked an empty style stack! Please report this as a bug.") + +-- | 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) diff --git a/src/Data/Text/Prettyprint/Doc/Util.hs b/src/Data/Text/Prettyprint/Doc/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Prettyprint/Doc/Util.hs @@ -0,0 +1,63 @@ +-- | Frequently useful definitions for working with general prettyprinters. +module Data.Text.Prettyprint.Doc.Util ( + module Data.Text.Prettyprint.Doc.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 + +-- $setup +-- +-- (Definitions for the doctests) +-- +-- >>> :set -XOverloadedStrings + + + +-- | 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 } diff --git a/test/Doctest/Main.hs b/test/Doctest/Main.hs new file mode 100644 --- /dev/null +++ b/test/Doctest/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Test.DocTest + +main :: IO () +main = doctest [ "src" , "-Imisc"] diff --git a/test/Testsuite/Main.hs b/test/Testsuite/Main.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Main.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +#include "version-compatibility-macros.h" + +module Main (main) where + + + +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Text as T +import Data.Text.PgpWordlist +import Data.Word + +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.Text + +import Test.Tasty +import Test.Tasty.QuickCheck + +#if !(APPLICATIVE_MONAD) +import Control.Applicative +#endif +#if !(MONOID_IN_PRELUDE) +import Data.Monoid (mconcat) +#endif + + + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Fusion" + [ testProperty "Shallow fusion does not change rendering" + (fusionDoesNotChangeRendering Shallow) + , testProperty "Deep fusion does not change rendering" + (fusionDoesNotChangeRendering Deep) + ] + +fusionDoesNotChangeRendering :: FusionDepth -> Property +fusionDoesNotChangeRendering depth + = forAll document (\doc -> + let rendered = render doc + renderedFused = render (fuse depth doc) + in counterexample (mkCounterexample rendered renderedFused) + (render doc == render (fuse depth doc)) ) + where + render = renderStrict . layoutPretty defaultLayoutOptions + mkCounterexample rendered renderedFused + = (T.unpack . render . 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 + +document :: Gen (Doc ann) +document = (dampen . frequency) + [ (20, content) + , (1, newlines) + , (1, nestingAndAlignment) + , (1, grouping) + , (20, concatenationOfTwo) + , (5, concatenationOfMany) + , (1, enclosingOfOne) + , (1, enclosingOfMany) ] + +content :: Gen (Doc ann) +content = frequency + [ (1, pure emptyDoc) + , (10, do word <- choose (minBound, maxBound :: Word8) + let pgp8Word = toText (BSL.singleton word) + pure (pretty pgp8Word) ) + , (1, (fmap pretty . elements . mconcat) + [ ['a'..'z'] + , ['A'..'Z'] + , ['0'..'9'] + , "…_[]^!<>=&@:-()?*}{/\\#$|~`+%\"';" ] ) + ] + +newlines :: Gen (Doc ann) +newlines = frequency + [ (1, pure line) + , (1, pure line') + , (1, pure softline) + , (1, pure softline') + , (1, pure hardline) ] + +nestingAndAlignment :: 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 = frequency + [ (1, align <$> document) + , (1, flatAlt <$> document <*> document) ] + +concatenationOfTwo :: Gen (Doc ann) +concatenationOfTwo = frequency + [ (1, (<>) <$> document <*> document) + , (1, (<+>) <$> document <*> document) ] + +concatenationOfMany :: Gen (Doc ann) +concatenationOfMany = frequency + [ (1, hsep <$> listOf document) + , (1, vsep <$> listOf document) + , (1, fillSep <$> listOf document) + , (1, sep <$> listOf document) + , (1, hcat <$> listOf document) + , (1, vcat <$> listOf document) + , (1, fillCat <$> listOf document) + , (1, cat <$> listOf document) ] + +enclosingOfOne :: Gen (Doc ann) +enclosingOfOne = frequency + [ (1, squotes <$> document) + , (1, dquotes <$> document) + , (1, parens <$> document) + , (1, angles <$> document) + , (1, brackets <$> document) + , (1, braces <$> document) ] + +enclosingOfMany :: Gen (Doc ann) +enclosingOfMany = frequency + [ (1, encloseSep <$> document <*> document <*> pure ", " <*> listOf document) + , (1, list <$> listOf document) + , (1, tupled <$> listOf document) ] + +-- QuickCheck 2.8 does not have 'scale' yet, so for compatibility with older +-- releases we hand-code it here +dampen :: Gen a -> Gen a +dampen gen = sized (\n -> resize ((n*2) `quot` 3) gen)