diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,26 @@ +# [1.7.0] + +## Breaking changes + +- [Fix `layoutPretty` and `layoutSmart` so they don't produce trailing whitespace as a result of indenting empty lines.](https://github.com/quchen/prettyprinter/pull/139) + * Users of `removeTrailingWhitespace` should check whether it is still needed. +- [Use `floor` instead of `round` to compute ribbon width.](https://github.com/quchen/prettyprinter/pull/160) +- [Remove deprecated `Data.Text.Prettyprint.Doc.Render.ShowS` module.](https://github.com/quchen/prettyprinter/pull/173) +- [Add optimized implementation of `stimes` for `Doc`.](https://github.com/quchen/prettyprinter/pull/135) +- [Generalize the type of `layoutCompact` to clarify that it doesn't preserve annotations.](https://github.com/quchen/prettyprinter/pull/183) +- [Add strictness annotations in `SimpleDocStream` and `PageWidth`.](https://github.com/quchen/prettyprinter/pull/129) + +## Non-breaking changes + +- [Add shallower `Prettyprinter` module hierarchy exposing the same API.](https://github.com/quchen/prettyprinter/pull/174) + * The current plan for the existing `Data.Text.Prettyprint.Doc*` modules is: + * Start deprecation in early 2021. + * Remove the modules after a deprecation period of at least one year. +- [Fix build with GHC 7.4.](https://github.com/quchen/prettyprinter/pull/187) +- Various documentation improvements. + +[1.7.0]: https://github.com/quchen/prettyprinter/compare/v1.6.2...v1.7.0 + # 1.6.2 - Speed up rendering to lazy and strict `Text`. diff --git a/prettyprinter.cabal b/prettyprinter.cabal --- a/prettyprinter.cabal +++ b/prettyprinter.cabal @@ -1,5 +1,5 @@ name: prettyprinter -version: 1.6.2 +version: 1.7.0 cabal-version: >= 1.10 category: User Interfaces, Text synopsis: A modern, easy to use, well-documented, extensible pretty-printer. @@ -10,7 +10,7 @@ , CHANGELOG.md , misc/version-compatibility-macros.h author: Phil Wadler, Daan Leijen, Max Bolingbroke, Edward Kmett, David Luposchainsky -maintainer: David Luposchainsky +maintainer: Simon Jakobi , David Luposchainsky bug-reports: http://github.com/quchen/prettyprinter/issues homepage: http://github.com/quchen/prettyprinter build-type: Simple @@ -25,7 +25,23 @@ library exposed-modules: - Data.Text.Prettyprint.Doc + Prettyprinter + , Prettyprinter.Internal + , Prettyprinter.Internal.Debug + , Prettyprinter.Internal.Type + , Prettyprinter.Render.String + , Prettyprinter.Render.Text + , Prettyprinter.Render.Tutorials.StackMachineTutorial + , Prettyprinter.Render.Tutorials.TreeRenderingTutorial + , Prettyprinter.Render.Util.Panic + , Prettyprinter.Render.Util.SimpleDocTree + , Prettyprinter.Render.Util.StackMachine + , Prettyprinter.Util + + , Prettyprinter.Symbols.Unicode + , Prettyprinter.Symbols.Ascii + + , Data.Text.Prettyprint.Doc , Data.Text.Prettyprint.Doc.Internal , Data.Text.Prettyprint.Doc.Internal.Debug , Data.Text.Prettyprint.Doc.Internal.Type @@ -41,9 +57,6 @@ , Data.Text.Prettyprint.Doc.Symbols.Unicode , Data.Text.Prettyprint.Doc.Symbols.Ascii - -- Deprecated - , Data.Text.Prettyprint.Doc.Render.ShowS - ghc-options: -Wall -O2 hs-source-dirs: src include-dirs: misc @@ -65,7 +78,7 @@ if impl(ghc >= 8.0) ghc-options: -Wcompat if !impl(ghc >= 8.0) - build-depends: semigroups >= 0.16.1 + build-depends: semigroups >= 0.17 build-depends: fail >= 4.9.0.0 && <4.10 if !impl(ghc >= 7.10) build-depends: void >=0.4 && <0.8 diff --git a/src/Data/Text/Prettyprint/Doc.hs b/src/Data/Text/Prettyprint/Doc.hs --- a/src/Data/Text/Prettyprint/Doc.hs +++ b/src/Data/Text/Prettyprint/Doc.hs @@ -1,345 +1,12 @@ -{-# LANGUAGE CPP #-} - -#include "version-compatibility-macros.h" - --- | --- Module : Data.Text.Prettyprint.Doc --- Copyright : Daan Leijen (c) 2000, http://www.cs.uu.nl/~daan --- Max Bolingbroke (c) 2008, http://blog.omega-prime.co.uk --- David Luposchainsky (c) 2016, http://github.com/quchen --- License : BSD-style (see the file LICENSE.md) --- Maintainer : David Luposchainsky --- Stability : experimental --- Portability : portable --- --- = Overview --- --- This module defines a prettyprinter to format text in a flexible and --- convenient way. The idea is to combine a 'Doc'ument out of many small --- components, then using a layouter to convert it to an easily renderable --- 'SimpleDocStream', which can then be rendered to a variety of formats, for --- example plain 'Text'. --- --- The documentation consists of several parts: --- --- 1. Just below is some general information about the library. --- 2. The actual library with extensive documentation and examples --- 3. Migration guide for users familiar with (ansi-)wl-pprint --- --- == Starting out --- --- As a reading list for starters, some of the most commonly used functions in --- this module include '<>', 'hsep', '<+>', 'vsep', 'align', 'hang'. These cover --- many use cases already, and many other functions are variations or --- combinations of these. --- --- = Simple example --- --- Let’s prettyprint a simple Haskell type definition. First, intersperse @->@ --- and add a leading @::@, --- --- >>> let prettyType = align . sep . zipWith (<+>) ("::" : repeat "->") --- --- The 'sep' function is one way of concatenating documents, there are multiple --- others, e.g. 'vsep', 'cat' and 'fillSep'. In our case, 'sep' space-separates --- all entries if there is space, and newlines if the remaining line is too --- short. --- --- Second, prepend the name to the type, --- --- >>> let prettyDecl n tys = pretty n <+> prettyType tys --- --- Now we can define a document that contains some type signature: --- --- >>> let doc = prettyDecl "example" ["Int", "Bool", "Char", "IO ()"] --- --- This document can now be printed, and it automatically adapts to available --- space. If the page is wide enough (80 characters in this case), the --- definitions are space-separated, --- --- >>> putDocW 80 doc --- example :: Int -> Bool -> Char -> IO () --- --- If we narrow the page width to only 20 characters, the /same document/ --- renders vertically aligned: --- --- >>> putDocW 20 doc --- example :: Int --- -> Bool --- -> Char --- -> IO () --- --- Speaking of alignment, had we not used 'align', the @->@ would be at the --- beginning of each line, and not beneath the @::@. --- --- The 'Data.Text.Prettyprint.Doc.Util.putDocW' renderer used here is from --- "Data.Text.Prettyprint.Doc.Util". --- --- = General workflow --- --- @ --- ╔══════════╗ --- ║ ║ ╭────────────────────╮ --- ║ ║ │ 'vsep', 'pretty', '<+>', │ --- ║ ║ │ 'nest', 'align', … │ --- ║ ║ ╰─────────┬──────────╯ --- ║ ║ │ --- ║ Create ║ │ --- ║ ║ │ --- ║ ║ ▽ --- ║ ║ ╭───────────────────╮ --- ║ ║ │ 'Doc' │ --- ╠══════════╣ │ (rich document) │ --- ║ ║ ╰─────────┬─────────╯ --- ║ ║ │ --- ║ ║ │ Layout algorithms --- ║ Layout ║ │ e.g. 'layoutPretty' --- ║ ║ ▽ --- ║ ║ ╭───────────────────╮ --- ║ ║ │ 'SimpleDocStream' │ --- ╠══════════╣ │ (simple document) │ --- ║ ║ ╰─────────┬─────────╯ --- ║ ║ │ --- ║ ║ ├─────────────────────────────╮ --- ║ ║ │ │ 'Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree.treeForm' --- ║ ║ │ ▽ --- ║ ║ │ ╭───────────────╮ --- ║ ║ │ │ 'Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree.SimpleDocTree' │ --- ║ Render ║ │ ╰───────┬───────╯ --- ║ ║ │ │ --- ║ ║ ╭───────────────────┼─────────────────╮ ╭────────┴────────╮ --- ║ ║ │ │ │ │ │ --- ║ ║ ▽ ▽ ▽ ▽ ▽ --- ║ ║ ╭───────────────╮ ╭───────────────╮ ╭───────────────╮ ╭───────────────╮ --- ║ ║ │ ANSI terminal │ │ Plain 'Text' │ │ other/custom │ │ HTML │ --- ║ ║ ╰───────────────╯ ╰───────────────╯ ╰───────────────╯ ╰───────────────╯ --- ║ ║ --- ╚══════════╝ --- @ --- --- = How the layout works --- --- There are two key concepts to laying a document out: the available width, and --- 'group'ing. --- --- == Available width --- --- The page has a certain maximum width, which the layouter tries to not exceed, --- by inserting line breaks where possible. The functions given in this module --- make it fairly straightforward to specify where, and under what --- circumstances, such a line break may be inserted by the layouter, for example --- via the 'sep' function. --- --- There is also the concept of /ribbon width/. The ribbon is the part of a line --- that is printed, i.e. the line length without the leading indentation. The --- layouters take a ribbon fraction argument, which specifies how much of a line --- should be filled before trying to break it up. A ribbon width of 0.5 in a --- document of width 80 will result in the layouter to try to not exceed @0.5*80 = --- 40@ (ignoring current indentation depth). --- --- == Grouping --- --- A document can be 'group'ed, which tells the layouter that it should attempt --- to collapse it to a single line. If the result does not fit within the --- constraints (given by page and ribbon widths), the document is rendered --- unaltered. This allows fallback definitions, so that we get nice results even --- when the original document would exceed the layout constraints. --- --- = Things the prettyprinter /cannot/ do --- --- Due to how the Wadler/Leijen algorithm is designed, a couple of things are --- unsupported right now, with a high possibility of having no sensible --- implementation without significantly changing the layout algorithm. In --- particular, this includes --- --- * Leading symbols instead of just spaces for indentation, as used by the --- Linux @tree@ tool for example --- * Multi-column layouts, in particular tables with multiple cells of equal --- width adjacent to each other --- --- = Some helpful tips --- --- == Which kind of annotation should I use? --- --- __Summary:__ Use semantic annotations for @'Doc'@, and after layouting map to --- backend-specific ones. --- --- For example, suppose you want to prettyprint some programming language code. --- If you want keywords to be red, you should annotate the @'Doc'@ with a type --- that has a 'Keyword' field (without any notion of color), and then after --- layouting convert the annotations to map @'Keyword'@ to e.g. @'Red'@ (using --- @'reAnnotateS'@). The alternative that I /do not/ recommend is directly --- annotating the @'Doc'@ with 'Red'. --- --- While both versions would superficially work equally well and would create --- identical output, the recommended way has two significant advantages: --- modularity and extensibility. +-- | This module is part of the old @Data.Text.Prettyprint.Doc@ module hierarchy +-- which is being replaced by a shallower @Prettyprinter@ module hierarchy +-- offering the same API. -- --- /Modularity:/ To change the color of keywords later, you have to touch one --- point, namely the mapping in @'reAnnotateS'@, where @'Keyword'@ is mapped to --- 'Red'. If you have @'annotate Red …'@ everywher, you’ll have to do a full --- text replacement, producing a large diff and touching lots of places for a --- very small change. +-- This module will be deprecated and eventually removed. -- --- /Extensibility:/ Adding a different backend in the recommended version is --- simply adding another @'reAnnotateS'@ to convert the @'Doc'@ annotation to --- something else. On the other hand, if you have @'Red'@ as an annotation in --- the @'Doc'@ already and the other backend does not support anything red --- (think of plain text or a website where red doesn’t work well with the rest --- of the style), you’ll have to worry about what to map »redness« to, which has --- no canonical answer. Should it be omitted? What does »red« mean anyway – --- maybe keywords and variables are red, and you want to change only the color --- of variables? +-- Use "Prettyprinter" instead. module Data.Text.Prettyprint.Doc ( - -- * Documents - Doc, - - -- * Basic functionality - Pretty(..), - viaShow, unsafeViaShow, - emptyDoc, nest, line, line', softline, softline', hardline, - - -- ** Primitives for alternative layouts - group, flatAlt, - - -- * Alignment functions - -- - -- | The functions in this section cannot be described by Wadler's original - -- functions. They align their output relative to the current output - -- position - in contrast to @'nest'@ which always aligns to the current - -- nesting level. This deprives these functions from being \'optimal\'. In - -- practice however they prove to be very useful. The functions in this - -- section should be used with care, since they are more expensive than the - -- other functions. For example, @'align'@ shouldn't be used to pretty print - -- all top-level declarations of a language, but using @'hang'@ for let - -- expressions is fine. - align, hang, indent, encloseSep, list, tupled, - - -- * Binary functions - (<>), (<+>), - - -- * List functions - - -- | The 'sep' and 'cat' functions differ in one detail: when 'group'ed, the - -- 'sep's replace newlines wich 'space's, while the 'cat's simply remove - -- them. If you're not sure what you want, start with the 'sep's. - - concatWith, - - -- ** 'sep' family - -- - -- | When 'group'ed, these will replace newlines with spaces. - hsep, vsep, fillSep, sep, - -- ** 'cat' family - -- - -- | When 'group'ed, these will remove newlines. - hcat, vcat, fillCat, cat, - -- ** Others - punctuate, - - -- * Reactive/conditional layouts - -- - -- | Lay documents out differently based on current position and the page - -- layout. - column, nesting, width, pageWidth, - - -- * Filler functions - -- - -- | Fill up available space - fill, fillBreak, - - -- * General convenience - -- - -- | Useful helper functions. - plural, enclose, surround, - - -- * Bracketing functions - -- - -- | Enclose documents in common ways. - squotes, dquotes, parens, angles, brackets, braces, - - -- * Named characters - -- - -- | Convenience definitions for common characters - lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket, squote, - dquote, semi, colon, comma, space, dot, slash, backslash, equals, pipe, - - -- ** Annotations - annotate, - unAnnotate, - reAnnotate, - alterAnnotations, - unAnnotateS, - reAnnotateS, - alterAnnotationsS, - - -- * Optimization - -- - -- Render documents faster - fuse, FusionDepth(..), - - -- * Layout - -- - -- | Laying a 'Doc'ument out produces a straightforward 'SimpleDocStream' - -- based on parameters such as page width and ribbon size, by evaluating how - -- a 'Doc' fits these constraints the best. There are various ways to render - -- a 'SimpleDocStream'. For the common case of rendering a 'SimpleDocStream' - -- as plain 'Text' take a look at "Data.Text.Prettyprint.Doc.Render.Text". - SimpleDocStream(..), - PageWidth(..), LayoutOptions(..), defaultLayoutOptions, - layoutPretty, layoutCompact, layoutSmart, - removeTrailingWhitespace, - - -- * Migration guide - -- - -- $migration + module Prettyprinter ) where - - -#if !(SEMIGROUP_MONOID_SUPERCLASS) -import Data.Semigroup -#endif -import Data.Text.Prettyprint.Doc.Internal -import Data.Text.Prettyprint.Doc.Symbols.Ascii - --- $setup --- --- (Definitions for the doctests) --- --- >>> :set -XOverloadedStrings --- >>> import Data.Text.Prettyprint.Doc.Render.Text --- >>> import Data.Text.Prettyprint.Doc.Util - - - --- $migration --- --- There are 3 main ways to migrate: --- --- 1. Direct: just replace the previous package and fix the errors --- 2. Using a drop-in replacement mimicing the API of the former module, see --- the @prettyprinter-compat-@ packages --- 3. Using a converter from the old @Doc@ type to the new one, see the --- @prettyprinter-convert-@ packages --- --- If you're already familiar with (ansi-)wl-pprint, you'll recognize many --- functions in this module, and they work just the same way. However, a couple --- of definitions are missing: --- --- - @char@, @string@, @double@, … – these are all special cases of the --- overloaded @'pretty'@ function. --- - @\<$>@, @\<$$>@, @\@, @\@ are special cases of --- @'vsep'@, @'vcat'@, @'fillSep'@, @'fillCat'@ with only two documents. --- - If you need 'String' output, use the backends in the --- "Data.Text.Prettyprint.Doc.Render.String" module. --- - The /display/ functions are moved to the rendering submodules, for --- example conversion to plain 'Text' is in the --- "Data.Text.Prettyprint.Doc.Render.Text" module. --- - The /render/ functions are called /layout/ functions. --- - @SimpleDoc@ was renamed to @'SimpleDocStream'@, in order to make it --- clearer in the presence of @SimpleDocTree@. --- - Instead of providing an own colorization function for each --- color\/intensity\/layer combination, they have been combined in 'color', --- 'colorDull', 'bgColor', and 'bgColorDull' functions, which can be found --- in the ANSI terminal specific @prettyprinter-ansi-terminal@ package. +import Prettyprinter diff --git a/src/Data/Text/Prettyprint/Doc/Internal.hs b/src/Data/Text/Prettyprint/Doc/Internal.hs --- a/src/Data/Text/Prettyprint/Doc/Internal.hs +++ b/src/Data/Text/Prettyprint/Doc/Internal.hs @@ -1,2203 +1,12 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# OPTIONS_HADDOCK not-home #-} - -#include "version-compatibility-macros.h" - --- | __Warning: internal module!__ This means that the API may change --- arbitrarily between versions without notice. Depending on this module may --- lead to unexpected breakages, so proceed with caution! --- --- For a stable API, use the non-internal modules. For the special case of --- writing adaptors to this library’s @'Doc'@ type, see --- "Data.Text.Prettyprint.Doc.Internal.Type". -module Data.Text.Prettyprint.Doc.Internal ( - -- * Documents - Doc(..), - - -- * Basic functionality - Pretty(..), - viaShow, unsafeViaShow, unsafeTextWithoutNewlines, - emptyDoc, nest, line, line', softline, softline', hardline, - - -- ** Primitives for alternative layouts - group, flatAlt, - - -- * Alignment functions - align, hang, indent, encloseSep, list, tupled, - - -- * Binary functions - (<+>), - - -- * List functions - concatWith, - - -- ** 'sep' family - hsep, vsep, fillSep, sep, - -- ** 'cat' family - hcat, vcat, fillCat, cat, - -- ** Others - punctuate, - - -- * Reactive/conditional layouts - column, nesting, width, pageWidth, - - -- * Filler functions - fill, fillBreak, - - -- * General convenience - plural, enclose, surround, - - -- ** Annotations - annotate, - unAnnotate, - reAnnotate, - alterAnnotations, - unAnnotateS, - reAnnotateS, - alterAnnotationsS, - - -- * Optimization - fuse, FusionDepth(..), - - -- * Layout - SimpleDocStream(..), - PageWidth(..), defaultPageWidth, - LayoutOptions(..), defaultLayoutOptions, - layoutPretty, layoutCompact, layoutSmart, - removeTrailingWhitespace, - - -- * Rendering - renderShowS, - - -- * Internal helpers - textSpaces -) where - - - -import Control.Applicative -import Data.Int -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe -import Data.String (IsString (..)) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Lazy as Lazy -import Data.Typeable (Typeable) -import Data.Void -import Data.Word -import GHC.Generics (Generic) - --- Depending on the Cabal file, this might be from base, or for older builds, --- from the semigroups package. -import Data.Semigroup - -#if NATURAL_IN_BASE -import Numeric.Natural -#endif - -#if !(FOLDABLE_TRAVERSABLE_IN_PRELUDE) -import Data.Foldable (Foldable (..)) -import Data.Traversable (Traversable (..)) -import Prelude hiding (foldr, foldr1) -#endif - -#if FUNCTOR_IDENTITY_IN_BASE -import Data.Functor.Identity -#endif - -import Data.Text.Prettyprint.Doc.Render.Util.Panic - - - --- | The abstract data type @'Doc' ann@ represents pretty documents that have --- been annotated with data of type @ann@. --- --- More specifically, a value of type @'Doc'@ represents a non-empty set of --- possible layouts of a document. The layout functions select one of these --- possibilities, taking into account things like the width of the output --- document. --- --- The annotation is an arbitrary piece of data associated with (part of) a --- document. Annotations may be used by the rendering backends in order to --- display output differently, such as --- --- - color information (e.g. when rendering to the terminal) --- - mouseover text (e.g. when rendering to rich HTML) --- - whether to show something or not (to allow simple or detailed versions) --- --- The simplest way to display a 'Doc' is via the 'Show' class. --- --- >>> putStrLn (show (vsep ["hello", "world"])) --- hello --- world -data Doc ann = - - -- | Occurs when flattening a line. The layouter will reject this document, - -- choosing a more suitable rendering. - Fail - - -- | The empty document; conceptually the unit of 'Cat' - | Empty - - -- | invariant: not '\n' - | Char !Char - - -- | Invariants: at least two characters long, does not contain '\n'. For - -- empty documents, there is @Empty@; for singleton documents, there is - -- @Char@; newlines should be replaced by e.g. @Line@. - -- - -- Since the frequently used 'T.length' of 'Text' is /O(length)/, we cache - -- it in this constructor. - | Text !Int !Text - - -- | Hard line break - | Line - - -- | Lay out the first 'Doc', but when flattened (via 'group'), prefer - -- the second. - -- - -- The layout algorithms work under the assumption that the first - -- alternative is less wide than the flattened second alternative. - | FlatAlt (Doc ann) (Doc ann) - - -- | Concatenation of two documents - | Cat (Doc ann) (Doc ann) - - -- | Document indented by a number of columns - | Nest !Int (Doc ann) - - -- | Invariant: The first lines of first document should be longer than the - -- first lines of the second one, so the layout algorithm can pick the one - -- that fits best. Used to implement layout alternatives for 'group'. - | Union (Doc ann) (Doc ann) - - -- | React on the current cursor position, see 'column' - | Column (Int -> Doc ann) - - -- | React on the document's width, see 'pageWidth' - | WithPageWidth (PageWidth -> Doc ann) - - -- | React on the current nesting level, see 'nesting' - | Nesting (Int -> Doc ann) - - -- | Add an annotation to the enclosed 'Doc'. Can be used for example to add - -- styling directives or alt texts that can then be used by the renderer. - | Annotated ann (Doc ann) - deriving (Generic, Typeable) - --- | --- @ --- x '<>' y = 'hcat' [x, y] --- @ --- --- >>> "hello" <> "world" :: Doc ann --- helloworld -instance Semigroup (Doc ann) where - (<>) = Cat - sconcat (x :| xs) = hcat (x:xs) - --- | --- @ --- 'mempty' = 'emptyDoc' --- 'mconcat' = 'hcat' --- @ --- --- >>> mappend "hello" "world" :: Doc ann --- helloworld -instance Monoid (Doc ann) where - mempty = emptyDoc - mappend = (<>) - mconcat = hcat - --- | >>> pretty ("hello\nworld") --- hello --- world --- --- This instance uses the 'Pretty' 'Text' instance, and uses the same newline to --- 'line' conversion. -instance IsString (Doc ann) where - fromString = pretty . T.pack - --- | Alter the document’s annotations. --- --- This instance makes 'Doc' more flexible (because it can be used in --- 'Functor'-polymorphic values), but @'fmap'@ is much less readable compared to --- using @'reAnnotate'@ in code that only works for @'Doc'@ anyway. Consider --- using the latter when the type does not matter. -instance Functor Doc where - fmap = reAnnotate - --- | Overloaded conversion to 'Doc'. --- --- Laws: --- --- 1. output should be pretty. :-) -class Pretty a where - - -- | >>> pretty 1 <+> pretty "hello" <+> pretty 1.234 - -- 1 hello 1.234 - pretty :: a -> Doc ann - - default pretty :: Show a => a -> Doc ann - pretty = viaShow - - -- | @'prettyList'@ is only used to define the @instance - -- 'Pretty' a => 'Pretty' [a]@. In normal circumstances only the @'pretty'@ - -- function is used. - -- - -- >>> prettyList [1, 23, 456] - -- [1, 23, 456] - prettyList :: [a] -> Doc ann - prettyList = align . list . map pretty - - {-# MINIMAL pretty #-} - --- $ --- Issue #67: Nested lists were not aligned with »pretty«, leading to non-pretty --- output, violating the Pretty class law. --- --- >>> pretty (replicate 2 (replicate 4 (1, replicate 8 2))) --- [ [ (1, [2, 2, 2, 2, 2, 2, 2, 2]) --- , (1, [2, 2, 2, 2, 2, 2, 2, 2]) --- , (1, [2, 2, 2, 2, 2, 2, 2, 2]) --- , (1, [2, 2, 2, 2, 2, 2, 2, 2]) ] --- , [ (1, [2, 2, 2, 2, 2, 2, 2, 2]) --- , (1, [2, 2, 2, 2, 2, 2, 2, 2]) --- , (1, [2, 2, 2, 2, 2, 2, 2, 2]) --- , (1, [2, 2, 2, 2, 2, 2, 2, 2]) ] ] - -instance Pretty a => Pretty (Const a b) where - pretty = pretty . getConst - -#if FUNCTOR_IDENTITY_IN_BASE --- | >>> pretty (Identity 1) --- 1 -instance Pretty a => Pretty (Identity a) where - pretty = pretty . runIdentity -#endif - --- | >>> pretty [1,2,3] --- [1, 2, 3] -instance Pretty a => Pretty [a] where - pretty = prettyList - -instance Pretty a => Pretty (NonEmpty a) where - pretty (x:|xs) = prettyList (x:xs) - --- | >>> pretty () --- () --- --- The argument is not used, --- --- >>> pretty (error "Strict?" :: ()) --- () -instance Pretty () where - pretty _ = "()" - --- | >>> pretty True --- True -instance Pretty Bool where - pretty True = "True" - pretty False = "False" - --- | Instead of @('pretty' '\n')@, consider using @'line'@ as a more readable --- alternative. --- --- >>> pretty 'f' <> pretty 'o' <> pretty 'o' --- foo --- >>> pretty ("string" :: String) --- string -instance Pretty Char where - pretty '\n' = line - pretty c = Char c - - prettyList = pretty . (id :: Text -> Text) . fromString - --- | Convenience function to convert a 'Show'able value to a 'Doc'. If the --- 'String' does not contain newlines, consider using the more performant --- 'unsafeViaShow'. -viaShow :: Show a => a -> Doc ann -viaShow = pretty . T.pack . show - --- | Convenience function to convert a 'Show'able value /that must not contain --- newlines/ to a 'Doc'. If there may be newlines, use 'viaShow' instead. -unsafeViaShow :: Show a => a -> Doc ann -unsafeViaShow = unsafeTextWithoutNewlines . T.pack . show - --- | >>> pretty (123 :: Int) --- 123 -instance Pretty Int where pretty = unsafeViaShow -instance Pretty Int8 where pretty = unsafeViaShow -instance Pretty Int16 where pretty = unsafeViaShow -instance Pretty Int32 where pretty = unsafeViaShow -instance Pretty Int64 where pretty = unsafeViaShow -instance Pretty Word where pretty = unsafeViaShow -instance Pretty Word8 where pretty = unsafeViaShow -instance Pretty Word16 where pretty = unsafeViaShow -instance Pretty Word32 where pretty = unsafeViaShow -instance Pretty Word64 where pretty = unsafeViaShow - --- | >>> pretty (2^123 :: Integer) --- 10633823966279326983230456482242756608 -instance Pretty Integer where pretty = unsafeViaShow - -#if NATURAL_IN_BASE -instance Pretty Natural where pretty = unsafeViaShow -#endif - --- | >>> pretty (pi :: Float) --- 3.1415927 -instance Pretty Float where pretty = unsafeViaShow - --- | >>> pretty (exp 1 :: Double) --- 2.71828182845904... -instance Pretty Double where pretty = unsafeViaShow - --- | >>> pretty (123, "hello") --- (123, hello) -instance (Pretty a1, Pretty a2) => Pretty (a1,a2) where - pretty (x1,x2) = tupled [pretty x1, pretty x2] - --- | >>> pretty (123, "hello", False) --- (123, hello, False) -instance (Pretty a1, Pretty a2, Pretty a3) => Pretty (a1,a2,a3) where - pretty (x1,x2,x3) = tupled [pretty x1, pretty x2, pretty x3] - --- -- | >>> pretty (123, "hello", False, ()) --- -- (123, hello, False, ()) --- instance (Pretty a1, Pretty a2, Pretty a3, Pretty a4) => Pretty (a1,a2,a3,a4) where --- pretty (x1,x2,x3,x4) = tupled [pretty x1, pretty x2, pretty x3, pretty x4] --- --- -- | >>> pretty (123, "hello", False, (), 3.14) --- -- (123, hello, False, (), 3.14) --- instance (Pretty a1, Pretty a2, Pretty a3, Pretty a4, Pretty a5) => Pretty (a1,a2,a3,a4,a5) where --- pretty (x1,x2,x3,x4,x5) = tupled [pretty x1, pretty x2, pretty x3, pretty x4, pretty x5] --- --- -- | >>> pretty (123, "hello", False, (), 3.14, Just 2.71) --- -- ( 123 --- -- , hello --- -- , False --- -- , () --- -- , 3.14 --- -- , 2.71 ) --- instance (Pretty a1, Pretty a2, Pretty a3, Pretty a4, Pretty a5, Pretty a6) => Pretty (a1,a2,a3,a4,a5,a6) where --- pretty (x1,x2,x3,x4,x5,x6) = tupled [pretty x1, pretty x2, pretty x3, pretty x4, pretty x5, pretty x6] --- --- -- | >>> pretty (123, "hello", False, (), 3.14, Just 2.71, [1,2,3]) --- -- ( 123 --- -- , hello --- -- , False --- -- , () --- -- , 3.14 --- -- , 2.71 --- -- , [1, 2, 3] ) --- instance (Pretty a1, Pretty a2, Pretty a3, Pretty a4, Pretty a5, Pretty a6, Pretty a7) => Pretty (a1,a2,a3,a4,a5,a6,a7) where --- pretty (x1,x2,x3,x4,x5,x6,x7) = tupled [pretty x1, pretty x2, pretty x3, pretty x4, pretty x5, pretty x6, pretty x7] - --- | Ignore 'Nothing's, print 'Just' contents. --- --- >>> pretty (Just True) --- True --- >>> braces (pretty (Nothing :: Maybe Bool)) --- {} --- --- >>> pretty [Just 1, Nothing, Just 3, Nothing] --- [1, 3] -instance Pretty a => Pretty (Maybe a) where - pretty = maybe mempty pretty - prettyList = prettyList . catMaybes - --- | Automatically converts all newlines to @'line'@. --- --- >>> pretty ("hello\nworld" :: Text) --- hello --- world --- --- Note that @'line'@ can be undone by @'group'@: --- --- >>> group (pretty ("hello\nworld" :: Text)) --- hello world --- --- Manually use @'hardline'@ if you /definitely/ want newlines. -instance Pretty Text where pretty = vsep . map unsafeTextWithoutNewlines . T.splitOn "\n" - --- | (lazy 'Text' instance, identical to the strict version) -instance Pretty Lazy.Text where pretty = pretty . Lazy.toStrict - --- | Finding a good example for printing something that does not exist is hard, --- so here is an example of printing a list full of nothing. --- --- >>> pretty ([] :: [Void]) --- [] -instance Pretty Void where pretty = absurd - - - --- | @(unsafeTextWithoutNewlines s)@ contains the literal string @s@. --- --- The string must not contain any newline characters, since this is an --- invariant of the 'Text' constructor. -unsafeTextWithoutNewlines :: Text -> Doc ann -unsafeTextWithoutNewlines text = case T.uncons text of - Nothing -> Empty - Just (t,ext) - | T.null ext -> Char t - | otherwise -> Text (T.length text) text - --- | The empty document behaves like @('pretty' "")@, so it has a height of 1. --- This may lead to surprising behaviour if we expect it to bear no weight --- inside e.g. 'vcat', where we get an empty line of output from it ('parens' --- for visibility only): --- --- >>> vsep ["hello", parens emptyDoc, "world"] --- hello --- () --- world --- --- Together with '<>', 'emptyDoc' forms the 'Monoid' 'Doc'. -emptyDoc :: Doc ann -emptyDoc = Empty - --- | @('nest' i x)@ lays out the document @x@ with the current nesting level --- (indentation of the following lines) increased by @i@. Negative values are --- allowed, and decrease the nesting level accordingly. --- --- >>> vsep [nest 4 (vsep ["lorem", "ipsum", "dolor"]), "sit", "amet"] --- lorem --- ipsum --- dolor --- sit --- amet --- --- See also --- --- * 'hang' ('nest' relative to current cursor position instead of --- current nesting level) --- * 'align' (set nesting level to current cursor position) --- * 'indent' (increase indentation on the spot, padding with spaces). -nest - :: Int -- ^ Change of nesting level - -> Doc ann - -> Doc ann -nest 0 x = x -- Optimization -nest i x = Nest i x - --- | The @'line'@ document advances to the next line and indents to the current --- nesting level. --- --- >>> let doc = "lorem ipsum" <> line <> "dolor sit amet" --- >>> doc --- lorem ipsum --- dolor sit amet --- --- @'line'@ behaves like @'space'@ if the line break is undone by 'group': --- --- >>> group doc --- lorem ipsum dolor sit amet -line :: Doc ann -line = FlatAlt Line (Char ' ') - --- | @'line''@ is like @'line'@, but behaves like @'mempty'@ if the line break --- is undone by 'group' (instead of @'space'@). --- --- >>> let doc = "lorem ipsum" <> line' <> "dolor sit amet" --- >>> doc --- lorem ipsum --- dolor sit amet --- >>> group doc --- lorem ipsumdolor sit amet -line' :: Doc ann -line' = FlatAlt Line mempty - --- | @softline@ behaves like @'space'@ if the resulting output fits the page, --- otherwise like @'line'@. --- --- Here, we have enough space to put everything in one line: --- --- >>> let doc = "lorem ipsum" <> softline <> "dolor sit amet" --- >>> putDocW 80 doc --- lorem ipsum dolor sit amet --- --- If we narrow the page to width 10, the layouter produces a line break: --- --- >>> putDocW 10 doc --- lorem ipsum --- dolor sit amet --- --- @ --- 'softline' = 'group' 'line' --- @ -softline :: Doc ann -softline = Union (Char ' ') Line - --- | @'softline''@ is like @'softline'@, but behaves like @'mempty'@ if the --- resulting output does not fit on the page (instead of @'space'@). In other --- words, @'line'@ is to @'line''@ how @'softline'@ is to @'softline''@. --- --- With enough space, we get direct concatenation: --- --- >>> let doc = "ThisWord" <> softline' <> "IsWayTooLong" --- >>> putDocW 80 doc --- ThisWordIsWayTooLong --- --- If we narrow the page to width 10, the layouter produces a line break: --- --- >>> putDocW 10 doc --- ThisWord --- IsWayTooLong --- --- @ --- 'softline'' = 'group' 'line'' --- @ -softline' :: Doc ann -softline' = Union mempty Line - --- | A @'hardline'@ is /always/ laid out as a line break, even when 'group'ed or --- when there is plenty of space. Note that it might still be simply discarded --- if it is part of a 'flatAlt' inside a 'group'. --- --- >>> let doc = "lorem ipsum" <> hardline <> "dolor sit amet" --- >>> putDocW 1000 doc --- lorem ipsum --- dolor sit amet --- --- >>> group doc --- lorem ipsum --- dolor sit amet -hardline :: Doc ann -hardline = Line - --- | @('group' x)@ tries laying out @x@ into a single line by removing the --- contained line breaks; if this does not fit the page, or when a 'hardline' --- within @x@ prevents it from being flattened, @x@ is laid out without any --- changes. --- --- The 'group' function is key to layouts that adapt to available space nicely. --- --- See 'vcat', 'line', or 'flatAlt' for examples that are related, or make good --- use of it. -group :: Doc ann -> Doc ann --- See note [Group: special flattening] -group x = case x of - Union{} -> x - FlatAlt a b -> case changesUponFlattening b of - Flattened b' -> Union b' a - AlreadyFlat -> Union b a - NeverFlat -> a - _ -> case changesUponFlattening x of - Flattened x' -> Union x' x - AlreadyFlat -> x - NeverFlat -> x - --- Note [Group: special flattening] --- --- Since certain documents do not change under removal of newlines etc, there is --- no point in creating a 'Union' of the flattened and unflattened version – all --- this does is introducing two branches for the layout algorithm to take, --- resulting in potentially exponential behavior on deeply nested examples, such --- as --- --- pathological n = iterate (\x -> hsep [x, sep []] ) "foobar" !! n --- --- See https://github.com/quchen/prettyprinter/issues/22 for the corresponding --- ticket. - -data FlattenResult a - = Flattened a - -- ^ @a@ is likely flatter than the input. - | AlreadyFlat - -- ^ The input was already flat, e.g. a 'Text'. - | NeverFlat - -- ^ The input couldn't be flattened: It contained a 'Line' or 'Fail'. - -instance Functor FlattenResult where - fmap f (Flattened a) = Flattened (f a) - fmap _ AlreadyFlat = AlreadyFlat - fmap _ NeverFlat = NeverFlat - --- | Choose the first element of each @Union@, and discard the first field of --- all @FlatAlt@s. --- --- The result is 'Flattened' if the element might change depending on the layout --- algorithm (i.e. contains differently renderable sub-documents), and 'AlreadyFlat' --- if the document is static (e.g. contains only a plain 'Empty' node). --- 'NeverFlat' is returned when the document cannot be flattened because it --- contains a hard 'Line' or 'Fail'. --- See [Group: special flattening] for further explanations. -changesUponFlattening :: Doc ann -> FlattenResult (Doc ann) -changesUponFlattening = \doc -> case doc of - FlatAlt _ y -> Flattened (flatten y) - Line -> NeverFlat - Union x _ -> Flattened x - Nest i x -> fmap (Nest i) (changesUponFlattening x) - Annotated ann x -> fmap (Annotated ann) (changesUponFlattening x) - - Column f -> Flattened (Column (flatten . f)) - Nesting f -> Flattened (Nesting (flatten . f)) - WithPageWidth f -> Flattened (WithPageWidth (flatten . f)) - - Cat x y -> case (changesUponFlattening x, changesUponFlattening y) of - (NeverFlat , _ ) -> NeverFlat - (_ , NeverFlat ) -> NeverFlat - (Flattened x' , Flattened y') -> Flattened (Cat x' y') - (Flattened x' , AlreadyFlat ) -> Flattened (Cat x' y) - (AlreadyFlat , Flattened y') -> Flattened (Cat x y') - (AlreadyFlat , AlreadyFlat ) -> AlreadyFlat - - Empty -> AlreadyFlat - Char{} -> AlreadyFlat - Text{} -> AlreadyFlat - Fail -> NeverFlat - where - -- Flatten, but don’t report whether anything changes. - flatten :: Doc ann -> Doc ann - flatten = \doc -> case doc of - FlatAlt _ y -> flatten y - Cat x y -> Cat (flatten x) (flatten y) - Nest i x -> Nest i (flatten x) - Line -> Fail - Union x _ -> flatten x - Column f -> Column (flatten . f) - WithPageWidth f -> WithPageWidth (flatten . f) - Nesting f -> Nesting (flatten . f) - Annotated ann x -> Annotated ann (flatten x) - - x@Fail -> x - x@Empty -> x - x@Char{} -> x - x@Text{} -> x - - - --- | By default, @('flatAlt' x y)@ renders as @x@. However when 'group'ed, --- @y@ will be preferred, with @x@ as the fallback for the case when @y@ --- doesn't fit. --- --- >>> let doc = flatAlt "a" "b" --- >>> putDoc doc --- a --- >>> putDoc (group doc) --- b --- >>> putDocW 0 (group doc) --- a --- --- 'flatAlt' is particularly useful for defining conditional separators such as --- --- @ --- softline = 'group' ('flatAlt' 'hardline' " ") --- @ --- --- >>> let hello = "Hello" <> softline <> "world!" --- >>> putDocW 12 hello --- Hello world! --- >>> putDocW 11 hello --- Hello --- world! --- --- === __Example: Haskell's do-notation__ --- --- We can use this to render Haskell's do-notation nicely: --- --- >>> let open = flatAlt "" "{ " --- >>> let close = flatAlt "" " }" --- >>> let separator = flatAlt "" "; " --- >>> let prettyDo xs = group ("do" <+> align (encloseSep open close separator xs)) --- >>> let statements = ["name:_ <- getArgs", "let greet = \"Hello, \" <> name", "putStrLn greet"] --- --- This is put into a single line with @{;}@ style if it fits, --- --- >>> putDocW 80 (prettyDo statements) --- do { name:_ <- getArgs; let greet = "Hello, " <> name; putStrLn greet } --- --- When there is not enough space the statements are broken up into lines --- nicely, --- --- >>> putDocW 10 (prettyDo statements) --- do name:_ <- getArgs --- let greet = "Hello, " <> name --- putStrLn greet --- --- === Notes --- --- Users should be careful to choose @x@ to be less wide than @y@. --- Otherwise, if @y@ turns out not to fit the page, we fall back on an even --- wider layout: --- --- >>> let ugly = group (flatAlt "even wider" "too wide") --- >>> putDocW 7 ugly --- even wider --- --- Also note that 'group' will flatten @y@: --- --- >>> putDoc (group (flatAlt "x" ("y" <> line <> "y"))) --- y y --- --- This also means that an "unflattenable" @y@ which contains a hard linebreak --- will /never/ be rendered: --- --- >>> putDoc (group (flatAlt "x" ("y" <> hardline <> "y"))) --- x -flatAlt - :: Doc ann -- ^ Default - -> Doc ann -- ^ Preferred when 'group'ed - -> Doc ann -flatAlt = FlatAlt - - - --- | @('align' x)@ lays out the document @x@ with the nesting level set to the --- current column. It is used for example to implement 'hang'. --- --- As an example, we will put a document right above another one, regardless of --- the current nesting level. Without 'align'ment, the second line is put simply --- below everything we've had so far, --- --- >>> "lorem" <+> vsep ["ipsum", "dolor"] --- lorem ipsum --- dolor --- --- If we add an 'align' to the mix, the @'vsep'@'s contents all start in the --- same column, --- --- >>> "lorem" <+> align (vsep ["ipsum", "dolor"]) --- lorem ipsum --- dolor -align :: Doc ann -> Doc ann -align d = column (\k -> nesting (\i -> nest (k - i) d)) -- nesting might be negative! - --- | @('hang' i x)@ lays out the document @x@ with a nesting level set to the --- /current column/ plus @i@. Negative values are allowed, and decrease the --- nesting level accordingly. --- --- >>> let doc = reflow "Indenting these words with hang" --- >>> putDocW 24 ("prefix" <+> hang 4 doc) --- prefix Indenting these --- words with --- hang --- --- This differs from 'nest', which is based on the /current nesting level/ plus --- @i@. When you're not sure, try the more efficient 'nest' first. In our --- example, this would yield --- --- >>> let doc = reflow "Indenting these words with nest" --- >>> putDocW 24 ("prefix" <+> nest 4 doc) --- prefix Indenting these --- words with nest --- --- @ --- 'hang' i doc = 'align' ('nest' i doc) --- @ -hang - :: Int -- ^ Change of nesting level, relative to the start of the first line - -> Doc ann - -> Doc ann -hang i d = align (nest i d) - --- | @('indent' i x)@ indents document @x@ with @i@ spaces, starting from the --- current cursor position. --- --- >>> let doc = reflow "The indent function indents these words!" --- >>> putDocW 24 ("prefix" <> indent 4 doc) --- prefix The indent --- function --- indents these --- words! --- --- @ --- 'indent' i d = 'hang' i ({i spaces} <> d) --- @ -indent - :: Int -- ^ Number of spaces to increase indentation by - -> Doc ann - -> Doc ann -indent i d = hang i (spaces i <> d) - --- | @('encloseSep' l r sep xs)@ concatenates the documents @xs@ separated by --- @sep@, and encloses the resulting document by @l@ and @r@. --- --- The documents are laid out horizontally if that fits the page, --- --- >>> let doc = "list" <+> align (encloseSep lbracket rbracket comma (map pretty [1,20,300,4000])) --- >>> putDocW 80 doc --- list [1,20,300,4000] --- --- If there is not enough space, then the input is split into lines entry-wise --- therwise they are laid out vertically, with separators put in the front: --- --- >>> putDocW 10 doc --- list [1 --- ,20 --- ,300 --- ,4000] --- --- Note that @doc@ contains an explicit call to 'align' so that the list items --- are aligned vertically. --- --- For putting separators at the end of entries instead, have a look at --- 'punctuate'. -encloseSep - :: Doc ann -- ^ left delimiter - -> Doc ann -- ^ right delimiter - -> Doc ann -- ^ separator - -> [Doc ann] -- ^ input documents - -> Doc ann -encloseSep l r s ds = case ds of - [] -> l <> r - [d] -> l <> d <> r - _ -> cat (zipWith (<>) (l : repeat s) ds) <> r - --- | Haskell-inspired variant of 'encloseSep' with braces and comma as --- separator. --- --- >>> let doc = list (map pretty [1,20,300,4000]) --- --- >>> putDocW 80 doc --- [1, 20, 300, 4000] --- --- >>> putDocW 10 doc --- [ 1 --- , 20 --- , 300 --- , 4000 ] -list :: [Doc ann] -> Doc ann -list = group . encloseSep (flatAlt "[ " "[") - (flatAlt " ]" "]") - ", " - --- | Haskell-inspired variant of 'encloseSep' with parentheses and comma as --- separator. --- --- >>> let doc = tupled (map pretty [1,20,300,4000]) --- --- >>> putDocW 80 doc --- (1, 20, 300, 4000) --- --- >>> putDocW 10 doc --- ( 1 --- , 20 --- , 300 --- , 4000 ) -tupled :: [Doc ann] -> Doc ann -tupled = group . encloseSep (flatAlt "( " "(") - (flatAlt " )" ")") - ", " - - - --- | @(x '<+>' y)@ concatenates document @x@ and @y@ with a @'space'@ in --- between. --- --- >>> "hello" <+> "world" --- hello world --- --- @ --- x '<+>' y = x '<>' 'space' '<>' y --- @ -(<+>) :: Doc ann -> Doc ann -> Doc ann -x <+> y = x <> Char ' ' <> y -infixr 6 <+> -- like <> - - - --- | Concatenate all documents element-wise with a binary function. --- --- @ --- 'concatWith' _ [] = 'mempty' --- 'concatWith' (**) [x,y,z] = x ** y ** z --- @ --- --- Multiple convenience definitions based on 'concatWith' are alredy predefined, --- for example --- --- @ --- 'hsep' = 'concatWith' ('<+>') --- 'fillSep' = 'concatWith' (\\x y -> x '<>' 'softline' '<>' y) --- @ --- --- This is also useful to define customized joiners, --- --- >>> concatWith (surround dot) ["Data", "Text", "Prettyprint", "Doc"] --- Data.Text.Prettyprint.Doc -concatWith :: Foldable t => (Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann -concatWith f ds -#if !(FOLDABLE_TRAVERSABLE_IN_PRELUDE) - | foldr (\_ _ -> False) True ds = mempty -#else - | null ds = mempty -#endif - | otherwise = foldr1 f ds -{-# INLINE concatWith #-} -{-# SPECIALIZE concatWith :: (Doc ann -> Doc ann -> Doc ann) -> [Doc ann] -> Doc ann #-} - --- | @('hsep' xs)@ concatenates all documents @xs@ horizontally with @'<+>'@, --- i.e. it puts a space between all entries. --- --- >>> let docs = Util.words "lorem ipsum dolor sit amet" --- --- >>> hsep docs --- lorem ipsum dolor sit amet --- --- @'hsep'@ does not introduce line breaks on its own, even when the page is too --- narrow: --- --- >>> putDocW 5 (hsep docs) --- lorem ipsum dolor sit amet --- --- For automatic line breaks, consider using 'fillSep' instead. -hsep :: [Doc ann] -> Doc ann -hsep = concatWith (<+>) - --- | @('vsep' xs)@ concatenates all documents @xs@ above each other. If a --- 'group' undoes the line breaks inserted by @vsep@, the documents are --- separated with a 'space' instead. --- --- Using 'vsep' alone yields --- --- >>> "prefix" <+> vsep ["text", "to", "lay", "out"] --- prefix text --- to --- lay --- out --- --- 'group'ing a 'vsep' separates the documents with a 'space' if it fits the --- page (and does nothing otherwise). See the @'sep'@ convenience function for --- this use case. --- --- The 'align' function can be used to align the documents under their first --- element: --- --- >>> "prefix" <+> align (vsep ["text", "to", "lay", "out"]) --- prefix text --- to --- lay --- out --- --- Since 'group'ing a 'vsep' is rather common, 'sep' is a built-in for doing --- that. -vsep :: [Doc ann] -> Doc ann -vsep = concatWith (\x y -> x <> line <> y) - --- | @('fillSep' xs)@ concatenates the documents @xs@ horizontally with @'<+>'@ --- as long as it fits the page, then inserts a @'line'@ and continues doing that --- for all documents in @xs@. (@'line'@ means that if 'group'ed, the documents --- are separated with a 'space' instead of newlines. Use 'fillCat' if you do not --- want a 'space'.) --- --- Let's print some words to fill the line: --- --- >>> let docs = take 20 (cycle ["lorem", "ipsum", "dolor", "sit", "amet"]) --- >>> putDocW 80 ("Docs:" <+> fillSep docs) --- Docs: lorem ipsum dolor sit amet lorem ipsum dolor sit amet lorem ipsum dolor --- sit amet lorem ipsum dolor sit amet --- --- The same document, printed at a width of only 40, yields --- --- >>> putDocW 40 ("Docs:" <+> fillSep docs) --- Docs: lorem ipsum dolor sit amet lorem --- ipsum dolor sit amet lorem ipsum dolor --- sit amet lorem ipsum dolor sit amet -fillSep :: [Doc ann] -> Doc ann -fillSep = concatWith (\x y -> x <> softline <> y) - --- | @('sep' xs)@ tries laying out the documents @xs@ separated with 'space's, --- and if this does not fit the page, separates them with newlines. This is what --- differentiates it from 'vsep', which always lays out its contents beneath --- each other. --- --- >>> let doc = "prefix" <+> sep ["text", "to", "lay", "out"] --- >>> putDocW 80 doc --- prefix text to lay out --- --- With a narrower layout, the entries are separated by newlines: --- --- >>> putDocW 20 doc --- prefix text --- to --- lay --- out --- --- @ --- 'sep' = 'group' . 'vsep' --- @ -sep :: [Doc ann] -> Doc ann -sep = group . vsep - - - --- | @('hcat' xs)@ concatenates all documents @xs@ horizontally with @'<>'@ --- (i.e. without any spacing). --- --- It is provided only for consistency, since it is identical to 'mconcat'. --- --- >>> let docs = Util.words "lorem ipsum dolor" --- >>> hcat docs --- loremipsumdolor -hcat :: [Doc ann] -> Doc ann -hcat = concatWith (<>) - --- | @('vcat' xs)@ vertically concatenates the documents @xs@. If it is --- 'group'ed, the line breaks are removed. --- --- In other words @'vcat'@ is like @'vsep'@, with newlines removed instead of --- replaced by 'space's. --- --- >>> let docs = Util.words "lorem ipsum dolor" --- >>> vcat docs --- lorem --- ipsum --- dolor --- >>> group (vcat docs) --- loremipsumdolor --- --- Since 'group'ing a 'vcat' is rather common, 'cat' is a built-in shortcut for --- it. -vcat :: [Doc ann] -> Doc ann -vcat = concatWith (\x y -> x <> line' <> y) - --- | @('fillCat' xs)@ concatenates documents @xs@ horizontally with @'<>'@ as --- long as it fits the page, then inserts a @'line''@ and continues doing that --- for all documents in @xs@. This is similar to how an ordinary word processor --- lays out the text if you just keep typing after you hit the maximum line --- length. --- --- (@'line''@ means that if 'group'ed, the documents are separated with nothing --- instead of newlines. See 'fillSep' if you want a 'space' instead.) --- --- Observe the difference between 'fillSep' and 'fillCat'. 'fillSep' --- concatenates the entries 'space'd when 'group'ed, --- --- >>> let docs = take 20 (cycle (["lorem", "ipsum", "dolor", "sit", "amet"])) --- >>> putDocW 40 ("Grouped:" <+> group (fillSep docs)) --- Grouped: lorem ipsum dolor sit amet --- lorem ipsum dolor sit amet lorem ipsum --- dolor sit amet lorem ipsum dolor sit --- amet --- --- On the other hand, 'fillCat' concatenates the entries directly when --- 'group'ed, --- --- >>> putDocW 40 ("Grouped:" <+> group (fillCat docs)) --- Grouped: loremipsumdolorsitametlorem --- ipsumdolorsitametloremipsumdolorsitamet --- loremipsumdolorsitamet -fillCat :: [Doc ann] -> Doc ann -fillCat = concatWith (\x y -> x <> softline' <> y) - --- | @('cat' xs)@ tries laying out the documents @xs@ separated with nothing, --- and if this does not fit the page, separates them with newlines. This is what --- differentiates it from 'vcat', which always lays out its contents beneath --- each other. --- --- >>> let docs = Util.words "lorem ipsum dolor" --- >>> putDocW 80 ("Docs:" <+> cat docs) --- Docs: loremipsumdolor --- --- When there is enough space, the documents are put above one another, --- --- >>> putDocW 10 ("Docs:" <+> cat docs) --- Docs: lorem --- ipsum --- dolor --- --- @ --- 'cat' = 'group' . 'vcat' --- @ -cat :: [Doc ann] -> Doc ann -cat = group . vcat - - - --- | @('punctuate' p xs)@ appends @p@ to all but the last document in @xs@. --- --- >>> let docs = punctuate comma (Util.words "lorem ipsum dolor sit amet") --- >>> putDocW 80 (hsep docs) --- lorem, ipsum, dolor, sit, amet --- --- The separators are put at the end of the entries, which we can see if we --- position the result vertically: --- --- >>> putDocW 20 (vsep docs) --- lorem, --- ipsum, --- dolor, --- sit, --- amet --- --- If you want put the commas in front of their elements instead of at the end, --- you should use 'tupled' or, in general, 'encloseSep'. -punctuate - :: Doc ann -- ^ Punctuation, e.g. 'comma' - -> [Doc ann] - -> [Doc ann] -punctuate p = go - where - go [] = [] - go [d] = [d] - go (d:ds) = (d <> p) : go ds - - - --- | Layout a document depending on which column it starts at. 'align' is --- implemented in terms of 'column'. --- --- >>> column (\l -> "Columns are" <+> pretty l <> "-based.") --- Columns are 0-based. --- --- >>> let doc = "prefix" <+> column (\l -> "| <- column" <+> pretty l) --- >>> vsep [indent n doc | n <- [0,4,8]] --- prefix | <- column 7 --- prefix | <- column 11 --- prefix | <- column 15 -column :: (Int -> Doc ann) -> Doc ann -column = Column - --- | Layout a document depending on the current 'nest'ing level. 'align' is --- implemented in terms of 'nesting'. --- --- >>> let doc = "prefix" <+> nesting (\l -> brackets ("Nested:" <+> pretty l)) --- >>> vsep [indent n doc | n <- [0,4,8]] --- prefix [Nested: 0] --- prefix [Nested: 4] --- prefix [Nested: 8] -nesting :: (Int -> Doc ann) -> Doc ann -nesting = Nesting - --- | @('width' doc f)@ lays out the document 'doc', and makes the column width --- of it available to a function. --- --- >>> let annotate doc = width (brackets doc) (\w -> " <- width:" <+> pretty w) --- >>> align (vsep (map annotate ["---", "------", indent 3 "---", vsep ["---", indent 4 "---"]])) --- [---] <- width: 5 --- [------] <- width: 8 --- [ ---] <- width: 8 --- [--- --- ---] <- width: 8 -width :: Doc ann -> (Int -> Doc ann) -> Doc ann -width doc f - = column (\colStart -> - doc <> column (\colEnd -> - f (colEnd - colStart))) - --- | Layout a document depending on the page width, if one has been specified. --- --- >>> let prettyPageWidth (AvailablePerLine l r) = "Width:" <+> pretty l <> ", ribbon fraction:" <+> pretty r --- >>> let doc = "prefix" <+> pageWidth (brackets . prettyPageWidth) --- >>> putDocW 32 (vsep [indent n doc | n <- [0,4,8]]) --- prefix [Width: 32, ribbon fraction: 1.0] --- prefix [Width: 32, ribbon fraction: 1.0] --- prefix [Width: 32, ribbon fraction: 1.0] -pageWidth :: (PageWidth -> Doc ann) -> Doc ann -pageWidth = WithPageWidth - - - --- | @('fill' i x)@ lays out the document @x@. It then appends @space@s until --- the width is equal to @i@. If the width of @x@ is already larger, nothing is --- appended. --- --- This function is quite useful in practice to output a list of bindings: --- --- >>> let types = [("empty","Doc"), ("nest","Int -> Doc -> Doc"), ("fillSep","[Doc] -> Doc")] --- >>> let ptype (name, tp) = fill 5 (pretty name) <+> "::" <+> pretty tp --- >>> "let" <+> align (vcat (map ptype types)) --- let empty :: Doc --- nest :: Int -> Doc -> Doc --- fillSep :: [Doc] -> Doc -fill - :: Int -- ^ Append spaces until the document is at least this wide - -> Doc ann - -> Doc ann -fill n doc = width doc (\w -> spaces (n - w)) - --- | @('fillBreak' i x)@ first lays out the document @x@. It then appends @space@s --- until the width is equal to @i@. If the width of @x@ is already larger than --- @i@, the nesting level is increased by @i@ and a @line@ is appended. When we --- redefine @ptype@ in the example given in 'fill' to use @'fillBreak'@, we get --- a useful variation of the output: --- --- >>> let types = [("empty","Doc"), ("nest","Int -> Doc -> Doc"), ("fillSep","[Doc] -> Doc")] --- >>> let ptype (name, tp) = fillBreak 5 (pretty name) <+> "::" <+> pretty tp --- >>> "let" <+> align (vcat (map ptype types)) --- let empty :: Doc --- nest :: Int -> Doc -> Doc --- fillSep --- :: [Doc] -> Doc -fillBreak - :: Int -- ^ Append spaces until the document is at least this wide - -> Doc ann - -> Doc ann -fillBreak f x = width x (\w -> - if w > f - then nest f line' - else spaces (f - w)) - --- | Insert a number of spaces. Negative values count as 0. -spaces :: Int -> Doc ann -spaces n - | n <= 0 = Empty - | n == 1 = Char ' ' - | otherwise = Text n (textSpaces n) - --- $ --- prop> \(NonNegative n) -> length (show (spaces n)) == n --- --- >>> case spaces 1 of Char ' ' -> True; _ -> False --- True --- --- >>> case spaces 0 of Empty -> True; _ -> False --- True --- --- prop> \(Positive n) -> case (spaces (-n)) of Empty -> True; _ -> False - - - --- | @('plural' n one many)@ is @one@ if @n@ is @1@, and @many@ otherwise. A --- typical use case is adding a plural "s". --- --- >>> let things = [True] --- >>> let amount = length things --- >>> pretty things <+> "has" <+> pretty amount <+> plural "entry" "entries" amount --- [True] has 1 entry -plural - :: (Num amount, Eq amount) - => doc -- ^ @1@ case - -> doc -- ^ other cases - -> amount - -> doc -plural one multiple n - | n == 1 = one - | otherwise = multiple - --- | @('enclose' l r x)@ encloses document @x@ between documents @l@ and @r@ --- using @'<>'@. --- --- >>> enclose "A" "Z" "·" --- A·Z --- --- @ --- 'enclose' l r x = l '<>' x '<>' r --- @ -enclose - :: Doc ann -- ^ L - -> Doc ann -- ^ R - -> Doc ann -- ^ x - -> Doc ann -- ^ LxR -enclose l r x = l <> x <> r - --- | @('surround' x l r)@ surrounds document @x@ with @l@ and @r@. --- --- >>> surround "·" "A" "Z" --- A·Z --- --- This is merely an argument reordering of @'enclose'@, but allows for --- definitions like --- --- >>> concatWith (surround ".") ["Data", "Text", "Prettyprint", "Doc"] --- Data.Text.Prettyprint.Doc -surround - :: Doc ann - -> Doc ann - -> Doc ann - -> Doc ann -surround x l r = l <> x <> r - - - - - - --- | Add an annotation to a @'Doc'@. This annotation can then be used by the --- renderer to e.g. add color to certain parts of the output. For a full --- tutorial example on how to use it, see the --- "Data.Text.Prettyprint.Doc.Render.Tutorials.StackMachineTutorial" or --- "Data.Text.Prettyprint.Doc.Render.Tutorials.TreeRenderingTutorial" modules. --- --- This function is only relevant for custom formats with their own annotations, --- and not relevant for basic prettyprinting. The predefined renderers, e.g. --- "Data.Text.Prettyprint.Doc.Render.Text", should be enough for the most common --- needs. -annotate :: ann -> Doc ann -> Doc ann -annotate = Annotated - --- | Remove all annotations. --- --- Although 'unAnnotate' is idempotent with respect to rendering, --- --- @ --- 'unAnnotate' . 'unAnnotate' = 'unAnnotate' --- @ --- --- it should not be used without caution, for each invocation traverses the --- entire contained document. If possible, it is preferrable to unannotate after --- producing the layout by using 'unAnnotateS'. -unAnnotate :: Doc ann -> Doc xxx -unAnnotate = alterAnnotations (const []) - --- | Change the annotation of a 'Doc'ument. --- --- Useful in particular to embed documents with one form of annotation in a more --- generlly annotated document. --- --- Since this traverses the entire @'Doc'@ tree, including parts that are not --- rendered due to other layouts fitting better, it is preferrable to reannotate --- after producing the layout by using @'reAnnotateS'@. --- --- Since @'reAnnotate'@ has the right type and satisfies @'reAnnotate id = id'@, --- it is used to define the @'Functor'@ instance of @'Doc'@. -reAnnotate :: (ann -> ann') -> Doc ann -> Doc ann' -reAnnotate re = alterAnnotations (pure . re) - --- | Change the annotations of a 'Doc'ument. Individual annotations can be --- removed, changed, or replaced by multiple ones. --- --- This is a general function that combines 'unAnnotate' and 'reAnnotate', and --- it is useful for mapping semantic annotations (such as »this is a keyword«) --- to display annotations (such as »this is red and underlined«), because some --- backends may not care about certain annotations, while others may. --- --- Annotations earlier in the new list will be applied earlier, i.e. returning --- @[Bold, Green]@ will result in a bold document that contains green text, and --- not vice-versa. --- --- Since this traverses the entire @'Doc'@ tree, including parts that are not --- rendered due to other layouts fitting better, it is preferrable to reannotate --- after producing the layout by using @'alterAnnotationsS'@. -alterAnnotations :: (ann -> [ann']) -> Doc ann -> Doc ann' -alterAnnotations re = go - where - go = \doc -> case doc of - Fail -> Fail - Empty -> Empty - Char c -> Char c - Text l t -> Text l t - Line -> Line - - FlatAlt x y -> FlatAlt (go x) (go y) - Cat x y -> Cat (go x) (go y) - Nest i x -> Nest i (go x) - Union x y -> Union (go x) (go y) - Column f -> Column (go . f) - WithPageWidth f -> WithPageWidth (go . f) - Nesting f -> Nesting (go . f) - Annotated ann x -> foldr Annotated (go x) (re ann) - --- $ --- >>> let doc = "lorem" <+> annotate () "ipsum" <+> "dolor" --- >>> let re () = ["FOO", "BAR"] --- >>> layoutPretty defaultLayoutOptions (alterAnnotations re doc) --- SText 5 "lorem" (SChar ' ' (SAnnPush "FOO" (SAnnPush "BAR" (SText 5 "ipsum" (SAnnPop (SAnnPop (SChar ' ' (SText 5 "dolor" SEmpty)))))))) - --- | Remove all annotations. 'unAnnotate' for 'SimpleDocStream'. -unAnnotateS :: SimpleDocStream ann -> SimpleDocStream xxx -unAnnotateS = go - where - go = \doc -> case doc of - SFail -> SFail - SEmpty -> SEmpty - SChar c rest -> SChar c (go rest) - SText l t rest -> SText l t (go rest) - SLine l rest -> SLine l (go rest) - SAnnPop rest -> go rest - SAnnPush _ann rest -> go rest - --- | Change the annotation of a document. 'reAnnotate' for 'SimpleDocStream'. -reAnnotateS :: (ann -> ann') -> SimpleDocStream ann -> SimpleDocStream ann' -reAnnotateS re = go - where - go = \doc -> case doc of - SFail -> SFail - SEmpty -> SEmpty - SChar c rest -> SChar c (go rest) - SText l t rest -> SText l t (go rest) - SLine l rest -> SLine l (go rest) - SAnnPop rest -> SAnnPop (go rest) - SAnnPush ann rest -> SAnnPush (re ann) (go rest) - -data AnnotationRemoval = Remove | DontRemove - deriving Typeable - --- | Change the annotation of a document to a different annotation, or none at --- all. 'alterAnnotations' for 'SimpleDocStream'. --- --- Note that the 'Doc' version is more flexible, since it allows changing a --- single annotation to multiple ones. --- ('Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree.SimpleDocTree' restores --- this flexibility again.) -alterAnnotationsS :: (ann -> Maybe ann') -> SimpleDocStream ann -> SimpleDocStream ann' -alterAnnotationsS re = go [] - where - -- We keep a stack of whether to remove a pop so that we can remove exactly - -- the pops corresponding to annotations that mapped to Nothing. - go stack = \sds -> case sds of - SFail -> SFail - SEmpty -> SEmpty - SChar c rest -> SChar c (go stack rest) - SText l t rest -> SText l t (go stack rest) - SLine l rest -> SLine l (go stack rest) - SAnnPush ann rest -> case re ann of - Nothing -> go (Remove:stack) rest - Just ann' -> SAnnPush ann' (go (DontRemove:stack) rest) - SAnnPop rest -> case stack of - [] -> panicPeekedEmpty - DontRemove:stack' -> SAnnPop (go stack' rest) - Remove:stack' -> go stack' rest - --- | Fusion depth parameter, used by 'fuse'. -data FusionDepth = - - -- | Do not dive deep into nested documents, fusing mostly concatenations of - -- text nodes together. - Shallow - - -- | Recurse into all parts of the 'Doc', including different layout - -- alternatives, and location-sensitive values such as created by 'nesting' - -- which cannot be fused before, but only during, the layout process. As a - -- result, the performance cost of using deep fusion is often hard to - -- predict, and depends on the interplay between page layout and document to - -- prettyprint. - -- - -- This value should only be used if profiling shows it is significantly - -- faster than using 'Shallow'. - | Deep - deriving (Eq, Ord, Show, Typeable) - --- | @('fuse' depth doc)@ combines text nodes so they can be rendered more --- efficiently. A fused document is always laid out identical to its unfused --- version. --- --- When laying a 'Doc'ument out to a 'SimpleDocStream', every component of the --- input is translated directly to the simpler output format. This sometimes --- yields undesirable chunking when many pieces have been concatenated together. --- --- For example --- --- >>> "a" <> "b" <> pretty 'c' <> "d" --- abcd --- --- results in a chain of four entries in a 'SimpleDocStream', although this is fully --- equivalent to the tightly packed --- --- >>> "abcd" :: Doc ann --- abcd --- --- which is only a single 'SimpleDocStream' entry, and can be processed faster. --- --- It is therefore a good idea to run 'fuse' on concatenations of lots of small --- strings that are used many times, --- --- >>> let oftenUsed = fuse Shallow ("a" <> "b" <> pretty 'c' <> "d") --- >>> hsep (replicate 5 oftenUsed) --- abcd abcd abcd abcd abcd -fuse :: FusionDepth -> Doc ann -> Doc ann -fuse depth = go - where - go = \doc -> case doc of - Cat Empty x -> go x - Cat x Empty -> go x - Cat (Char c1) (Char c2) -> Text 2 (T.singleton c1 <> T.singleton c2) - Cat (Text lt t) (Char c) -> Text (lt+1) (T.snoc t c) - Cat (Char c) (Text lt t) -> Text (1+lt) (T.cons c t) - Cat (Text l1 t1) (Text l2 t2) -> Text (l1+l2) (t1 <> t2) - - Cat x@Char{} (Cat y@Char{} z) -> go (Cat (go (Cat x y)) z) - Cat x@Text{} (Cat y@Char{} z) -> go (Cat (go (Cat x y)) z) - Cat x@Char{} (Cat y@Text{} z) -> go (Cat (go (Cat x y)) z) - Cat x@Text{} (Cat y@Text{} z) -> go (Cat (go (Cat x y)) z) - - Cat (Cat x y@Char{}) z -> go (Cat x (go (Cat y z))) - Cat (Cat x y@Text{}) z -> go (Cat x (go (Cat y z))) - - Cat x y -> Cat (go x) (go y) - - Nest i (Nest j x) -> let !fused = Nest (i+j) x - in go fused - Nest _ x@Empty{} -> x - Nest _ x@Text{} -> x - Nest _ x@Char{} -> x - Nest 0 x -> go x - Nest i x -> Nest i (go x) - - Annotated ann x -> Annotated ann (go x) - - FlatAlt x1 x2 -> FlatAlt (go x1) (go x2) - Union x1 x2 -> Union (go x1) (go x2) - - other | depth == Shallow -> other - - Column f -> Column (go . f) - WithPageWidth f -> WithPageWidth (go . f) - Nesting f -> Nesting (go . f) - - other -> other - - - --- | The data type @SimpleDocStream@ represents laid out documents and is used --- by the display functions. --- --- A simplified view is that @'Doc' = ['SimpleDocStream']@, and the layout --- functions pick one of the 'SimpleDocStream's based on which one fits the --- layout constraints best. This means that 'SimpleDocStream' has all complexity --- contained in 'Doc' resolved, making it very easy to convert it to other --- formats, such as plain text or terminal output. --- --- To write your own @'Doc'@ to X converter, it is therefore sufficient to --- convert from @'SimpleDocStream'@. The »Render« submodules provide some --- built-in converters to do so, and helpers to create own ones. -data SimpleDocStream ann = - SFail - | SEmpty - | SChar Char (SimpleDocStream ann) - - -- | Some layout algorithms use the Since the frequently used 'T.length' of - -- the 'Text', which scales linearly with its length, we cache it in this - -- constructor. - | SText !Int Text (SimpleDocStream ann) - - -- | @Int@ = indentation level for the (next) line - | SLine !Int (SimpleDocStream ann) - - -- | Add an annotation to the remaining document. - | SAnnPush ann (SimpleDocStream ann) - - -- | Remove a previously pushed annotation. - | SAnnPop (SimpleDocStream ann) - deriving (Eq, Ord, Show, Generic, Typeable) - --- | Remove all trailing space characters. --- --- This has some performance impact, because it does an entire additional pass --- over the 'SimpleDocStream'. --- --- No trimming will be done inside annotations, which are considered to contain --- no (trimmable) whitespace, since the annotation might actually be /about/ the --- whitespace, for example a renderer that colors the background of trailing --- whitespace, as e.g. @git diff@ can be configured to do. -removeTrailingWhitespace :: SimpleDocStream ann -> SimpleDocStream ann -removeTrailingWhitespace = go (RecordedWhitespace [] 0) - where - commitWhitespace - :: [Int] -- Withheld lines - -> Int -- Withheld spaces - -> SimpleDocStream ann - -> SimpleDocStream ann - commitWhitespace is !n sds = case is of - [] -> case n of - 0 -> sds - 1 -> SChar ' ' sds - _ -> SText n (textSpaces n) sds - (i:is') -> let !end = SLine (i + n) sds - in prependEmptyLines is' end - - prependEmptyLines :: [Int] -> SimpleDocStream ann -> SimpleDocStream ann - prependEmptyLines is sds0 = foldr (\_ sds -> SLine 0 sds) sds0 is - - go :: WhitespaceStrippingState -> SimpleDocStream ann -> SimpleDocStream ann - -- We do not strip whitespace inside annotated documents, since it might - -- actually be relevant there. - go annLevel@(AnnotationLevel annLvl) = \sds -> case sds of - SFail -> SFail - SEmpty -> SEmpty - SChar c rest -> SChar c (go annLevel rest) - SText l text rest -> SText l text (go annLevel rest) - SLine i rest -> SLine i (go annLevel rest) - SAnnPush ann rest -> let !annLvl' = annLvl+1 - in SAnnPush ann (go (AnnotationLevel annLvl') rest) - SAnnPop rest - | annLvl > 1 -> let !annLvl' = annLvl-1 - in SAnnPop (go (AnnotationLevel annLvl') rest) - | otherwise -> SAnnPop (go (RecordedWhitespace [] 0) rest) - -- Record all spaces/lines encountered, and once proper text starts again, - -- release only the necessary ones. - go (RecordedWhitespace withheldLines withheldSpaces) = \sds -> case sds of - SFail -> SFail - SEmpty -> prependEmptyLines withheldLines SEmpty - SChar c rest - | c == ' ' -> go (RecordedWhitespace withheldLines (withheldSpaces+1)) rest - | otherwise -> commitWhitespace - withheldLines - withheldSpaces - (SChar c (go (RecordedWhitespace [] 0) rest)) - SText textLength text rest -> - let stripped = T.dropWhileEnd (== ' ') text - strippedLength = T.length stripped - trailingLength = textLength - strippedLength - isOnlySpace = strippedLength == 0 - in if isOnlySpace - then go (RecordedWhitespace withheldLines (withheldSpaces + textLength)) rest - else commitWhitespace - withheldLines - withheldSpaces - (SText strippedLength - stripped - (go (RecordedWhitespace [] trailingLength) rest)) - SLine i rest -> go (RecordedWhitespace (i:withheldLines) 0) rest - SAnnPush ann rest -> commitWhitespace - withheldLines - withheldSpaces - (SAnnPush ann (go (AnnotationLevel 1) rest)) - SAnnPop _ -> error "Tried skipping spaces in unannotated data! Please report this as a bug in 'prettyprinter'." - -data WhitespaceStrippingState - = AnnotationLevel !Int - | RecordedWhitespace [Int] !Int - -- ^ [Newline with indentation i] Spaces - deriving Typeable - - - --- $ --- >>> import qualified Data.Text.IO as T --- >>> doc = "lorem" <> hardline <> hardline <> pretty "ipsum" --- >>> go = T.putStrLn . renderStrict . removeTrailingWhitespace . layoutPretty defaultLayoutOptions --- >>> go doc --- lorem --- --- ipsum - - - --- | Alter the document’s annotations. --- --- This instance makes 'SimpleDocStream' more flexible (because it can be used in --- 'Functor'-polymorphic values), but @'fmap'@ is much less readable compared to --- using @'reAnnotateST'@ in code that only works for @'SimpleDocStream'@ anyway. --- Consider using the latter when the type does not matter. -instance Functor SimpleDocStream where - fmap = reAnnotateS - --- | Collect all annotations from a document. -instance Foldable SimpleDocStream where - foldMap f = go - where - go = \sds -> case sds of - SFail -> mempty - SEmpty -> mempty - SChar _ rest -> go rest - SText _ _ rest -> go rest - SLine _ rest -> go rest - SAnnPush ann rest -> f ann `mappend` go rest - SAnnPop rest -> go rest - --- | Transform a document based on its annotations, possibly leveraging --- 'Applicative' effects. -instance Traversable SimpleDocStream where - traverse f = go - where - go = \sds -> case sds of - SFail -> pure SFail - SEmpty -> pure SEmpty - SChar c rest -> SChar c <$> go rest - SText l t rest -> SText l t <$> go rest - SLine i rest -> SLine i <$> go rest - SAnnPush ann rest -> SAnnPush <$> f ann <*> go rest - SAnnPop rest -> SAnnPop <$> go rest - --- | Decide whether a 'SimpleDocStream' fits the constraints given, namely --- --- - original indentation of the current line --- - current column --- - initial indentation of the alternative 'SimpleDocStream' if it --- starts with a line break (used by 'layoutSmart') --- - width in which to fit the first line -newtype FittingPredicate ann - = FittingPredicate (Int - -> Int - -> Maybe Int - -> SimpleDocStream ann - -> Bool) - deriving Typeable - --- | List of nesting level/document pairs yet to be laid out. -data LayoutPipeline ann = - Nil - | Cons !Int (Doc ann) (LayoutPipeline ann) - | UndoAnn (LayoutPipeline ann) - deriving Typeable - --- | Maximum number of characters that fit in one line. The layout algorithms --- will try not to exceed the set limit by inserting line breaks when applicable --- (e.g. via 'softline''). -data PageWidth - - = AvailablePerLine Int Double - -- ^ Layouters should not exceed the specified space per line. - -- - -- - The 'Int' is the number of characters, including whitespace, that - -- fit in a line. A typical value is 80. - -- - -- - The 'Double' is the ribbon with, i.e. the fraction of the total - -- page width that can be printed on. This allows limiting the length - -- of printable text per line. Values must be between 0 and 1, and - -- 0.4 to 1 is typical. - - | Unbounded - -- ^ Layouters should not introduce line breaks on their own. - - deriving (Eq, Ord, Show, Typeable) - -defaultPageWidth :: PageWidth -defaultPageWidth = AvailablePerLine 80 1 - --- | The remaining width on the current line. -remainingWidth :: Int -> Double -> Int -> Int -> Int -remainingWidth lineLength ribbonFraction lineIndent currentColumn = - min columnsLeftInLine columnsLeftInRibbon - where - columnsLeftInLine = lineLength - currentColumn - columnsLeftInRibbon = lineIndent + ribbonWidth - currentColumn - ribbonWidth = - (max 0 . min lineLength . round) - (fromIntegral lineLength * ribbonFraction) - --- $ Test to avoid surprising behaviour --- >>> Unbounded > AvailablePerLine maxBound 1 --- True - --- | Options to influence the layout algorithms. -newtype LayoutOptions = LayoutOptions { layoutPageWidth :: PageWidth } - deriving (Eq, Ord, Show, Typeable) - --- | The default layout options, suitable when you just want some output, and --- don’t particularly care about the details. Used by the 'Show' instance, for --- example. --- --- >>> defaultLayoutOptions --- LayoutOptions {layoutPageWidth = AvailablePerLine 80 1.0} -defaultLayoutOptions :: LayoutOptions -defaultLayoutOptions = LayoutOptions { layoutPageWidth = defaultPageWidth } - --- | This is the default layout algorithm, and it is used by 'show', 'putDoc' --- and 'hPutDoc'. --- --- @'layoutPretty'@ commits to rendering something in a certain way if the next --- element fits the layout constraints; in other words, it has one --- 'SimpleDocStream' element lookahead when rendering. Consider using the --- smarter, but a bit less performant, @'layoutSmart'@ algorithm if the results --- seem to run off to the right before having lots of line breaks. -layoutPretty - :: LayoutOptions - -> Doc ann - -> SimpleDocStream ann -layoutPretty (LayoutOptions pageWidth_@(AvailablePerLine lineLength ribbonFraction)) = - layoutWadlerLeijen - (FittingPredicate - (\lineIndent currentColumn _initialIndentY sdoc -> - fits - (remainingWidth lineLength ribbonFraction lineIndent currentColumn) - sdoc)) - pageWidth_ - where - fits :: Int -- ^ Width in which to fit the first line - -> SimpleDocStream ann - -> Bool - fits w _ | w < 0 = False - fits _ SFail = False - fits _ SEmpty = True - fits w (SChar _ x) = fits (w - 1) x - fits w (SText l _t x) = fits (w - l) x - fits _ SLine{} = True - fits w (SAnnPush _ x) = fits w x - fits w (SAnnPop x) = fits w x - -layoutPretty (LayoutOptions Unbounded) = layoutUnbounded - --- | A layout algorithm with more lookahead than 'layoutPretty', that introduces --- line breaks earlier if the content does not (or will not, rather) fit into --- one line. --- --- Consider the following python-ish document, --- --- >>> let fun x = hang 2 ("fun(" <> softline' <> x) <> ")" --- >>> let doc = (fun . fun . fun . fun . fun) (align (list ["abcdef", "ghijklm"])) --- --- which we’ll be rendering using the following pipeline (where the layout --- algorithm has been left open), --- --- >>> import Data.Text.IO as T --- >>> import 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 until it encounters a line with the --- same indentation or less than the start of the document. Any line encountered --- earlier is assumed to belong to the same syntactic structure. --- 'layoutPretty' checks only the first line. --- --- Consider for example the question of whether the @A@s fit into the document --- below: --- --- > 1 A --- > 2 A --- > 3 A --- > 4 B --- > 5 B --- --- 'layoutPretty' will check only line 1, ignoring whether e.g. line 2 might --- already be too wide. --- By contrast, 'layoutSmart' stops only once it reaches line 4, where the @B@ --- has the same indentation as the first @A@. -layoutSmart - :: LayoutOptions - -> Doc ann - -> SimpleDocStream ann -layoutSmart (LayoutOptions pageWidth_@(AvailablePerLine lineLength ribbonFraction)) = - layoutWadlerLeijen (FittingPredicate fits) pageWidth_ - where - -- Why doesn't layoutSmart simply check the entire document? - -- - -- 1. That would be very expensive. - -- 2. In that case the layout of a particular part of a document would - -- depend on the fit of completely unrelated parts of the same document. - -- See https://github.com/quchen/prettyprinter/issues/83 for a related - -- bug. - - fits :: Int -> Int -> Maybe Int -> SimpleDocStream ann -> Bool - fits lineIndent currentColumn initialIndentY = go availableWidth - where - go w _ | w < 0 = False - go _ SFail = False - go _ SEmpty = True - go w (SChar _ x) = go (w - 1) x - go w (SText l _t x) = go (w - l) x - go _ (SLine i x) - | minNestingLevel < i = go (lineLength - i) x -- TODO: Take ribbon width into account?! (#142) - | otherwise = True - go w (SAnnPush _ x) = go w x - go w (SAnnPop x) = go w x - - availableWidth = remainingWidth lineLength ribbonFraction lineIndent currentColumn - - minNestingLevel = - -- See the Note - -- [Choosing the right minNestingLevel for consistent smart layouts] - case initialIndentY of - Just i -> - -- y could be a (less wide) hanging layout. If so, let's - -- check x a bit more thoroughly so we don't miss a potentially - -- better fitting y. - min i currentColumn - Nothing -> - -- y definitely isn't a hanging layout. Let's check x with the - -- same minNestingLevel that any subsequent lines with the same - -- indentation use. - currentColumn - -layoutSmart (LayoutOptions Unbounded) = layoutUnbounded - --- | Layout a document with @Unbounded@ page width. -layoutUnbounded :: Doc ann -> SimpleDocStream ann -layoutUnbounded = - layoutWadlerLeijen - (FittingPredicate - (\_lineIndent _currentColumn _initialIndentY sdoc -> not (failsOnFirstLine sdoc))) - Unbounded - where - -- See the Note [Detecting failure with Unbounded page width]. - failsOnFirstLine :: SimpleDocStream ann -> Bool - failsOnFirstLine = go - where - go sds = case sds of - SFail -> True - SEmpty -> False - SChar _ s -> go s - SText _ _ s -> go s - SLine _ _ -> False - SAnnPush _ s -> go s - SAnnPop s -> go s - --- | The Wadler/Leijen layout algorithm -layoutWadlerLeijen - :: forall ann. FittingPredicate ann - -> PageWidth - -> Doc ann - -> SimpleDocStream ann -layoutWadlerLeijen - (FittingPredicate fits) - pageWidth_ - doc - = best 0 0 (Cons 0 doc Nil) - where - - -- * current column >= current nesting level - -- * current column - current indentaion = number of chars inserted in line - best - :: Int -- Current nesting level - -> Int -- Current column, i.e. "where the cursor is" - -> LayoutPipeline ann -- Documents remaining to be handled (in order) - -> SimpleDocStream ann - best !_ !_ Nil = SEmpty - best nl cc (UndoAnn ds) = SAnnPop (best nl cc ds) - best nl cc (Cons i d ds) = case d of - Fail -> SFail - Empty -> best nl cc ds - Char c -> let !cc' = cc+1 in SChar c (best nl cc' ds) - Text l t -> let !cc' = cc+l in SText l t (best nl cc' ds) - Line -> 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 nl cc x' y' - Column f -> best nl cc (Cons i (f cc) ds) - WithPageWidth f -> best nl cc (Cons i (f pageWidth_) ds) - Nesting f -> best nl cc (Cons i (f i) ds) - Annotated ann x -> SAnnPush ann (best nl cc (Cons i x (UndoAnn ds))) - - -- Select the better fitting of two documents: - -- Choice A if it fits, otherwise choice B. - -- - -- The fit of choice B is /not/ checked! It is ultimately the user's - -- responsibility to provide an alternative that can fit the page even when - -- choice A doesn't. - selectNicer - :: Int -- ^ Current nesting level - -> Int -- ^ Current column - -> SimpleDocStream ann -- ^ Choice A. - -> SimpleDocStream ann -- ^ Choice B. Should fit more easily - -- (== be less wide) than choice A. - -> SimpleDocStream ann -- ^ Choice A if it fits, otherwise B. - selectNicer lineIndent currentColumn x y - | fits lineIndent currentColumn (initialIndentation y) x = x - | otherwise = y - - initialIndentation :: SimpleDocStream ann -> Maybe Int - initialIndentation sds = case sds of - SLine i _ -> Just i - SAnnPush _ s -> initialIndentation s - SAnnPop s -> initialIndentation s - _ -> Nothing - - -{- Note [Choosing the right minNestingLevel for consistent smart layouts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this document: - - doc = - "Groceries: " - <> align - (cat - [ sep ["pommes", "de", "terre"] - , "apples" - , "Donaudampfschifffahrtskapitänskajütenmülleimer" - ] - ) - -... and assume we want to fit it into 40 columns as nicely as possible: - - opts = LayoutOptions (AvailablePerLine 40 1) - -We already have bad luck with the last item – it's longer than 40 characters -on its own! - -We'd still like the first item, pommes de terre, to be laid out nicely, that is, -on one line, since it's not too wide. This is what we'd like to see: - - Groceries: pommes de terre - apples - Donaudampfschifffahrtskapitänskajütenmülleimer - -Before #83 was fixed, that wasn't what we got! Instead we got this: - -> renderIO stdout $ layoutSmart opts doc -Groceries: pommes - de - terre - apples - Donaudampfschifffahrtskapitänskajütenmülleimer - -Why? - -minNestingLevel was effectively defined as - - minNestingLevel = lineIndent - -The lineIndent for "pommes de terre" is 0. - -The FittingPredicate for layoutSmart will continue to check the rest of the -document until it finds a line where the indentation <= minNestingLevel. -In this case this meant that layoutSmart would traverse all the items, -and note that the last item, Donaudampfschifffahrtskapitänskajütenmülleimer, -doesn't fit into the available space! The "flatter" version of the document -has failed, so "pommes de terre" gets spread over several lines! - -Obviously this would be an inconsistency with the layout of the other items. -Their lineIndent is 11 each, so for them, the FittingPredicate stops already -on the next line. - -The obvious solution is to change the definition of minNestingLevel: - - minNestingLevel = currentColumn - -This however breaks the "python-ish" document from the documentation for -layoutSmart: - - expected: |------------------------| - fun( - fun( - fun( - fun( - fun( - [ abcdef - , ghijklm ]))))) - |------------------------| - - but got: |------------------------| - fun( - fun( - fun( - fun( - fun([ abcdef - , ghijklm ]))))) - |------------------------| - -We now accept the worse layout because the problematic last line has -the same indentation as the current column of "[ abcdef", so we don't check it! - -The solution we went with in the end is a bit of a hack: - -We check whether the alternative, "high" layout is a (potentially less wide) -hanging layout, and in that case pick its indentation as the minNestingLevel. - -This way we achieve the optimal layout in both scenarios. - -See https://github.com/quchen/prettyprinter/issues/83 for the bug that lead -to the current solution. - - -Note [Detecting failure with Unbounded page width] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To understand why it is sufficient to check the first line of the -SimpleDocStream, trace how an SFail ends up there: - -1. We group a Doc containing a hard linebreak (hardline), producing a - (Union x y) where x contains Fail. - -2. In layoutWadlerLeijen.best, any Unions are handled recursively, rejecting any - alternatives that would result in SFail. - -So once a SimpleDocStream reaches selectNicer, any SFail in it must -appear before the first linebreak – any other SFail would have been -detected and rejected in a previous iteration. --} - - - --- | @(layoutCompact x)@ lays out the document @x@ without adding any --- indentation. Since no \'pretty\' printing is involved, this layouter is very --- fast. The resulting output contains fewer characters than a prettyprinted --- version and can be used for output that is read by other programs. --- --- >>> let doc = hang 4 (vsep ["lorem", "ipsum", hang 4 (vsep ["dolor", "sit"])]) --- >>> doc --- lorem --- ipsum --- dolor --- sit --- --- >>> let putDocCompact = renderIO System.IO.stdout . layoutCompact --- >>> putDocCompact doc --- lorem --- ipsum --- dolor --- sit -layoutCompact :: Doc ann -> SimpleDocStream ann -layoutCompact doc = scan 0 [doc] - where - scan _ [] = SEmpty - scan !col (d:ds) = case d of - Fail -> SFail - Empty -> scan col ds - Char c -> SChar c (scan (col+1) ds) - Text l t -> let !col' = col+l in SText l t (scan col' ds) - FlatAlt x _ -> scan col (x:ds) - Line -> SLine 0 (scan 0 ds) - Cat x y -> scan col (x:y:ds) - Nest _ x -> scan col (x:ds) - Union _ y -> scan col (y:ds) - Column f -> scan col (f col:ds) - WithPageWidth f -> scan col (f Unbounded : ds) - Nesting f -> scan col (f 0 : ds) - Annotated _ x -> scan col (x:ds) - --- | @('show' doc)@ prettyprints document @doc@ with 'defaultLayoutOptions', --- ignoring all annotations. -instance Show (Doc ann) where - showsPrec _ doc = renderShowS (layoutPretty defaultLayoutOptions doc) - --- | Render a 'SimpleDocStream' to a 'ShowS', useful to write 'Show' instances --- based on the prettyprinter. --- --- @ --- instance 'Show' MyType where --- 'showsPrec' _ = 'renderShowS' . 'layoutPretty' 'defaultLayoutOptions' . 'pretty' --- @ -renderShowS :: SimpleDocStream ann -> ShowS -renderShowS = \sds -> case sds of - SFail -> panicUncaughtFail - SEmpty -> id - SChar c x -> showChar c . renderShowS x - SText _l t x -> showString (T.unpack t) . renderShowS x - SLine i x -> showString ('\n' : replicate i ' ') . renderShowS x - SAnnPush _ x -> renderShowS x - SAnnPop x -> renderShowS x - - --- | A utility for producing indentation etc. --- --- >>> textSpaces 3 --- " " --- --- This produces much better Core than the equivalent --- --- > T.replicate n " " --- --- (See .) -textSpaces :: Int -> Text -textSpaces n = T.replicate n (T.singleton ' ') - - --- $setup --- --- (Definitions for the doctests) --- --- >>> :set -XOverloadedStrings --- >>> import Data.Text.Prettyprint.Doc.Render.Text --- >>> import Data.Text.Prettyprint.Doc.Symbols.Ascii --- >>> import Data.Text.Prettyprint.Doc.Util as Util --- >>> import Test.QuickCheck.Modifiers +-- | This module is part of the old @Data.Text.Prettyprint.Doc@ module hierarchy +-- which is being replaced by a shallower @Prettyprinter@ module hierarchy +-- offering the same API. +-- +-- This module will be deprecated and eventually removed. +-- +-- Use "Prettyprinter.Internal" instead. +module Data.Text.Prettyprint.Doc.Internal ( + module Prettyprinter.Internal +) where + +import Prettyprinter.Internal diff --git a/src/Data/Text/Prettyprint/Doc/Internal/Debug.hs b/src/Data/Text/Prettyprint/Doc/Internal/Debug.hs --- a/src/Data/Text/Prettyprint/Doc/Internal/Debug.hs +++ b/src/Data/Text/Prettyprint/Doc/Internal/Debug.hs @@ -1,95 +1,12 @@ --- | __Warning: internal module!__ This means that the API may change --- arbitrarily between versions without notice. Depending on this module may --- lead to unexpected breakages, so proceed with caution! --- --- This module provides debugging helpers for inspecting 'Doc's. --- --- Use the @pretty-simple@ package to get a nicer layout for 'show'n --- 'Diag's: --- --- > > Text.Pretty.Simple.pPrintNoColor . diag $ align (vcat ["foo", "bar"]) --- > Column --- > [ --- > ( 10 --- > , Nesting --- > [ --- > ( 10 --- > , Cat ( Text 3 "foo" ) --- > ( Cat ( FlatAlt Line Empty ) ( Text 3 "bar" ) ) --- > ) --- > ] --- > ) --- > ] - - -module Data.Text.Prettyprint.Doc.Internal.Debug where - -import Data.Text (Text) -import Data.Text.Prettyprint.Doc.Internal (PageWidth, Doc) -import qualified Data.Text.Prettyprint.Doc.Internal as Doc - --- | A variant of 'Doc' for debugging. --- --- Unlike in the 'Doc' type, the 'Column', 'WithPageWidth' and 'Nesting' --- constructors don't contain functions but are \"sampled\" to allow --- simple inspection with 'show'. -data Diag ann = - Fail - | Empty - | Char !Char - | Text !Int !Text - | Line - | FlatAlt (Diag ann) (Diag ann) - | Cat (Diag ann) (Diag ann) - | Nest !Int (Diag ann) - | Union (Diag ann) (Diag ann) - | Column [(Int, Diag ann)] - -- ^ 'Doc': @(Int -> Diag ann)@ - | WithPageWidth [(PageWidth, Diag ann)] - -- ^ 'Doc': @(PageWidth -> Diag ann)@ - | Nesting [(Int, Diag ann)] - -- ^ 'Doc': @(Int -> Diag ann)@ - | Annotated ann (Diag ann) - deriving Show - --- | Convert a 'Doc' to its diagnostic representation. --- --- The functions in the 'Column', 'WithPageWidth' and 'Nesting' constructors are --- sampled with some default values. +-- | This module is part of the old @Data.Text.Prettyprint.Doc@ module hierarchy +-- which is being replaced by a shallower @Prettyprinter@ module hierarchy +-- offering the same API. -- --- Use `diag'` to control the function inputs yourself. +-- This module will be deprecated and eventually removed. -- --- >>> diag $ Doc.align (Doc.vcat ["foo", "bar"]) --- Column [(10,Nesting [(10,Cat (Text 3 "foo") (Cat (FlatAlt Line Empty) (Text 3 "bar")))])] -diag :: Doc ann -> Diag ann -diag = diag' [10] [Doc.defaultPageWidth] [10] - -diag' - :: [Int] - -- ^ Cursor positions for the 'Column' constructor - -> [PageWidth] - -- ^ For 'WithPageWidth' - -> [Int] - -- ^ Nesting levels for 'Nesting' - -> Doc ann - -> Diag ann -diag' columns pageWidths nestings = go - where - go doc = case doc of - Doc.Fail -> Fail - Doc.Empty -> Empty - Doc.Char c -> Char c - Doc.Text l t -> Text l t - Doc.Line -> Line - Doc.FlatAlt a b -> FlatAlt (go a) (go b) - Doc.Cat a b -> Cat (go a) (go b) - Doc.Nest i d -> Nest i (go d) - Doc.Union a b -> Union (go a) (go b) - Doc.Column f -> Column (apply f columns) - Doc.WithPageWidth f -> WithPageWidth (apply f pageWidths) - Doc.Nesting f -> Nesting (apply f nestings) - Doc.Annotated ann d -> Annotated ann (go d) - - apply :: (a -> Doc ann) -> [a] -> [(a, Diag ann)] - apply f = map (\x -> (x, go (f x))) +-- Use "Prettyprinter.Internal.Debug" instead. +module Data.Text.Prettyprint.Doc.Internal.Debug ( + module Prettyprinter.Internal.Debug +) where +import Prettyprinter.Internal.Debug diff --git a/src/Data/Text/Prettyprint/Doc/Internal/Type.hs b/src/Data/Text/Prettyprint/Doc/Internal/Type.hs --- a/src/Data/Text/Prettyprint/Doc/Internal/Type.hs +++ b/src/Data/Text/Prettyprint/Doc/Internal/Type.hs @@ -1,14 +1,15 @@ -{-# OPTIONS_HADDOCK not-home #-} - --- | __Internal module with stability guarantees__ +-- | This module is part of the old @Data.Text.Prettyprint.Doc@ module hierarchy +-- which is being replaced by a shallower @Prettyprinter@ module hierarchy +-- offering the same API. -- --- 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. +-- This module will be deprecated and eventually removed. -- --- 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 +-- Use "Prettyprinter.Internal.Type" instead. +module Data.Text.Prettyprint.Doc.Internal.Type ( + module Prettyprinter.Internal.Type +) where -import Data.Text.Prettyprint.Doc.Internal +import Prettyprinter.Internal.Type + + + diff --git a/src/Data/Text/Prettyprint/Doc/Render/ShowS.hs b/src/Data/Text/Prettyprint/Doc/Render/ShowS.hs deleted file mode 100644 --- a/src/Data/Text/Prettyprint/Doc/Render/ShowS.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Data.Text.Prettyprint.Doc.Render.ShowS {-# DEPRECATED "Use Data.Text.Prettyprint.Doc.Render.String instead" #-} ( - renderShowS -) where - -import Data.Text.Prettyprint.Doc.Internal (renderShowS) diff --git a/src/Data/Text/Prettyprint/Doc/Render/String.hs b/src/Data/Text/Prettyprint/Doc/Render/String.hs --- a/src/Data/Text/Prettyprint/Doc/Render/String.hs +++ b/src/Data/Text/Prettyprint/Doc/Render/String.hs @@ -1,10 +1,12 @@ +-- | This module is part of the old @Data.Text.Prettyprint.Doc@ module hierarchy +-- which is being replaced by a shallower @Prettyprinter@ module hierarchy +-- offering the same API. +-- +-- This module will be deprecated and eventually removed. +-- +-- Use "Prettyprinter.Render.String" instead. module Data.Text.Prettyprint.Doc.Render.String ( - renderString, - renderShowS, + module Prettyprinter.Render.String ) where -import Data.Text.Prettyprint.Doc.Internal (SimpleDocStream, renderShowS) - --- | Render a 'SimpleDocStream' to a 'String'. -renderString :: SimpleDocStream ann -> String -renderString s = renderShowS s "" +import Prettyprinter.Render.String diff --git a/src/Data/Text/Prettyprint/Doc/Render/Text.hs b/src/Data/Text/Prettyprint/Doc/Render/Text.hs --- a/src/Data/Text/Prettyprint/Doc/Render/Text.hs +++ b/src/Data/Text/Prettyprint/Doc/Render/Text.hs @@ -1,129 +1,12 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -#include "version-compatibility-macros.h" - --- | Render an unannotated 'SimpleDocStream' as plain 'Text'. -module Data.Text.Prettyprint.Doc.Render.Text ( - -- * Conversion to plain 'Text' - renderLazy, renderStrict, - - -- * Render to a 'Handle' - renderIO, - - -- ** Convenience functions - putDoc, hPutDoc -) where - - - -import Data.Text (Text) -import qualified Data.Text.IO as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TLB -import System.IO - -import Data.Text.Prettyprint.Doc -import Data.Text.Prettyprint.Doc.Internal -import Data.Text.Prettyprint.Doc.Render.Util.Panic - -#if !(SEMIGROUP_IN_BASE) -import Data.Semigroup -#endif - -#if !(APPLICATIVE_MONAD) -import Control.Applicative -#endif - --- $setup --- --- (Definitions for the doctests) --- --- >>> :set -XOverloadedStrings --- >>> import qualified Data.Text.IO as T --- >>> import qualified Data.Text.Lazy.IO as TL - - - --- | @('renderLazy' sdoc)@ takes the output @sdoc@ from a rendering function --- and transforms it to lazy text. --- --- >>> let render = TL.putStrLn . renderLazy . layoutPretty defaultLayoutOptions --- >>> let doc = "lorem" <+> align (vsep ["ipsum dolor", parens "foo bar", "sit amet"]) --- >>> render doc --- lorem ipsum dolor --- (foo bar) --- sit amet -renderLazy :: SimpleDocStream ann -> TL.Text -renderLazy = TLB.toLazyText . go - where - go = \case - SFail -> panicUncaughtFail - SEmpty -> mempty - SChar c rest -> TLB.singleton c <> go rest - SText _l t rest -> TLB.fromText t <> go rest - SLine i rest -> TLB.singleton '\n' <> (TLB.fromText (textSpaces i) <> go rest) - SAnnPush _ann rest -> go rest - SAnnPop rest -> go rest - --- | @('renderStrict' sdoc)@ takes the output @sdoc@ from a rendering function --- and transforms it to strict text. -renderStrict :: SimpleDocStream ann -> Text -renderStrict = TL.toStrict . renderLazy - - - --- | @('renderIO' h sdoc)@ writes @sdoc@ to the file @h@. --- --- >>> renderIO System.IO.stdout (layoutPretty defaultLayoutOptions "hello\nworld") --- hello --- world --- --- This function is more efficient than @'T.hPutStr' h ('renderStrict' sdoc)@, --- since it writes to the handle directly, skipping the intermediate 'Text' --- representation. -renderIO :: Handle -> SimpleDocStream ann -> IO () -renderIO h = go - where - go :: SimpleDocStream ann -> IO () - go = \sds -> case sds of - SFail -> panicUncaughtFail - SEmpty -> pure () - SChar c rest -> do hPutChar h c - go rest - SText _ t rest -> do T.hPutStr h t - go rest - SLine n rest -> do hPutChar h '\n' - T.hPutStr h (textSpaces n) - go rest - SAnnPush _ann rest -> go rest - SAnnPop rest -> go rest - --- | @('putDoc' doc)@ prettyprints document @doc@ to standard output. Uses the --- 'defaultLayoutOptions'. +-- | This module is part of the old @Data.Text.Prettyprint.Doc@ module hierarchy +-- which is being replaced by a shallower @Prettyprinter@ module hierarchy +-- offering the same API. -- --- >>> putDoc ("hello" <+> "world") --- hello world +-- This module will be deprecated and eventually removed. -- --- @ --- 'putDoc' = 'hPutDoc' 'stdout' --- @ -putDoc :: Doc ann -> IO () -putDoc = hPutDoc stdout +-- Use "Prettyprinter.Render.Text" instead. +module Data.Text.Prettyprint.Doc.Render.Text ( + module Prettyprinter.Render.Text +) where --- | Like 'putDoc', but instead of using 'stdout', print to a user-provided --- handle, e.g. a file or a socket. Uses the 'defaultLayoutOptions'. --- --- @ --- main = 'withFile' filename (\h -> 'hPutDoc' h doc) --- where --- doc = 'vcat' ["vertical", "text"] --- filename = "someFile.txt" --- @ --- --- @ --- 'hPutDoc' h doc = 'renderIO' h ('layoutPretty' 'defaultLayoutOptions' doc) --- @ -hPutDoc :: Handle -> Doc ann -> IO () -hPutDoc h doc = renderIO h (layoutPretty defaultLayoutOptions doc) +import Prettyprinter.Render.Text diff --git a/src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs b/src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs --- a/src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs +++ b/src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs @@ -1,158 +1,14 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - -{-# OPTIONS_GHC -fno-warn-deprecations #-} - -#include "version-compatibility-macros.h" - --- | This module shows how to write a custom prettyprinter backend, based on --- directly converting a 'SimpleDocStream' to an output format using a stack --- machine. For a tree serialization approach, which may be more suitable for --- certain output formats, see --- "Data.Text.Prettyprint.Doc.Render.Tutorials.TreeRenderingTutorial". --- --- Rendering to ANSI terminal with colors is an important use case for stack --- machine based rendering. --- --- The module is written to be readable top-to-bottom in both Haddock and raw --- source form. -module Data.Text.Prettyprint.Doc.Render.Tutorials.StackMachineTutorial - {-# DEPRECATED "Writing your own stack machine is probably more efficient and customizable; also consider using »renderSimplyDecorated(A)« instead" #-} - where - -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.Internal -import Data.Text.Prettyprint.Doc.Render.Util.Panic -import Data.Text.Prettyprint.Doc.Render.Util.StackMachine - -#if !(APPLICATIVE_MONAD) -import Control.Applicative -#endif - --- * The type of available markup --- --- $standalone-text --- --- First, we define a set of valid annotations must be defined, with the goal of --- defining a @'Doc' 'SimpleHtml'@. We will later define how to convert this to --- the output format ('TL.Text'). - -data SimpleHtml = Bold | Italics | Color Color | Paragraph | Headline -data Color = Red | Green | Blue - --- ** Convenience definitions - -bold, italics, paragraph, headline :: Doc SimpleHtml -> Doc SimpleHtml -bold = annotate Bold -italics = annotate Italics -paragraph = annotate Paragraph -headline = annotate Headline - -color :: Color -> Doc SimpleHtml -> Doc SimpleHtml -color c = annotate (Color c) - --- * The rendering algorithm --- --- $standalone-text --- --- With the annotation definitions out of the way, we can now define a --- conversion function from 'SimpleDocStream' annotated with our 'SimpleHtml' to the --- final 'TL.Text' representation. --- --- There are two ways to render this; the simpler one is just using --- 'renderSimplyDecorated'. However, some output formats require more --- complicated functionality, so we explore this explicitly with a simple --- example below. An example for something more complicated is ANSI terminal --- rendering, where on popping we need to regenerate the previous style, --- requiring a pop (discard current style) followed by a peek (regenerate --- previous style). - --- | The 'StackMachine' type defines a stack machine suitable for many rendering --- needs. It has two auxiliary parameters: the type of the end result, and the --- type of the document’s annotations. --- --- Most 'StackMachine' creations will look like this definition: a recursive --- walk through the 'SimpleDocStream', pushing styles on the stack and popping --- them off again, and writing raw output. +-- | This module is part of the old @Data.Text.Prettyprint.Doc@ module hierarchy +-- which is being replaced by a shallower @Prettyprinter@ module hierarchy +-- offering the same API. -- --- The equivalent to this in the tree based rendering approach is --- 'Data.Text.Prettyprint.Doc.Render.Tutorials.TreeRenderingTutorial.renderTree'. -renderStackMachine :: SimpleDocStream SimpleHtml -> StackMachine TLB.Builder SimpleHtml () -renderStackMachine = \sds -> case sds of - SFail -> panicUncaughtFail - SEmpty -> pure () - SChar c x -> do - writeOutput (TLB.singleton c) - renderStackMachine x - SText _l t x -> do - writeOutput (TLB.fromText t) - renderStackMachine x - SLine i x -> do - writeOutput (TLB.singleton '\n') - writeOutput (TLB.fromText (textSpaces i)) - renderStackMachine x - SAnnPush s x -> do - pushStyle s - writeOutput (fst (htmlTag s)) - renderStackMachine x - SAnnPop x -> do - s <- unsafePopStyle - writeOutput (snd (htmlTag s)) - renderStackMachine x - --- | Convert a 'SimpleHtml' annotation to a pair of opening and closing tags. --- This is where the translation of style to raw output happens. -htmlTag :: SimpleHtml -> (TLB.Builder, TLB.Builder) -htmlTag = \sh -> case sh of - Bold -> ("", "") - Italics -> ("", "") - Color c -> (" hexCode c <> "\">", "") - Paragraph -> ("

", "

") - Headline -> ("

", "

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

Example document

---

This is a paragraph,

---

and this text is bold.

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

" <> x <> "

" - Headline -> \x -> "

" <> x <> "

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

Example document

---

This is a paragraph,

---

and this text is bold.

+import Prettyprinter.Render.Tutorials.TreeRenderingTutorial diff --git a/src/Data/Text/Prettyprint/Doc/Render/Util/Panic.hs b/src/Data/Text/Prettyprint/Doc/Render/Util/Panic.hs --- a/src/Data/Text/Prettyprint/Doc/Render/Util/Panic.hs +++ b/src/Data/Text/Prettyprint/Doc/Render/Util/Panic.hs @@ -1,38 +1,12 @@ +-- | This module is part of the old @Data.Text.Prettyprint.Doc@ module hierarchy +-- which is being replaced by a shallower @Prettyprinter@ module hierarchy +-- offering the same API. +-- +-- This module will be deprecated and eventually removed. +-- +-- Use "Prettyprinter.Render.Util.Panic" instead. module Data.Text.Prettyprint.Doc.Render.Util.Panic ( - panicUncaughtFail, - panicUnpairedPop, - panicSimpleDocTreeConversionFailed, - panicInputNotFullyConsumed, - panicPeekedEmpty, - panicPoppedEmpty, + module Prettyprinter.Render.Util.Panic ) where --- | Raise a hard 'error' if there is a 'Data.Text.Prettyprint.Doc.SFail' in a --- 'Data.Text.Prettyprint.Doc.SimpleDocStream'. -panicUncaughtFail :: void -panicUncaughtFail = error ("»SFail« must not appear in a rendered »SimpleDocStream«. This is a bug in the layout algorithm! " ++ report) - --- | Raise a hard 'error' when an annotation terminator is encountered in an --- unannotated region. -panicUnpairedPop :: void -panicUnpairedPop = error ("An unpaired style terminator was encountered. This is a bug in the layout algorithm! " ++ report) - --- | Raise a hard generic 'error' when the --- 'Data.Text.Prettyprint.Doc.SimpleDocStream' to --- 'Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree.SimpleDocTree' conversion fails. -panicSimpleDocTreeConversionFailed :: void -panicSimpleDocTreeConversionFailed = error ("Conversion from SimpleDocStream to SimpleDocTree failed! " ++ report) - --- | Raise a hard 'error' when the »to --- 'Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree.SimpleDocTree'« parser finishes --- without consuming the full input. -panicInputNotFullyConsumed :: void -panicInputNotFullyConsumed = error ("Conversion from SimpleDocStream to SimpleDocTree left unconsumed input! " ++ report) - -report :: String -report = "Please report this as a bug" - -panicPeekedEmpty, panicPoppedEmpty :: void -(panicPeekedEmpty, panicPoppedEmpty) = (mkErr "Peeked", mkErr "Popped") - where - mkErr x = error (x ++ " an empty style stack! Please report this as a bug.") +import Prettyprinter.Render.Util.Panic diff --git a/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs b/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs --- a/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs +++ b/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs @@ -1,278 +1,12 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -#include "version-compatibility-macros.h" - --- | Conversion of the linked-list-like 'SimpleDocStream' to a tree-like --- 'SimpleDocTree'. -module Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree ( - - -- * Type and conversion - SimpleDocTree(..), - treeForm, - - -- * Manipulating annotations - unAnnotateST, - reAnnotateST, - alterAnnotationsST, - - -- * Common use case shortcut definitions - renderSimplyDecorated, - renderSimplyDecoratedA, -) where - - - -import Control.Applicative -import Data.Text (Text) -import qualified Data.Text as T -import Data.Typeable (Typeable) -import GHC.Generics - -import Data.Text.Prettyprint.Doc -import Data.Text.Prettyprint.Doc.Internal -import Data.Text.Prettyprint.Doc.Render.Util.Panic - -import qualified Control.Monad.Fail as Fail - -#if !(MONOID_IN_PRELUDE) -import Data.Monoid (Monoid (..)) -#endif - -#if !(FOLDABLE_TRAVERSABLE_IN_PRELUDE) -import Data.Foldable (Foldable (..)) -import Data.Traversable (Traversable (..)) -#endif - --- $setup --- --- (Definitions for the doctests) --- --- >>> import Data.Text.Prettyprint.Doc hiding ((<>)) --- >>> import qualified Data.Text.IO as T - - - --- | Simplest possible tree-based renderer. --- --- For example, here is a document annotated with @()@, and the behaviour is to --- surround annotated regions with »>>>« and »<<<«: --- --- >>> let doc = "hello" <+> annotate () "world" <> "!" --- >>> let stdoc = treeForm (layoutPretty defaultLayoutOptions doc) --- >>> T.putStrLn (renderSimplyDecorated id (\() x -> ">>>" <> x <> "<<<") stdoc) --- hello >>>world<< (Text -> out) -- ^ Render plain 'Text' - -> (ann -> out -> out) -- ^ How to modify an element with an annotation - -> SimpleDocTree ann - -> out -renderSimplyDecorated text renderAnn = go - where - go = \sdt -> case sdt of - STEmpty -> mempty - STChar c -> text (T.singleton c) - STText _ t -> text t - STLine i -> text (T.singleton '\n') `mappend` text (textSpaces i) - STAnn ann rest -> renderAnn ann (go rest) - STConcat xs -> foldMap go xs -{-# INLINE renderSimplyDecorated #-} - --- | Version of 'renderSimplyDecoratedA' that allows for 'Applicative' effects. -renderSimplyDecoratedA - :: (Applicative f, Monoid out) - => (Text -> f out) -- ^ Render plain 'Text' - -> (ann -> f out -> f out) -- ^ How to modify an element with an annotation - -> SimpleDocTree ann - -> f out -renderSimplyDecoratedA text renderAnn = go - where - go = \sdt -> case sdt of - STEmpty -> pure mempty - STChar c -> text (T.singleton c) - STText _ t -> text t - STLine i -> text (T.cons '\n' (textSpaces i)) - STAnn ann rest -> renderAnn ann (go rest) - STConcat xs -> fmap mconcat (traverse go xs) -{-# INLINE renderSimplyDecoratedA #-} - - - --- | A type for parsers of unique results. Token stream »s«, results »a«. --- --- Hand-written to avoid a dependency on a parser lib. -newtype UniqueParser s a = UniqueParser { runParser :: s -> Maybe (a, s) } - deriving Typeable - -instance Functor (UniqueParser s) where - fmap f (UniqueParser mx) = UniqueParser (\s -> - fmap (\(x,s') -> (f x, s')) (mx s)) - -instance Applicative (UniqueParser s) where - pure x = UniqueParser (\rest -> Just (x, rest)) - UniqueParser mf <*> UniqueParser mx = UniqueParser (\s -> do - (f, s') <- mf s - (x, s'') <- mx s' - pure (f x, s'') ) - -instance Monad (UniqueParser s) where - UniqueParser p >>= f = UniqueParser (\s -> do - (a', s') <- p s - let UniqueParser p' = f a' - p' s' ) - -#if !(APPLICATIVE_MONAD) - return = pure -#endif -#if FAIL_IN_MONAD - fail = Fail.fail -#endif - -instance Fail.MonadFail (UniqueParser s) where - fail _err = empty - -instance Alternative (UniqueParser s) where - empty = UniqueParser (const empty) - UniqueParser p <|> UniqueParser q = UniqueParser (\s -> p s <|> q s) - -data SimpleDocTok ann - = TokEmpty - | TokChar Char - | TokText !Int Text - | TokLine Int - | TokAnnPush ann - | TokAnnPop - deriving (Eq, Ord, Show, Typeable) - --- | A 'SimpleDocStream' is a linked list of different annotated cons cells --- ('SText' and then some further 'SimpleDocStream', 'SLine' and then some --- further 'SimpleDocStream', …). This format is very suitable as a target for a --- layout engine, but not very useful for rendering to a structured format such --- as HTML, where we don’t want to do a lookahead until the end of some markup. --- These formats benefit from a tree-like structure that explicitly marks its --- contents as annotated. 'SimpleDocTree' is that format. -data SimpleDocTree ann - = STEmpty - | STChar Char - - -- | Some layout algorithms use the Since the frequently used 'T.length' of - -- the 'Text', which scales linearly with its length, we cache it in this - -- constructor. - | STText !Int Text - - -- | @Int@ = indentation level for the (next) line - | STLine !Int - - -- | Annotate the contained document. - | STAnn ann (SimpleDocTree ann) - - -- | Horizontal concatenation of multiple documents. - | STConcat [SimpleDocTree ann] - deriving (Eq, Ord, Show, Generic, Typeable) - --- | Alter the document’s annotations. --- --- This instance makes 'SimpleDocTree' more flexible (because it can be used in --- 'Functor'-polymorphic values), but @'fmap'@ is much less readable compared to --- using @'reAnnotateST'@ in code that only works for @'SimpleDocTree'@ anyway. --- Consider using the latter when the type does not matter. -instance Functor SimpleDocTree where - fmap = reAnnotateST - --- | Get the next token, consuming it in the process. -nextToken :: UniqueParser (SimpleDocStream ann) (SimpleDocTok ann) -nextToken = UniqueParser (\sds -> case sds of - SFail -> panicUncaughtFail - SEmpty -> empty - SChar c rest -> Just (TokChar c , rest) - SText l t rest -> Just (TokText l t , rest) - SLine i rest -> Just (TokLine i , rest) - SAnnPush ann rest -> Just (TokAnnPush ann , rest) - SAnnPop rest -> Just (TokAnnPop , rest) ) - -sdocToTreeParser :: UniqueParser (SimpleDocStream ann) (SimpleDocTree ann) -sdocToTreeParser = fmap wrap (many contentPiece) - - where - - wrap :: [SimpleDocTree ann] -> SimpleDocTree ann - wrap = \sdts -> case sdts of - [] -> STEmpty - [x] -> x - xs -> STConcat xs - - contentPiece = nextToken >>= \tok -> case tok of - TokEmpty -> pure STEmpty - TokChar c -> pure (STChar c) - TokText l t -> pure (STText l t) - TokLine i -> pure (STLine i) - TokAnnPop -> empty - TokAnnPush ann -> do annotatedContents <- sdocToTreeParser - TokAnnPop <- nextToken - pure (STAnn ann annotatedContents) - --- | Convert a 'SimpleDocStream' to its 'SimpleDocTree' representation. -treeForm :: SimpleDocStream ann -> SimpleDocTree ann -treeForm sdoc = case runParser sdocToTreeParser sdoc of - Nothing -> panicSimpleDocTreeConversionFailed - Just (sdoct, SEmpty) -> sdoct - Just (_, _unconsumed) -> panicInputNotFullyConsumed - --- $ +-- | This module is part of the old @Data.Text.Prettyprint.Doc@ module hierarchy +-- which is being replaced by a shallower @Prettyprinter@ module hierarchy +-- offering the same API. -- --- >>> :set -XOverloadedStrings --- >>> treeForm (layoutPretty defaultLayoutOptions ("lorem" <+> "ipsum" <+> annotate True ("TRUE" <+> annotate False "FALSE") <+> "dolor")) --- STConcat [STText 5 "lorem",STChar ' ',STText 5 "ipsum",STChar ' ',STAnn True (STConcat [STText 4 "TRUE",STChar ' ',STAnn False (STText 5 "FALSE")]),STChar ' ',STText 5 "dolor"] - --- | Remove all annotations. 'unAnnotate' for 'SimpleDocTree'. -unAnnotateST :: SimpleDocTree ann -> SimpleDocTree xxx -unAnnotateST = alterAnnotationsST (const []) - --- | Change the annotation of a document. 'reAnnotate' for 'SimpleDocTree'. -reAnnotateST :: (ann -> ann') -> SimpleDocTree ann -> SimpleDocTree ann' -reAnnotateST f = alterAnnotationsST (pure . f) - --- | Change the annotation of a document to a different annotation, or none at --- all. 'alterAnnotations' for 'SimpleDocTree'. +-- This module will be deprecated and eventually removed. -- --- Note that this is as powerful as 'alterAnnotations', allowing one annotation --- to become multiple ones, contrary to 'alterAnnotationsS', which cannot do --- this. -alterAnnotationsST :: (ann -> [ann']) -> SimpleDocTree ann -> SimpleDocTree ann' -alterAnnotationsST re = go - where - go = \sdt -> case sdt of - STEmpty -> STEmpty - STChar c -> STChar c - STText l t -> STText l t - STLine i -> STLine i - STConcat xs -> STConcat (map go xs) - STAnn ann rest -> Prelude.foldr STAnn (go rest) (re ann) - --- | Collect all annotations from a document. -instance Foldable SimpleDocTree where - foldMap f = go - where - go = \sdt -> case sdt of - STEmpty -> mempty - STChar _ -> mempty - STText _ _ -> mempty - STLine _ -> mempty - STAnn ann rest -> f ann `mappend` go rest - STConcat xs -> mconcat (map go xs) +-- Use "Prettyprinter.Render.Util.SimpleDocTree" instead. +module Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree ( + module Prettyprinter.Render.Util.SimpleDocTree +) where --- | Transform a document based on its annotations, possibly leveraging --- 'Applicative' effects. -instance Traversable SimpleDocTree where - traverse f = go - where - go = \sdt -> case sdt of - STEmpty -> pure STEmpty - STChar c -> pure (STChar c) - STText l t -> pure (STText l t) - STLine i -> pure (STLine i) - STAnn ann rest -> STAnn <$> f ann <*> go rest - STConcat xs -> STConcat <$> traverse go xs +import Prettyprinter.Render.Util.SimpleDocTree diff --git a/src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs b/src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs --- a/src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs +++ b/src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs @@ -1,168 +1,15 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} - -#include "version-compatibility-macros.h" - --- | Definitions to write renderers based on looking at a 'SimpleDocStream' as --- an instruction tape for a stack machine: text is written, annotations are --- added (pushed) and later removed (popped). -module Data.Text.Prettyprint.Doc.Render.Util.StackMachine ( - - -- * Simple, pre-defined stack machines - -- - -- | These cover most basic use cases where there is not too much special - -- logic, and all that’s important is how to render text, and how to - -- add/remove an annotation. - renderSimplyDecorated, - renderSimplyDecoratedA, - - -- * General stack machine - -- - -- | These definitions allow defining a full-blown stack machine renderer, - -- allowing for arbitrary peeking, popping and what not. - StackMachine, - execStackMachine, - - pushStyle, - unsafePopStyle, - unsafePeekStyle, - writeOutput, -) where - - - -import Control.Applicative -import Data.Text (Text) -import qualified Data.Text as T - -import Data.Text.Prettyprint.Doc.Internal -import Data.Text.Prettyprint.Doc.Render.Util.Panic - -#if !(SEMIGROUP_MONOID_SUPERCLASS) -import Data.Monoid -#endif - - --- $setup --- --- (Definitions for the doctests) --- --- >>> import Data.Text.Prettyprint.Doc hiding ((<>)) --- >>> import qualified Data.Text.IO as T - - - --- | Simplest possible stack-based renderer. --- --- For example, here is a document annotated with @()@, and the behaviour is to --- write »>>>« at the beginning, and »<<<« at the end of the annotated region: +-- | This module is part of the old @Data.Text.Prettyprint.Doc@ module hierarchy +-- which is being replaced by a shallower @Prettyprinter@ module hierarchy +-- offering the same API. -- --- >>> let doc = "hello" <+> annotate () "world" <> "!" --- >>> let sdoc = layoutPretty defaultLayoutOptions doc --- >>> T.putStrLn (renderSimplyDecorated id (\() -> ">>>") (\() -> "<<<") sdoc) --- hello >>>world<< (Text -> out) -- ^ Render plain 'Text' - -> (ann -> out) -- ^ How to render an annotation - -> (ann -> out) -- ^ How to render the removed annotation - -> SimpleDocStream ann - -> out -renderSimplyDecorated text push pop = go [] - where - go _ SFail = panicUncaughtFail - go [] SEmpty = mempty - go (_:_) SEmpty = panicInputNotFullyConsumed - go stack (SChar c rest) = text (T.singleton c) <> go stack rest - go stack (SText _l t rest) = text t <> go stack rest - go stack (SLine i rest) = text (T.singleton '\n') <> text (textSpaces i) <> go stack rest - go stack (SAnnPush ann rest) = push ann <> go (ann : stack) rest - go (ann:stack) (SAnnPop rest) = pop ann <> go stack rest - go [] SAnnPop{} = panicUnpairedPop -{-# INLINE renderSimplyDecorated #-} - --- | Version of 'renderSimplyDecoratedA' that allows for 'Applicative' effects. -renderSimplyDecoratedA - :: (Applicative f, Monoid out) - => (Text -> f out) -- ^ Render plain 'Text' - -> (ann -> f out) -- ^ How to render an annotation - -> (ann -> f out) -- ^ How to render the removed annotation - -> SimpleDocStream ann - -> f out -renderSimplyDecoratedA text push pop = go [] - where - go _ SFail = panicUncaughtFail - go [] SEmpty = pure mempty - go (_:_) SEmpty = panicInputNotFullyConsumed - go stack (SChar c rest) = text (T.singleton c) <++> go stack rest - go stack (SText _l t rest) = text t <++> go stack rest - go stack (SLine i rest) = text (T.singleton '\n') <++> text (textSpaces i) <++> go stack rest - go stack (SAnnPush ann rest) = push ann <++> go (ann : stack) rest - go (ann:stack) (SAnnPop rest) = pop ann <++> go stack rest - go [] SAnnPop{} = panicUnpairedPop +-- Use "Prettyprinter.Render.Util.StackMachine" instead. +module Data.Text.Prettyprint.Doc.Render.Util.StackMachine ( + module Prettyprinter.Render.Util.StackMachine +) where - (<++>) = liftA2 mappend -{-# INLINE renderSimplyDecoratedA #-} +import Prettyprinter.Render.Util.StackMachine --- | @WriterT output StateT [style] a@, but with a strict Writer value. --- --- The @output@ type is used to append data chunks to, the @style@ is the member --- of a stack of styles to model nested styles with. -newtype StackMachine output style a = StackMachine ([style] -> (a, output, [style])) -{-# DEPRECATED StackMachine "Writing your own stack machine is probably more efficient and customizable; also consider using »renderSimplyDecorated(A)« instead" #-} - -instance Functor (StackMachine output style) where - fmap f (StackMachine r) = StackMachine (\s -> - let (x1, w1, s1) = r s - in (f x1, w1, s1)) - -instance Monoid output => Applicative (StackMachine output style) where - pure x = StackMachine (\s -> (x, mempty, s)) - StackMachine f <*> StackMachine x = StackMachine (\s -> - let (f1, w1, s1) = f s - (x2, w2, s2) = x s1 - !w12 = w1 <> w2 - in (f1 x2, w12, s2)) - -instance Monoid output => Monad (StackMachine output style) where -#if !(APPLICATIVE_MONAD) - return = pure -#endif - StackMachine r >>= f = StackMachine (\s -> - let (x1, w1, s1) = r s - StackMachine r1 = f x1 - (x2, w2, s2) = r1 s1 - !w12 = w1 <> w2 - in (x2, w12, s2)) - --- | Add a new style to the style stack. -pushStyle :: Monoid output => style -> StackMachine output style () -pushStyle style = StackMachine (\styles -> ((), mempty, style : styles)) - --- | Get the topmost style. --- --- If the stack is empty, this raises an 'error'. -unsafePopStyle :: Monoid output => StackMachine output style style -unsafePopStyle = StackMachine (\stack -> case stack of - x:xs -> (x, mempty, xs) - [] -> panicPoppedEmpty ) - --- | View the topmost style, but do not modify the stack. --- --- If the stack is empty, this raises an 'error'. -unsafePeekStyle :: Monoid output => StackMachine output style style -unsafePeekStyle = StackMachine (\styles -> case styles of - x:_ -> (x, mempty, styles) - [] -> panicPeekedEmpty ) - --- | Append a value to the output end. -writeOutput :: output -> StackMachine output style () -writeOutput w = StackMachine (\styles -> ((), w, styles)) - --- | Run the renderer and retrive the writing end -execStackMachine :: [styles] -> StackMachine output styles a -> (output, [styles]) -execStackMachine styles (StackMachine r) = let (_, w, s) = r styles in (w, s) diff --git a/src/Data/Text/Prettyprint/Doc/Symbols/Ascii.hs b/src/Data/Text/Prettyprint/Doc/Symbols/Ascii.hs --- a/src/Data/Text/Prettyprint/Doc/Symbols/Ascii.hs +++ b/src/Data/Text/Prettyprint/Doc/Symbols/Ascii.hs @@ -1,154 +1,12 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - -#include "version-compatibility-macros.h" - --- | Common symbols composed out of the ASCII subset of Unicode. For non-ASCII --- symbols, see "Data.Text.Prettyprint.Doc.Symbols.Unicode". -module Data.Text.Prettyprint.Doc.Symbols.Ascii where - - - -import Data.Text.Prettyprint.Doc.Internal - - - --- | >>> squotes "·" --- '·' -squotes :: Doc ann -> Doc ann -squotes = enclose squote squote - --- | >>> dquotes "·" --- "·" -dquotes :: Doc ann -> Doc ann -dquotes = enclose dquote dquote - --- | >>> parens "·" --- (·) -parens :: Doc ann -> Doc ann -parens = enclose lparen rparen - --- | >>> angles "·" --- <·> -angles :: Doc ann -> Doc ann -angles = enclose langle rangle - --- | >>> brackets "·" --- [·] -brackets :: Doc ann -> Doc ann -brackets = enclose lbracket rbracket - --- | >>> braces "·" --- {·} -braces :: Doc ann -> Doc ann -braces = enclose lbrace rbrace - --- | >>> squote --- ' -squote :: Doc ann -squote = Char '\'' - --- | >>> dquote --- " -dquote :: Doc ann -dquote = Char '"' - --- | >>> lparen --- ( -lparen :: Doc ann -lparen = Char '(' - --- | >>> rparen --- ) -rparen :: Doc ann -rparen = Char ')' - --- | >>> langle --- < -langle :: Doc ann -langle = Char '<' - --- | >>> rangle --- > -rangle :: Doc ann -rangle = Char '>' - --- | >>> lbracket --- [ -lbracket :: Doc ann -lbracket = Char '[' --- | >>> rbracket --- ] -rbracket :: Doc ann -rbracket = Char ']' - --- | >>> lbrace --- { -lbrace :: Doc ann -lbrace = Char '{' --- | >>> rbrace --- } -rbrace :: Doc ann -rbrace = Char '}' - --- | >>> semi --- ; -semi :: Doc ann -semi = Char ';' - --- | >>> colon --- : -colon :: Doc ann -colon = Char ':' - --- | >>> comma --- , -comma :: Doc ann -comma = Char ',' - --- | >>> "a" <> space <> "b" --- a b +-- | This module is part of the old @Data.Text.Prettyprint.Doc@ module hierarchy +-- which is being replaced by a shallower @Prettyprinter@ module hierarchy +-- offering the same API. -- --- This is mostly used via @'<+>'@, +-- This module will be deprecated and eventually removed. -- --- >>> "a" <+> "b" --- a b -space :: Doc ann -space = Char ' ' - --- | >>> dot --- . -dot :: Doc ann -dot = Char '.' - --- | >>> slash --- / -slash :: Doc ann -slash = Char '/' - --- | >>> backslash --- \\ - -backslash :: Doc ann -backslash = "\\" - --- | >>> equals --- = -equals :: Doc ann -equals = Char '=' - --- | >>> pipe --- | -pipe :: Doc ann -pipe = Char '|' - - +-- Use "Prettyprinter.Symbols.Ascii" instead. +module Data.Text.Prettyprint.Doc.Symbols.Ascii ( + module Prettyprinter.Symbols.Ascii +) where --- $setup --- --- (Definitions for the doctests) --- --- >>> :set -XOverloadedStrings --- >>> import Data.Semigroup --- >>> import Data.Text.Prettyprint.Doc.Render.Text --- >>> import Data.Text.Prettyprint.Doc.Util +import Prettyprinter.Symbols.Ascii diff --git a/src/Data/Text/Prettyprint/Doc/Symbols/Unicode.hs b/src/Data/Text/Prettyprint/Doc/Symbols/Unicode.hs --- a/src/Data/Text/Prettyprint/Doc/Symbols/Unicode.hs +++ b/src/Data/Text/Prettyprint/Doc/Symbols/Unicode.hs @@ -1,210 +1,12 @@ --- | A collection of predefined Unicode values outside of ASCII range. For --- ASCII, see "Data.Text.Prettyprint.Doc.Symbols.Ascii". -module Data.Text.Prettyprint.Doc.Symbols.Unicode ( - -- * Quotes - - -- ** Enclosing - d9966quotes, - d6699quotes, - s96quotes, - s69quotes, - dGuillemetsOut, - dGuillemetsIn, - sGuillemetsOut, - sGuillemetsIn, - - -- ** Standalone - b99dquote, - t66dquote, - t99dquote, - b9quote, - t6quote, - t9quote, - - rdGuillemet, - ldGuillemet, - rsGuillemet, - lsGuillemet, - - -- * Various typographical symbols - bullet, - endash, - - -- * Currencies - euro, - cent, - yen, - pound, -) where - - - -import Data.Text.Prettyprint.Doc.Internal - - - --- | Double „99-66“ quotes, as used in German typography. --- --- >>> putDoc (d9966quotes "·") --- „·“ -d9966quotes :: Doc ann -> Doc ann -d9966quotes = enclose b99dquote t66dquote - --- | Double “66-99” quotes, as used in English typography. --- --- >>> putDoc (d6699quotes "·") --- “·” -d6699quotes :: Doc ann -> Doc ann -d6699quotes = enclose t66dquote t99dquote - --- | Single ‚9-6‘ quotes, as used in German typography. --- --- >>> putDoc (s96quotes "·") --- ‚·‘ -s96quotes :: Doc ann -> Doc ann -s96quotes = enclose b9quote t6quote - --- | Single ‘6-9’ quotes, as used in English typography. --- --- >>> putDoc (s69quotes "·") --- ‘·’ -s69quotes :: Doc ann -> Doc ann -s69quotes = enclose t6quote t9quote - --- | Double «guillemets», pointing outwards (without adding any spacing). --- --- >>> putDoc (dGuillemetsOut "·") --- «·» -dGuillemetsOut :: Doc ann -> Doc ann -dGuillemetsOut = enclose ldGuillemet rdGuillemet - --- | Double »guillemets«, pointing inwards (without adding any spacing). --- --- >>> putDoc (dGuillemetsIn "·") --- »·« -dGuillemetsIn :: Doc ann -> Doc ann -dGuillemetsIn = enclose rdGuillemet ldGuillemet - --- | Single ‹guillemets›, pointing outwards (without adding any spacing). --- --- >>> putDoc (sGuillemetsOut "·") --- ‹·› -sGuillemetsOut :: Doc ann -> Doc ann -sGuillemetsOut = enclose lsGuillemet rsGuillemet - --- | Single ›guillemets‹, pointing inwards (without adding any spacing). --- --- >>> putDoc (sGuillemetsIn "·") --- ›·‹ -sGuillemetsIn :: Doc ann -> Doc ann -sGuillemetsIn = enclose rsGuillemet lsGuillemet - --- | Bottom „99“ style double quotes. --- --- >>> putDoc b99dquote --- „ -b99dquote :: Doc ann -b99dquote = Char '„' - --- | Top “66” style double quotes. --- --- >>> putDoc t66dquote --- “ -t66dquote :: Doc ann -t66dquote = Char '“' - --- | Top “99” style double quotes. --- --- >>> putDoc t99dquote --- ” -t99dquote :: Doc ann -t99dquote = Char '”' - --- | Bottom ‚9‘ style single quote. --- --- >>> putDoc b9quote --- ‚ -b9quote :: Doc ann -b9quote = Char '‚' - --- | Top ‘66’ style single quote. --- --- >>> putDoc t6quote --- ‘ -t6quote :: Doc ann -t6quote = Char '‘' - --- | Top ‘9’ style single quote. --- --- >>> putDoc t9quote --- ’ -t9quote :: Doc ann -t9quote = Char '’' - --- | Right-pointing double guillemets --- --- >>> putDoc rdGuillemet --- » -rdGuillemet :: Doc ann -rdGuillemet = Char '»' - --- | Left-pointing double guillemets --- --- >>> putDoc ldGuillemet --- « -ldGuillemet :: Doc ann -ldGuillemet = Char '«' - --- | Right-pointing single guillemets +-- | This module is part of the old @Data.Text.Prettyprint.Doc@ module hierarchy +-- which is being replaced by a shallower @Prettyprinter@ module hierarchy +-- offering the same API. -- --- >>> putDoc rsGuillemet --- › -rsGuillemet :: Doc ann -rsGuillemet = Char '›' - --- | Left-pointing single guillemets +-- This module will be deprecated and eventually removed. -- --- >>> putDoc lsGuillemet --- ‹ -lsGuillemet :: Doc ann -lsGuillemet = Char '‹' - --- | >>> putDoc bullet --- • -bullet :: Doc ann -bullet = Char '•' - --- | >>> putDoc endash --- – -endash :: Doc ann -endash = Char '–' - --- | >>> putDoc euro --- € -euro :: Doc ann -euro = Char '€' - --- | >>> putDoc cent --- ¢ -cent :: Doc ann -cent = Char '¢' - --- | >>> putDoc yen --- ¥ -yen :: Doc ann -yen = Char '¥' - --- | >>> putDoc pound --- £ -pound :: Doc ann -pound = Char '£' - - +-- Use "Prettyprinter.Symbols.Unicode" instead. +module Data.Text.Prettyprint.Doc.Symbols.Unicode ( + module Prettyprinter.Symbols.Unicode +) where --- $setup --- --- (Definitions for the doctests) --- --- >>> :set -XOverloadedStrings --- >>> import Data.Text.Prettyprint.Doc.Render.Text --- >>> import Data.Text.Prettyprint.Doc.Util +import Prettyprinter.Symbols.Unicode diff --git a/src/Data/Text/Prettyprint/Doc/Util.hs b/src/Data/Text/Prettyprint/Doc/Util.hs --- a/src/Data/Text/Prettyprint/Doc/Util.hs +++ b/src/Data/Text/Prettyprint/Doc/Util.hs @@ -1,65 +1,15 @@ --- | 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 - - - --- | 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. +-- | This module is part of the old @Data.Text.Prettyprint.Doc@ module hierarchy +-- which is being replaced by a shallower @Prettyprinter@ module hierarchy +-- offering the same API. -- --- >>> 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. +-- This module will be deprecated and eventually removed. -- --- @ --- 'reflow' = 'fillSep' . 'words' --- @ -reflow :: Text -> Doc ann -reflow = fillSep . words +-- Use "Prettyprinter.Util" instead. +module Data.Text.Prettyprint.Doc.Util ( + module Prettyprinter.Util +) where --- | Render a document with a certain width. Useful for quick-and-dirty testing --- of layout behaviour. Used heavily in the doctests of this package, for --- example. --- --- >>> let doc = reflow "Lorem ipsum dolor sit amet, consectetur adipisicing elit" --- >>> putDocW 20 doc --- Lorem ipsum dolor --- sit amet, --- consectetur --- adipisicing elit --- >>> putDocW 30 doc --- Lorem ipsum dolor sit amet, --- consectetur adipisicing elit -putDocW :: Int -> Doc ann -> IO () -putDocW w doc = renderIO System.IO.stdout (layoutPretty layoutOptions (unAnnotate doc)) - where - layoutOptions = LayoutOptions { layoutPageWidth = AvailablePerLine w 1 } +import Prettyprinter.Util --- $setup --- --- (Definitions for the doctests) --- --- >>> :set -XOverloadedStrings diff --git a/src/Prettyprinter.hs b/src/Prettyprinter.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE CPP #-} + +#include "version-compatibility-macros.h" + +-- | +-- Module : Prettyprinter +-- Copyright : Daan Leijen (c) 2000, http://www.cs.uu.nl/~daan +-- Max Bolingbroke (c) 2008, http://blog.omega-prime.co.uk +-- David Luposchainsky (c) 2016, http://github.com/quchen +-- License : BSD-style (see the file LICENSE.md) +-- Maintainer : David Luposchainsky +-- Stability : experimental +-- Portability : portable +-- +-- = Overview +-- +-- This module defines a prettyprinter to format text in a flexible and +-- convenient way. The idea is to combine a 'Doc'ument out of many small +-- components, then using a layouter to convert it to an easily renderable +-- 'SimpleDocStream', which can then be rendered to a variety of formats, for +-- example plain 'Text'. +-- +-- The documentation consists of several parts: +-- +-- 1. Just below is some general information about the library. +-- 2. The actual library with extensive documentation and examples +-- 3. Migration guide for users familiar with (ansi-)wl-pprint +-- +-- == Starting out +-- +-- As a reading list for starters, some of the most commonly used functions in +-- this module include '<>', 'hsep', '<+>', 'vsep', 'align', 'hang'. These cover +-- many use cases already, and many other functions are variations or +-- combinations of these. +-- +-- = Simple example +-- +-- Let’s prettyprint a simple Haskell type definition. First, intersperse @->@ +-- and add a leading @::@, +-- +-- >>> 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 @::@. +-- +-- The 'Prettyprinter.Util.putDocW' renderer used here is from +-- "Prettyprinter.Util". +-- +-- = General workflow +-- +-- @ +-- ╔══════════╗ +-- ║ ║ ╭────────────────────╮ +-- ║ ║ │ 'vsep', 'pretty', '<+>', │ +-- ║ ║ │ 'nest', 'align', … │ +-- ║ ║ ╰─────────┬──────────╯ +-- ║ ║ │ +-- ║ Create ║ │ +-- ║ ║ │ +-- ║ ║ ▽ +-- ║ ║ ╭───────────────────╮ +-- ║ ║ │ 'Doc' │ +-- ╠══════════╣ │ (rich document) │ +-- ║ ║ ╰─────────┬─────────╯ +-- ║ ║ │ +-- ║ ║ │ Layout algorithms +-- ║ Layout ║ │ e.g. 'layoutPretty' +-- ║ ║ ▽ +-- ║ ║ ╭───────────────────╮ +-- ║ ║ │ 'SimpleDocStream' │ +-- ╠══════════╣ │ (simple document) │ +-- ║ ║ ╰─────────┬─────────╯ +-- ║ ║ │ +-- ║ ║ ├─────────────────────────────╮ +-- ║ ║ │ │ 'Prettyprinter.Render.Util.SimpleDocTree.treeForm' +-- ║ ║ │ ▽ +-- ║ ║ │ ╭───────────────╮ +-- ║ ║ │ │ 'Prettyprinter.Render.Util.SimpleDocTree.SimpleDocTree' │ +-- ║ Render ║ │ ╰───────┬───────╯ +-- ║ ║ │ │ +-- ║ ║ ╭───────────────────┼─────────────────╮ ╭────────┴────────╮ +-- ║ ║ │ │ │ │ │ +-- ║ ║ ▽ ▽ ▽ ▽ ▽ +-- ║ ║ ╭───────────────╮ ╭───────────────╮ ╭───────────────╮ ╭───────────────╮ +-- ║ ║ │ ANSI terminal │ │ Plain 'Text' │ │ other/custom │ │ HTML │ +-- ║ ║ ╰───────────────╯ ╰───────────────╯ ╰───────────────╯ ╰───────────────╯ +-- ║ ║ +-- ╚══════════╝ +-- @ +-- +-- = How the layout works +-- +-- There are two key concepts to laying a document out: the available width, and +-- 'group'ing. +-- +-- == Available width +-- +-- The page has a certain maximum width, which the layouter tries to not exceed, +-- by inserting line breaks where possible. The functions given in this module +-- make it fairly straightforward to specify where, and under what +-- circumstances, such a line break may be inserted by the layouter, for example +-- via the 'sep' function. +-- +-- There is also the concept of /ribbon width/. The ribbon is the part of a line +-- that is printed, i.e. the line length without the leading indentation. The +-- layouters take a ribbon fraction argument, which specifies how much of a line +-- should be filled before trying to break it up. A ribbon width of 0.5 in a +-- document of width 80 will result in the layouter to try to not exceed @0.5*80 = +-- 40@ (ignoring current indentation depth). +-- +-- == Grouping +-- +-- A document can be 'group'ed, which tells the layouter that it should attempt +-- to collapse it to a single line. If the result does not fit within the +-- constraints (given by page and ribbon widths), the document is rendered +-- unaltered. This allows fallback definitions, so that we get nice results even +-- when the original document would exceed the layout constraints. +-- +-- = Things the prettyprinter /cannot/ do +-- +-- Due to how the Wadler/Leijen algorithm is designed, a couple of things are +-- unsupported right now, with a high possibility of having no sensible +-- implementation without significantly changing the layout algorithm. In +-- particular, this includes +-- +-- * Leading symbols instead of just spaces for indentation, as used by the +-- Linux @tree@ tool for example +-- * Multi-column layouts, in particular tables with multiple cells of equal +-- width adjacent to each other +-- +-- = Some helpful tips +-- +-- == Which kind of annotation should I use? +-- +-- __Summary:__ Use semantic annotations for @'Doc'@, and after layouting map to +-- backend-specific ones. +-- +-- For example, suppose you want to prettyprint some programming language code. +-- If you want keywords to be red, you should annotate the @'Doc'@ with a type +-- that has a 'Keyword' field (without any notion of color), and then after +-- layouting convert the annotations to map @'Keyword'@ to e.g. @'Red'@ (using +-- @'reAnnotateS'@). The alternative that I /do not/ recommend is directly +-- annotating the @'Doc'@ with 'Red'. +-- +-- While both versions would superficially work equally well and would create +-- identical output, the recommended way has two significant advantages: +-- modularity and extensibility. +-- +-- /Modularity:/ To change the color of keywords later, you have to touch one +-- point, namely the mapping in @'reAnnotateS'@, where @'Keyword'@ is mapped to +-- 'Red'. If you have @'annotate Red …'@ everywher, you’ll have to do a full +-- text replacement, producing a large diff and touching lots of places for a +-- very small change. +-- +-- /Extensibility:/ Adding a different backend in the recommended version is +-- simply adding another @'reAnnotateS'@ to convert the @'Doc'@ annotation to +-- something else. On the other hand, if you have @'Red'@ as an annotation in +-- the @'Doc'@ already and the other backend does not support anything red +-- (think of plain text or a website where red doesn’t work well with the rest +-- of the style), you’ll have to worry about what to map »redness« to, which has +-- no canonical answer. Should it be omitted? What does »red« mean anyway – +-- maybe keywords and variables are red, and you want to change only the color +-- of variables? +module Prettyprinter ( + -- * Documents + Doc, + + -- * Basic functionality + Pretty(..), + viaShow, unsafeViaShow, + emptyDoc, nest, line, line', softline, softline', hardline, + + -- ** Primitives for alternative layouts + group, flatAlt, + + -- * Alignment functions + -- + -- | The functions in this section cannot be described by Wadler's original + -- functions. They align their output relative to the current output + -- position - in contrast to @'nest'@ which always aligns to the current + -- nesting level. This deprives these functions from being \'optimal\'. In + -- practice however they prove to be very useful. The functions in this + -- section should be used with care, since they are more expensive than the + -- other functions. For example, @'align'@ shouldn't be used to pretty print + -- all top-level declarations of a language, but using @'hang'@ for let + -- expressions is fine. + align, hang, indent, encloseSep, list, tupled, + + -- * Binary functions + (<>), (<+>), + + -- * List functions + + -- | The 'sep' and 'cat' functions differ in one detail: when 'group'ed, the + -- 'sep's replace newlines wich 'space's, while the 'cat's simply remove + -- them. If you're not sure what you want, start with the 'sep's. + + concatWith, + + -- ** 'sep' family + -- + -- | When 'group'ed, these will replace newlines with spaces. + hsep, vsep, fillSep, sep, + -- ** 'cat' family + -- + -- | When 'group'ed, these will remove newlines. + hcat, vcat, fillCat, cat, + -- ** Others + punctuate, + + -- * Reactive/conditional layouts + -- + -- | Lay documents out differently based on current position and the page + -- layout. + column, nesting, width, pageWidth, + + -- * Filler functions + -- + -- | Fill up available space + fill, fillBreak, + + -- * General convenience + -- + -- | Useful helper functions. + plural, enclose, surround, + + -- * Bracketing functions + -- + -- | Enclose documents in common ways. + squotes, dquotes, parens, angles, brackets, braces, + + -- * Named characters + -- + -- | Convenience definitions for common characters + lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket, squote, + dquote, semi, colon, comma, space, dot, slash, backslash, equals, pipe, + + -- ** Annotations + annotate, + unAnnotate, + reAnnotate, + alterAnnotations, + unAnnotateS, + reAnnotateS, + alterAnnotationsS, + + -- * Optimization + -- + -- Render documents faster + fuse, FusionDepth(..), + + -- * Layout + -- + -- | Laying a 'Doc'ument out produces a straightforward 'SimpleDocStream' + -- based on parameters such as page width and ribbon size, by evaluating how + -- a 'Doc' fits these constraints the best. There are various ways to render + -- a 'SimpleDocStream'. For the common case of rendering a 'SimpleDocStream' + -- as plain 'Text' take a look at "Prettyprinter.Render.Text". + SimpleDocStream(..), + PageWidth(..), LayoutOptions(..), defaultLayoutOptions, + layoutPretty, layoutCompact, layoutSmart, + removeTrailingWhitespace, + + -- * Migration guide + -- + -- $migration +) where + + + +#if !(SEMIGROUP_MONOID_SUPERCLASS) +import Data.Semigroup +#endif +import Prettyprinter.Internal +import Prettyprinter.Symbols.Ascii + +-- $setup +-- +-- (Definitions for the doctests) +-- +-- >>> :set -XOverloadedStrings +-- >>> import Prettyprinter.Render.Text +-- >>> import Prettyprinter.Util + + + +-- $migration +-- +-- There are 3 main ways to migrate: +-- +-- 1. Direct: just replace the previous package and fix the errors +-- 2. Using a drop-in replacement mimicing the API of the former module, see +-- the @prettyprinter-compat-@ packages +-- 3. Using a converter from the old @Doc@ type to the new one, see the +-- @prettyprinter-convert-@ packages +-- +-- If you're already familiar with (ansi-)wl-pprint, you'll recognize many +-- functions in this module, and they work just the same way. However, a couple +-- of definitions are missing: +-- +-- - @char@, @string@, @double@, … – these are all special cases of the +-- overloaded @'pretty'@ function. +-- - @\<$>@, @\<$$>@, @\@, @\@ are special cases of +-- @'vsep'@, @'vcat'@, @'fillSep'@, @'fillCat'@ with only two documents. +-- - If you need 'String' output, use the backends in the +-- "Prettyprinter.Render.String" module. +-- - The /display/ functions are moved to the rendering submodules, for +-- example conversion to plain 'Text' is in the +-- "Prettyprinter.Render.Text" module. +-- - The /render/ functions are called /layout/ functions. +-- - @SimpleDoc@ was renamed to @'SimpleDocStream'@, in order to make it +-- clearer in the presence of @SimpleDocTree@. +-- - Instead of providing an own colorization function for each +-- color\/intensity\/layer combination, they have been combined in 'color', +-- 'colorDull', 'bgColor', and 'bgColorDull' functions, which can be found +-- in the ANSI terminal specific @prettyprinter-ansi-terminal@ package. diff --git a/src/Prettyprinter/Internal.hs b/src/Prettyprinter/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter/Internal.hs @@ -0,0 +1,2236 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_HADDOCK not-home #-} + +#include "version-compatibility-macros.h" + +-- | __Warning: internal module!__ This means that the API may change +-- arbitrarily between versions without notice. Depending on this module may +-- lead to unexpected breakages, so proceed with caution! +-- +-- For a stable API, use the non-internal modules. For the special case of +-- writing adaptors to this library’s @'Doc'@ type, see +-- "Prettyprinter.Internal.Type". +module Prettyprinter.Internal ( + -- * Documents + Doc(..), + + -- * Basic functionality + Pretty(..), + viaShow, unsafeViaShow, unsafeTextWithoutNewlines, + emptyDoc, nest, line, line', softline, softline', hardline, + + -- ** Primitives for alternative layouts + group, flatAlt, + + -- * Alignment functions + align, hang, indent, encloseSep, list, tupled, + + -- * Binary functions + (<+>), + + -- * List functions + concatWith, + + -- ** 'sep' family + hsep, vsep, fillSep, sep, + -- ** 'cat' family + hcat, vcat, fillCat, cat, + -- ** Others + punctuate, + + -- * Reactive/conditional layouts + column, nesting, width, pageWidth, + + -- * Filler functions + fill, fillBreak, + + -- * General convenience + plural, enclose, surround, + + -- ** Annotations + annotate, + unAnnotate, + reAnnotate, + alterAnnotations, + unAnnotateS, + reAnnotateS, + alterAnnotationsS, + + -- * Optimization + fuse, FusionDepth(..), + + -- * Layout + SimpleDocStream(..), + PageWidth(..), defaultPageWidth, + LayoutOptions(..), defaultLayoutOptions, + layoutPretty, layoutCompact, layoutSmart, + removeTrailingWhitespace, + + -- * Rendering + renderShowS, + + -- * Internal helpers + textSpaces +) where + + + +import Control.Applicative +import Data.Int +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe +import Data.String (IsString (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as Lazy +import Data.Typeable (Typeable) +import Data.Void +import Data.Word +import GHC.Generics (Generic) + +-- Depending on the Cabal file, this might be from base, or for older builds, +-- from the semigroups package. +import Data.Semigroup + +#if NATURAL_IN_BASE +import Numeric.Natural +#endif + +#if !(FOLDABLE_TRAVERSABLE_IN_PRELUDE) +import Data.Foldable (Foldable (..)) +import Data.Traversable (Traversable (..)) +import Prelude hiding (foldr, foldr1) +#endif + +#if FUNCTOR_IDENTITY_IN_BASE +import Data.Functor.Identity +#endif + +import Prettyprinter.Render.Util.Panic + + + +-- | The abstract data type @'Doc' ann@ represents pretty documents that have +-- been annotated with data of type @ann@. +-- +-- More specifically, a value of type @'Doc'@ represents a non-empty set of +-- possible layouts of a document. The layout functions select one of these +-- possibilities, taking into account things like the width of the output +-- document. +-- +-- The annotation is an arbitrary piece of data associated with (part of) a +-- document. Annotations may be used by the rendering backends in order to +-- display output differently, such as +-- +-- - color information (e.g. when rendering to the terminal) +-- - mouseover text (e.g. when rendering to rich HTML) +-- - whether to show something or not (to allow simple or detailed versions) +-- +-- The simplest way to display a 'Doc' is via the 'Show' class. +-- +-- >>> putStrLn (show (vsep ["hello", "world"])) +-- hello +-- world +data Doc ann = + + -- | Occurs when flattening a line. The layouter will reject this document, + -- choosing a more suitable rendering. + Fail + + -- | The empty document; conceptually the unit of 'Cat' + | Empty + + -- | invariant: not '\n' + | Char !Char + + -- | Invariants: at least two characters long, does not contain '\n'. For + -- empty documents, there is @Empty@; for singleton documents, there is + -- @Char@; newlines should be replaced by e.g. @Line@. + -- + -- Since the frequently used 'T.length' of 'Text' is /O(length)/, we cache + -- it in this constructor. + | Text !Int !Text + + -- | Hard line break + | Line + + -- | Lay out the first 'Doc', but when flattened (via 'group'), prefer + -- the second. + -- + -- The layout algorithms work under the assumption that the first + -- alternative is less wide than the flattened second alternative. + | FlatAlt (Doc ann) (Doc ann) + + -- | Concatenation of two documents + | Cat (Doc ann) (Doc ann) + + -- | Document indented by a number of columns + | Nest !Int (Doc ann) + + -- | Invariant: The first lines of first document should be longer than the + -- first lines of the second one, so the layout algorithm can pick the one + -- that fits best. Used to implement layout alternatives for 'group'. + | Union (Doc ann) (Doc ann) + + -- | React on the current cursor position, see 'column' + | Column (Int -> Doc ann) + + -- | React on the document's width, see 'pageWidth' + | WithPageWidth (PageWidth -> Doc ann) + + -- | React on the current nesting level, see 'nesting' + | Nesting (Int -> Doc ann) + + -- | Add an annotation to the enclosed 'Doc'. Can be used for example to add + -- styling directives or alt texts that can then be used by the renderer. + | Annotated ann (Doc ann) + deriving (Generic, Typeable) + +-- | +-- @ +-- x '<>' y = 'hcat' [x, y] +-- @ +-- +-- >>> "hello" <> "world" :: Doc ann +-- helloworld +instance Semigroup (Doc ann) where + (<>) = Cat + sconcat (x :| xs) = hcat (x:xs) + stimes n x + | n <= 0 = Empty + | n == 1 = x + | otherwise = + let n' = fromIntegral n + nx = hcat (replicate n' x) + in case x of + Fail -> Fail + Empty -> Empty + Char c -> Text n' (T.replicate n' (T.singleton c)) + Text l t -> Text (n' * l) (T.replicate n' t) + Line -> nx + FlatAlt{} -> nx + Cat{} -> nx + Nest{} -> nx + Union{} -> nx + Column{} -> nx + WithPageWidth{} -> nx + Nesting{} -> nx + Annotated{} -> nx + +-- | +-- @ +-- 'mempty' = 'emptyDoc' +-- 'mconcat' = 'hcat' +-- @ +-- +-- >>> mappend "hello" "world" :: Doc ann +-- helloworld +instance Monoid (Doc ann) where + mempty = emptyDoc + mappend = (<>) + mconcat = hcat + +-- | >>> pretty ("hello\nworld") +-- hello +-- world +-- +-- This instance uses the 'Pretty' 'Text' instance, and uses the same newline to +-- 'line' conversion. +instance IsString (Doc ann) where + fromString = pretty . T.pack + +-- | Alter the document’s annotations. +-- +-- This instance makes 'Doc' more flexible (because it can be used in +-- 'Functor'-polymorphic values), but @'fmap'@ is much less readable compared to +-- using @'reAnnotate'@ in code that only works for @'Doc'@ anyway. Consider +-- using the latter when the type does not matter. +instance Functor Doc where + fmap = reAnnotate + +-- | Overloaded conversion to 'Doc'. +-- +-- Laws: +-- +-- 1. output should be pretty. :-) +class Pretty a where + + -- | >>> pretty 1 <+> pretty "hello" <+> pretty 1.234 + -- 1 hello 1.234 + pretty :: a -> Doc ann + + default pretty :: Show a => a -> Doc ann + pretty = viaShow + + -- | @'prettyList'@ is only used to define the @instance + -- 'Pretty' a => 'Pretty' [a]@. In normal circumstances only the @'pretty'@ + -- function is used. + -- + -- >>> prettyList [1, 23, 456] + -- [1, 23, 456] + prettyList :: [a] -> Doc ann + prettyList = align . list . map pretty + + {-# MINIMAL pretty #-} + +-- $ +-- Issue #67: Nested lists were not aligned with »pretty«, leading to non-pretty +-- output, violating the Pretty class law. +-- +-- >>> pretty (replicate 2 (replicate 4 (1, replicate 8 2))) +-- [ [ (1, [2, 2, 2, 2, 2, 2, 2, 2]) +-- , (1, [2, 2, 2, 2, 2, 2, 2, 2]) +-- , (1, [2, 2, 2, 2, 2, 2, 2, 2]) +-- , (1, [2, 2, 2, 2, 2, 2, 2, 2]) ] +-- , [ (1, [2, 2, 2, 2, 2, 2, 2, 2]) +-- , (1, [2, 2, 2, 2, 2, 2, 2, 2]) +-- , (1, [2, 2, 2, 2, 2, 2, 2, 2]) +-- , (1, [2, 2, 2, 2, 2, 2, 2, 2]) ] ] + +instance Pretty a => Pretty (Const a b) where + pretty = pretty . getConst + +#if FUNCTOR_IDENTITY_IN_BASE +-- | >>> pretty (Identity 1) +-- 1 +instance Pretty a => Pretty (Identity a) where + pretty = pretty . runIdentity +#endif + +-- | >>> pretty [1,2,3] +-- [1, 2, 3] +instance Pretty a => Pretty [a] where + pretty = prettyList + +instance Pretty a => Pretty (NonEmpty a) where + pretty (x:|xs) = prettyList (x:xs) + +-- | >>> pretty () +-- () +-- +-- The argument is not used, +-- +-- >>> pretty (error "Strict?" :: ()) +-- () +instance Pretty () where + pretty _ = "()" + +-- | >>> pretty True +-- True +instance Pretty Bool where + pretty True = "True" + pretty False = "False" + +-- | Instead of @('pretty' '\n')@, consider using @'line'@ as a more readable +-- alternative. +-- +-- >>> pretty 'f' <> pretty 'o' <> pretty 'o' +-- foo +-- >>> pretty ("string" :: String) +-- string +instance Pretty Char where + pretty '\n' = line + pretty c = Char c + + prettyList = pretty . (id :: Text -> Text) . fromString + +-- | Convenience function to convert a 'Show'able value to a 'Doc'. If the +-- 'String' does not contain newlines, consider using the more performant +-- 'unsafeViaShow'. +viaShow :: Show a => a -> Doc ann +viaShow = pretty . T.pack . show + +-- | Convenience function to convert a 'Show'able value /that must not contain +-- newlines/ to a 'Doc'. If there may be newlines, use 'viaShow' instead. +unsafeViaShow :: Show a => a -> Doc ann +unsafeViaShow = unsafeTextWithoutNewlines . T.pack . show + +-- | >>> pretty (123 :: Int) +-- 123 +instance Pretty Int where pretty = unsafeViaShow +instance Pretty Int8 where pretty = unsafeViaShow +instance Pretty Int16 where pretty = unsafeViaShow +instance Pretty Int32 where pretty = unsafeViaShow +instance Pretty Int64 where pretty = unsafeViaShow +instance Pretty Word where pretty = unsafeViaShow +instance Pretty Word8 where pretty = unsafeViaShow +instance Pretty Word16 where pretty = unsafeViaShow +instance Pretty Word32 where pretty = unsafeViaShow +instance Pretty Word64 where pretty = unsafeViaShow + +-- | >>> pretty (2^123 :: Integer) +-- 10633823966279326983230456482242756608 +instance Pretty Integer where pretty = unsafeViaShow + +#if NATURAL_IN_BASE +instance Pretty Natural where pretty = unsafeViaShow +#endif + +-- | >>> pretty (pi :: Float) +-- 3.1415927 +instance Pretty Float where pretty = unsafeViaShow + +-- | >>> pretty (exp 1 :: Double) +-- 2.71828182845904... +instance Pretty Double where pretty = unsafeViaShow + +-- | >>> pretty (123, "hello") +-- (123, hello) +instance (Pretty a1, Pretty a2) => Pretty (a1,a2) where + pretty (x1,x2) = tupled [pretty x1, pretty x2] + +-- | >>> pretty (123, "hello", False) +-- (123, hello, False) +instance (Pretty a1, Pretty a2, Pretty a3) => Pretty (a1,a2,a3) where + pretty (x1,x2,x3) = tupled [pretty x1, pretty x2, pretty x3] + +-- -- | >>> pretty (123, "hello", False, ()) +-- -- (123, hello, False, ()) +-- instance (Pretty a1, Pretty a2, Pretty a3, Pretty a4) => Pretty (a1,a2,a3,a4) where +-- pretty (x1,x2,x3,x4) = tupled [pretty x1, pretty x2, pretty x3, pretty x4] +-- +-- -- | >>> pretty (123, "hello", False, (), 3.14) +-- -- (123, hello, False, (), 3.14) +-- instance (Pretty a1, Pretty a2, Pretty a3, Pretty a4, Pretty a5) => Pretty (a1,a2,a3,a4,a5) where +-- pretty (x1,x2,x3,x4,x5) = tupled [pretty x1, pretty x2, pretty x3, pretty x4, pretty x5] +-- +-- -- | >>> pretty (123, "hello", False, (), 3.14, Just 2.71) +-- -- ( 123 +-- -- , hello +-- -- , False +-- -- , () +-- -- , 3.14 +-- -- , 2.71 ) +-- instance (Pretty a1, Pretty a2, Pretty a3, Pretty a4, Pretty a5, Pretty a6) => Pretty (a1,a2,a3,a4,a5,a6) where +-- pretty (x1,x2,x3,x4,x5,x6) = tupled [pretty x1, pretty x2, pretty x3, pretty x4, pretty x5, pretty x6] +-- +-- -- | >>> pretty (123, "hello", False, (), 3.14, Just 2.71, [1,2,3]) +-- -- ( 123 +-- -- , hello +-- -- , False +-- -- , () +-- -- , 3.14 +-- -- , 2.71 +-- -- , [1, 2, 3] ) +-- instance (Pretty a1, Pretty a2, Pretty a3, Pretty a4, Pretty a5, Pretty a6, Pretty a7) => Pretty (a1,a2,a3,a4,a5,a6,a7) where +-- pretty (x1,x2,x3,x4,x5,x6,x7) = tupled [pretty x1, pretty x2, pretty x3, pretty x4, pretty x5, pretty x6, pretty x7] + +-- | Ignore 'Nothing's, print 'Just' contents. +-- +-- >>> pretty (Just True) +-- True +-- >>> braces (pretty (Nothing :: Maybe Bool)) +-- {} +-- +-- >>> pretty [Just 1, Nothing, Just 3, Nothing] +-- [1, 3] +instance Pretty a => Pretty (Maybe a) where + pretty = maybe mempty pretty + prettyList = prettyList . catMaybes + +-- | Automatically converts all newlines to @'line'@. +-- +-- >>> pretty ("hello\nworld" :: Text) +-- hello +-- world +-- +-- Note that @'line'@ can be undone by @'group'@: +-- +-- >>> group (pretty ("hello\nworld" :: Text)) +-- hello world +-- +-- Manually use @'hardline'@ if you /definitely/ want newlines. +instance Pretty Text where pretty = vsep . map unsafeTextWithoutNewlines . T.splitOn "\n" + +-- | (lazy 'Text' instance, identical to the strict version) +instance Pretty Lazy.Text where pretty = pretty . Lazy.toStrict + +-- | Finding a good example for printing something that does not exist is hard, +-- so here is an example of printing a list full of nothing. +-- +-- >>> pretty ([] :: [Void]) +-- [] +instance Pretty Void where pretty = absurd + + + +-- | @(unsafeTextWithoutNewlines s)@ contains the literal string @s@. +-- +-- The string must not contain any newline characters, since this is an +-- invariant of the 'Text' constructor. +unsafeTextWithoutNewlines :: Text -> Doc ann +unsafeTextWithoutNewlines text = case T.uncons text of + Nothing -> Empty + Just (t,ext) + | T.null ext -> Char t + | otherwise -> Text (T.length text) text + +-- | The empty document behaves like @('pretty' "")@, so it has a height of 1. +-- This may lead to surprising behaviour if we expect it to bear no weight +-- inside e.g. 'vcat', where we get an empty line of output from it ('parens' +-- for visibility only): +-- +-- >>> vsep ["hello", parens emptyDoc, "world"] +-- hello +-- () +-- world +-- +-- Together with '<>', 'emptyDoc' forms the 'Monoid' 'Doc'. +emptyDoc :: Doc ann +emptyDoc = Empty + +-- | @('nest' i x)@ lays out the document @x@ with the current nesting level +-- (indentation of the following lines) increased by @i@. Negative values are +-- allowed, and decrease the nesting level accordingly. +-- +-- >>> vsep [nest 4 (vsep ["lorem", "ipsum", "dolor"]), "sit", "amet"] +-- lorem +-- ipsum +-- dolor +-- sit +-- amet +-- +-- See also +-- +-- * 'hang' ('nest' relative to current cursor position instead of +-- current nesting level) +-- * 'align' (set nesting level to current cursor position) +-- * 'indent' (increase indentation on the spot, padding with spaces). +nest + :: Int -- ^ Change of nesting level + -> Doc ann + -> Doc ann +nest 0 x = x -- Optimization +nest i x = Nest i x + +-- | The @'line'@ document advances to the next line and indents to the current +-- nesting level. +-- +-- >>> let doc = "lorem ipsum" <> line <> "dolor sit amet" +-- >>> doc +-- lorem ipsum +-- dolor sit amet +-- +-- @'line'@ behaves like @'space'@ if the line break is undone by 'group': +-- +-- >>> group doc +-- lorem ipsum dolor sit amet +line :: Doc ann +line = FlatAlt Line (Char ' ') + +-- | @'line''@ is like @'line'@, but behaves like @'mempty'@ if the line break +-- is undone by 'group' (instead of @'space'@). +-- +-- >>> let doc = "lorem ipsum" <> line' <> "dolor sit amet" +-- >>> doc +-- lorem ipsum +-- dolor sit amet +-- >>> group doc +-- lorem ipsumdolor sit amet +line' :: Doc ann +line' = FlatAlt Line mempty + +-- | @softline@ behaves like @'space'@ if the resulting output fits the page, +-- otherwise like @'line'@. +-- +-- Here, we have enough space to put everything in one line: +-- +-- >>> let doc = "lorem ipsum" <> softline <> "dolor sit amet" +-- >>> putDocW 80 doc +-- lorem ipsum dolor sit amet +-- +-- If we narrow the page to width 10, the layouter produces a line break: +-- +-- >>> putDocW 10 doc +-- lorem ipsum +-- dolor sit amet +-- +-- @ +-- 'softline' = 'group' 'line' +-- @ +softline :: Doc ann +softline = Union (Char ' ') Line + +-- | @'softline''@ is like @'softline'@, but behaves like @'mempty'@ if the +-- resulting output does not fit on the page (instead of @'space'@). In other +-- words, @'line'@ is to @'line''@ how @'softline'@ is to @'softline''@. +-- +-- With enough space, we get direct concatenation: +-- +-- >>> let doc = "ThisWord" <> softline' <> "IsWayTooLong" +-- >>> putDocW 80 doc +-- ThisWordIsWayTooLong +-- +-- If we narrow the page to width 10, the layouter produces a line break: +-- +-- >>> putDocW 10 doc +-- ThisWord +-- IsWayTooLong +-- +-- @ +-- 'softline'' = 'group' 'line'' +-- @ +softline' :: Doc ann +softline' = Union mempty Line + +-- | A @'hardline'@ is /always/ laid out as a line break, even when 'group'ed or +-- when there is plenty of space. Note that it might still be simply discarded +-- if it is part of a 'flatAlt' inside a 'group'. +-- +-- >>> let doc = "lorem ipsum" <> hardline <> "dolor sit amet" +-- >>> putDocW 1000 doc +-- lorem ipsum +-- dolor sit amet +-- +-- >>> group doc +-- lorem ipsum +-- dolor sit amet +hardline :: Doc ann +hardline = Line + +-- | @('group' x)@ tries laying out @x@ into a single line by removing the +-- contained line breaks; if this does not fit the page, or when a 'hardline' +-- within @x@ prevents it from being flattened, @x@ is laid out without any +-- changes. +-- +-- The 'group' function is key to layouts that adapt to available space nicely. +-- +-- See 'vcat', 'line', or 'flatAlt' for examples that are related, or make good +-- use of it. +group :: Doc ann -> Doc ann +-- See note [Group: special flattening] +group x = case x of + Union{} -> x + FlatAlt a b -> case changesUponFlattening b of + Flattened b' -> Union b' a + AlreadyFlat -> Union b a + NeverFlat -> a + _ -> case changesUponFlattening x of + Flattened x' -> Union x' x + AlreadyFlat -> x + NeverFlat -> x + +-- Note [Group: special flattening] +-- +-- Since certain documents do not change under removal of newlines etc, there is +-- no point in creating a 'Union' of the flattened and unflattened version – all +-- this does is introducing two branches for the layout algorithm to take, +-- resulting in potentially exponential behavior on deeply nested examples, such +-- as +-- +-- pathological n = iterate (\x -> hsep [x, sep []] ) "foobar" !! n +-- +-- See https://github.com/quchen/prettyprinter/issues/22 for the corresponding +-- ticket. + +data FlattenResult a + = Flattened a + -- ^ @a@ is likely flatter than the input. + | AlreadyFlat + -- ^ The input was already flat, e.g. a 'Text'. + | NeverFlat + -- ^ The input couldn't be flattened: It contained a 'Line' or 'Fail'. + +instance Functor FlattenResult where + fmap f (Flattened a) = Flattened (f a) + fmap _ AlreadyFlat = AlreadyFlat + fmap _ NeverFlat = NeverFlat + +-- | Choose the first element of each @Union@, and discard the first field of +-- all @FlatAlt@s. +-- +-- The result is 'Flattened' if the element might change depending on the layout +-- algorithm (i.e. contains differently renderable sub-documents), and 'AlreadyFlat' +-- if the document is static (e.g. contains only a plain 'Empty' node). +-- 'NeverFlat' is returned when the document cannot be flattened because it +-- contains a hard 'Line' or 'Fail'. +-- See [Group: special flattening] for further explanations. +changesUponFlattening :: Doc ann -> FlattenResult (Doc ann) +changesUponFlattening = \doc -> case doc of + FlatAlt _ y -> Flattened (flatten y) + Line -> NeverFlat + Union x _ -> Flattened x + Nest i x -> fmap (Nest i) (changesUponFlattening x) + Annotated ann x -> fmap (Annotated ann) (changesUponFlattening x) + + Column f -> Flattened (Column (flatten . f)) + Nesting f -> Flattened (Nesting (flatten . f)) + WithPageWidth f -> Flattened (WithPageWidth (flatten . f)) + + Cat x y -> case (changesUponFlattening x, changesUponFlattening y) of + (NeverFlat , _ ) -> NeverFlat + (_ , NeverFlat ) -> NeverFlat + (Flattened x' , Flattened y') -> Flattened (Cat x' y') + (Flattened x' , AlreadyFlat ) -> Flattened (Cat x' y) + (AlreadyFlat , Flattened y') -> Flattened (Cat x y') + (AlreadyFlat , AlreadyFlat ) -> AlreadyFlat + + Empty -> AlreadyFlat + Char{} -> AlreadyFlat + Text{} -> AlreadyFlat + Fail -> NeverFlat + where + -- Flatten, but don’t report whether anything changes. + flatten :: Doc ann -> Doc ann + flatten = \doc -> case doc of + FlatAlt _ y -> flatten y + Cat x y -> Cat (flatten x) (flatten y) + Nest i x -> Nest i (flatten x) + Line -> Fail + Union x _ -> flatten x + Column f -> Column (flatten . f) + WithPageWidth f -> WithPageWidth (flatten . f) + Nesting f -> Nesting (flatten . f) + Annotated ann x -> Annotated ann (flatten x) + + x@Fail -> x + x@Empty -> x + x@Char{} -> x + x@Text{} -> x + + + +-- | By default, @('flatAlt' x y)@ renders as @x@. However when 'group'ed, +-- @y@ will be preferred, with @x@ as the fallback for the case when @y@ +-- doesn't fit. +-- +-- >>> let doc = flatAlt "a" "b" +-- >>> putDoc doc +-- a +-- >>> putDoc (group doc) +-- b +-- >>> putDocW 0 (group doc) +-- a +-- +-- 'flatAlt' is particularly useful for defining conditional separators such as +-- +-- @ +-- softline = 'group' ('flatAlt' 'hardline' " ") +-- @ +-- +-- >>> let hello = "Hello" <> softline <> "world!" +-- >>> putDocW 12 hello +-- Hello world! +-- >>> putDocW 11 hello +-- Hello +-- world! +-- +-- === __Example: Haskell's do-notation__ +-- +-- We can use this to render Haskell's do-notation nicely: +-- +-- >>> let open = flatAlt "" "{ " +-- >>> let close = flatAlt "" " }" +-- >>> let separator = flatAlt "" "; " +-- >>> let prettyDo xs = group ("do" <+> align (encloseSep open close separator xs)) +-- >>> let statements = ["name:_ <- getArgs", "let greet = \"Hello, \" <> name", "putStrLn greet"] +-- +-- This is put into a single line with @{;}@ style if it fits, +-- +-- >>> putDocW 80 (prettyDo statements) +-- do { name:_ <- getArgs; let greet = "Hello, " <> name; putStrLn greet } +-- +-- When there is not enough space the statements are broken up into lines +-- nicely, +-- +-- >>> putDocW 10 (prettyDo statements) +-- do name:_ <- getArgs +-- let greet = "Hello, " <> name +-- putStrLn greet +-- +-- === Notes +-- +-- Users should be careful to choose @x@ to be less wide than @y@. +-- Otherwise, if @y@ turns out not to fit the page, we fall back on an even +-- wider layout: +-- +-- >>> let ugly = group (flatAlt "even wider" "too wide") +-- >>> putDocW 7 ugly +-- even wider +-- +-- Also note that 'group' will flatten @y@: +-- +-- >>> putDoc (group (flatAlt "x" ("y" <> line <> "y"))) +-- y y +-- +-- This also means that an "unflattenable" @y@ which contains a hard linebreak +-- will /never/ be rendered: +-- +-- >>> putDoc (group (flatAlt "x" ("y" <> hardline <> "y"))) +-- x +flatAlt + :: Doc ann -- ^ Default + -> Doc ann -- ^ Preferred when 'group'ed + -> Doc ann +flatAlt = FlatAlt + + + +-- | @('align' x)@ lays out the document @x@ with the nesting level set to the +-- current column. It is used for example to implement 'hang'. +-- +-- As an example, we will put a document right above another one, regardless of +-- the current nesting level. Without 'align'ment, the second line is put simply +-- below everything we've had so far, +-- +-- >>> "lorem" <+> vsep ["ipsum", "dolor"] +-- lorem ipsum +-- dolor +-- +-- If we add an 'align' to the mix, the @'vsep'@'s contents all start in the +-- same column, +-- +-- >>> "lorem" <+> align (vsep ["ipsum", "dolor"]) +-- lorem ipsum +-- dolor +align :: Doc ann -> Doc ann +align d = column (\k -> nesting (\i -> nest (k - i) d)) -- nesting might be negative! + +-- | @('hang' i x)@ lays out the document @x@ with a nesting level set to the +-- /current column/ plus @i@. Negative values are allowed, and decrease the +-- nesting level accordingly. +-- +-- >>> let doc = reflow "Indenting these words with hang" +-- >>> putDocW 24 ("prefix" <+> hang 4 doc) +-- prefix Indenting these +-- words with +-- hang +-- +-- This differs from 'nest', which is based on the /current nesting level/ plus +-- @i@. When you're not sure, try the more efficient 'nest' first. In our +-- example, this would yield +-- +-- >>> let doc = reflow "Indenting these words with nest" +-- >>> putDocW 24 ("prefix" <+> nest 4 doc) +-- prefix Indenting these +-- words with nest +-- +-- @ +-- 'hang' i doc = 'align' ('nest' i doc) +-- @ +hang + :: Int -- ^ Change of nesting level, relative to the start of the first line + -> Doc ann + -> Doc ann +hang i d = align (nest i d) + +-- | @('indent' i x)@ indents document @x@ by @i@ columns, starting from the +-- current cursor position. +-- +-- >>> let doc = reflow "The indent function indents these words!" +-- >>> putDocW 24 ("prefix" <> indent 4 doc) +-- prefix The indent +-- function +-- indents these +-- words! +-- +-- @ +-- 'indent' i d = 'hang' i ({i spaces} <> d) +-- @ +indent + :: Int -- ^ Number of spaces to increase indentation by + -> Doc ann + -> Doc ann +indent i d = hang i (spaces i <> d) + +-- | @('encloseSep' l r sep xs)@ concatenates the documents @xs@ separated by +-- @sep@, and encloses the resulting document by @l@ and @r@. +-- +-- The documents are laid out horizontally if that fits the page, +-- +-- >>> let doc = "list" <+> align (encloseSep lbracket rbracket comma (map pretty [1,20,300,4000])) +-- >>> putDocW 80 doc +-- list [1,20,300,4000] +-- +-- If there is not enough space, then the input is split into lines entry-wise +-- therwise they are laid out vertically, with separators put in the front: +-- +-- >>> putDocW 10 doc +-- list [1 +-- ,20 +-- ,300 +-- ,4000] +-- +-- Note that @doc@ contains an explicit call to 'align' so that the list items +-- are aligned vertically. +-- +-- For putting separators at the end of entries instead, have a look at +-- 'punctuate'. +encloseSep + :: Doc ann -- ^ left delimiter + -> Doc ann -- ^ right delimiter + -> Doc ann -- ^ separator + -> [Doc ann] -- ^ input documents + -> Doc ann +encloseSep l r s ds = case ds of + [] -> l <> r + [d] -> l <> d <> r + _ -> cat (zipWith (<>) (l : repeat s) ds) <> r + +-- | Haskell-inspired variant of 'encloseSep' with braces and comma as +-- separator. +-- +-- >>> let doc = list (map pretty [1,20,300,4000]) +-- +-- >>> putDocW 80 doc +-- [1, 20, 300, 4000] +-- +-- >>> putDocW 10 doc +-- [ 1 +-- , 20 +-- , 300 +-- , 4000 ] +list :: [Doc ann] -> Doc ann +list = group . encloseSep (flatAlt "[ " "[") + (flatAlt " ]" "]") + ", " + +-- | Haskell-inspired variant of 'encloseSep' with parentheses and comma as +-- separator. +-- +-- >>> let doc = tupled (map pretty [1,20,300,4000]) +-- +-- >>> putDocW 80 doc +-- (1, 20, 300, 4000) +-- +-- >>> putDocW 10 doc +-- ( 1 +-- , 20 +-- , 300 +-- , 4000 ) +tupled :: [Doc ann] -> Doc ann +tupled = group . encloseSep (flatAlt "( " "(") + (flatAlt " )" ")") + ", " + + + +-- | @(x '<+>' y)@ concatenates document @x@ and @y@ with a @'space'@ in +-- between. +-- +-- >>> "hello" <+> "world" +-- hello world +-- +-- @ +-- x '<+>' y = x '<>' 'space' '<>' y +-- @ +(<+>) :: Doc ann -> Doc ann -> Doc ann +x <+> y = x <> Char ' ' <> y +infixr 6 <+> -- like <> + + + +-- | Concatenate all documents element-wise with a binary function. +-- +-- @ +-- 'concatWith' _ [] = 'mempty' +-- 'concatWith' (**) [x,y,z] = x ** y ** z +-- @ +-- +-- Multiple convenience definitions based on 'concatWith' are alredy predefined, +-- for example +-- +-- @ +-- 'hsep' = 'concatWith' ('<+>') +-- 'fillSep' = 'concatWith' (\\x y -> x '<>' 'softline' '<>' y) +-- @ +-- +-- This is also useful to define customized joiners, +-- +-- >>> concatWith (surround dot) ["Prettyprinter", "Render", "Text"] +-- Prettyprinter.Render.Text +concatWith :: Foldable t => (Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann +concatWith f ds +#if !(FOLDABLE_TRAVERSABLE_IN_PRELUDE) + | foldr (\_ _ -> False) True ds = mempty +#else + | null ds = mempty +#endif + | otherwise = foldr1 f ds +{-# INLINE concatWith #-} +{-# SPECIALIZE concatWith :: (Doc ann -> Doc ann -> Doc ann) -> [Doc ann] -> Doc ann #-} + +-- | @('hsep' xs)@ concatenates all documents @xs@ horizontally with @'<+>'@, +-- i.e. it puts a space between all entries. +-- +-- >>> let docs = Util.words "lorem ipsum dolor sit amet" +-- +-- >>> hsep docs +-- lorem ipsum dolor sit amet +-- +-- @'hsep'@ does not introduce line breaks on its own, even when the page is too +-- narrow: +-- +-- >>> putDocW 5 (hsep docs) +-- lorem ipsum dolor sit amet +-- +-- For automatic line breaks, consider using 'fillSep' instead. +hsep :: [Doc ann] -> Doc ann +hsep = concatWith (<+>) + +-- | @('vsep' xs)@ concatenates all documents @xs@ above each other. If a +-- 'group' undoes the line breaks inserted by @vsep@, the documents are +-- separated with a 'space' instead. +-- +-- Using 'vsep' alone yields +-- +-- >>> "prefix" <+> vsep ["text", "to", "lay", "out"] +-- prefix text +-- to +-- lay +-- out +-- +-- 'group'ing a 'vsep' separates the documents with a 'space' if it fits the +-- page (and does nothing otherwise). See the @'sep'@ convenience function for +-- this use case. +-- +-- The 'align' function can be used to align the documents under their first +-- element: +-- +-- >>> "prefix" <+> align (vsep ["text", "to", "lay", "out"]) +-- prefix text +-- to +-- lay +-- out +-- +-- Since 'group'ing a 'vsep' is rather common, 'sep' is a built-in for doing +-- that. +vsep :: [Doc ann] -> Doc ann +vsep = concatWith (\x y -> x <> line <> y) + +-- | @('fillSep' xs)@ concatenates the documents @xs@ horizontally with @'<+>'@ +-- as long as it fits the page, then inserts a @'line'@ and continues doing that +-- for all documents in @xs@. (@'line'@ means that if 'group'ed, the documents +-- are separated with a 'space' instead of newlines. Use 'fillCat' if you do not +-- want a 'space'.) +-- +-- Let's print some words to fill the line: +-- +-- >>> let docs = take 20 (cycle ["lorem", "ipsum", "dolor", "sit", "amet"]) +-- >>> putDocW 80 ("Docs:" <+> fillSep docs) +-- Docs: lorem ipsum dolor sit amet lorem ipsum dolor sit amet lorem ipsum dolor +-- sit amet lorem ipsum dolor sit amet +-- +-- The same document, printed at a width of only 40, yields +-- +-- >>> putDocW 40 ("Docs:" <+> fillSep docs) +-- Docs: lorem ipsum dolor sit amet lorem +-- ipsum dolor sit amet lorem ipsum dolor +-- sit amet lorem ipsum dolor sit amet +fillSep :: [Doc ann] -> Doc ann +fillSep = concatWith (\x y -> x <> softline <> y) + +-- | @('sep' xs)@ tries laying out the documents @xs@ separated with 'space's, +-- and if this does not fit the page, separates them with newlines. This is what +-- differentiates it from 'vsep', which always lays out its contents beneath +-- each other. +-- +-- >>> let doc = "prefix" <+> sep ["text", "to", "lay", "out"] +-- >>> putDocW 80 doc +-- prefix text to lay out +-- +-- With a narrower layout, the entries are separated by newlines: +-- +-- >>> putDocW 20 doc +-- prefix text +-- to +-- lay +-- out +-- +-- @ +-- 'sep' = 'group' . 'vsep' +-- @ +sep :: [Doc ann] -> Doc ann +sep = group . vsep + + + +-- | @('hcat' xs)@ concatenates all documents @xs@ horizontally with @'<>'@ +-- (i.e. without any spacing). +-- +-- It is provided only for consistency, since it is identical to 'mconcat'. +-- +-- >>> let docs = Util.words "lorem ipsum dolor" +-- >>> hcat docs +-- loremipsumdolor +hcat :: [Doc ann] -> Doc ann +hcat = concatWith (<>) + +-- | @('vcat' xs)@ vertically concatenates the documents @xs@. If it is +-- 'group'ed, the line breaks are removed. +-- +-- In other words @'vcat'@ is like @'vsep'@, with newlines removed instead of +-- replaced by 'space's. +-- +-- >>> let docs = Util.words "lorem ipsum dolor" +-- >>> vcat docs +-- lorem +-- ipsum +-- dolor +-- >>> group (vcat docs) +-- loremipsumdolor +-- +-- Since 'group'ing a 'vcat' is rather common, 'cat' is a built-in shortcut for +-- it. +vcat :: [Doc ann] -> Doc ann +vcat = concatWith (\x y -> x <> line' <> y) + +-- | @('fillCat' xs)@ concatenates documents @xs@ horizontally with @'<>'@ as +-- long as it fits the page, then inserts a @'line''@ and continues doing that +-- for all documents in @xs@. This is similar to how an ordinary word processor +-- lays out the text if you just keep typing after you hit the maximum line +-- length. +-- +-- (@'line''@ means that if 'group'ed, the documents are separated with nothing +-- instead of newlines. See 'fillSep' if you want a 'space' instead.) +-- +-- Observe the difference between 'fillSep' and 'fillCat'. 'fillSep' +-- concatenates the entries 'space'd when 'group'ed, +-- +-- >>> let docs = take 20 (cycle (["lorem", "ipsum", "dolor", "sit", "amet"])) +-- >>> putDocW 40 ("Grouped:" <+> group (fillSep docs)) +-- Grouped: lorem ipsum dolor sit amet +-- lorem ipsum dolor sit amet lorem ipsum +-- dolor sit amet lorem ipsum dolor sit +-- amet +-- +-- On the other hand, 'fillCat' concatenates the entries directly when +-- 'group'ed, +-- +-- >>> putDocW 40 ("Grouped:" <+> group (fillCat docs)) +-- Grouped: loremipsumdolorsitametlorem +-- ipsumdolorsitametloremipsumdolorsitamet +-- loremipsumdolorsitamet +fillCat :: [Doc ann] -> Doc ann +fillCat = concatWith (\x y -> x <> softline' <> y) + +-- | @('cat' xs)@ tries laying out the documents @xs@ separated with nothing, +-- and if this does not fit the page, separates them with newlines. This is what +-- differentiates it from 'vcat', which always lays out its contents beneath +-- each other. +-- +-- >>> let docs = Util.words "lorem ipsum dolor" +-- >>> putDocW 80 ("Docs:" <+> cat docs) +-- Docs: loremipsumdolor +-- +-- When there is enough space, the documents are put above one another, +-- +-- >>> putDocW 10 ("Docs:" <+> cat docs) +-- Docs: lorem +-- ipsum +-- dolor +-- +-- @ +-- 'cat' = 'group' . 'vcat' +-- @ +cat :: [Doc ann] -> Doc ann +cat = group . vcat + + + +-- | @('punctuate' p xs)@ appends @p@ to all but the last document in @xs@. +-- +-- >>> let docs = punctuate comma (Util.words "lorem ipsum dolor sit amet") +-- >>> putDocW 80 (hsep docs) +-- lorem, ipsum, dolor, sit, amet +-- +-- The separators are put at the end of the entries, which we can see if we +-- position the result vertically: +-- +-- >>> putDocW 20 (vsep docs) +-- lorem, +-- ipsum, +-- dolor, +-- sit, +-- amet +-- +-- If you want put the commas in front of their elements instead of at the end, +-- you should use 'tupled' or, in general, 'encloseSep'. +punctuate + :: Doc ann -- ^ Punctuation, e.g. 'comma' + -> [Doc ann] + -> [Doc ann] +punctuate p = go + where + go [] = [] + go [d] = [d] + go (d:ds) = (d <> p) : go ds + + + +-- | Layout a document depending on which column it starts at. 'align' is +-- implemented in terms of 'column'. +-- +-- >>> column (\l -> "Columns are" <+> pretty l <> "-based.") +-- Columns are 0-based. +-- +-- >>> let doc = "prefix" <+> column (\l -> "| <- column" <+> pretty l) +-- >>> vsep [indent n doc | n <- [0,4,8]] +-- prefix | <- column 7 +-- prefix | <- column 11 +-- prefix | <- column 15 +column :: (Int -> Doc ann) -> Doc ann +column = Column + +-- | Layout a document depending on the current 'nest'ing level. 'align' is +-- implemented in terms of 'nesting'. +-- +-- >>> let doc = "prefix" <+> nesting (\l -> brackets ("Nested:" <+> pretty l)) +-- >>> vsep [indent n doc | n <- [0,4,8]] +-- prefix [Nested: 0] +-- prefix [Nested: 4] +-- prefix [Nested: 8] +nesting :: (Int -> Doc ann) -> Doc ann +nesting = Nesting + +-- | @('width' doc f)@ lays out the document 'doc', and makes the column width +-- of it available to a function. +-- +-- >>> let annotate doc = width (brackets doc) (\w -> " <- width:" <+> pretty w) +-- >>> align (vsep (map annotate ["---", "------", indent 3 "---", vsep ["---", indent 4 "---"]])) +-- [---] <- width: 5 +-- [------] <- width: 8 +-- [ ---] <- width: 8 +-- [--- +-- ---] <- width: 8 +width :: Doc ann -> (Int -> Doc ann) -> Doc ann +width doc f + = column (\colStart -> + doc <> column (\colEnd -> + f (colEnd - colStart))) + +-- | Layout a document depending on the page width, if one has been specified. +-- +-- >>> let prettyPageWidth (AvailablePerLine l r) = "Width:" <+> pretty l <> ", ribbon fraction:" <+> pretty r +-- >>> let doc = "prefix" <+> pageWidth (brackets . prettyPageWidth) +-- >>> putDocW 32 (vsep [indent n doc | n <- [0,4,8]]) +-- prefix [Width: 32, ribbon fraction: 1.0] +-- prefix [Width: 32, ribbon fraction: 1.0] +-- prefix [Width: 32, ribbon fraction: 1.0] +pageWidth :: (PageWidth -> Doc ann) -> Doc ann +pageWidth = WithPageWidth + + + +-- | @('fill' i x)@ lays out the document @x@. It then appends @space@s until +-- the width is equal to @i@. If the width of @x@ is already larger, nothing is +-- appended. +-- +-- This function is quite useful in practice to output a list of bindings: +-- +-- >>> let types = [("empty","Doc"), ("nest","Int -> Doc -> Doc"), ("fillSep","[Doc] -> Doc")] +-- >>> let ptype (name, tp) = fill 5 (pretty name) <+> "::" <+> pretty tp +-- >>> "let" <+> align (vcat (map ptype types)) +-- let empty :: Doc +-- nest :: Int -> Doc -> Doc +-- fillSep :: [Doc] -> Doc +fill + :: Int -- ^ Append spaces until the document is at least this wide + -> Doc ann + -> Doc ann +fill n doc = width doc (\w -> spaces (n - w)) + +-- | @('fillBreak' i x)@ first lays out the document @x@. It then appends @space@s +-- until the width is equal to @i@. If the width of @x@ is already larger than +-- @i@, the nesting level is increased by @i@ and a @line@ is appended. When we +-- redefine @ptype@ in the example given in 'fill' to use @'fillBreak'@, we get +-- a useful variation of the output: +-- +-- >>> let types = [("empty","Doc"), ("nest","Int -> Doc -> Doc"), ("fillSep","[Doc] -> Doc")] +-- >>> let ptype (name, tp) = fillBreak 5 (pretty name) <+> "::" <+> pretty tp +-- >>> "let" <+> align (vcat (map ptype types)) +-- let empty :: Doc +-- nest :: Int -> Doc -> Doc +-- fillSep +-- :: [Doc] -> Doc +fillBreak + :: Int -- ^ Append spaces until the document is at least this wide + -> Doc ann + -> Doc ann +fillBreak f x = width x (\w -> + if w > f + then nest f line' + else spaces (f - w)) + +-- | Insert a number of spaces. Negative values count as 0. +spaces :: Int -> Doc ann +spaces n + | n <= 0 = Empty + | n == 1 = Char ' ' + | otherwise = Text n (textSpaces n) + +-- $ +-- prop> \(NonNegative n) -> length (show (spaces n)) == n +-- +-- >>> case spaces 1 of Char ' ' -> True; _ -> False +-- True +-- +-- >>> case spaces 0 of Empty -> True; _ -> False +-- True +-- +-- prop> \(Positive n) -> case (spaces (-n)) of Empty -> True; _ -> False + + + +-- | @('plural' n one many)@ is @one@ if @n@ is @1@, and @many@ otherwise. A +-- typical use case is adding a plural "s". +-- +-- >>> let things = [True] +-- >>> let amount = length things +-- >>> pretty things <+> "has" <+> pretty amount <+> plural "entry" "entries" amount +-- [True] has 1 entry +plural + :: (Num amount, Eq amount) + => doc -- ^ @1@ case + -> doc -- ^ other cases + -> amount + -> doc +plural one multiple n + | n == 1 = one + | otherwise = multiple + +-- | @('enclose' l r x)@ encloses document @x@ between documents @l@ and @r@ +-- using @'<>'@. +-- +-- >>> enclose "A" "Z" "·" +-- A·Z +-- +-- @ +-- 'enclose' l r x = l '<>' x '<>' r +-- @ +enclose + :: Doc ann -- ^ L + -> Doc ann -- ^ R + -> Doc ann -- ^ x + -> Doc ann -- ^ LxR +enclose l r x = l <> x <> r + +-- | @('surround' x l r)@ surrounds document @x@ with @l@ and @r@. +-- +-- >>> surround "·" "A" "Z" +-- A·Z +-- +-- This is merely an argument reordering of @'enclose'@, but allows for +-- definitions like +-- +-- >>> concatWith (surround dot) ["Prettyprinter", "Render", "Text"] +-- Prettyprinter.Render.Text +surround + :: Doc ann + -> Doc ann + -> Doc ann + -> Doc ann +surround x l r = l <> x <> r + + + + + + +-- | Add an annotation to a @'Doc'@. This annotation can then be used by the +-- renderer to e.g. add color to certain parts of the output. For a full +-- tutorial example on how to use it, see the +-- "Prettyprinter.Render.Tutorials.StackMachineTutorial" or +-- "Prettyprinter.Render.Tutorials.TreeRenderingTutorial" modules. +-- +-- This function is only relevant for custom formats with their own annotations, +-- and not relevant for basic prettyprinting. The predefined renderers, e.g. +-- "Prettyprinter.Render.Text", should be enough for the most common +-- needs. +annotate :: ann -> Doc ann -> Doc ann +annotate = Annotated + +-- | Remove all annotations. +-- +-- Although 'unAnnotate' is idempotent with respect to rendering, +-- +-- @ +-- 'unAnnotate' . 'unAnnotate' = 'unAnnotate' +-- @ +-- +-- it should not be used without caution, for each invocation traverses the +-- entire contained document. If possible, it is preferrable to unannotate after +-- producing the layout by using 'unAnnotateS'. +unAnnotate :: Doc ann -> Doc xxx +unAnnotate = alterAnnotations (const []) + +-- | Change the annotation of a 'Doc'ument. +-- +-- Useful in particular to embed documents with one form of annotation in a more +-- generlly annotated document. +-- +-- Since this traverses the entire @'Doc'@ tree, including parts that are not +-- rendered due to other layouts fitting better, it is preferrable to reannotate +-- after producing the layout by using @'reAnnotateS'@. +-- +-- Since @'reAnnotate'@ has the right type and satisfies @'reAnnotate id = id'@, +-- it is used to define the @'Functor'@ instance of @'Doc'@. +reAnnotate :: (ann -> ann') -> Doc ann -> Doc ann' +reAnnotate re = alterAnnotations (pure . re) + +-- | Change the annotations of a 'Doc'ument. Individual annotations can be +-- removed, changed, or replaced by multiple ones. +-- +-- This is a general function that combines 'unAnnotate' and 'reAnnotate', and +-- it is useful for mapping semantic annotations (such as »this is a keyword«) +-- to display annotations (such as »this is red and underlined«), because some +-- backends may not care about certain annotations, while others may. +-- +-- Annotations earlier in the new list will be applied earlier, i.e. returning +-- @[Bold, Green]@ will result in a bold document that contains green text, and +-- not vice-versa. +-- +-- Since this traverses the entire @'Doc'@ tree, including parts that are not +-- rendered due to other layouts fitting better, it is preferrable to reannotate +-- after producing the layout by using @'alterAnnotationsS'@. +alterAnnotations :: (ann -> [ann']) -> Doc ann -> Doc ann' +alterAnnotations re = go + where + go = \doc -> case doc of + Fail -> Fail + Empty -> Empty + Char c -> Char c + Text l t -> Text l t + Line -> Line + + FlatAlt x y -> FlatAlt (go x) (go y) + Cat x y -> Cat (go x) (go y) + Nest i x -> Nest i (go x) + Union x y -> Union (go x) (go y) + Column f -> Column (go . f) + WithPageWidth f -> WithPageWidth (go . f) + Nesting f -> Nesting (go . f) + Annotated ann x -> foldr Annotated (go x) (re ann) + +-- $ +-- >>> let doc = "lorem" <+> annotate () "ipsum" <+> "dolor" +-- >>> let re () = ["FOO", "BAR"] +-- >>> layoutPretty defaultLayoutOptions (alterAnnotations re doc) +-- SText 5 "lorem" (SChar ' ' (SAnnPush "FOO" (SAnnPush "BAR" (SText 5 "ipsum" (SAnnPop (SAnnPop (SChar ' ' (SText 5 "dolor" SEmpty)))))))) + +-- | Remove all annotations. 'unAnnotate' for 'SimpleDocStream'. +unAnnotateS :: SimpleDocStream ann -> SimpleDocStream xxx +unAnnotateS = go + where + go = \doc -> case doc of + SFail -> SFail + SEmpty -> SEmpty + SChar c rest -> SChar c (go rest) + SText l t rest -> SText l t (go rest) + SLine l rest -> SLine l (go rest) + SAnnPop rest -> go rest + SAnnPush _ann rest -> go rest + +-- | Change the annotation of a document. 'reAnnotate' for 'SimpleDocStream'. +reAnnotateS :: (ann -> ann') -> SimpleDocStream ann -> SimpleDocStream ann' +reAnnotateS re = go + where + go = \doc -> case doc of + SFail -> SFail + SEmpty -> SEmpty + SChar c rest -> SChar c (go rest) + SText l t rest -> SText l t (go rest) + SLine l rest -> SLine l (go rest) + SAnnPop rest -> SAnnPop (go rest) + SAnnPush ann rest -> SAnnPush (re ann) (go rest) + +data AnnotationRemoval = Remove | DontRemove + deriving Typeable + +-- | Change the annotation of a document to a different annotation, or none at +-- all. 'alterAnnotations' for 'SimpleDocStream'. +-- +-- Note that the 'Doc' version is more flexible, since it allows changing a +-- single annotation to multiple ones. +-- ('Prettyprinter.Render.Util.SimpleDocTree.SimpleDocTree' restores +-- this flexibility again.) +alterAnnotationsS :: (ann -> Maybe ann') -> SimpleDocStream ann -> SimpleDocStream ann' +alterAnnotationsS re = go [] + where + -- We keep a stack of whether to remove a pop so that we can remove exactly + -- the pops corresponding to annotations that mapped to Nothing. + go stack = \sds -> case sds of + SFail -> SFail + SEmpty -> SEmpty + SChar c rest -> SChar c (go stack rest) + SText l t rest -> SText l t (go stack rest) + SLine l rest -> SLine l (go stack rest) + SAnnPush ann rest -> case re ann of + Nothing -> go (Remove:stack) rest + Just ann' -> SAnnPush ann' (go (DontRemove:stack) rest) + SAnnPop rest -> case stack of + [] -> panicPeekedEmpty + DontRemove:stack' -> SAnnPop (go stack' rest) + Remove:stack' -> go stack' rest + +-- | Fusion depth parameter, used by 'fuse'. +data FusionDepth = + + -- | Do not dive deep into nested documents, fusing mostly concatenations of + -- text nodes together. + Shallow + + -- | Recurse into all parts of the 'Doc', including different layout + -- alternatives, and location-sensitive values such as created by 'nesting' + -- which cannot be fused before, but only during, the layout process. As a + -- result, the performance cost of using deep fusion is often hard to + -- predict, and depends on the interplay between page layout and document to + -- prettyprint. + -- + -- This value should only be used if profiling shows it is significantly + -- faster than using 'Shallow'. + | Deep + deriving (Eq, Ord, Show, Typeable) + +-- | @('fuse' depth doc)@ combines text nodes so they can be rendered more +-- efficiently. A fused document is always laid out identical to its unfused +-- version. +-- +-- When laying a 'Doc'ument out to a 'SimpleDocStream', every component of the +-- input is translated directly to the simpler output format. This sometimes +-- yields undesirable chunking when many pieces have been concatenated together. +-- +-- For example +-- +-- >>> "a" <> "b" <> pretty 'c' <> "d" +-- abcd +-- +-- results in a chain of four entries in a 'SimpleDocStream', although this is fully +-- equivalent to the tightly packed +-- +-- >>> "abcd" :: Doc ann +-- abcd +-- +-- which is only a single 'SimpleDocStream' entry, and can be processed faster. +-- +-- It is therefore a good idea to run 'fuse' on concatenations of lots of small +-- strings that are used many times, +-- +-- >>> let oftenUsed = fuse Shallow ("a" <> "b" <> pretty 'c' <> "d") +-- >>> hsep (replicate 5 oftenUsed) +-- abcd abcd abcd abcd abcd +fuse :: FusionDepth -> Doc ann -> Doc ann +fuse depth = go + where + go = \doc -> case doc of + Cat Empty x -> go x + Cat x Empty -> go x + Cat (Char c1) (Char c2) -> Text 2 (T.singleton c1 <> T.singleton c2) + Cat (Text lt t) (Char c) -> Text (lt+1) (T.snoc t c) + Cat (Char c) (Text lt t) -> Text (1+lt) (T.cons c t) + Cat (Text l1 t1) (Text l2 t2) -> Text (l1+l2) (t1 <> t2) + + Cat x@Char{} (Cat y@Char{} z) -> go (Cat (go (Cat x y)) z) + Cat x@Text{} (Cat y@Char{} z) -> go (Cat (go (Cat x y)) z) + Cat x@Char{} (Cat y@Text{} z) -> go (Cat (go (Cat x y)) z) + Cat x@Text{} (Cat y@Text{} z) -> go (Cat (go (Cat x y)) z) + + Cat (Cat x y@Char{}) z -> go (Cat x (go (Cat y z))) + Cat (Cat x y@Text{}) z -> go (Cat x (go (Cat y z))) + + Cat x y -> Cat (go x) (go y) + + Nest i (Nest j x) -> let !fused = Nest (i+j) x + in go fused + Nest _ x@Empty{} -> x + Nest _ x@Text{} -> x + Nest _ x@Char{} -> x + Nest 0 x -> go x + Nest i x -> Nest i (go x) + + Annotated ann x -> Annotated ann (go x) + + FlatAlt x1 x2 -> FlatAlt (go x1) (go x2) + Union x1 x2 -> Union (go x1) (go x2) + + other | depth == Shallow -> other + + Column f -> Column (go . f) + WithPageWidth f -> WithPageWidth (go . f) + Nesting f -> Nesting (go . f) + + other -> other + + + +-- | The data type @SimpleDocStream@ represents laid out documents and is used +-- by the display functions. +-- +-- A simplified view is that @'Doc' = ['SimpleDocStream']@, and the layout +-- functions pick one of the 'SimpleDocStream's based on which one fits the +-- layout constraints best. This means that 'SimpleDocStream' has all complexity +-- contained in 'Doc' resolved, making it very easy to convert it to other +-- formats, such as plain text or terminal output. +-- +-- To write your own @'Doc'@ to X converter, it is therefore sufficient to +-- convert from @'SimpleDocStream'@. The »Render« submodules provide some +-- built-in converters to do so, and helpers to create own ones. +data SimpleDocStream ann = + SFail + | SEmpty + | SChar !Char (SimpleDocStream ann) + + -- | 'T.length' is /O(n)/, so we cache it in the 'Int' field. + | SText !Int !Text (SimpleDocStream ann) + + -- | @Int@ = indentation level for the (next) line + | SLine !Int (SimpleDocStream ann) + + -- | Add an annotation to the remaining document. + | SAnnPush ann (SimpleDocStream ann) + + -- | Remove a previously pushed annotation. + | SAnnPop (SimpleDocStream ann) + deriving (Eq, Ord, Show, Generic, Typeable) + +-- | Remove all trailing space characters. +-- +-- This has some performance impact, because it does an entire additional pass +-- over the 'SimpleDocStream'. +-- +-- No trimming will be done inside annotations, which are considered to contain +-- no (trimmable) whitespace, since the annotation might actually be /about/ the +-- whitespace, for example a renderer that colors the background of trailing +-- whitespace, as e.g. @git diff@ can be configured to do. +-- +-- /Historical note:/ Since v1.7.0, 'layoutPretty' and 'layoutSmart' avoid +-- producing the trailing whitespace that was the original motivation for +-- creating 'removeTrailingWhitespace'. +-- See for some background +-- info. +removeTrailingWhitespace :: SimpleDocStream ann -> SimpleDocStream ann +removeTrailingWhitespace = go (RecordedWhitespace [] 0) + where + commitWhitespace + :: [Int] -- Withheld lines + -> Int -- Withheld spaces + -> SimpleDocStream ann + -> SimpleDocStream ann + commitWhitespace is !n sds = case is of + [] -> case n of + 0 -> sds + 1 -> SChar ' ' sds + _ -> SText n (textSpaces n) sds + (i:is') -> let !end = SLine (i + n) sds + in prependEmptyLines is' end + + prependEmptyLines :: [Int] -> SimpleDocStream ann -> SimpleDocStream ann + prependEmptyLines is sds0 = foldr (\_ sds -> SLine 0 sds) sds0 is + + go :: WhitespaceStrippingState -> SimpleDocStream ann -> SimpleDocStream ann + -- We do not strip whitespace inside annotated documents, since it might + -- actually be relevant there. + go annLevel@(AnnotationLevel annLvl) = \sds -> case sds of + SFail -> SFail + SEmpty -> SEmpty + SChar c rest -> SChar c (go annLevel rest) + SText l text rest -> SText l text (go annLevel rest) + SLine i rest -> SLine i (go annLevel rest) + SAnnPush ann rest -> let !annLvl' = annLvl+1 + in SAnnPush ann (go (AnnotationLevel annLvl') rest) + SAnnPop rest + | annLvl > 1 -> let !annLvl' = annLvl-1 + in SAnnPop (go (AnnotationLevel annLvl') rest) + | otherwise -> SAnnPop (go (RecordedWhitespace [] 0) rest) + -- Record all spaces/lines encountered, and once proper text starts again, + -- release only the necessary ones. + go (RecordedWhitespace withheldLines withheldSpaces) = \sds -> case sds of + SFail -> SFail + SEmpty -> prependEmptyLines withheldLines SEmpty + SChar c rest + | c == ' ' -> go (RecordedWhitespace withheldLines (withheldSpaces+1)) rest + | otherwise -> commitWhitespace + withheldLines + withheldSpaces + (SChar c (go (RecordedWhitespace [] 0) rest)) + SText textLength text rest -> + let stripped = T.dropWhileEnd (== ' ') text + strippedLength = T.length stripped + trailingLength = textLength - strippedLength + isOnlySpace = strippedLength == 0 + in if isOnlySpace + then go (RecordedWhitespace withheldLines (withheldSpaces + textLength)) rest + else commitWhitespace + withheldLines + withheldSpaces + (SText strippedLength + stripped + (go (RecordedWhitespace [] trailingLength) rest)) + SLine i rest -> go (RecordedWhitespace (i:withheldLines) 0) rest + SAnnPush ann rest -> commitWhitespace + withheldLines + withheldSpaces + (SAnnPush ann (go (AnnotationLevel 1) rest)) + SAnnPop _ -> error "Tried skipping spaces in unannotated data! Please report this as a bug in 'prettyprinter'." + +data WhitespaceStrippingState + = AnnotationLevel !Int + | RecordedWhitespace [Int] !Int + -- ^ [Newline with indentation i] Spaces + deriving Typeable + + + +-- $ +-- >>> import qualified Data.Text.IO as T +-- >>> doc = "lorem" <> hardline <> hardline <> pretty "ipsum" +-- >>> go = T.putStrLn . renderStrict . removeTrailingWhitespace . layoutPretty defaultLayoutOptions +-- >>> go doc +-- lorem +-- +-- ipsum + + + +-- | Alter the document’s annotations. +-- +-- This instance makes 'SimpleDocStream' more flexible (because it can be used in +-- 'Functor'-polymorphic values), but @'fmap'@ is much less readable compared to +-- using @'reAnnotateST'@ in code that only works for @'SimpleDocStream'@ anyway. +-- Consider using the latter when the type does not matter. +instance Functor SimpleDocStream where + fmap = reAnnotateS + +-- | Collect all annotations from a document. +instance Foldable SimpleDocStream where + foldMap f = go + where + go = \sds -> case sds of + SFail -> mempty + SEmpty -> mempty + SChar _ rest -> go rest + SText _ _ rest -> go rest + SLine _ rest -> go rest + SAnnPush ann rest -> f ann `mappend` go rest + SAnnPop rest -> go rest + +-- | Transform a document based on its annotations, possibly leveraging +-- 'Applicative' effects. +instance Traversable SimpleDocStream where + traverse f = go + where + go = \sds -> case sds of + SFail -> pure SFail + SEmpty -> pure SEmpty + SChar c rest -> SChar c <$> go rest + SText l t rest -> SText l t <$> go rest + SLine i rest -> SLine i <$> go rest + SAnnPush ann rest -> SAnnPush <$> f ann <*> go rest + SAnnPop rest -> SAnnPop <$> go rest + +-- | Decide whether a 'SimpleDocStream' fits the constraints given, namely +-- +-- - original indentation of the current line +-- - current column +-- - initial indentation of the alternative 'SimpleDocStream' if it +-- starts with a line break (used by 'layoutSmart') +-- - width in which to fit the first line +newtype FittingPredicate ann + = FittingPredicate (Int + -> Int + -> Maybe Int + -> SimpleDocStream ann + -> Bool) + deriving Typeable + +-- | List of nesting level/document pairs yet to be laid out. +data LayoutPipeline ann = + Nil + | Cons !Int (Doc ann) (LayoutPipeline ann) + | UndoAnn (LayoutPipeline ann) + deriving Typeable + +-- | Maximum number of characters that fit in one line. The layout algorithms +-- will try not to exceed the set limit by inserting line breaks when applicable +-- (e.g. via 'softline''). +data PageWidth + + = AvailablePerLine !Int !Double + -- ^ Layouters should not exceed the specified space per line. + -- + -- - The 'Int' is the number of characters, including whitespace, that + -- fit in a line. A typical value is 80. + -- + -- - The 'Double' is the ribbon with, i.e. the fraction of the total + -- page width that can be printed on. This allows limiting the length + -- of printable text per line. Values must be between 0 and 1, and + -- 0.4 to 1 is typical. + + | Unbounded + -- ^ Layouters should not introduce line breaks on their own. + + deriving (Eq, Ord, Show, Typeable) + +defaultPageWidth :: PageWidth +defaultPageWidth = AvailablePerLine 80 1 + +-- | The remaining width on the current line. +remainingWidth :: Int -> Double -> Int -> Int -> Int +remainingWidth lineLength ribbonFraction lineIndent currentColumn = + min columnsLeftInLine columnsLeftInRibbon + where + columnsLeftInLine = lineLength - currentColumn + columnsLeftInRibbon = lineIndent + ribbonWidth - currentColumn + ribbonWidth = + (max 0 . min lineLength . floor) + (fromIntegral lineLength * ribbonFraction) + +-- $ Test to avoid surprising behaviour +-- >>> Unbounded > AvailablePerLine maxBound 1 +-- True + +-- | Options to influence the layout algorithms. +newtype LayoutOptions = LayoutOptions { layoutPageWidth :: PageWidth } + deriving (Eq, Ord, Show, Typeable) + +-- | The default layout options, suitable when you just want some output, and +-- don’t particularly care about the details. Used by the 'Show' instance, for +-- example. +-- +-- >>> defaultLayoutOptions +-- LayoutOptions {layoutPageWidth = AvailablePerLine 80 1.0} +defaultLayoutOptions :: LayoutOptions +defaultLayoutOptions = LayoutOptions { layoutPageWidth = defaultPageWidth } + +-- | This is the default layout algorithm, and it is used by 'show', 'putDoc' +-- and 'hPutDoc'. +-- +-- @'layoutPretty'@ commits to rendering something in a certain way if the next +-- element fits the layout constraints; in other words, it has one +-- 'SimpleDocStream' element lookahead when rendering. Consider using the +-- smarter, but a bit less performant, @'layoutSmart'@ algorithm if the results +-- seem to run off to the right before having lots of line breaks. +layoutPretty + :: LayoutOptions + -> Doc ann + -> SimpleDocStream ann +layoutPretty (LayoutOptions pageWidth_@(AvailablePerLine lineLength ribbonFraction)) = + layoutWadlerLeijen + (FittingPredicate + (\lineIndent currentColumn _initialIndentY sdoc -> + fits + (remainingWidth lineLength ribbonFraction lineIndent currentColumn) + sdoc)) + pageWidth_ + where + fits :: Int -- ^ Width in which to fit the first line + -> SimpleDocStream ann + -> Bool + fits w _ | w < 0 = False + fits _ SFail = False + fits _ SEmpty = True + fits w (SChar _ x) = fits (w - 1) x + fits w (SText l _t x) = fits (w - l) x + fits _ SLine{} = True + fits w (SAnnPush _ x) = fits w x + fits w (SAnnPop x) = fits w x + +layoutPretty (LayoutOptions Unbounded) = layoutUnbounded + +-- | A layout algorithm with more lookahead than 'layoutPretty', that introduces +-- line breaks earlier if the content does not (or will not, rather) fit into +-- one line. +-- +-- Consider the following python-ish document, +-- +-- >>> let fun x = hang 2 ("fun(" <> softline' <> x) <> ")" +-- >>> let doc = (fun . fun . fun . fun . fun) (align (list ["abcdef", "ghijklm"])) +-- +-- which we’ll be rendering using the following pipeline (where the layout +-- algorithm has been left open), +-- +-- >>> import Data.Text.IO as T +-- >>> import Prettyprinter.Render.Text +-- >>> let hr = pipe <> pretty (replicate (26-2) '-') <> pipe +-- >>> let go layouter x = (T.putStrLn . renderStrict . layouter (LayoutOptions (AvailablePerLine 26 1))) (vsep [hr, x, hr]) +-- +-- If we render this using 'layoutPretty' with a page width of 26 characters +-- per line, all the @fun@ calls fit into the first line so they will be put +-- there, +-- +-- >>> go layoutPretty doc +-- |------------------------| +-- fun(fun(fun(fun(fun( +-- [ abcdef +-- , ghijklm ]))))) +-- |------------------------| +-- +-- Note that this exceeds the desired 26 character page width. The same +-- document, rendered with @'layoutSmart'@, fits the layout contstraints: +-- +-- >>> go layoutSmart doc +-- |------------------------| +-- fun( +-- fun( +-- fun( +-- fun( +-- fun( +-- [ abcdef +-- , ghijklm ]))))) +-- |------------------------| +-- +-- The key difference between 'layoutPretty' and 'layoutSmart' is that the +-- latter will check the potential document until it encounters a line with the +-- same indentation or less than the start of the document. Any line encountered +-- earlier is assumed to belong to the same syntactic structure. +-- 'layoutPretty' checks only the first line. +-- +-- Consider for example the question of whether the @A@s fit into the document +-- below: +-- +-- > 1 A +-- > 2 A +-- > 3 A +-- > 4 B +-- > 5 B +-- +-- 'layoutPretty' will check only line 1, ignoring whether e.g. line 2 might +-- already be too wide. +-- By contrast, 'layoutSmart' stops only once it reaches line 4, where the @B@ +-- has the same indentation as the first @A@. +layoutSmart + :: LayoutOptions + -> Doc ann + -> SimpleDocStream ann +layoutSmart (LayoutOptions pageWidth_@(AvailablePerLine lineLength ribbonFraction)) = + layoutWadlerLeijen (FittingPredicate fits) pageWidth_ + where + -- Why doesn't layoutSmart simply check the entire document? + -- + -- 1. That would be very expensive. + -- 2. In that case the layout of a particular part of a document would + -- depend on the fit of completely unrelated parts of the same document. + -- See https://github.com/quchen/prettyprinter/issues/83 for a related + -- bug. + + fits :: Int -> Int -> Maybe Int -> SimpleDocStream ann -> Bool + fits lineIndent currentColumn initialIndentY = go availableWidth + where + go w _ | w < 0 = False + go _ SFail = False + go _ SEmpty = True + go w (SChar _ x) = go (w - 1) x + go w (SText l _t x) = go (w - l) x + go _ (SLine i x) + | minNestingLevel < i = go (lineLength - i) x -- TODO: Take ribbon width into account?! (#142) + | otherwise = True + go w (SAnnPush _ x) = go w x + go w (SAnnPop x) = go w x + + availableWidth = remainingWidth lineLength ribbonFraction lineIndent currentColumn + + minNestingLevel = + -- See the Note + -- [Choosing the right minNestingLevel for consistent smart layouts] + case initialIndentY of + Just i -> + -- y could be a (less wide) hanging layout. If so, let's + -- check x a bit more thoroughly so we don't miss a potentially + -- better fitting y. + min i currentColumn + Nothing -> + -- y definitely isn't a hanging layout. Let's check x with the + -- same minNestingLevel that any subsequent lines with the same + -- indentation use. + currentColumn + +layoutSmart (LayoutOptions Unbounded) = layoutUnbounded + +-- | Layout a document with @Unbounded@ page width. +layoutUnbounded :: Doc ann -> SimpleDocStream ann +layoutUnbounded = + layoutWadlerLeijen + (FittingPredicate + (\_lineIndent _currentColumn _initialIndentY sdoc -> not (failsOnFirstLine sdoc))) + Unbounded + where + -- See the Note [Detecting failure with Unbounded page width]. + failsOnFirstLine :: SimpleDocStream ann -> Bool + failsOnFirstLine = go + where + go sds = case sds of + SFail -> True + SEmpty -> False + SChar _ s -> go s + SText _ _ s -> go s + SLine _ _ -> False + SAnnPush _ s -> go s + SAnnPop s -> go s + +-- | The Wadler/Leijen layout algorithm +layoutWadlerLeijen + :: forall ann. FittingPredicate ann + -> PageWidth + -> Doc ann + -> SimpleDocStream ann +layoutWadlerLeijen + (FittingPredicate fits) + pageWidth_ + doc + = best 0 0 (Cons 0 doc Nil) + where + + -- * current column >= current nesting level + -- * current column - current indentaion = number of chars inserted in line + best + :: Int -- Current nesting level + -> Int -- Current column, i.e. "where the cursor is" + -> LayoutPipeline ann -- Documents remaining to be handled (in order) + -> SimpleDocStream ann + best !_ !_ Nil = SEmpty + best nl cc (UndoAnn ds) = SAnnPop (best nl cc ds) + best nl cc (Cons i d ds) = case d of + Fail -> SFail + Empty -> best nl cc ds + Char c -> let !cc' = cc+1 in SChar c (best nl cc' ds) + Text l t -> let !cc' = cc+l in SText l t (best nl cc' ds) + Line -> let x = best i i ds + -- Don't produce indentation if there's no + -- following text on the same line. + -- This prevents trailing whitespace. + i' = case x of + SEmpty -> 0 + SLine{} -> 0 + _ -> i + in SLine i' x + FlatAlt x _ -> best nl cc (Cons i x ds) + Cat x y -> best nl cc (Cons i x (Cons i y ds)) + Nest j x -> let !ij = i+j in best nl cc (Cons ij x ds) + Union x y -> let x' = best nl cc (Cons i x ds) + y' = best nl cc (Cons i y ds) + in selectNicer nl cc x' y' + Column f -> best nl cc (Cons i (f cc) ds) + WithPageWidth f -> best nl cc (Cons i (f pageWidth_) ds) + Nesting f -> best nl cc (Cons i (f i) ds) + Annotated ann x -> SAnnPush ann (best nl cc (Cons i x (UndoAnn ds))) + + -- Select the better fitting of two documents: + -- Choice A if it fits, otherwise choice B. + -- + -- The fit of choice B is /not/ checked! It is ultimately the user's + -- responsibility to provide an alternative that can fit the page even when + -- choice A doesn't. + selectNicer + :: Int -- ^ Current nesting level + -> Int -- ^ Current column + -> SimpleDocStream ann -- ^ Choice A. + -> SimpleDocStream ann -- ^ Choice B. Should fit more easily + -- (== be less wide) than choice A. + -> SimpleDocStream ann -- ^ Choice A if it fits, otherwise B. + selectNicer lineIndent currentColumn x y + | fits lineIndent currentColumn (initialIndentation y) x = x + | otherwise = y + + initialIndentation :: SimpleDocStream ann -> Maybe Int + initialIndentation sds = case sds of + SLine i _ -> Just i + SAnnPush _ s -> initialIndentation s + SAnnPop s -> initialIndentation s + _ -> Nothing + + +{- Note [Choosing the right minNestingLevel for consistent smart layouts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this document: + + doc = + "Groceries: " + <> align + (cat + [ sep ["pommes", "de", "terre"] + , "apples" + , "Donaudampfschifffahrtskapitänskajütenmülleimer" + ] + ) + +... and assume we want to fit it into 40 columns as nicely as possible: + + opts = LayoutOptions (AvailablePerLine 40 1) + +We already have bad luck with the last item – it's longer than 40 characters +on its own! + +We'd still like the first item, pommes de terre, to be laid out nicely, that is, +on one line, since it's not too wide. This is what we'd like to see: + + Groceries: pommes de terre + apples + Donaudampfschifffahrtskapitänskajütenmülleimer + +Before #83 was fixed, that wasn't what we got! Instead we got this: + +> renderIO stdout $ layoutSmart opts doc +Groceries: pommes + de + terre + apples + Donaudampfschifffahrtskapitänskajütenmülleimer + +Why? + +minNestingLevel was effectively defined as + + minNestingLevel = lineIndent + +The lineIndent for "pommes de terre" is 0. + +The FittingPredicate for layoutSmart will continue to check the rest of the +document until it finds a line where the indentation <= minNestingLevel. +In this case this meant that layoutSmart would traverse all the items, +and note that the last item, Donaudampfschifffahrtskapitänskajütenmülleimer, +doesn't fit into the available space! The "flatter" version of the document +has failed, so "pommes de terre" gets spread over several lines! + +Obviously this would be an inconsistency with the layout of the other items. +Their lineIndent is 11 each, so for them, the FittingPredicate stops already +on the next line. + +The obvious solution is to change the definition of minNestingLevel: + + minNestingLevel = currentColumn + +This however breaks the "python-ish" document from the documentation for +layoutSmart: + + expected: |------------------------| + fun( + fun( + fun( + fun( + fun( + [ abcdef + , ghijklm ]))))) + |------------------------| + + but got: |------------------------| + fun( + fun( + fun( + fun( + fun([ abcdef + , ghijklm ]))))) + |------------------------| + +We now accept the worse layout because the problematic last line has +the same indentation as the current column of "[ abcdef", so we don't check it! + +The solution we went with in the end is a bit of a hack: + +We check whether the alternative, "high" layout is a (potentially less wide) +hanging layout, and in that case pick its indentation as the minNestingLevel. + +This way we achieve the optimal layout in both scenarios. + +See https://github.com/quchen/prettyprinter/issues/83 for the bug that lead +to the current solution. + + +Note [Detecting failure with Unbounded page width] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To understand why it is sufficient to check the first line of the +SimpleDocStream, trace how an SFail ends up there: + +1. We group a Doc containing a hard linebreak (hardline), producing a + (Union x y) where x contains Fail. + +2. In layoutWadlerLeijen.best, any Unions are handled recursively, rejecting any + alternatives that would result in SFail. + +So once a SimpleDocStream reaches selectNicer, any SFail in it must +appear before the first linebreak – any other SFail would have been +detected and rejected in a previous iteration. +-} + + + +-- | @(layoutCompact x)@ lays out the document @x@ without adding any +-- indentation and without preserving annotations. +-- Since no \'pretty\' printing is involved, this layouter is very +-- fast. The resulting output contains fewer characters than a prettyprinted +-- version and can be used for output that is read by other programs. +-- +-- >>> let doc = hang 4 (vsep ["lorem", "ipsum", hang 4 (vsep ["dolor", "sit"])]) +-- >>> doc +-- lorem +-- ipsum +-- dolor +-- sit +-- +-- >>> let putDocCompact = renderIO System.IO.stdout . layoutCompact +-- >>> putDocCompact doc +-- lorem +-- ipsum +-- dolor +-- sit +layoutCompact :: Doc ann1 -> SimpleDocStream ann2 +layoutCompact doc = scan 0 [doc] + where + scan _ [] = SEmpty + scan !col (d:ds) = case d of + Fail -> SFail + Empty -> scan col ds + Char c -> SChar c (scan (col+1) ds) + Text l t -> let !col' = col+l in SText l t (scan col' ds) + FlatAlt x _ -> scan col (x:ds) + Line -> SLine 0 (scan 0 ds) + Cat x y -> scan col (x:y:ds) + Nest _ x -> scan col (x:ds) + Union _ y -> scan col (y:ds) + Column f -> scan col (f col:ds) + WithPageWidth f -> scan col (f Unbounded : ds) + Nesting f -> scan col (f 0 : ds) + Annotated _ x -> scan col (x:ds) + +-- | @('show' doc)@ prettyprints document @doc@ with 'defaultLayoutOptions', +-- ignoring all annotations. +instance Show (Doc ann) where + showsPrec _ doc = renderShowS (layoutPretty defaultLayoutOptions doc) + +-- | Render a 'SimpleDocStream' to a 'ShowS', useful to write 'Show' instances +-- based on the prettyprinter. +-- +-- @ +-- instance 'Show' MyType where +-- 'showsPrec' _ = 'renderShowS' . 'layoutPretty' 'defaultLayoutOptions' . 'pretty' +-- @ +renderShowS :: SimpleDocStream ann -> ShowS +renderShowS = \sds -> case sds of + SFail -> panicUncaughtFail + SEmpty -> id + SChar c x -> showChar c . renderShowS x + SText _l t x -> showString (T.unpack t) . renderShowS x + SLine i x -> showString ('\n' : replicate i ' ') . renderShowS x + SAnnPush _ x -> renderShowS x + SAnnPop x -> renderShowS x + + +-- | A utility for producing indentation etc. +-- +-- >>> textSpaces 3 +-- " " +-- +-- This produces much better Core than the equivalent +-- +-- > T.replicate n " " +-- +-- (See .) +textSpaces :: Int -> Text +textSpaces n = T.replicate n (T.singleton ' ') + + +-- $setup +-- +-- (Definitions for the doctests) +-- +-- >>> :set -XOverloadedStrings +-- >>> import Prettyprinter.Render.Text +-- >>> import Prettyprinter.Symbols.Ascii +-- >>> import Prettyprinter.Util as Util +-- >>> import Test.QuickCheck.Modifiers diff --git a/src/Prettyprinter/Internal/Debug.hs b/src/Prettyprinter/Internal/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter/Internal/Debug.hs @@ -0,0 +1,95 @@ +-- | __Warning: internal module!__ This means that the API may change +-- arbitrarily between versions without notice. Depending on this module may +-- lead to unexpected breakages, so proceed with caution! +-- +-- This module provides debugging helpers for inspecting 'Doc's. +-- +-- Use the @pretty-simple@ package to get a nicer layout for 'show'n +-- 'Diag's: +-- +-- > > Text.Pretty.Simple.pPrintNoColor . diag $ align (vcat ["foo", "bar"]) +-- > Column +-- > [ +-- > ( 10 +-- > , Nesting +-- > [ +-- > ( 10 +-- > , Cat ( Text 3 "foo" ) +-- > ( Cat ( FlatAlt Line Empty ) ( Text 3 "bar" ) ) +-- > ) +-- > ] +-- > ) +-- > ] + + +module Prettyprinter.Internal.Debug where + +import Data.Text (Text) +import Prettyprinter.Internal (PageWidth, Doc) +import qualified Prettyprinter.Internal as Doc + +-- | A variant of 'Doc' for debugging. +-- +-- Unlike in the 'Doc' type, the 'Column', 'WithPageWidth' and 'Nesting' +-- constructors don't contain functions but are \"sampled\" to allow +-- simple inspection with 'show'. +data Diag ann = + Fail + | Empty + | Char !Char + | Text !Int !Text + | Line + | FlatAlt (Diag ann) (Diag ann) + | Cat (Diag ann) (Diag ann) + | Nest !Int (Diag ann) + | Union (Diag ann) (Diag ann) + | Column [(Int, Diag ann)] + -- ^ 'Doc': @(Int -> Diag ann)@ + | WithPageWidth [(PageWidth, Diag ann)] + -- ^ 'Doc': @(PageWidth -> Diag ann)@ + | Nesting [(Int, Diag ann)] + -- ^ 'Doc': @(Int -> Diag ann)@ + | Annotated ann (Diag ann) + deriving Show + +-- | Convert a 'Doc' to its diagnostic representation. +-- +-- The functions in the 'Column', 'WithPageWidth' and 'Nesting' constructors are +-- sampled with some default values. +-- +-- Use `diag'` to control the function inputs yourself. +-- +-- >>> diag $ Doc.align (Doc.vcat ["foo", "bar"]) +-- Column [(10,Nesting [(10,Cat (Text 3 "foo") (Cat (FlatAlt Line Empty) (Text 3 "bar")))])] +diag :: Doc ann -> Diag ann +diag = diag' [10] [Doc.defaultPageWidth] [10] + +diag' + :: [Int] + -- ^ Cursor positions for the 'Column' constructor + -> [PageWidth] + -- ^ For 'WithPageWidth' + -> [Int] + -- ^ Nesting levels for 'Nesting' + -> Doc ann + -> Diag ann +diag' columns pageWidths nestings = go + where + go doc = case doc of + Doc.Fail -> Fail + Doc.Empty -> Empty + Doc.Char c -> Char c + Doc.Text l t -> Text l t + Doc.Line -> Line + Doc.FlatAlt a b -> FlatAlt (go a) (go b) + Doc.Cat a b -> Cat (go a) (go b) + Doc.Nest i d -> Nest i (go d) + Doc.Union a b -> Union (go a) (go b) + Doc.Column f -> Column (apply f columns) + Doc.WithPageWidth f -> WithPageWidth (apply f pageWidths) + Doc.Nesting f -> Nesting (apply f nestings) + Doc.Annotated ann d -> Annotated ann (go d) + + apply :: (a -> Doc ann) -> [a] -> [(a, Diag ann)] + apply f = map (\x -> (x, go (f x))) + diff --git a/src/Prettyprinter/Internal/Type.hs b/src/Prettyprinter/Internal/Type.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter/Internal/Type.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | __Internal module with stability guarantees__ +-- +-- This module exposes the internals of the @'Doc'@ type so other libraries can +-- write adaptors to/from it. For all other uses, please use only the API +-- provided by non-internal modules. +-- +-- Although this module is internal, it follows the usual package versioning +-- policy, AKA Haskell’s version of semantic versioning. In other words, this +-- module is as stable as the public API. +module Prettyprinter.Internal.Type (Doc(..)) where + +import Prettyprinter.Internal diff --git a/src/Prettyprinter/Render/String.hs b/src/Prettyprinter/Render/String.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter/Render/String.hs @@ -0,0 +1,10 @@ +module Prettyprinter.Render.String ( + renderString, + renderShowS, +) where + +import Prettyprinter.Internal (SimpleDocStream, renderShowS) + +-- | Render a 'SimpleDocStream' to a 'String'. +renderString :: SimpleDocStream ann -> String +renderString s = renderShowS s "" diff --git a/src/Prettyprinter/Render/Text.hs b/src/Prettyprinter/Render/Text.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter/Render/Text.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +#include "version-compatibility-macros.h" + +-- | Render an unannotated 'SimpleDocStream' as plain 'Text'. +module Prettyprinter.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.IO as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import System.IO + +import Prettyprinter +import Prettyprinter.Internal +import Prettyprinter.Render.Util.Panic + +#if !(SEMIGROUP_IN_BASE) +import Data.Semigroup +#endif + +#if !(APPLICATIVE_MONAD) +import Control.Applicative +#endif + +-- $setup +-- +-- (Definitions for the doctests) +-- +-- >>> :set -XOverloadedStrings +-- >>> import qualified Data.Text.IO as T +-- >>> import qualified Data.Text.Lazy.IO as TL + + + +-- | @('renderLazy' sdoc)@ takes the output @sdoc@ from a rendering function +-- and transforms it to lazy text. +-- +-- >>> let render = TL.putStrLn . renderLazy . layoutPretty defaultLayoutOptions +-- >>> let doc = "lorem" <+> align (vsep ["ipsum dolor", parens "foo bar", "sit amet"]) +-- >>> render doc +-- lorem ipsum dolor +-- (foo bar) +-- sit amet +renderLazy :: SimpleDocStream ann -> TL.Text +renderLazy = TLB.toLazyText . go + where + go x = case x of + SFail -> panicUncaughtFail + SEmpty -> mempty + SChar c rest -> TLB.singleton c <> go rest + SText _l t rest -> TLB.fromText t <> go rest + SLine i rest -> TLB.singleton '\n' <> (TLB.fromText (textSpaces i) <> go rest) + SAnnPush _ann rest -> go rest + SAnnPop rest -> go rest + +-- | @('renderStrict' sdoc)@ takes the output @sdoc@ from a rendering function +-- and transforms it to strict text. +renderStrict :: SimpleDocStream ann -> Text +renderStrict = TL.toStrict . renderLazy + + + +-- | @('renderIO' h sdoc)@ writes @sdoc@ to the file @h@. +-- +-- >>> renderIO System.IO.stdout (layoutPretty defaultLayoutOptions "hello\nworld") +-- hello +-- world +-- +-- This function is more efficient than @'T.hPutStr' h ('renderStrict' sdoc)@, +-- since it writes to the handle directly, skipping the intermediate 'Text' +-- representation. +renderIO :: Handle -> SimpleDocStream ann -> IO () +renderIO h = go + where + go :: SimpleDocStream ann -> IO () + go = \sds -> case sds of + SFail -> panicUncaughtFail + SEmpty -> pure () + SChar c rest -> do hPutChar h c + go rest + SText _ t rest -> do T.hPutStr h t + go rest + SLine n rest -> do hPutChar h '\n' + T.hPutStr h (textSpaces n) + go rest + SAnnPush _ann rest -> go rest + SAnnPop rest -> go rest + +-- | @('putDoc' doc)@ prettyprints document @doc@ to standard output. Uses the +-- 'defaultLayoutOptions'. +-- +-- >>> putDoc ("hello" <+> "world") +-- hello world +-- +-- @ +-- 'putDoc' = 'hPutDoc' 'stdout' +-- @ +putDoc :: Doc ann -> IO () +putDoc = hPutDoc stdout + +-- | Like 'putDoc', but instead of using 'stdout', print to a user-provided +-- handle, e.g. a file or a socket. Uses the 'defaultLayoutOptions'. +-- +-- @ +-- main = 'withFile' filename (\h -> 'hPutDoc' h doc) +-- where +-- doc = 'vcat' ["vertical", "text"] +-- filename = "someFile.txt" +-- @ +-- +-- @ +-- 'hPutDoc' h doc = 'renderIO' h ('layoutPretty' 'defaultLayoutOptions' doc) +-- @ +hPutDoc :: Handle -> Doc ann -> IO () +hPutDoc h doc = renderIO h (layoutPretty defaultLayoutOptions doc) diff --git a/src/Prettyprinter/Render/Tutorials/StackMachineTutorial.hs b/src/Prettyprinter/Render/Tutorials/StackMachineTutorial.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter/Render/Tutorials/StackMachineTutorial.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +#include "version-compatibility-macros.h" + +-- | This module shows how to write a custom prettyprinter backend, based on +-- directly converting a 'SimpleDocStream' to an output format using a stack +-- machine. For a tree serialization approach, which may be more suitable for +-- certain output formats, see +-- "Prettyprinter.Render.Tutorials.TreeRenderingTutorial". +-- +-- Rendering to ANSI terminal with colors is an important use case for stack +-- machine based rendering. +-- +-- The module is written to be readable top-to-bottom in both Haddock and raw +-- source form. +module Prettyprinter.Render.Tutorials.StackMachineTutorial + {-# DEPRECATED "Writing your own stack machine is probably more efficient and customizable; also consider using »renderSimplyDecorated(A)« instead" #-} + where + +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB + +import Prettyprinter +import Prettyprinter.Internal +import Prettyprinter.Render.Util.Panic +import Prettyprinter.Render.Util.StackMachine + +#if !(APPLICATIVE_MONAD) +import Control.Applicative +#endif + +-- * The type of available markup +-- +-- $standalone-text +-- +-- First, we define a set of valid annotations must be defined, with the goal of +-- defining a @'Doc' 'SimpleHtml'@. We will later define how to convert this to +-- the output format ('TL.Text'). + +data SimpleHtml = Bold | Italics | Color Color | Paragraph | Headline +data Color = Red | Green | Blue + +-- ** Convenience definitions + +bold, italics, paragraph, headline :: Doc SimpleHtml -> Doc SimpleHtml +bold = annotate Bold +italics = annotate Italics +paragraph = annotate Paragraph +headline = annotate Headline + +color :: Color -> Doc SimpleHtml -> Doc SimpleHtml +color c = annotate (Color c) + +-- * The rendering algorithm +-- +-- $standalone-text +-- +-- With the annotation definitions out of the way, we can now define a +-- conversion function from 'SimpleDocStream' annotated with our 'SimpleHtml' to the +-- final 'TL.Text' representation. +-- +-- There are two ways to render this; the simpler one is just using +-- 'renderSimplyDecorated'. However, some output formats require more +-- complicated functionality, so we explore this explicitly with a simple +-- example below. An example for something more complicated is ANSI terminal +-- rendering, where on popping we need to regenerate the previous style, +-- requiring a pop (discard current style) followed by a peek (regenerate +-- previous style). + +-- | The 'StackMachine' type defines a stack machine suitable for many rendering +-- needs. It has two auxiliary parameters: the type of the end result, and the +-- type of the document’s annotations. +-- +-- Most 'StackMachine' creations will look like this definition: a recursive +-- walk through the 'SimpleDocStream', pushing styles on the stack and popping +-- them off again, and writing raw output. +-- +-- The equivalent to this in the tree based rendering approach is +-- 'Prettyprinter.Render.Tutorials.TreeRenderingTutorial.renderTree'. +renderStackMachine :: SimpleDocStream SimpleHtml -> StackMachine TLB.Builder SimpleHtml () +renderStackMachine = \sds -> case sds of + SFail -> panicUncaughtFail + SEmpty -> pure () + SChar c x -> do + writeOutput (TLB.singleton c) + renderStackMachine x + SText _l t x -> do + writeOutput (TLB.fromText t) + renderStackMachine x + SLine i x -> do + writeOutput (TLB.singleton '\n') + writeOutput (TLB.fromText (textSpaces i)) + renderStackMachine x + SAnnPush s x -> do + pushStyle s + writeOutput (fst (htmlTag s)) + renderStackMachine x + SAnnPop x -> do + s <- unsafePopStyle + writeOutput (snd (htmlTag s)) + renderStackMachine x + +-- | Convert a 'SimpleHtml' annotation to a pair of opening and closing tags. +-- This is where the translation of style to raw output happens. +htmlTag :: SimpleHtml -> (TLB.Builder, TLB.Builder) +htmlTag = \sh -> case sh of + Bold -> ("", "") + Italics -> ("", "") + Color c -> (" hexCode c <> "\">", "") + Paragraph -> ("

", "

") + Headline -> ("

", "

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

Example document

+--

This is a paragraph,

+--

and this text is bold.

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

" <> x <> "

" + Headline -> \x -> "

" <> x <> "

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

Example document

+--

This is a paragraph,

+--

and this text is bold.

diff --git a/src/Prettyprinter/Render/Util/Panic.hs b/src/Prettyprinter/Render/Util/Panic.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter/Render/Util/Panic.hs @@ -0,0 +1,38 @@ +module Prettyprinter.Render.Util.Panic ( + panicUncaughtFail, + panicUnpairedPop, + panicSimpleDocTreeConversionFailed, + panicInputNotFullyConsumed, + panicPeekedEmpty, + panicPoppedEmpty, +) where + +-- | Raise a hard 'error' if there is a 'Prettyprinter.SFail' in a +-- 'Prettyprinter.SimpleDocStream'. +panicUncaughtFail :: void +panicUncaughtFail = error ("»SFail« must not appear in a rendered »SimpleDocStream«. This is a bug in the layout algorithm! " ++ report) + +-- | Raise a hard 'error' when an annotation terminator is encountered in an +-- unannotated region. +panicUnpairedPop :: void +panicUnpairedPop = error ("An unpaired style terminator was encountered. This is a bug in the layout algorithm! " ++ report) + +-- | Raise a hard generic 'error' when the +-- 'Prettyprinter.SimpleDocStream' to +-- 'Prettyprinter.Render.Util.SimpleDocTree.SimpleDocTree' conversion fails. +panicSimpleDocTreeConversionFailed :: void +panicSimpleDocTreeConversionFailed = error ("Conversion from SimpleDocStream to SimpleDocTree failed! " ++ report) + +-- | Raise a hard 'error' when the »to +-- 'Prettyprinter.Render.Util.SimpleDocTree.SimpleDocTree'« parser finishes +-- without consuming the full input. +panicInputNotFullyConsumed :: void +panicInputNotFullyConsumed = error ("Conversion from SimpleDocStream to SimpleDocTree left unconsumed input! " ++ report) + +report :: String +report = "Please report this as a bug" + +panicPeekedEmpty, panicPoppedEmpty :: void +(panicPeekedEmpty, panicPoppedEmpty) = (mkErr "Peeked", mkErr "Popped") + where + mkErr x = error (x ++ " an empty style stack! Please report this as a bug.") diff --git a/src/Prettyprinter/Render/Util/SimpleDocTree.hs b/src/Prettyprinter/Render/Util/SimpleDocTree.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter/Render/Util/SimpleDocTree.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +#include "version-compatibility-macros.h" + +-- | Conversion of the linked-list-like 'SimpleDocStream' to a tree-like +-- 'SimpleDocTree'. +module Prettyprinter.Render.Util.SimpleDocTree ( + + -- * Type and conversion + SimpleDocTree(..), + treeForm, + + -- * Manipulating annotations + unAnnotateST, + reAnnotateST, + alterAnnotationsST, + + -- * Common use case shortcut definitions + renderSimplyDecorated, + renderSimplyDecoratedA, +) where + + + +import Control.Applicative +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable (Typeable) +import GHC.Generics + +import Prettyprinter +import Prettyprinter.Internal +import Prettyprinter.Render.Util.Panic + +import qualified Control.Monad.Fail as Fail + +#if !(MONOID_IN_PRELUDE) +import Data.Monoid (Monoid (..)) +#endif + +#if !(FOLDABLE_TRAVERSABLE_IN_PRELUDE) +import Data.Foldable (Foldable (..)) +import Data.Traversable (Traversable (..)) +#endif + +-- $setup +-- +-- (Definitions for the doctests) +-- +-- >>> import Prettyprinter hiding ((<>)) +-- >>> import qualified Data.Text.IO as T + + + +-- | Simplest possible tree-based renderer. +-- +-- For example, here is a document annotated with @()@, and the behaviour is to +-- surround annotated regions with »>>>« and »<<<«: +-- +-- >>> let doc = "hello" <+> annotate () "world" <> "!" +-- >>> let stdoc = treeForm (layoutPretty defaultLayoutOptions doc) +-- >>> T.putStrLn (renderSimplyDecorated id (\() x -> ">>>" <> x <> "<<<") stdoc) +-- hello >>>world<< (Text -> out) -- ^ Render plain 'Text' + -> (ann -> out -> out) -- ^ How to modify an element with an annotation + -> SimpleDocTree ann + -> out +renderSimplyDecorated text renderAnn = go + where + go = \sdt -> case sdt of + STEmpty -> mempty + STChar c -> text (T.singleton c) + STText _ t -> text t + STLine i -> text (T.singleton '\n') `mappend` text (textSpaces i) + STAnn ann rest -> renderAnn ann (go rest) + STConcat xs -> foldMap go xs +{-# INLINE renderSimplyDecorated #-} + +-- | Version of 'renderSimplyDecoratedA' that allows for 'Applicative' effects. +renderSimplyDecoratedA + :: (Applicative f, Monoid out) + => (Text -> f out) -- ^ Render plain 'Text' + -> (ann -> f out -> f out) -- ^ How to modify an element with an annotation + -> SimpleDocTree ann + -> f out +renderSimplyDecoratedA text renderAnn = go + where + go = \sdt -> case sdt of + STEmpty -> pure mempty + STChar c -> text (T.singleton c) + STText _ t -> text t + STLine i -> text (T.cons '\n' (textSpaces i)) + STAnn ann rest -> renderAnn ann (go rest) + STConcat xs -> fmap mconcat (traverse go xs) +{-# INLINE renderSimplyDecoratedA #-} + + + +-- | A type for parsers of unique results. Token stream »s«, results »a«. +-- +-- Hand-written to avoid a dependency on a parser lib. +newtype UniqueParser s a = UniqueParser { runParser :: s -> Maybe (a, s) } + deriving Typeable + +instance Functor (UniqueParser s) where + fmap f (UniqueParser mx) = UniqueParser (\s -> + fmap (\(x,s') -> (f x, s')) (mx s)) + +instance Applicative (UniqueParser s) where + pure x = UniqueParser (\rest -> Just (x, rest)) + UniqueParser mf <*> UniqueParser mx = UniqueParser (\s -> do + (f, s') <- mf s + (x, s'') <- mx s' + pure (f x, s'') ) + +instance Monad (UniqueParser s) where + UniqueParser p >>= f = UniqueParser (\s -> do + (a', s') <- p s + let UniqueParser p' = f a' + p' s' ) + +#if !(APPLICATIVE_MONAD) + return = pure +#endif +#if FAIL_IN_MONAD + fail = Fail.fail +#endif + +instance Fail.MonadFail (UniqueParser s) where + fail _err = empty + +instance Alternative (UniqueParser s) where + empty = UniqueParser (const empty) + UniqueParser p <|> UniqueParser q = UniqueParser (\s -> p s <|> q s) + +data SimpleDocTok ann + = TokEmpty + | TokChar Char + | TokText !Int Text + | TokLine Int + | TokAnnPush ann + | TokAnnPop + deriving (Eq, Ord, Show, Typeable) + +-- | A 'SimpleDocStream' is a linked list of different annotated cons cells +-- ('SText' and then some further 'SimpleDocStream', 'SLine' and then some +-- further 'SimpleDocStream', …). This format is very suitable as a target for a +-- layout engine, but not very useful for rendering to a structured format such +-- as HTML, where we don’t want to do a lookahead until the end of some markup. +-- These formats benefit from a tree-like structure that explicitly marks its +-- contents as annotated. 'SimpleDocTree' is that format. +data SimpleDocTree ann + = STEmpty + | STChar Char + + -- | 'Data.Text.length' is /O(n)/, so we cache it in the 'Int' field. + | STText !Int Text + + -- | @Int@ = indentation level for the (next) line + | STLine !Int + + -- | Annotate the contained document. + | STAnn ann (SimpleDocTree ann) + + -- | Horizontal concatenation of multiple documents. + | STConcat [SimpleDocTree ann] + deriving (Eq, Ord, Show, Generic, Typeable) + +-- | Alter the document’s annotations. +-- +-- This instance makes 'SimpleDocTree' more flexible (because it can be used in +-- 'Functor'-polymorphic values), but @'fmap'@ is much less readable compared to +-- using @'reAnnotateST'@ in code that only works for @'SimpleDocTree'@ anyway. +-- Consider using the latter when the type does not matter. +instance Functor SimpleDocTree where + fmap = reAnnotateST + +-- | Get the next token, consuming it in the process. +nextToken :: UniqueParser (SimpleDocStream ann) (SimpleDocTok ann) +nextToken = UniqueParser (\sds -> case sds of + SFail -> panicUncaughtFail + SEmpty -> empty + SChar c rest -> Just (TokChar c , rest) + SText l t rest -> Just (TokText l t , rest) + SLine i rest -> Just (TokLine i , rest) + SAnnPush ann rest -> Just (TokAnnPush ann , rest) + SAnnPop rest -> Just (TokAnnPop , rest) ) + +sdocToTreeParser :: UniqueParser (SimpleDocStream ann) (SimpleDocTree ann) +sdocToTreeParser = fmap wrap (many contentPiece) + + where + + wrap :: [SimpleDocTree ann] -> SimpleDocTree ann + wrap = \sdts -> case sdts of + [] -> STEmpty + [x] -> x + xs -> STConcat xs + + contentPiece = nextToken >>= \tok -> case tok of + TokEmpty -> pure STEmpty + TokChar c -> pure (STChar c) + TokText l t -> pure (STText l t) + TokLine i -> pure (STLine i) + TokAnnPop -> empty + TokAnnPush ann -> do annotatedContents <- sdocToTreeParser + TokAnnPop <- nextToken + pure (STAnn ann annotatedContents) + +-- | Convert a 'SimpleDocStream' to its 'SimpleDocTree' representation. +treeForm :: SimpleDocStream ann -> SimpleDocTree ann +treeForm sdoc = case runParser sdocToTreeParser sdoc of + Nothing -> panicSimpleDocTreeConversionFailed + Just (sdoct, SEmpty) -> sdoct + Just (_, _unconsumed) -> panicInputNotFullyConsumed + +-- $ +-- +-- >>> :set -XOverloadedStrings +-- >>> treeForm (layoutPretty defaultLayoutOptions ("lorem" <+> "ipsum" <+> annotate True ("TRUE" <+> annotate False "FALSE") <+> "dolor")) +-- STConcat [STText 5 "lorem",STChar ' ',STText 5 "ipsum",STChar ' ',STAnn True (STConcat [STText 4 "TRUE",STChar ' ',STAnn False (STText 5 "FALSE")]),STChar ' ',STText 5 "dolor"] + +-- | Remove all annotations. 'unAnnotate' for 'SimpleDocTree'. +unAnnotateST :: SimpleDocTree ann -> SimpleDocTree xxx +unAnnotateST = alterAnnotationsST (const []) + +-- | Change the annotation of a document. 'reAnnotate' for 'SimpleDocTree'. +reAnnotateST :: (ann -> ann') -> SimpleDocTree ann -> SimpleDocTree ann' +reAnnotateST f = alterAnnotationsST (pure . f) + +-- | Change the annotation of a document to a different annotation, or none at +-- all. 'alterAnnotations' for 'SimpleDocTree'. +-- +-- Note that this is as powerful as 'alterAnnotations', allowing one annotation +-- to become multiple ones, contrary to 'alterAnnotationsS', which cannot do +-- this. +alterAnnotationsST :: (ann -> [ann']) -> SimpleDocTree ann -> SimpleDocTree ann' +alterAnnotationsST re = go + where + go = \sdt -> case sdt of + STEmpty -> STEmpty + STChar c -> STChar c + STText l t -> STText l t + STLine i -> STLine i + STConcat xs -> STConcat (map go xs) + STAnn ann rest -> Prelude.foldr STAnn (go rest) (re ann) + +-- | Collect all annotations from a document. +instance Foldable SimpleDocTree where + foldMap f = go + where + go = \sdt -> case sdt of + STEmpty -> mempty + STChar _ -> mempty + STText _ _ -> mempty + STLine _ -> mempty + STAnn ann rest -> f ann `mappend` go rest + STConcat xs -> mconcat (map go xs) + +-- | Transform a document based on its annotations, possibly leveraging +-- 'Applicative' effects. +instance Traversable SimpleDocTree where + traverse f = go + where + go = \sdt -> case sdt of + STEmpty -> pure STEmpty + STChar c -> pure (STChar c) + STText l t -> pure (STText l t) + STLine i -> pure (STLine i) + STAnn ann rest -> STAnn <$> f ann <*> go rest + STConcat xs -> STConcat <$> traverse go xs diff --git a/src/Prettyprinter/Render/Util/StackMachine.hs b/src/Prettyprinter/Render/Util/StackMachine.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter/Render/Util/StackMachine.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} + +#include "version-compatibility-macros.h" + +-- | Definitions to write renderers based on looking at a 'SimpleDocStream' as +-- an instruction tape for a stack machine: text is written, annotations are +-- added (pushed) and later removed (popped). +module Prettyprinter.Render.Util.StackMachine ( + + -- * Simple, pre-defined stack machines + -- + -- | These cover most basic use cases where there is not too much special + -- logic, and all that’s important is how to render text, and how to + -- add/remove an annotation. + renderSimplyDecorated, + renderSimplyDecoratedA, + + -- * General stack machine + -- + -- | These definitions allow defining a full-blown stack machine renderer, + -- allowing for arbitrary peeking, popping and what not. + StackMachine, + execStackMachine, + + pushStyle, + unsafePopStyle, + unsafePeekStyle, + writeOutput, +) where + + + +import Control.Applicative +import Data.Text (Text) +import qualified Data.Text as T + +import Prettyprinter.Internal +import Prettyprinter.Render.Util.Panic + +#if !(SEMIGROUP_MONOID_SUPERCLASS) +import Data.Monoid +#endif + + +-- $setup +-- +-- (Definitions for the doctests) +-- +-- >>> import Prettyprinter hiding ((<>)) +-- >>> import qualified Data.Text.IO as T + + + +-- | Simplest possible stack-based renderer. +-- +-- For example, here is a document annotated with @()@, and the behaviour is to +-- write »>>>« at the beginning, and »<<<« at the end of the annotated region: +-- +-- >>> let doc = "hello" <+> annotate () "world" <> "!" +-- >>> let sdoc = layoutPretty defaultLayoutOptions doc +-- >>> T.putStrLn (renderSimplyDecorated id (\() -> ">>>") (\() -> "<<<") sdoc) +-- hello >>>world<< (Text -> out) -- ^ Render plain 'Text' + -> (ann -> out) -- ^ How to render an annotation + -> (ann -> out) -- ^ How to render the removed annotation + -> SimpleDocStream ann + -> out +renderSimplyDecorated text push pop = go [] + where + go _ SFail = panicUncaughtFail + go [] SEmpty = mempty + go (_:_) SEmpty = panicInputNotFullyConsumed + go stack (SChar c rest) = text (T.singleton c) <> go stack rest + go stack (SText _l t rest) = text t <> go stack rest + go stack (SLine i rest) = text (T.singleton '\n') <> text (textSpaces i) <> go stack rest + go stack (SAnnPush ann rest) = push ann <> go (ann : stack) rest + go (ann:stack) (SAnnPop rest) = pop ann <> go stack rest + go [] SAnnPop{} = panicUnpairedPop +{-# INLINE renderSimplyDecorated #-} + +-- | Version of 'renderSimplyDecoratedA' that allows for 'Applicative' effects. +renderSimplyDecoratedA + :: (Applicative f, Monoid out) + => (Text -> f out) -- ^ Render plain 'Text' + -> (ann -> f out) -- ^ How to render an annotation + -> (ann -> f out) -- ^ How to render the removed annotation + -> SimpleDocStream ann + -> f out +renderSimplyDecoratedA text push pop = go [] + where + go _ SFail = panicUncaughtFail + go [] SEmpty = pure mempty + go (_:_) SEmpty = panicInputNotFullyConsumed + go stack (SChar c rest) = text (T.singleton c) <++> go stack rest + go stack (SText _l t rest) = text t <++> go stack rest + go stack (SLine i rest) = text (T.singleton '\n') <++> text (textSpaces i) <++> go stack rest + go stack (SAnnPush ann rest) = push ann <++> go (ann : stack) rest + go (ann:stack) (SAnnPop rest) = pop ann <++> go stack rest + go [] SAnnPop{} = panicUnpairedPop + + (<++>) = liftA2 mappend +{-# INLINE renderSimplyDecoratedA #-} + + + +-- | @WriterT output StateT [style] a@, but with a strict Writer value. +-- +-- The @output@ type is used to append data chunks to, the @style@ is the member +-- of a stack of styles to model nested styles with. +newtype StackMachine output style a = StackMachine ([style] -> (a, output, [style])) +{-# DEPRECATED StackMachine "Writing your own stack machine is probably more efficient and customizable; also consider using »renderSimplyDecorated(A)« instead" #-} + +instance Functor (StackMachine output style) where + fmap f (StackMachine r) = StackMachine (\s -> + let (x1, w1, s1) = r s + in (f x1, w1, s1)) + +instance Monoid output => Applicative (StackMachine output style) where + pure x = StackMachine (\s -> (x, mempty, s)) + StackMachine f <*> StackMachine x = StackMachine (\s -> + let (f1, w1, s1) = f s + (x2, w2, s2) = x s1 + !w12 = w1 <> w2 + in (f1 x2, w12, s2)) + +instance Monoid output => Monad (StackMachine output style) where +#if !(APPLICATIVE_MONAD) + return = pure +#endif + StackMachine r >>= f = StackMachine (\s -> + let (x1, w1, s1) = r s + StackMachine r1 = f x1 + (x2, w2, s2) = r1 s1 + !w12 = w1 <> w2 + in (x2, w12, s2)) + +-- | Add a new style to the style stack. +pushStyle :: Monoid output => style -> StackMachine output style () +pushStyle style = StackMachine (\styles -> ((), mempty, style : styles)) + +-- | Get the topmost style. +-- +-- If the stack is empty, this raises an 'error'. +unsafePopStyle :: Monoid output => StackMachine output style style +unsafePopStyle = StackMachine (\stack -> case stack of + x:xs -> (x, mempty, xs) + [] -> panicPoppedEmpty ) + +-- | View the topmost style, but do not modify the stack. +-- +-- If the stack is empty, this raises an 'error'. +unsafePeekStyle :: Monoid output => StackMachine output style style +unsafePeekStyle = StackMachine (\styles -> case styles of + x:_ -> (x, mempty, styles) + [] -> panicPeekedEmpty ) + +-- | Append a value to the output end. +writeOutput :: output -> StackMachine output style () +writeOutput w = StackMachine (\styles -> ((), w, styles)) + +-- | Run the renderer and retrive the writing end +execStackMachine :: [styles] -> StackMachine output styles a -> (output, [styles]) +execStackMachine styles (StackMachine r) = let (_, w, s) = r styles in (w, s) diff --git a/src/Prettyprinter/Symbols/Ascii.hs b/src/Prettyprinter/Symbols/Ascii.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter/Symbols/Ascii.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +#include "version-compatibility-macros.h" + +-- | Common symbols composed out of the ASCII subset of Unicode. For non-ASCII +-- symbols, see "Prettyprinter.Symbols.Unicode". +module Prettyprinter.Symbols.Ascii where + + + +import Prettyprinter.Internal + + + +-- | >>> squotes "·" +-- '·' +squotes :: Doc ann -> Doc ann +squotes = enclose squote squote + +-- | >>> dquotes "·" +-- "·" +dquotes :: Doc ann -> Doc ann +dquotes = enclose dquote dquote + +-- | >>> parens "·" +-- (·) +parens :: Doc ann -> Doc ann +parens = enclose lparen rparen + +-- | >>> angles "·" +-- <·> +angles :: Doc ann -> Doc ann +angles = enclose langle rangle + +-- | >>> brackets "·" +-- [·] +brackets :: Doc ann -> Doc ann +brackets = enclose lbracket rbracket + +-- | >>> braces "·" +-- {·} +braces :: Doc ann -> Doc ann +braces = enclose lbrace rbrace + +-- | >>> squote +-- ' +squote :: Doc ann +squote = Char '\'' + +-- | >>> dquote +-- " +dquote :: Doc ann +dquote = Char '"' + +-- | >>> lparen +-- ( +lparen :: Doc ann +lparen = Char '(' + +-- | >>> rparen +-- ) +rparen :: Doc ann +rparen = Char ')' + +-- | >>> langle +-- < +langle :: Doc ann +langle = Char '<' + +-- | >>> rangle +-- > +rangle :: Doc ann +rangle = Char '>' + +-- | >>> lbracket +-- [ +lbracket :: Doc ann +lbracket = Char '[' +-- | >>> rbracket +-- ] +rbracket :: Doc ann +rbracket = Char ']' + +-- | >>> lbrace +-- { +lbrace :: Doc ann +lbrace = Char '{' +-- | >>> rbrace +-- } +rbrace :: Doc ann +rbrace = Char '}' + +-- | >>> semi +-- ; +semi :: Doc ann +semi = Char ';' + +-- | >>> colon +-- : +colon :: Doc ann +colon = Char ':' + +-- | >>> comma +-- , +comma :: Doc ann +comma = Char ',' + +-- | >>> "a" <> space <> "b" +-- a b +-- +-- This is mostly used via @'<+>'@, +-- +-- >>> "a" <+> "b" +-- a b +space :: Doc ann +space = Char ' ' + +-- | >>> dot +-- . +dot :: Doc ann +dot = Char '.' + +-- | >>> slash +-- / +slash :: Doc ann +slash = Char '/' + +-- | >>> backslash +-- \\ + +backslash :: Doc ann +backslash = "\\" + +-- | >>> equals +-- = +equals :: Doc ann +equals = Char '=' + +-- | >>> pipe +-- | +pipe :: Doc ann +pipe = Char '|' + + + +-- $setup +-- +-- (Definitions for the doctests) +-- +-- >>> :set -XOverloadedStrings +-- >>> import Data.Semigroup +-- >>> import Prettyprinter.Render.Text +-- >>> import Prettyprinter.Util diff --git a/src/Prettyprinter/Symbols/Unicode.hs b/src/Prettyprinter/Symbols/Unicode.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter/Symbols/Unicode.hs @@ -0,0 +1,210 @@ +-- | A collection of predefined Unicode values outside of ASCII range. For +-- ASCII, see "Prettyprinter.Symbols.Ascii". +module Prettyprinter.Symbols.Unicode ( + -- * Quotes + + -- ** Enclosing + d9966quotes, + d6699quotes, + s96quotes, + s69quotes, + dGuillemetsOut, + dGuillemetsIn, + sGuillemetsOut, + sGuillemetsIn, + + -- ** Standalone + b99dquote, + t66dquote, + t99dquote, + b9quote, + t6quote, + t9quote, + + rdGuillemet, + ldGuillemet, + rsGuillemet, + lsGuillemet, + + -- * Various typographical symbols + bullet, + endash, + + -- * Currencies + euro, + cent, + yen, + pound, +) where + + + +import Prettyprinter.Internal + + + +-- | Double „99-66“ quotes, as used in German typography. +-- +-- >>> putDoc (d9966quotes "·") +-- „·“ +d9966quotes :: Doc ann -> Doc ann +d9966quotes = enclose b99dquote t66dquote + +-- | Double “66-99” quotes, as used in English typography. +-- +-- >>> putDoc (d6699quotes "·") +-- “·” +d6699quotes :: Doc ann -> Doc ann +d6699quotes = enclose t66dquote t99dquote + +-- | Single ‚9-6‘ quotes, as used in German typography. +-- +-- >>> putDoc (s96quotes "·") +-- ‚·‘ +s96quotes :: Doc ann -> Doc ann +s96quotes = enclose b9quote t6quote + +-- | Single ‘6-9’ quotes, as used in English typography. +-- +-- >>> putDoc (s69quotes "·") +-- ‘·’ +s69quotes :: Doc ann -> Doc ann +s69quotes = enclose t6quote t9quote + +-- | Double «guillemets», pointing outwards (without adding any spacing). +-- +-- >>> putDoc (dGuillemetsOut "·") +-- «·» +dGuillemetsOut :: Doc ann -> Doc ann +dGuillemetsOut = enclose ldGuillemet rdGuillemet + +-- | Double »guillemets«, pointing inwards (without adding any spacing). +-- +-- >>> putDoc (dGuillemetsIn "·") +-- »·« +dGuillemetsIn :: Doc ann -> Doc ann +dGuillemetsIn = enclose rdGuillemet ldGuillemet + +-- | Single ‹guillemets›, pointing outwards (without adding any spacing). +-- +-- >>> putDoc (sGuillemetsOut "·") +-- ‹·› +sGuillemetsOut :: Doc ann -> Doc ann +sGuillemetsOut = enclose lsGuillemet rsGuillemet + +-- | Single ›guillemets‹, pointing inwards (without adding any spacing). +-- +-- >>> putDoc (sGuillemetsIn "·") +-- ›·‹ +sGuillemetsIn :: Doc ann -> Doc ann +sGuillemetsIn = enclose rsGuillemet lsGuillemet + +-- | Bottom „99“ style double quotes. +-- +-- >>> putDoc b99dquote +-- „ +b99dquote :: Doc ann +b99dquote = Char '„' + +-- | Top “66” style double quotes. +-- +-- >>> putDoc t66dquote +-- “ +t66dquote :: Doc ann +t66dquote = Char '“' + +-- | Top “99” style double quotes. +-- +-- >>> putDoc t99dquote +-- ” +t99dquote :: Doc ann +t99dquote = Char '”' + +-- | Bottom ‚9‘ style single quote. +-- +-- >>> putDoc b9quote +-- ‚ +b9quote :: Doc ann +b9quote = Char '‚' + +-- | Top ‘66’ style single quote. +-- +-- >>> putDoc t6quote +-- ‘ +t6quote :: Doc ann +t6quote = Char '‘' + +-- | Top ‘9’ style single quote. +-- +-- >>> putDoc t9quote +-- ’ +t9quote :: Doc ann +t9quote = Char '’' + +-- | Right-pointing double guillemets +-- +-- >>> putDoc rdGuillemet +-- » +rdGuillemet :: Doc ann +rdGuillemet = Char '»' + +-- | Left-pointing double guillemets +-- +-- >>> putDoc ldGuillemet +-- « +ldGuillemet :: Doc ann +ldGuillemet = Char '«' + +-- | Right-pointing single guillemets +-- +-- >>> putDoc rsGuillemet +-- › +rsGuillemet :: Doc ann +rsGuillemet = Char '›' + +-- | Left-pointing single guillemets +-- +-- >>> putDoc lsGuillemet +-- ‹ +lsGuillemet :: Doc ann +lsGuillemet = Char '‹' + +-- | >>> putDoc bullet +-- • +bullet :: Doc ann +bullet = Char '•' + +-- | >>> putDoc endash +-- – +endash :: Doc ann +endash = Char '–' + +-- | >>> putDoc euro +-- € +euro :: Doc ann +euro = Char '€' + +-- | >>> putDoc cent +-- ¢ +cent :: Doc ann +cent = Char '¢' + +-- | >>> putDoc yen +-- ¥ +yen :: Doc ann +yen = Char '¥' + +-- | >>> putDoc pound +-- £ +pound :: Doc ann +pound = Char '£' + + + +-- $setup +-- +-- (Definitions for the doctests) +-- +-- >>> :set -XOverloadedStrings +-- >>> import Prettyprinter.Render.Text +-- >>> import Prettyprinter.Util diff --git a/src/Prettyprinter/Util.hs b/src/Prettyprinter/Util.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter/Util.hs @@ -0,0 +1,65 @@ +-- | Frequently useful definitions for working with general prettyprinters. +module Prettyprinter.Util ( + module Prettyprinter.Util +) where + + + +import Data.Text (Text) +import qualified Data.Text as T +import Prettyprinter.Render.Text +import Prelude hiding (words) +import System.IO + +import Prettyprinter + + + +-- | Split an input into word-sized 'Doc's. +-- +-- >>> putDoc (tupled (words "Lorem ipsum dolor")) +-- (Lorem, ipsum, dolor) +words :: Text -> [Doc ann] +words = map pretty . T.words + +-- | Insert soft linebreaks between words, so that text is broken into multiple +-- lines when it exceeds the available width. +-- +-- >>> putDocW 32 (reflow "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.") +-- Lorem ipsum dolor sit amet, +-- consectetur adipisicing elit, +-- sed do eiusmod tempor incididunt +-- ut labore et dolore magna +-- aliqua. +-- +-- @ +-- 'reflow' = 'fillSep' . 'words' +-- @ +reflow :: Text -> Doc ann +reflow = fillSep . words + +-- | Render a document with a certain width. Useful for quick-and-dirty testing +-- of layout behaviour. Used heavily in the doctests of this package, for +-- example. +-- +-- >>> let doc = reflow "Lorem ipsum dolor sit amet, consectetur adipisicing elit" +-- >>> putDocW 20 doc +-- Lorem ipsum dolor +-- sit amet, +-- consectetur +-- adipisicing elit +-- >>> putDocW 30 doc +-- Lorem ipsum dolor sit amet, +-- consectetur adipisicing elit +putDocW :: Int -> Doc ann -> IO () +putDocW w doc = renderIO System.IO.stdout (layoutPretty layoutOptions (unAnnotate doc)) + where + layoutOptions = LayoutOptions { layoutPageWidth = AvailablePerLine w 1 } + + + +-- $setup +-- +-- (Definitions for the doctests) +-- +-- >>> :set -XOverloadedStrings diff --git a/test/Testsuite/Main.hs b/test/Testsuite/Main.hs --- a/test/Testsuite/Main.hs +++ b/test/Testsuite/Main.hs @@ -88,6 +88,10 @@ [ testCase "Line" regressionUnboundedGroupedLine , testCase "Line within align" regressionUnboundedGroupedLineWithinAlign ] + , testCase "Indentation on otherwise empty lines results in trailing whitespace (#139)" + indentationShouldntCauseTrailingWhitespaceOnOtherwiseEmptyLines + , testCase "Ribbon width should be computed with `floor` instead of `round` (#157)" + computeRibbonWidthWithFloor ] ] @@ -379,4 +383,20 @@ doc = group (align ("x" <> hardline <> "y")) sdoc = layoutPretty (LayoutOptions Unbounded) doc expected = SChar 'x' (SLine 0 (SChar 'y' SEmpty)) + in assertEqual "" expected sdoc + +indentationShouldntCauseTrailingWhitespaceOnOtherwiseEmptyLines :: Assertion +indentationShouldntCauseTrailingWhitespaceOnOtherwiseEmptyLines + = let doc :: Doc () + doc = indent 1 ("x" <> hardline <> hardline <> "y" <> hardline) + sdoc = layoutPretty (LayoutOptions Unbounded) doc + expected = SChar ' ' (SChar 'x' (SLine 0 (SLine 1 (SChar 'y' (SLine 0 SEmpty))))) + in assertEqual "" expected sdoc + +computeRibbonWidthWithFloor :: Assertion +computeRibbonWidthWithFloor + = let doc :: Doc () + doc = "a" <> softline' <> "b" + sdoc = layoutPretty (LayoutOptions (AvailablePerLine 3 0.5)) doc + expected = SChar 'a' (SLine 0 (SChar 'b' SEmpty)) in assertEqual "" expected sdoc