diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md new file mode 100644 --- /dev/null +++ b/CONTRIBUTORS.md @@ -0,0 +1,24 @@ +# Contributors + +A list of people that have contributed to this library, be it code, ideas, or +even just as rubber ducks. :-) + +Ordered by earliest appearance in the git log. + +## `prettyprinter` library (this one) + +- Moritz Kiefer, @cocreature +- Daniel Mendler, @minad – several ideas after the preliminary release +- David Luposchainsky, @quchen – current maintainer + +## `ansi-wl-pprint` (origin forked from) + +- Edward Kmett, @edwardk – maintainer of `ansi-wl-pprint` +- Herbert Valerio Riedel, @hvr +- Bradford Larsen +- Sebastian Witte +- Andrew Shulaev +- David Fox +- Max Bolingbroke +- Samir Jindel +- Bryan O'Sullivan, @bos diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,8 +5,8 @@ A modern Wadler/Leijen Prettyprinter ==================================== -[![status](https://img.shields.io/github/release/quchen/prettyprinter.svg?style=flat-square&label=Latest%20version)](https://github.com/quchen/prettyprinter/releases) -[![status](https://img.shields.io/travis/quchen/prettyprinter/master.svg?style=flat-square&label=Master%20build)](https://travis-ci.org/quchen/prettyprinter) +[![](https://img.shields.io/travis/quchen/prettyprinter/master.svg?style=flat-square&label=Master%20build)](https://travis-ci.org/quchen/prettyprinter) +[![](https://img.shields.io/github/release/quchen/prettyprinter.svg?style=flat-square&label=Latest%20version&colorB=0a7bbb)](https://github.com/quchen/prettyprinter/releases) [![](https://img.shields.io/hackage/v/prettyprinter.svg?style=flat-square&label=Hackage&colorB=0a7bbb)](https://hackage.haskell.org/package/prettyprinter) [![](https://www.stackage.org/package/prettyprinter/badge/lts?style=flat-square&label=Stackage&colorB=0a7bbb)](https://www.stackage.org/package/prettyprinter) @@ -15,10 +15,28 @@ A prettyprinter/text rendering engine. Easy to use, well-documented, ANSI terminal backend exists, HTML backend is trivial to implement, no name clashes, -Text-based, extensible. +`Text`-based, extensible. +```haskell +let prettyType = align . sep . zipWith (<+>) ("::" : repeat "->") + prettySig name ty = pretty name <+> prettyType ty +in prettySig "example" ["Int", "Bool", "Char", "IO ()"] +``` +```haskell +-- Output for wide enough formats: +example :: Int -> Bool -> Char -> IO () +-- Output for narrow formats: +example :: Int + -> Bool + -> Char + -> IO () +``` + + + + Longer; want to read -------------------- @@ -44,7 +62,7 @@ ### `Text` instead of `String` `String` has exactly one use, and that’s showing Hello World in tutorials. For -all other uses, Text is what people should be using. The prettyprinter uses no +all other uses, `Text` is what people should be using. The prettyprinter uses no `String` definitions anywhere; using a `String` means an immediate conversion to the internal `Text`-based format. @@ -77,7 +95,8 @@ More complex uses of annotations include e.g. adding type annotations for mouse-over hovers when printing a syntax tree, adding URLs to documentation, or adding source locations to show where a certain piece of output comes from. -Idris is a project that makes extensive use of such a feature. +[Idris](https://github.com/idris-lang/Idris-dev) is a project that makes +extensive use of such a feature. Special care has been applied to make annotations unobtrusive, so that if you don’t need or care about them there is no overhead, neither in terms of @@ -108,11 +127,11 @@ ### Open implementation -The type of documents is unanimously (!) abstract in the other Wadler/Leijen -prettyprinters, making it impossible to write adaptors from one library to -another. The type should be exposed for such purposes so it is possible to write -adaptors from library to library, or each of them is doomed to live on its own -small island of incompatibility. For this reason, the `Doc` type is fully +The type of documents is abstract in most of the other Wadler/Leijen +prettyprinters, making it hard to impossible to write adaptors from one library +to another. The type should be exposed for such purposes so it is possible to +write adaptors from library to library, or each of them is doomed to live on its +own small island of incompatibility. For this reason, the `Doc` type is fully exposed in a semi-internal module for this specific use case. @@ -155,9 +174,11 @@ 4. Use of `Text` instead of `String`. 5. A `fuse` function to optimize often-used documents before rendering for efficiency. - 6. Instead of providing an own colorization function for each - color/intensity/layer combination, they have been combined in 'color' - 'colorDull', 'bgColor', and 'bgColorDull' functions. + 6. SimpleDoc was renamed `SimpleDocStream`, to contrast the new + `SimpleDocTree`. + 7. In the ANSI backend, instead of providing an own colorization function for + each color/intensity/layer combination, they have been combined in /color/ + /colorDull/, /bgColor/, and /bgColorDull/ functions. diff --git a/app/GenerateReadme.hs b/app/GenerateReadme.hs --- a/app/GenerateReadme.hs +++ b/app/GenerateReadme.hs @@ -29,16 +29,37 @@ , h1 "A modern Wadler/Leijen Prettyprinter" - , cat - [ "[![status](https://img.shields.io/github/release/quchen/prettyprinter.svg?style=flat-square&label=Latest%20version)](https://github.com/quchen/prettyprinter/releases)" - , "[![status](https://img.shields.io/travis/quchen/prettyprinter/master.svg?style=flat-square&label=Master%20build)](https://travis-ci.org/quchen/prettyprinter)" - ] + , mconcat + [ "[![](https://img.shields.io/travis/quchen/prettyprinter/master.svg?style=flat-square&label=Master%20build)](https://travis-ci.org/quchen/prettyprinter)" + , " " <> hardline -- Awkwardly enough, two trailing spaces are a small break in Markdown. + , hsep + [ "[![](https://img.shields.io/github/release/quchen/prettyprinter.svg?style=flat-square&label=Latest%20version&colorB=0a7bbb)](https://github.com/quchen/prettyprinter/releases)" + , "[![](https://img.shields.io/hackage/v/prettyprinter.svg?style=flat-square&label=Hackage&colorB=0a7bbb)](https://hackage.haskell.org/package/prettyprinter)" + , "[![](https://www.stackage.org/package/prettyprinter/badge/lts?style=flat-square&label=Stackage&colorB=0a7bbb)](https://www.stackage.org/package/prettyprinter)" ]] , h2 "tl;dr" , paragraph [multiline| A prettyprinter/text rendering engine. Easy to use, well-documented, ANSI terminal backend exists, HTML backend is - trivial to implement, no name clashes, Text-based, extensible. |] + trivial to implement, no name clashes, `Text`-based, extensible. |] + , (pretty . T.unlines) + [ "```haskell" + , "let prettyType = align . sep . zipWith (<+>) (\"::\" : repeat \"->\")" + , " prettySig name ty = pretty name <+> prettyType ty" + , "in prettySig \"example\" [\"Int\", \"Bool\", \"Char\", \"IO ()\"]" + , "```" + , "" + , "```haskell" + , "-- Output for wide enough formats:" + , "example :: Int -> Bool -> Char -> IO ()" + , "" + , "-- Output for narrow formats:" + , "example :: Int" + , " -> Bool" + , " -> Char" + , " -> IO ()" + , "```" ] + , h2 "Longer; want to read" , paragraph [multiline| This package defines a prettyprinter to format text in a flexible and convenient way. The idea is to combine a document @@ -56,10 +77,10 @@ , h3 "`Text` instead of `String`" , paragraph [multiline| `String` has exactly one use, and that’s showing - Hello World in tutorials. For all other uses, Text is what people should - be using. The prettyprinter uses no `String` definitions anywhere; using - a `String` means an immediate conversion to the internal `Text`-based - format. |] + Hello World in tutorials. For all other uses, `Text` is what people + should be using. The prettyprinter uses no `String` definitions + anywhere; using a `String` means an immediate conversion to the internal + `Text`-based format. |] , h3 "Extensive documentation" , paragraph [multiline| The library is stuffed with runnable examples, @@ -83,8 +104,9 @@ , paragraph [multiline| More complex uses of annotations include e.g. adding type annotations for mouse-over hovers when printing a syntax tree, adding URLs to documentation, or adding source locations to show - where a certain piece of output comes from. Idris is a project that - makes extensive use of such a feature. |] + where a certain piece of output comes from. + [Idris](https://github.com/idris-lang/Idris-dev) is a project that makes + extensive use of such a feature. |] , paragraph [multiline| Special care has been applied to make annotations unobtrusive, so that if you don’t need or care about them @@ -108,14 +130,15 @@ cases for the programmer. |] , h3 "Open implementation" - , paragraph [multiline| The type of documents is unanimously (!) - abstract in the other Wadler/Leijen prettyprinters, making it impossible - to write adaptors from one library to another. The type should be - exposed for such purposes so it is possible to write adaptors from - library to library, or each of them is doomed to live on its own small - island of incompatibility. For this reason, the `Doc` type is fully - exposed in a semi-internal module for this specific use case. |] + , paragraph [multiline| The type of documents is abstract in most of the + other Wadler/Leijen prettyprinters, making it hard to impossible to + write adaptors from one library to another. The type should be exposed + for such purposes so it is possible to write adaptors from library to + library, or each of them is doomed to live on its own small island of + incompatibility. For this reason, the `Doc` type is fully exposed in a + semi-internal module for this specific use case. |] + , h2 "The prettyprinter family" , paragraph "The `prettyprinter` family of packages consists of:" , (indent 2 . unorderedList . map paragraph) @@ -154,9 +177,12 @@ , [multiline| Use of `Text` instead of `String`. |] , [multiline| A `fuse` function to optimize often-used documents before rendering for efficiency. |] - , [multiline| Instead of providing an own colorization function for each - color/intensity/layer combination, they have been combined in 'color' - 'colorDull', 'bgColor', and 'bgColorDull' functions. |] + , [multiline| SimpleDoc was renamed `SimpleDocStream`, to contrast the + new `SimpleDocTree`. |] + , [multiline| In the ANSI backend, instead of providing an own + colorization function for each color/intensity/layer combination, they + have been combined in /color/ /colorDull/, /bgColor/, and + /bgColorDull/ functions. |] ] , h2 "Historical notes" diff --git a/bench/FasterUnsafeText.hs b/bench/FasterUnsafeText.hs --- a/bench/FasterUnsafeText.hs +++ b/bench/FasterUnsafeText.hs @@ -21,7 +21,7 @@ n -> Text n t current :: Text -> Doc ann -current = unsafeText +current = unsafeTextWithoutNewlines main :: IO () main = defaultMain [ benchText (letters n) | n <- [0,1,2,3,5,10,50,100] ] diff --git a/misc/version-compatibility-macros.h b/misc/version-compatibility-macros.h --- a/misc/version-compatibility-macros.h +++ b/misc/version-compatibility-macros.h @@ -12,8 +12,8 @@ #define FOLDABLE_TRAVERSABLE_IN_PRELUDE MIN_VERSION_base(4,8,0) #define MONOID_IN_PRELUDE MIN_VERSION_base(4,8,0) #define NATURAL_IN_BASE MIN_VERSION_base(4,8,0) -#define SEMIGROUP_IN_BASE MIN_VERSION_base(4,8,0) +#define SEMIGROUP_IN_BASE MIN_VERSION_base(4,9,0) #define MONAD_FAIL MIN_VERSION_base(4,9,0) #endif diff --git a/prettyprinter.cabal b/prettyprinter.cabal --- a/prettyprinter.cabal +++ b/prettyprinter.cabal @@ -1,5 +1,5 @@ name: prettyprinter -version: 0.1 +version: 1 cabal-version: >= 1.10 category: User Interfaces, Text synopsis: A modern, extensible and well-documented prettyprinter. @@ -8,6 +8,7 @@ license-file: LICENSE.md extra-source-files: README.md , misc/version-compatibility-macros.h + , CONTRIBUTORS.md author: Phil Wadler, Daan Leijen, Max Bolingbroke, Edward Kmett, David Luposchainsky maintainer: David Luposchainsky bug-reports: http://github.com/quchen/prettyprinter/issues 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 @@ -13,8 +13,8 @@ -- This module defines a prettyprinter to format text in a flexible and -- convenient way. The idea is to combine a 'Doc'ument out of many small -- components, then using a layouter to convert it to an easily renderable --- 'SimpleDoc', which can then be rendered to a variety of formats, for example --- plain 'Text'. +-- 'SimpleDocStream', which can then be rendered to a variety of formats, for +-- example plain 'Text'. -- -- The documentation consists of several parts: -- @@ -80,7 +80,7 @@ -- │ e.g. 'layoutPretty' -- ▽ -- ╭───────────────────╮ --- │ 'SimpleDoc' │ +-- │ 'SimpleDocStream' │ -- │ (simple document) │ -- ╰─────────┬─────────╯ -- │ @@ -205,12 +205,12 @@ -- * Layout -- - -- | Laying a 'Doc'ument out produces a straightforward 'SimpleDoc' based on - -- parameters such as page width and ribbon size, by evaluating how a 'Doc' - -- fits these constraints the best. There are various ways to render a - -- 'SimpleDoc'. For the common case of rendering a 'SimpleDoc' as plain - -- 'Text' take a look at "Data.Text.Prettyprint.Doc.Render.Text". - SimpleDoc(..), + -- | 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, @@ -249,6 +249,8 @@ -- 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. 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,6 +1,8 @@ +{-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -29,6 +31,7 @@ import qualified Data.Text.Lazy as Lazy import Data.Void import Data.Word +import GHC.Generics (Generic) -- Depending on the Cabal file, this might be from base, or for older builds, -- from the semigroups package. @@ -38,10 +41,16 @@ import Numeric.Natural #endif +#if !(APPLICATIVE_MONAD) +import Control.Applicative +#endif + #if !(FOLDABLE_TRAVERSABLE_IN_PRELUDE) -import Data.Foldable (Foldable (..)) -import Prelude hiding (foldr, foldr1) +import Data.Foldable (Foldable (..)) +import Data.Traversable (Traversable (..)) +import Prelude hiding (foldr, foldr1) #endif + #if !(MONOID_IN_PRELUDE) import Data.Monoid hiding ((<>)) #endif @@ -50,17 +59,6 @@ --- $setup --- --- (Definitions for the doctests) --- --- >>> :set -XOverloadedStrings --- >>> import Data.Text.Prettyprint.Doc.Render.Text --- >>> import Data.Text.Prettyprint.Doc.Util as Util --- >>> import Test.QuickCheck.Modifiers - - - -- | The abstract data type @'Doc' ann@ represents pretty documents that have -- been annotated with data of type @ann@. -- @@ -75,8 +73,7 @@ -- -- - color information (e.g. when rendering to the terminal) -- - mouseover text (e.g. when rendering to rich HTML) --- - metailed whether to show something or not (to allow simple or detailed --- versions) +-- - whether to show something or not (to allow simple or detailed versions) -- -- The simplest way to display a 'Doc' is via the 'Show' class. -- @@ -89,11 +86,11 @@ -- choosing a more suitable rendering. Fail - -- | The empty document; unit of 'Cat' (observationally) + -- | The empty document; conceptually the unit of 'Cat' | Empty - -- | invariant: char is not '\n' - | Char Char + -- | 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 @@ -101,9 +98,9 @@ -- -- Since the frequently used 'T.length' of 'Text' is /O(length)/, we cache -- it in this constructor. - | Text !Int Text + | Text !Int !Text - -- | Line break + -- | Hard line break | Line -- | Lay out the first 'Doc', but when flattened (via 'group'), fall back to @@ -117,8 +114,9 @@ -- | Document indented by a number of columns | Nest !Int (Doc ann) - -- | Invariant: first lines of first '(Doc ann)' longer than the first lines of - -- the second one. Used to implement layout alternatives for 'group'. + -- | 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' @@ -133,6 +131,7 @@ -- | 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) -- | -- @ @@ -167,7 +166,20 @@ 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 @@ -243,7 +255,7 @@ -- | Convert a 'Show'able value /that must not contain newlines/ to a 'Doc'. -- If there are newlines, use 'viaShow' instead. unsafeViaShow :: Show a => a -> Doc ann -unsafeViaShow = unsafeText . T.pack . show +unsafeViaShow = unsafeTextWithoutNewlines . T.pack . show -- | >>> pretty (123 :: Int) -- 123 @@ -340,7 +352,7 @@ -- hello world -- -- Manually use @'hardline'@ if you /definitely/ want newlines. -instance Pretty Text where pretty = vsep . map unsafeText . T.splitOn "\n" +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 @@ -350,45 +362,12 @@ --- | The data type @SimpleDoc@ represents laid out documents and is used by the --- display functions. --- --- A simplified view is that @'Doc' = ['SimpleDoc']@, and the layout functions --- pick one of the 'SimpleDoc's. This means that 'SimpleDoc' has all complexity --- contained in 'Doc' resolved, making it very easy to convert it to other --- formats, such as plain text or terminal output. --- --- To write your own @'Doc'@ to X converter, it is therefore sufficient to --- convert from @'SimpleDoc'@. The »Render« submodules provide some built-in --- converters to do so, and helpers to create own ones. -data SimpleDoc ann = - SFail - | SEmpty - | SChar Char (SimpleDoc ann) - - -- | Some layout algorithms use the Since the frequently used 'T.length' of - -- the 'Text', which scales linearly with its length, we cache it in this - -- constructor. - | SText !Int Text (SimpleDoc ann) - - -- | @Int@ = indentation level for the line - | SLine !Int (SimpleDoc ann) - - -- | Add an annotation to the remaining document. - | SAnnPush ann (SimpleDoc ann) - - -- | Remove a previously pushed annotation. - | SAnnPop (SimpleDoc ann) - deriving (Eq, Ord, Show) - - - --- | @(unsafeText s)@ contains the literal string @s@. +-- | @(unsafeTextWithoutNewlines s)@ contains the literal string @s@. -- -- The string must not contain any newline characters, since this is an -- invariant of the 'Text' constructor. -unsafeText :: Text -> Doc ann -unsafeText text = case T.uncons text of +unsafeTextWithoutNewlines :: Text -> Doc ann +unsafeTextWithoutNewlines text = case T.uncons text of Nothing -> Empty Just (t,ext) | T.null ext -> Char t @@ -833,8 +812,8 @@ -- | @('sep' xs)@ tries laying out the documents @xs@ separated with 'space's, -- and if this does not fit the page, separates them with newlines. This is what --- differentiates it from 'vsep', which always layouts its contents beneath each --- other. +-- differentiates it from 'vsep', which always lays out its contents beneath +-- each other. -- -- >>> let doc = "prefix" <+> sep ["text", "to", "lay", "out"] -- >>> putDocW 80 doc @@ -878,6 +857,8 @@ -- lorem -- ipsum -- dolor +-- >>> group (vcat docs) +-- loremipsumdolor -- -- Since 'group'ing a 'vcat' is rather common, 'cat' is a built-in shortcut for -- it. @@ -915,8 +896,8 @@ -- | @('cat' xs)@ tries laying out the documents @xs@ separated with nothing, -- and if this does not fit the page, separates them with newlines. This is what --- differentiates it from 'vcat', which always layouts its contents beneath each --- other. +-- 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) @@ -1063,7 +1044,7 @@ -- | Insert a number of spaces. Negative values count as 0. spaces :: Int -> Doc ann -spaces n = unsafeText (T.replicate n " ") +spaces n = unsafeTextWithoutNewlines (T.replicate n " ") -- $ -- prop> \(NonNegative n) -> length (show (spaces n)) == n @@ -1111,7 +1092,6 @@ -> Doc ann -- ^ LxR enclose l r x = l <> x <> r - -- | @('surround' x l r)@ surrounds document @x@ with @l@ and @r@. -- -- >>> surround "·" "A" "Z" @@ -1288,11 +1268,11 @@ -- producing the layout by using 'unAnnotateS'. unAnnotate :: Doc ann -> Doc xxx unAnnotate = \case - Fail -> Fail - Empty -> Empty - Char c -> Char c - Text l t -> Text l t - Line -> Line + Fail -> Fail + Empty -> Empty + Char c -> Char c + Text l t -> Text l t + Line -> Line FlatAlt x y -> FlatAlt (unAnnotate x) (unAnnotate y) Cat x y -> Cat (unAnnotate x) (unAnnotate y) @@ -1308,11 +1288,12 @@ -- Useful in particular to embed documents with one form of annotation in a more -- generlly annotated document. -- --- Since this traverses the entire 'Doc' tree, it is preferrable to reannotate --- after producing the layout by using 'reAnnotateS'. +-- 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'@. -- --- Technically 'reAnnotate' makes 'Doc' a 'Functor', but since reannotation is --- hardly intuitive we omit the instance. +-- 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 = go where @@ -1332,8 +1313,8 @@ Nesting f -> Nesting (go . f) Annotated ann x -> Annotated (re ann) (go x) --- | Remove all annotations. 'unAnnotate' for 'SimpleDoc'. -unAnnotateS :: SimpleDoc ann -> SimpleDoc xxx +-- | Remove all annotations. 'unAnnotate' for 'SimpleDocStream'. +unAnnotateS :: SimpleDocStream ann -> SimpleDocStream xxx unAnnotateS = go where go = \case @@ -1345,8 +1326,8 @@ SAnnPush _ rest -> go rest SAnnPop rest -> go rest --- | Change the annotation of a document. 'reAnnotate' for 'SimpleDoc'. -reAnnotateS :: (ann -> ann') -> SimpleDoc ann -> SimpleDoc ann' +-- | Change the annotation of a document. 'reAnnotate' for 'SimpleDocStream'. +reAnnotateS :: (ann -> ann') -> SimpleDocStream ann -> SimpleDocStream ann' reAnnotateS f = go where go = \case @@ -1383,22 +1364,22 @@ -- efficiently. A fused document is always laid out identical to its unfused -- version. -- --- When laying a 'Doc'ument out to a 'SimpleDoc', every component of the input --- is translated directly to the simpler output format. This sometimes yields --- undesirable chunking when many pieces have been concatenated together. +-- 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 'SimpleDoc', although this is fully +-- 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 'SimpleDoc' entry, and can be processed faster. +-- 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, @@ -1448,12 +1429,78 @@ other -> other --- | Decide whether a 'SimpleDoc' fits the constraints given, namely + + +-- | 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 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) + +-- | 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 = \case + SFail -> mempty + SEmpty -> mempty + SChar _ rest -> foldMap f rest + SText _ _ rest -> foldMap f rest + SLine _ rest -> foldMap f rest + SAnnPush ann rest -> f ann `mappend` foldMap f rest + SAnnPop rest -> foldMap f rest + +-- | Transform a document based on its annotations, possibly leveraging +-- 'Applicative' effects. +instance Traversable SimpleDocStream where + traverse f = \case + SFail -> pure SFail + SEmpty -> pure SEmpty + SChar c rest -> SChar c <$> traverse f rest + SText l t rest -> SText l t <$> traverse f rest + SLine i rest -> SLine i <$> traverse f rest + SAnnPush ann rest -> SAnnPush <$> f ann <*> traverse f rest + SAnnPop rest -> SAnnPop <$> traverse f rest + +-- | Decide whether a 'SimpleDocStream' fits the constraints given, namely +-- -- - page width -- - minimum nesting level to fit in -- - width in which to fit the first line; Nothing is unbounded -newtype FittingPredicate ann = FP (PageWidth -> Int -> Maybe Int -> SimpleDoc ann -> Bool) +newtype FittingPredicate ann = FP (PageWidth -> Int -> Maybe Int -> SimpleDocStream ann -> Bool) -- | List of nesting level/document pairs yet to be laid out. data LayoutPipeline ann = @@ -1503,22 +1550,22 @@ -- and 'hPutDoc'. -- -- @'layoutPretty'@ commits to rendering something in a certain way if the next --- element fits the layout constraints; in other words, it has one 'SimpleDoc' --- element lookahead when rendering. Consider using the smarter, but a bit less --- performant, @'layoutSmart'@ algorithm if the results seem to run off to the --- right before having lots of line breaks. +-- 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 - -> SimpleDoc ann -layoutPretty = layoutFits fits1 + -> SimpleDocStream ann +layoutPretty = layout fits1 where -- | @fits1@ does 1 line lookahead. fits1 :: FittingPredicate ann fits1 = FP (\_p _m w -> go w) where go :: Maybe Int -- ^ Width in which to fit the first line; Nothing is infinite - -> SimpleDoc ann + -> SimpleDocStream ann -> Bool go Nothing _ = True go (Just w) _ | w < 0 = False @@ -1578,8 +1625,8 @@ layoutSmart :: LayoutOptions -> Doc ann - -> SimpleDoc ann -layoutSmart = layoutFits fitsR + -> SimpleDocStream ann +layoutSmart = layout fitsR where -- @fitsR@ has a little more lookahead: assuming that nesting roughly -- corresponds to syntactic depth, @fitsR@ checks that not only the current @@ -1595,7 +1642,7 @@ go :: PageWidth -> Int -- ^ Minimum nesting level to fit in -> Maybe Int -- ^ Width in which to fit the first line - -> SimpleDoc ann + -> SimpleDocStream ann -> Bool go _ _ Nothing _ = False go _ _ (Just w) _ | w < 0 = False @@ -1611,12 +1658,12 @@ -layoutFits +layout :: forall ann. FittingPredicate ann -> LayoutOptions -> Doc ann - -> SimpleDoc ann -layoutFits + -> SimpleDocStream ann +layout fittingPredicate LayoutOptions { layoutPageWidth = pWidth } doc @@ -1629,7 +1676,7 @@ :: Int -- Current nesting level -> Int -- Current column, i.e. "where the cursor is" -> LayoutPipeline ann -- Documents remaining to be handled (in order) - -> SimpleDoc ann + -> 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 @@ -1653,9 +1700,9 @@ :: FittingPredicate ann -> Int -- ^ Current nesting level -> Int -- ^ Current column - -> SimpleDoc ann -- ^ Choice A. Invariant: first lines should not be longer than B's. - -> SimpleDoc ann -- ^ Choice B. - -> SimpleDoc ann -- ^ Choice A if it fits, otherwise B. + -> SimpleDocStream ann -- ^ Choice A. Invariant: first lines should not be longer than B's. + -> SimpleDocStream ann -- ^ Choice B. + -> SimpleDocStream ann -- ^ Choice A if it fits, otherwise B. selectNicer (FP fits) lineIndent currentColumn x y | fits pWidth minNestingLevel availableWidth x = x | otherwise = y @@ -1697,7 +1744,7 @@ -- ipsum -- dolor -- sit -layoutCompact :: Doc ann -> SimpleDoc ann +layoutCompact :: Doc ann -> SimpleDocStream ann layoutCompact doc = scan 0 [doc] where scan _ [] = SEmpty @@ -1721,14 +1768,14 @@ instance Show (Doc ann) where showsPrec _ doc = renderShowS (layoutPretty defaultLayoutOptions doc) --- | Render a 'SimpleDoc' to a 'ShowS', useful to write 'Show' instances based --- on the prettyprinter. +-- | 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 :: SimpleDoc ann -> ShowS +renderShowS :: SimpleDocStream ann -> ShowS renderShowS = \case SFail -> panicUncaughtFail SEmpty -> id @@ -1737,3 +1784,14 @@ SLine i x -> showString ('\n' : replicate i ' ') . renderShowS x SAnnPush _ x -> renderShowS x SAnnPop x -> renderShowS x + + + +-- $setup +-- +-- (Definitions for the doctests) +-- +-- >>> :set -XOverloadedStrings +-- >>> import Data.Text.Prettyprint.Doc.Render.Text +-- >>> import Data.Text.Prettyprint.Doc.Util as Util +-- >>> import Test.QuickCheck.Modifiers diff --git a/src/Data/Text/Prettyprint/Doc/Render/ShowS.hs b/src/Data/Text/Prettyprint/Doc/Render/ShowS.hs --- a/src/Data/Text/Prettyprint/Doc/Render/ShowS.hs +++ b/src/Data/Text/Prettyprint/Doc/Render/ShowS.hs @@ -2,4 +2,4 @@ renderShowS ) where -import Data.Text.Prettyprint.Doc.Internal +import Data.Text.Prettyprint.Doc.Internal (renderShowS) 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,10 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} #include "version-compatibility-macros.h" --- | Render an unannotated 'SimpleDoc' as plain 'Text'. +-- | Render an unannotated 'SimpleDocStream' as plain 'Text'. module Data.Text.Prettyprint.Doc.Render.Text ( -- * Conversion to plain 'Text' renderLazy, renderStrict, @@ -19,19 +17,22 @@ import Data.Text (Text) -import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB import qualified Data.Text.Lazy.IO as TL import System.IO import Data.Text.Prettyprint.Doc -import Data.Text.Prettyprint.Doc.Render.Util.Panic +import Data.Text.Prettyprint.Doc.Render.Util.StackMachine #if !(SEMIGROUP_IN_BASE) import Data.Semigroup #endif +#if !(APPLICATIVE_MONAD) +import Control.Applicative +#endif + -- $setup -- -- (Definitions for the doctests) @@ -51,21 +52,12 @@ -- lorem ipsum dolor -- (foo bar) -- sit amet -renderLazy :: SimpleDoc ann -> TL.Text -renderLazy = TLB.toLazyText . build - where - build = \case - SFail -> panicUncaughtFail - SEmpty -> mempty - SChar c x -> TLB.singleton c <> build x - SText _l t x -> TLB.fromText t <> build x - SLine i x -> TLB.singleton '\n' <> TLB.fromText (T.replicate i " ") <> build x - SAnnPush _ x -> build x - SAnnPop x -> build x +renderLazy :: SimpleDocStream ann -> TL.Text +renderLazy = TLB.toLazyText . renderSimplyDecorated TLB.fromText (pure mempty) (pure mempty) -- | @('renderLazy' sdoc)@ takes the output @sdoc@ from a rendering and -- transforms it to strict text. -renderStrict :: SimpleDoc ann -> Text +renderStrict :: SimpleDocStream ann -> Text renderStrict = TL.toStrict . renderLazy @@ -75,7 +67,7 @@ -- >>> renderIO System.IO.stdout (layoutPretty defaultLayoutOptions "hello\nworld") -- hello -- world -renderIO :: Handle -> SimpleDoc ann -> IO () +renderIO :: Handle -> SimpleDocStream ann -> IO () renderIO h sdoc = TL.hPutStrLn h (renderLazy sdoc) -- | @('putDoc' doc)@ prettyprints document @doc@ to standard output. Uses the 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 @@ -5,9 +5,9 @@ #include "version-compatibility-macros.h" -- | This module shows how to write a custom prettyprinter backend, based on --- directly converting a 'SimpleDoc' to an output format using a stack machine. --- For a tree serialization approach, which may be more suitable for certain --- output formats, see +-- 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 @@ -68,20 +68,28 @@ -- = The rendering algorithm -- -- With the annotation definitions out of the way, we can now define a --- conversion function from 'SimpleDoc' annotated with our 'SimpleHtml' to the +-- 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 'SimpleDoc', pushing styles on the stack and popping them off --- again, and writing raw output. +-- Most 'StackMachine' creations will look like this definition: a recursive +-- walk through the 'SimpleDocStream', pushing styles on the stack and popping +-- them off again, and writing raw output. -- -- The equivalent to this in the tree based rendering approach is -- 'Data.Text.Prettyprint.Doc.Render.Tutorials.TreeRenderingTutorial.renderTree'. -renderStackMachine :: SimpleDoc SimpleHtml -> StackMachine TLB.Builder SimpleHtml () +renderStackMachine :: SimpleDocStream SimpleHtml -> StackMachine TLB.Builder SimpleHtml () renderStackMachine = \case SFail -> panicUncaughtFail SEmpty -> pure () @@ -92,7 +100,7 @@ writeOutput (TLB.fromText t) renderStackMachine x SLine i x -> do - writeOutput (TLB.singleton '\n' ) + writeOutput (TLB.singleton '\n') writeOutput (TLB.fromText (T.replicate i " ")) renderStackMachine x SAnnPush s x -> do @@ -129,7 +137,7 @@ -- the main API function of a stack machine renderer. The tree renderer -- equivalent to this is -- 'Data.Text.Prettyprint.Doc.Render.Tutorials.TreeRenderingTutorial.render'. -render :: SimpleDoc SimpleHtml -> TL.Text +render :: SimpleDocStream SimpleHtml -> TL.Text render doc = let (resultBuilder, remainingStyles) = execStackMachine [] (renderStackMachine doc) in if null remainingStyles 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 @@ -5,7 +5,7 @@ #include "version-compatibility-macros.h" -- | This module shows how to write a custom prettyprinter backend, based on a --- tree representation of a 'SimpleDoc'. For a stack machine approach, which +-- 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". -- @@ -64,18 +64,26 @@ -- = The rendering algorithm -- -- With the annotation definitions out of the way, we can now define a --- conversion function from 'SimpleDoc' (annotated with our 'SimpleHtml') to the --- tree-shaped 'SimpleDocTree', which is easily convertible to a HTML/'Text' --- representation. +-- 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 'SimpleDoc' to the 'SimpleDocTree' --- format, which makes enveloping sub-documents in markup easier. +-- | To render the HTML, we first convert the 'SimpleDocStream' to the +-- 'SimpleDocTree' format, which makes enveloping sub-documents in markup +-- easier. -- -- This function is the entry main API function of the renderer; as such, it is -- only glue for the internal functions. This is similar to -- 'Data.Text.Prettyprint.Doc.Render.Tutorials.StackMachineTutorial.render' from -- the stack machine tutorial in its purpose. -render :: SimpleDoc SimpleHtml -> TL.Text +render :: SimpleDocStream SimpleHtml -> TL.Text render = TLB.toLazyText . renderTree . treeForm -- | Render a 'SimpleDocTree' to a 'TLB.Builder'; this is the workhorse of the 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 @@ -6,9 +6,9 @@ ) where -- | Raise a hard 'error' if there is a 'Data.Text.Prettyprint.Doc.SFail' in a --- 'Data.Text.Prettyprint.Doc.SimpleDoc'. +-- 'Data.Text.Prettyprint.Doc.SimpleDocStream'. panicUncaughtFail :: a -panicUncaughtFail = error ("»SFail« must not appear in a rendered »SimpleDoc«. This is a bug in the layout algorithm! " ++ report) +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. @@ -16,16 +16,16 @@ panicUnpairedPop = error ("An unpaired style terminator was encountered. This is a bug in the layout algorithm! " ++ report) -- | Raise a hard generic 'error' when the --- 'Data.Text.Prettyprint.Doc.SimpleDoc' to +-- 'Data.Text.Prettyprint.Doc.SimpleDocStream' to -- 'Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree.SimpleDocTree' conversion fails. panicSimpleDocTreeConversionFailed :: a -panicSimpleDocTreeConversionFailed = error ("Conversion from SimpleDoc to SimpleDocTree failed! " ++ report) +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 :: a -panicInputNotFullyConsumed = error ("Conversion from SimpleDoc to SimpleDocTree left unconsumed input! " ++ report) +panicInputNotFullyConsumed = error ("Conversion from SimpleDocStream to SimpleDocTree left unconsumed input! " ++ report) report :: String report = "Please report this as a bug" diff --git a/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs b/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs --- a/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs +++ b/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs @@ -1,22 +1,34 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} #include "version-compatibility-macros.h" --- | Conversion of the linked-list-like 'SimpleDoc' to a tree-like +-- | 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, + + -- * Common use case shortcut definitions + renderSimplyDecorated, + renderSimplyDecoratedA, ) where -import Control.Applicative -import Data.Text (Text) +import Control.Applicative +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Util.Panic @@ -25,8 +37,68 @@ import Control.Monad.Fail #endif +#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 = \case + STEmpty -> mempty + STChar c -> text (T.singleton c) + STText _ t -> text t + STLine i -> text (T.singleton '\n' <> T.replicate i " ") + STAnn ann rest -> renderAnn ann (go rest) + STConcat xs -> foldMap go xs + +-- | 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 = \case + STEmpty -> pure mempty + STChar c -> text (T.singleton c) + STText _ t -> text t + STLine i -> text (T.singleton '\n' <> T.replicate i " ") + STAnn ann rest -> renderAnn ann (go rest) + STConcat xs -> fmap mconcat (traverse go xs) + + + -- | A type for parsers of unique results. Token stream »s«, results »a«. -- -- Hand-written to avoid a dependency on a parser lib. @@ -72,13 +144,13 @@ | TokAnnPop deriving (Eq, Ord, Show) --- | A 'SimpleDoc' is a linked list of different annotated cons cells ('SText' --- and then some further 'SimpleDoc', 'SLine' and then some further 'SimpleDoc', …). --- This format is very suitable as a target for a layout engine, but not very --- useful for rendering to a structured format such as HTML, where we don’t want --- to do a lookahead until the end of some markup. These formats benefit from a --- tree-like structure that explicitly marks its contents as annotated. --- 'SimpleDocTree' is that format. +-- | 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 @@ -86,10 +158,19 @@ | STLine !Int | STAnn ann (SimpleDocTree ann) | STConcat [SimpleDocTree ann] - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) +-- | Alter the document’s annotations. +-- +-- This instance makes 'SimpleDocTree' more flexible (because it can be used in +-- 'Functor'-polymorphic values), but @'fmap'@ is much less readable compared to +-- using @'reAnnotateST'@ in code that only works for @'SimpleDocTree'@ anyway. +-- Consider using the latter when the type does not matter. +instance Functor SimpleDocTree where + fmap = reAnnotateST + -- | Get the next token, consuming it in the process. -nextToken :: UniqueParser (SimpleDoc ann) (SimpleDocTok ann) +nextToken :: UniqueParser (SimpleDocStream ann) (SimpleDocTok ann) nextToken = UniqueParser (\case SFail -> panicUncaughtFail SEmpty -> empty @@ -99,7 +180,7 @@ SAnnPush ann rest -> Just (TokAnnPush ann , rest) SAnnPop rest -> Just (TokAnnPop , rest) ) -sdocToTreeParser :: UniqueParser (SimpleDoc ann) (SimpleDocTree ann) +sdocToTreeParser :: UniqueParser (SimpleDocStream ann) (SimpleDocTree ann) sdocToTreeParser = fmap wrap (many contentPiece) where @@ -120,8 +201,8 @@ TokAnnPop <- nextToken pure (STAnn ann annotatedContents) --- | Convert a 'SimpleDoc' to its 'SimpleDocTree' representation. -treeForm :: SimpleDoc ann -> SimpleDocTree ann +-- | 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 @@ -154,3 +235,24 @@ STLine i -> STLine i STAnn ann rest -> STAnn (f ann) (go rest) STConcat xs -> STConcat (map go xs) + +-- | Collect all annotations from a document. +instance Foldable SimpleDocTree where + foldMap f = \case + STEmpty -> mempty + STChar _ -> mempty + STText _ _ -> mempty + STLine _ -> mempty + STAnn ann rest -> f ann `mappend` foldMap f rest + STConcat xs -> mconcat (map (foldMap f) xs) + +-- | Transform a document based on its annotations, possibly leveraging +-- 'Applicative' effects. +instance Traversable SimpleDocTree where + traverse f = \case + 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 <*> traverse f rest + STConcat xs -> STConcat <$> traverse (traverse f) xs 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 @@ -5,9 +5,23 @@ #include "version-compatibility-macros.h" --- | A strict State/Writer monad to implement a stack machine for rendering --- 'SimpleDoc's. +-- | 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, @@ -19,11 +33,72 @@ -import Data.Monoid +import Control.Applicative +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T -#if !(APPLICATIVE_MONAD) -import Control.Applicative -#endif +import Data.Text.Prettyprint.Doc (SimpleDocStream (..)) +import Data.Text.Prettyprint.Doc.Render.Util.Panic + +-- $setup +-- +-- (Definitions for the doctests) +-- +-- >>> import Data.Text.Prettyprint.Doc hiding ((<>)) +-- >>> import qualified Data.Text.IO as T + + + +-- | Simplest possible stack-based renderer. +-- +-- For example, here is a document annotated with @()@, and the behaviour is to +-- write »>>>« at the beginning, and »<<<« at the end of the annotated region: +-- +-- >>> let doc = "hello" <+> annotate () "world" <> "!" +-- >>> let sdoc = layoutPretty defaultLayoutOptions doc +-- >>> T.putStrLn (renderSimplyDecorated id (\() -> ">>>") (\() -> "<<<") sdoc) +-- hello >>>world<< (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' <> T.replicate i " ") <> go stack rest + go stack (SAnnPush ann rest) = push ann <> go (ann : stack) rest + go (ann:stack) (SAnnPop rest) = pop ann <> go stack rest + go [] SAnnPop{} = panicUnpairedPop + +-- | 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' <> T.replicate i " ") <++> go stack rest + go stack (SAnnPush ann rest) = push ann <++> go (ann : stack) rest + go (ann:stack) (SAnnPop rest) = pop ann <++> go stack rest + go [] SAnnPop{} = panicUnpairedPop + + (<++>) = liftA2 mappend 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 @@ -13,14 +13,8 @@ import Data.Text.Prettyprint.Doc --- $setup --- --- (Definitions for the doctests) --- --- >>> :set -XOverloadedStrings - -- | Split an input into word-sized 'Doc's. -- -- >>> putDoc (tupled (words "Lorem ipsum dolor")) @@ -61,3 +55,11 @@ 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