packages feed

wl-pprint-extras 3.2 → 3.3

raw patch · 6 files changed

+1208/−1199 lines, 6 filesdep +natsdep ~semigroupoidsdep ~semigroups

Dependencies added: nats

Dependency ranges changed: semigroupoids, semigroups

Files

.travis.yml view
@@ -1,1 +1,8 @@ language: haskell+notifications:+  irc:+    channels:+      - "irc.freenode.org#haskell-lens"+    skip_join: true+    template:+      - "\x0313wl-pprint-extras\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"
− Text/PrettyPrint/Free.hs 
@@ -1,120 +0,0 @@-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}--------------------------------------------------------------------------------- |--- Module      :  Text.PrettyPrint.Free--- Copyright   :  Edward Kmett (c) 2011,---                Daan Leijen (c) 2000--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- Portability :  portable------ Pretty print module based on Daan Leijen's implementation of Philip Wadler's --- \"prettier printer\"------ @---      \"A prettier printer\"---      Draft paper, April 1997, revised March 1998.---      <http://homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf>--- @------ This is an implementation of the pretty printing combinators--- described by Philip Wadler (1997). In their bare essence, the--- combinators of Wadler are not expressive enough to describe some--- commonly occurring layouts. The PPrint library adds new primitives--- to describe these layouts and works well in practice.------ The library is based on a single way to concatenate documents,--- which is associative and has both a left and right unit.  This--- simple design leads to an efficient and short implementation. The--- simplicity is reflected in the predictable behaviour of the--- combinators which make them easy to use in practice.------ A thorough description of the primitive combinators and their--- implementation can be found in Philip Wadler's paper--- (1997). Additions and the main differences with his original paper--- are:------ * The nil document is called empty.------ * The operator '</>' is used--- for soft line breaks.------ * There are three new primitives: 'align', 'fill' and--- 'fillBreak'. These are very useful in practice.------ * Lots of other useful combinators, like 'fillSep' and 'list'.------ * There are two renderers, 'renderPretty' for pretty printing and--- 'renderCompact' for compact output. The pretty printing algorithm--- also uses a ribbon-width now for even prettier output.------ * There are two displayers, 'displayS' for strings and 'displayIO' for--- file based output.------ * There is a 'Pretty' class.------ * The implementation uses optimised representations and strictness--- annotations.------ * A type argument has been added and embedded 'effects' can be seen in--- the SimpleDoc type.--- --- --------------------------------------------------------------module Text.PrettyPrint.Free (-  -- * Documents-    Doc, putDoc, hPutDoc--  -- * Basic combinators-  , char, text, nest, line, linebreak, group, softline-  , softbreak--  -- * Alignment-  ---  -- The combinators in this section can not be described by Wadler's-  -- original combinators. 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-  -- combinators from being \`optimal\'. In practice however they-  -- prove to be very useful. The combinators in this section should-  -- be used with care, since they are more expensive than the other-  -- combinators. 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, semiBraces--  -- * Operators-  , (<+>), above, (</>), aboveBreak, (<//>)--  -- * List combinators-  , hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate--  -- * Fillers-  , fill, fillBreak--  -- * Bracketing combinators-  , enclose, squotes, dquotes, parens, angles, braces, brackets--  -- * Character documents-  , lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket-  , squote, dquote, semi, colon, comma, space, dot, backslash, equals--  -- * Pretty class-  , Pretty(..)--  -- * Rendering-  , SimpleDoc(..), renderPretty, renderCompact-  , displayS, displayIO--  -- * Undocumented--  , column, nesting, width, columns--  -- * Re-exported standard functions-  , empty, (<>)-  ) where--import Text.PrettyPrint.Free.Internal
− Text/PrettyPrint/Free/Internal.hs 
@@ -1,1076 +0,0 @@-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}--------------------------------------------------------------------------------- |--- Module      :  Text.PrettyPrint.Free.Internal--- Copyright   :  Edward Kmett (c) 2011,---                Daan Leijen (c) 2000--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- Portability :  portable------ Pretty print module based on Daan Leijen's implementation of Philip Wadler's --- \"prettier printer\"------ @---      \"A prettier printer\"---      Draft paper, April 1997, revised March 1998.---      <http://homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf>--- @------ This is an implementation of the pretty printing combinators--- described by Philip Wadler (1997). In their bare essence, the--- combinators of Wadler are not expressive enough to describe some--- commonly occurring layouts. The PPrint library adds new primitives--- to describe these layouts and works well in practice.------ The library is based on a single way to concatenate documents,--- which is associative and has both a left and right unit.  This--- simple design leads to an efficient and short implementation. The--- simplicity is reflected in the predictable behaviour of the--- combinators which make them easy to use in practice.------ A thorough description of the primitive combinators and their--- implementation can be found in Philip Wadler's paper--- (1997). Additions and the main differences with his original paper--- are:------ * The nil document is called empty.------ * The operator '</>' is used--- for soft line breaks.------ * There are three new primitives: 'align', 'fill' and--- 'fillBreak'. These are very useful in practice.------ * Lots of other useful combinators, like 'fillSep' and 'list'.------ * There are two renderers, 'renderPretty' for pretty printing and--- 'renderCompact' for compact output. The pretty printing algorithm--- also uses a ribbon-width now for even prettier output.------ * There are two display routines, 'displayS' for strings and 'displayIO' --- for file based output.------ * There is a 'Pretty' class.------ * The implementation uses optimised representations and strictness--- annotations.------ * A type argument has been added and embedded 'effects' can be seen in--- the SimpleDoc type.--- --- --------------------------------------------------------------module Text.PrettyPrint.Free.Internal (-  -- * Documents-    Doc(..), putDoc, hPutDoc--  -- * Basic combinators-  , char, text, nest, line, linebreak, group, softline-  , softbreak--  -- * Alignment-  ---  -- The combinators in this section can not be described by Wadler's-  -- original combinators. 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-  -- combinators from being \`optimal\'. In practice however they-  -- prove to be very useful. The combinators in this section should-  -- be used with care, since they are more expensive than the other-  -- combinators. 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, semiBraces--  -- * Operators-  , (<+>), above, (</>), aboveBreak, (<//>)--  -- * List combinators-  , hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate--  -- * Fillers-  , fill, fillBreak--  -- * Bracketing combinators-  , enclose, squotes, dquotes, parens, angles, braces, brackets--  -- * Character documents-  , lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket-  , squote, dquote, semi, colon, comma, space, dot, backslash, equals--  -- * Pretty class-  , Pretty(..)--  -- * Rendering-  , SimpleDoc(..), renderPretty, renderCompact-  , displayS, displayIO--  -- * Undocumented--  , column, nesting, width, columns, ribbon--  -- * Re-exported standard functions-  , empty, (<>)-  ) where--import Data.String-import Data.Foldable hiding (fold)-import Data.Traversable-import Data.Functor.Apply-import Data.Functor.Bind-import Data.Functor.Plus-import Data.Int-import Data.Word-import qualified Data.ByteString.UTF8 as Strict-import qualified Data.ByteString.Lazy.UTF8 as Lazy-import Data.List.NonEmpty (NonEmpty)-import Numeric.Natural (Natural)-import Control.Applicative-import Control.Monad-import Data.Sequence (Seq)-import Data.Semigroup-import System.IO (Handle,hPutStr,hPutChar,stdout)-import Prelude hiding (foldr1)--infixr 5 </>,<//>,`above`,`aboveBreak`-infixr 6 <+>---------------------------------------------------------------- list, tupled and semiBraces pretty print a list of--- documents either horizontally or vertically aligned.---------------------------------------------------------------- | The document @(list xs)@ comma separates the documents @xs@ and--- encloses them in square brackets. The documents are rendered--- horizontally if that fits the page. Otherwise they are aligned--- vertically. All comma separators are put in front of the elements.-list :: Foldable f => f (Doc e) -> Doc e-list = encloseSep lbracket rbracket comma---- | The document @(tupled xs)@ comma separates the documents @xs@ and--- encloses them in parenthesis. The documents are rendered--- horizontally if that fits the page. Otherwise they are aligned--- vertically. All comma separators are put in front of the elements.-tupled :: Foldable f => f (Doc e) -> Doc e -tupled = encloseSep lparen rparen comma--(<+>) :: Doc e -> Doc e -> Doc e-x <+> y = x <> space <> y---- | The document @(semiBraces xs)@ separates the documents @xs@ with--- semi colons and encloses them in braces. The documents are rendered--- horizontally if that fits the page. Otherwise they are aligned--- vertically. All semi colons are put in front of the elements.-semiBraces :: Foldable f => f (Doc e) -> Doc e-semiBraces = encloseSep lbrace rbrace semi---- | The document @(encloseSep l r sep xs)@ concatenates the documents--- @xs@ separated by @sep@ and encloses the resulting document by @l@--- and @r@. The documents are rendered horizontally if that fits the--- page. Otherwise they are aligned vertically. All separators are put--- in front of the elements. For example, the combinator 'list' can be--- defined with @encloseSep@:------ > list xs = encloseSep lbracket rbracket comma xs--- > test    = text "list" <+> (list (map int [10,200,3000]))------ Which is layed out with a page width of 20 as:------ @--- list [10,200,3000]--- @------ But when the page width is 15, it is layed out as:------ @--- list [10---      ,200---      ,3000]--- @-encloseSep :: Foldable f => Doc e -> Doc e -> Doc e -> f (Doc e) -> Doc e-encloseSep left right sp ds0-    = case toList ds0 of-        []  -> left <> right-        [d] -> left <> d <> right-        ds  -> align (cat (zipWith (<>) (left : repeat sp) ds) <> right) ----------------------------------------------------------------- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn]----------------------------------------------------------------- | @(punctuate p xs)@ concatenates all documents in @xs@ with--- document @p@ except for the last document.------ > someText = map text ["words","in","a","tuple"]--- > test     = parens (align (cat (punctuate comma someText)))------ This is layed out on a page width of 20 as:------ @--- (words,in,a,tuple)--- @------ But when the page width is 15, it is layed out as:------ @--- (words,---  in,---  a,---  tuple)--- @------ (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 :: Traversable f => Doc e -> f (Doc e) -> f (Doc e)-punctuate p xs = snd $ mapAccumL (\(d:ds) _ -> (ds, if null ds then d else (d <> p))) (toList xs) xs---------------------------------------------------------------- high-level combinators----------------------------------------------------------------- | The document @(sep xs)@ concatenates all documents @xs@ either--- horizontally with @(\<+\>)@, if it fits the page, or vertically with--- @above@.------ > sep xs  = group (vsep xs)-sep :: Foldable f => f (Doc e) -> Doc e-sep = group . vsep---- | The document @(fillSep xs)@ concatenates documents @xs@--- horizontally with @(\<+\>)@ as long as its fits the page, than--- inserts a @line@ and continues doing that for all documents in--- @xs@.------ > fillSep xs  = foldr (</>) empty xs-fillSep :: Foldable f => f (Doc e) -> Doc e-fillSep = fold (</>)---- | The document @(hsep xs)@ concatenates all documents @xs@--- horizontally with @(\<+\>)@.-hsep :: Foldable f => f (Doc e) -> Doc e-hsep = fold (<+>)---- | The document @(vsep xs)@ concatenates all documents @xs@--- vertically with @above@. If a 'group' undoes the line breaks--- inserted by @vsep@, all documents are separated with a space.------ > someText = map text (words ("text to lay out"))--- >--- > test     = text "some" <+> vsep someText------ This is layed out as:------ @--- some text--- to--- lay--- out--- @------ The 'align' combinator can be used to align the documents under--- their first element------ > test = text "some" <+> align (vsep someText)------ Which is printed as:------ @--- some text---      to---      lay---      out--- @-vsep :: Foldable f => f (Doc e) -> Doc e-vsep = fold above---- | The document @(cat xs)@ concatenates all documents @xs@ either--- horizontally with @(\<\>)@, if it fits the page, or vertically with--- @aboveBreak@.------ > cat xs  = group (vcat xs)-cat :: Foldable f => f (Doc e) -> Doc e-cat = group . vcat---- | The document @(fillCat xs)@ concatenates documents @xs@--- horizontally with @(\<\>)@ as long as its fits the page, than inserts--- a @linebreak@ and continues doing that for all documents in @xs@.------ > fillCat xs  = foldr (<//>) empty xs-fillCat :: Foldable f => f (Doc e) -> Doc e-fillCat = fold (<//>)---- | The document @(hcat xs)@ concatenates all documents @xs@--- horizontally with @(\<\>)@.-hcat :: Foldable f => f (Doc e) -> Doc e-hcat = fold (<>)---- | The document @(vcat xs)@ concatenates all documents @xs@--- vertically with @aboveBreak@. If a 'group' undoes the line breaks--- inserted by @vcat@, all documents are directly concatenated.-vcat :: Foldable f => f (Doc e) -> Doc e-vcat = fold aboveBreak--fold :: Foldable f => (Doc e -> Doc e -> Doc e) -> f (Doc e) -> Doc e-fold f xs = case toList xs of -  [] -> empty-  _  -> foldr1 f xs--instance Semigroup (Doc e) where-  -- | The document @(x \<\> y)@ concatenates document @x@ and document-  -- @y@. It is an associative operation having 'empty' as a left and-  -- right unit.  (infixl 6)-  (<>) = Cat--instance Monoid (Doc e) where-  mappend = Cat-  mempty = empty---- | The document @(x \<\/\> y)@ concatenates document @x@ and @y@ with a--- 'softline' in between. This effectively puts @x@ and @y@ either--- next to each other (with a @space@ in between) or underneath each--- other. (infixr 5)-(</>) :: Doc e -> Doc e -> Doc e-x </> y = x <> softline <> y---- | The document @(x \<\/\/\> y)@ concatenates document @x@ and @y@ with--- a 'softbreak' in between. This effectively puts @x@ and @y@ either--- right next to each other or underneath each other. (infixr 5)-(<//>) :: Doc e -> Doc e -> Doc e-x <//> y        = x <> softbreak <> y---- | The document @above x y@ concatenates document @x@ and @y@ with a--- 'line' in between. (infixr 5)-above :: Doc e -> Doc e -> Doc e-above x y         = x <> line <> y---- | The document @aboveBreak x y@ concatenates document @x@ and @y@ with--- a @linebreak@ in between. (infixr 5)-aboveBreak :: Doc e -> Doc e -> Doc e-aboveBreak x y        = x <> linebreak <> y---- | The document @softline@ behaves like 'space' if the resulting--- output fits the page, otherwise it behaves like 'line'.------ > softline = group line-softline :: Doc e-softline = group line---- | The document @softbreak@ behaves like 'empty' if the resulting--- output fits the page, otherwise it behaves like 'line'.------ > softbreak  = group linebreak-softbreak :: Doc e-softbreak = group linebreak---- | Document @(squotes x)@ encloses document @x@ with single quotes--- \"'\".-squotes :: Doc e -> Doc e-squotes = enclose squote squote---- | Document @(dquotes x)@ encloses document @x@ with double quotes--- '\"'.-dquotes :: Doc e -> Doc e-dquotes = enclose dquote dquote---- | Document @(braces x)@ encloses document @x@ in braces, \"{\" and--- \"}\".-braces :: Doc e -> Doc e-braces = enclose lbrace rbrace---- | Document @(parens x)@ encloses document @x@ in parenthesis, \"(\"--- and \")\".-parens :: Doc e -> Doc e-parens = enclose lparen rparen---- | Document @(angles x)@ encloses document @x@ in angles, \"\<\" and--- \"\>\".-angles :: Doc e -> Doc e-angles = enclose langle rangle---- | Document @(brackets x)@ encloses document @x@ in square brackets,--- \"[\" and \"]\".-brackets :: Doc e -> Doc e-brackets = enclose lbracket rbracket---- | The document @(enclose l r x)@ encloses document @x@ between--- documents @l@ and @r@ using @(\<\>)@.------ > enclose l r x   = l <> x <> r-enclose :: Doc e -> Doc e -> Doc e -> Doc e-enclose l r x = l <> x <> r---- | The document @lparen@ contains a left parenthesis, \"(\".-lparen :: Doc e-lparen = char '('---- | The document @rparen@ contains a right parenthesis, \")\".-rparen :: Doc e-rparen = char ')'---- | The document @langle@ contains a left angle, \"\<\".-langle :: Doc e-langle = char '<'---- | The document @rangle@ contains a right angle, \">\".-rangle :: Doc e-rangle = char '>'---- | The document @lbrace@ contains a left brace, \"{\".-lbrace :: Doc e-lbrace = char '{'---- | The document @rbrace@ contains a right brace, \"}\".-rbrace :: Doc e-rbrace = char '}'---- | The document @lbracket@ contains a left square bracket, \"[\".-lbracket :: Doc e-lbracket = char '['---- | The document @rbracket@ contains a right square bracket, \"]\".-rbracket :: Doc e-rbracket = char ']'---- | The document @squote@ contains a single quote, \"'\".-squote :: Doc e-squote = char '\''---- | The document @dquote@ contains a double quote, '\"'.-dquote :: Doc e-dquote = char '"'---- | The document @semi@ contains a semi colon, \";\".-semi :: Doc e-semi = char ';'---- | The document @colon@ contains a colon, \":\".-colon :: Doc e-colon = char ':'---- | The document @comma@ contains a comma, \",\".-comma :: Doc e-comma = char ','---- | The document @space@ contains a single space, \" \".------ > x <+> y   = x <> space <> y-space :: Doc e -space = char ' '---- | The document @dot@ contains a single dot, \".\".-dot :: Doc e-dot = char '.'---- | The document @backslash@ contains a back slash, \"\\\".-backslash :: Doc e-backslash = char '\\'---- | The document @equals@ contains an equal sign, \"=\".-equals :: Doc e-equals = char '='--instance IsString (Doc e) where-  fromString = pretty---------------------------------------------------------------- overloading "pretty"---------------------------------------------------------------- | The member @prettyList@ is only used to define the @instance Pretty--- a => Pretty [a]@. In normal circumstances only the @pretty@ function--- is used.-class Pretty a where-  pretty     :: a   -> Doc e-  prettyList :: [a] -> Doc e-  prettyList = list . map pretty--instance Pretty a => Pretty [a] where-  pretty = prettyList---- instance Pretty (Doc ()) where---   pretty = id--instance Pretty Strict.ByteString where-  pretty = pretty . Strict.toString--instance Pretty Lazy.ByteString where-  pretty = pretty . Lazy.toString--instance Pretty () where-  pretty () = text "()"--instance Pretty Bool where-  pretty = text . show--instance Pretty Char where-  pretty = char-  prettyList "" = empty-  prettyList ('\n':s) = line <> prettyList s-  prettyList s = case span (/='\n') s of-             (xs,ys) -> text xs <> prettyList ys--instance Pretty a => Pretty (Seq a) where-  pretty = prettyList . toList--instance Pretty a => Pretty (NonEmpty a) where-  pretty = prettyList . toList--instance Pretty Int where-  pretty = text . show--instance Pretty Int8 where-  pretty = text . show--instance Pretty Int16 where-  pretty = text . show--instance Pretty Int32 where-  pretty = text . show--instance Pretty Int64 where-  pretty = text . show--instance Pretty Word where-  pretty = text . show--instance Pretty Word8 where-  pretty = text . show--instance Pretty Word16 where-  pretty = text . show--instance Pretty Word32 where-  pretty = text . show--instance Pretty Word64 where-  pretty = text . show--instance Pretty Integer where-  pretty = text . show--instance Pretty Natural where-  pretty = text . show--instance Pretty Float where-  pretty = text . show--instance Pretty Double where-  pretty = text . show--instance Pretty (Doc a) where-  pretty d = d *> empty--instance (Pretty a,Pretty b) => Pretty (a,b) where-  pretty (x,y) = tupled [pretty x, pretty y]--instance (Pretty a,Pretty b,Pretty c) => Pretty (a,b,c) where-  pretty (x,y,z)= tupled [pretty x, pretty y, pretty z]--instance Pretty a => Pretty (Maybe a) where-  pretty Nothing = empty-  pretty (Just x) = pretty x---------------------------------------------------------------- semi primitive: fill and fillBreak---------------------------------------------------------------- | The document @(fillBreak i x)@ first renders document @x@. It--- than 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 previous example to use @fillBreak@, we get a useful--- variation of the previous output:------ > ptype (name,tp)--- >        = fillBreak 6 (text name) <+> text "::" <+> text tp------ The output will now be:------ @--- let empty  :: Doc e---     nest   :: Int -> Doc e -> Doc e ---     linebreak---            :: Doc e--- @-fillBreak :: Int -> Doc e -> Doc e-fillBreak f x   = width x $ \w ->-                  if (w > f) then nest f linebreak-                             else text (spaces (f - w))----- | The document @(fill i x)@ renders document @x@. It than appends--- @space@s until the width is equal to @i@. If the width of @x@ is--- already larger, nothing is appended. This combinator is quite--- useful in practice to output a list of bindings. The following--- example demonstrates this.------ > types  = [("empty","Doc e")--- >          ,("nest","Int -> Doc e -> Doc e")--- >          ,("linebreak","Doc e")]--- >--- > ptype (name,tp)--- >        = fill 6 (text name) <+> text "::" <+> text tp--- >--- > test   = text "let" <+> align (vcat (map ptype types))------ Which is layed out as:------ @--- let empty  :: Doc e---     nest   :: Int -> Doc e -> Doc e---     linebreak :: Doc e--- @-fill :: Int -> Doc e -> Doc e-fill f d = width d $ \w ->-                     if (w >= f) -                     then empty-                     else text (spaces (f - w))--width :: Doc e -> (Int -> Doc e) -> Doc e-width d f = column (\k1 -> d <> column (\k2 -> f (k2 - k1)))----------------------------------------------------------------- semi primitive: Alignment and indentation---------------------------------------------------------------- | The document @(indent i x)@ indents document @x@ with @i@ spaces.------ > test  = indent 4 (fillSep (map text--- >         (words "the indent combinator indents these words !")))------ Which lays out with a page width of 20 as:------ @---     the indent---     combinator---     indents these---     words !--- @-indent :: Int -> Doc e -> Doc e-indent i d = hang i (text (spaces i) <> d)---- | The hang combinator implements hanging indentation. The document--- @(hang i x)@ renders document @x@ with a nesting level set to the--- current column plus @i@. The following example uses hanging--- indentation for some text:------ > test  = hang 4 (fillSep (map text--- >         (words "the hang combinator indents these words !")))------ Which lays out on a page with a width of 20 characters as:------ @--- the hang combinator---     indents these---     words !--- @------ The @hang@ combinator is implemented as:------ > hang i x  = align (nest i x)-hang :: Int -> Doc e -> Doc e-hang i d = align (nest i d)---- | The document @(align x)@ renders 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:------ > x $$ y  = align (above x y)------ > test    = text "hi" <+> (text "nice" $$ text "world")------ which will be layed out as:------ @--- hi nice---    world--- @-align :: Doc e -> Doc e-align d = column $ \k -> -         nesting $ \i -> nest (k - i) d   --nesting might be negative :-)---------------------------------------------------------------- Primitives---------------------------------------------------------------- | The abstract data type @Doc@ represents pretty documents.------ @Doc@ is an instance of the 'Show' class. @(show doc)@ pretty--- prints document @doc@ with a page width of 100 characters and a--- ribbon width of 40 characters.------ > show (text "hello" `above` text "world")------ Which would return the string \"hello\\nworld\", i.e.------ @--- hello--- world--- @-data Doc e-  = Empty-  | Char {-# UNPACK #-} !Char       -- invariant: char is not '\n'-  | Text {-# UNPACK #-} !Int String -- invariant: text doesn't contain '\n'-  | Line !(Maybe Char)              -- Nothing <=> when undone by group, do not insert a space-  | Cat (Doc e) (Doc e)-  | Nest {-# UNPACK #-} !Int (Doc e)-  | Union (Doc e) (Doc e) -- invariant: first lines of first doc longer than the first lines of the second doc-  | Effect e-  | Column  (Int -> Doc e)-  | Nesting (Int -> Doc e)-  | Columns (Int -> Doc e)-  | Ribbon  (Int -> Doc e)--instance Functor Doc where-  fmap _ Empty = Empty-  fmap _ (Char c) = Char c-  fmap _ (Line b) = Line b-  fmap _ (Text i s) = Text i s-  fmap f (Cat l r) = Cat (fmap f l) (fmap f r)-  fmap f (Nest i d) = Nest i (fmap f d)-  fmap f (Union l r) = Union (fmap f l) (fmap f r)-  fmap f (Effect e) = Effect (f e)-  fmap f (Column k) = Column (fmap f . k)-  fmap f (Nesting k) = Nesting (fmap f . k)-  fmap f (Columns k) = Columns (fmap f . k)-  fmap f (Ribbon k) = Columns (fmap f . k)--instance Apply Doc where-  (<.>) = ap--instance Applicative Doc where-  pure = Effect-  (<*>) = ap--instance Bind Doc where-  (>>-) = (>>=)--instance Monad Doc where-  return = Effect-  Empty >>= _ = Empty-  Char c >>= _ = Char c-  Text i s >>= _ = Text i s-  Line b >>= _ = Line b-  Cat l r >>= k = Cat (l >>= k) (r >>= k)-  Nest i d >>= k = Nest i (d >>= k)-  Union l r >>= k = Union (l >>= k) (r >>= k)-  Effect e >>= k = k e-  Column f >>= k = Column (f >=> k)-  Nesting f >>= k = Nesting (f >=> k)-  Columns f >>= k = Columns (f >=> k)-  Ribbon f >>= k = Ribbon (f >=> k)-  fail _ = empty--instance Alt Doc where-  (<!>) = (<>)--instance Plus Doc where-  zero = empty--instance Alternative Doc where-  (<|>) = (<>)-  -- | The empty document is, indeed, empty. Although @empty@ has no-  -- content, it does have a \'height\' of 1 and behaves exactly like-  -- @(text \"\")@ (and is therefore not a unit of @above@).-  empty = Empty--instance MonadPlus Doc where-  mplus = (<>) -  mzero = empty-  --- | The data type @SimpleDoc@ represents rendered documents and is--- used by the display functions.------ The @Int@ in @SText@ contains the length of the string. The @Int@--- in @SLine@ contains the indentation for that line. The library--- provides two default display functions 'displayS' and--- 'displayIO'. You can provide your own display function by writing a--- function from a @SimpleDoc@ to your own output format.-data SimpleDoc e -  = SEmpty-  | SChar {-# UNPACK #-} !Char (SimpleDoc e)-  | SText {-# UNPACK #-} !Int String (SimpleDoc e)-  | SLine {-# UNPACK #-} !Int (SimpleDoc e)-  | SEffect e (SimpleDoc e)--instance Functor SimpleDoc where-  fmap _ SEmpty = SEmpty-  fmap f (SChar c d) = SChar c (fmap f d)-  fmap f (SText i s d) = SText i s (fmap f d)-  fmap f (SLine i d) = SLine i (fmap f d)-  fmap f (SEffect e d) = SEffect (f e) (fmap f d)--instance Foldable SimpleDoc where-  foldMap _ SEmpty = mempty-  foldMap f (SChar _ d) = foldMap f d-  foldMap f (SText _ _ d) = foldMap f d-  foldMap f (SLine _ d) = foldMap f d-  foldMap f (SEffect e d) = f e `mappend` foldMap f d--instance Traversable SimpleDoc where-  traverse _ SEmpty = pure SEmpty-  traverse f (SChar c d) = SChar c <$> traverse f d-  traverse f (SText i s d) = SText i s <$> traverse f d-  traverse f (SLine i d) = SLine i <$> traverse f d-  traverse f (SEffect e d) = SEffect <$> f e <*> traverse f d---- | The document @(char c)@ contains the literal character @c@. The--- character shouldn't be a newline (@'\n'@), the function 'line'--- should be used for line breaks.-char :: Char -> Doc e-char '\n' = line-char c = Char c---- | The document @(text s)@ contains the literal string @s@. The--- string shouldn't contain any newline (@'\n'@) characters. If the--- string contains newline characters, the function 'string' should be--- used.-text :: String -> Doc e-text "" = Empty-text s  = Text (length s) s---- | The @line@ document advances to the next line and indents to the--- current nesting level. Document @line@ behaves like @(text \" \")@--- if the line break is undone by 'group'.-line :: Doc e-line = Line (Just ' ')---- | The @linebreak@ document advances to the next line and indents to--- the current nesting level. Document @linebreak@ behaves like--- 'empty' if the line break is undone by 'group'.-linebreak :: Doc e-linebreak = Line Nothing---- | The document @(nest i x)@ renders document @x@ with the current--- indentation level increased by i (See also 'hang', 'align' and--- 'indent').------ > nest 2 (text "hello" `above` text "world") `above` text "!"------ outputs as:------ @--- hello---   world--- !--- @-nest :: Int -> Doc e -> Doc e-nest = Nest--column, nesting :: (Int -> Doc e) -> Doc e-column = Column-nesting = Nesting--columns :: (Int -> Doc e) -> Doc e-columns = Columns--ribbon :: (Int -> Doc e) -> Doc e-ribbon = Ribbon---- | The @group@ combinator is used to specify alternative--- layouts. The document @(group x)@ undoes all line breaks in--- document @x@. The resulting line is added to the current line if--- that fits the page. Otherwise, the document @x@ is rendered without--- any changes.-group :: Doc e -> Doc e-group x = Union (flatten x) x--flatten :: Doc e -> Doc e-flatten (Cat x y)       = Cat (flatten x) (flatten y)-flatten (Nest i x)      = Nest i (flatten x)-flatten (Line brk)      = maybe Empty Char brk-flatten (Union x _)     = flatten x-flatten (Column f)      = Column (flatten . f)-flatten (Nesting f)     = Nesting (flatten . f)-flatten (Columns f)     = Columns (flatten . f)-flatten (Ribbon f)      = Ribbon (flatten . f)-flatten other           = other                     --Empty,Char,Text------------------------------------------------------------------ Renderers---------------------------------------------------------------------------------------------------------------------------- renderPretty: the default pretty printing algorithm---------------------------------------------------------------- list of indentation/document pairs; saves an indirection over [(Int,Doc)]-data Docs e = Nil-          | Cons {-# UNPACK #-} !Int (Doc e) (Docs e)---- | This is the default pretty printer which is used by 'show',--- 'putDoc' and 'hPutDoc'. @(renderPretty ribbonfrac width x)@ renders--- document @x@ with a page width of @width@ and a ribbon width of--- @(ribbonfrac * width)@ characters. The ribbon width is the maximal--- amount of non-indentation characters on a line. The parameter--- @ribbonfrac@ should be between @0.0@ and @1.0@. If it is lower or--- higher, the ribbon width will be 0 or @width@ respectively.-renderPretty :: Float -> Int -> Doc e -> SimpleDoc e-renderPretty rfrac w x-    = best 0 0 (Cons 0 x Nil)-    where-      -- r :: the ribbon width in characters-      r  = max 0 (min w (round (fromIntegral w * rfrac)))--      -- best :: n = indentation of current line-      --         k = current column-      --        (ie. (k >= n) && (k - n == count of inserted characters)-      best _ _ Nil      = SEmpty-      best n k (Cons i d ds)-        = case d of-            Empty       -> best n k ds-            Char c      -> let k' = k+1 in seq k' (SChar c (best n k' ds))-            Text l s    -> let k' = k+l in seq k' (SText l s (best n k' ds))-            Line _      -> SLine i (best i i ds)-            Cat x' y     -> best n k (Cons i x' (Cons i y ds))-            Nest j x'    -> let i' = i+j in seq i' (best n k (Cons i' x' ds))-            Effect e    -> SEffect e (best n k ds)-            Union x' y   -> nicest n k (best n k (Cons i x' ds))-                                       (best n k (Cons i y ds))--            Column f    -> best n k (Cons i (f k) ds)-            Nesting f   -> best n k (Cons i (f i) ds)-            Columns f   -> best n k (Cons i (f w) ds)-            Ribbon f    -> best n k (Cons i (f r) ds)--      --nicest :: r = ribbon width, w = page width,-      --          n = indentation of current line, k = current column-      --          x and y, the (simple) documents to chose from.-      --          precondition: first line of x are longer than the first line of y.-      nicest n k x' y | fits wid x' = x'-                      | otherwise  = y-                        where-                          wid = min (w - k) (r - k + n)---fits :: Int -> SimpleDoc e -> Bool-fits w _ | w < 0     = False-fits _ SEmpty        = True-fits w (SChar _ x)   = fits (w - 1) x-fits w (SText l _ x) = fits (w - l) x-fits _ (SLine _ _)   = True-fits w (SEffect _ x) = fits w x----------------------------------------------------------------- renderCompact: renders documents without indentation---  fast and fewer characters output, good for machines----------------------------------------------------------------- | @(renderCompact x)@ renders document @x@ without adding any--- indentation. Since no \'pretty\' printing is involved, this--- renderer is very fast. The resulting output contains fewer--- characters than a pretty printed version and can be used for output--- that is read by other programs.-renderCompact :: Doc e -> SimpleDoc e-renderCompact x-    = scan 0 [x]-    where-      scan _ []     = SEmpty-      scan k (d:ds) = case d of-                        Empty       -> scan k ds-                        Char c      -> let k' = k+1 in seq k' (SChar c (scan k' ds))-                        Text l s    -> let k' = k+l in seq k' (SText l s (scan k' ds))-                        Effect e    -> SEffect e (scan k ds)-                        Line _      -> SLine 0 (scan 0 ds)-                        Cat y z     -> scan k (y:z:ds)-                        Nest _ y    -> scan k (y:ds)-                        Union _ y   -> scan k (y:ds)-                        Column f    -> scan k (f k:ds)-                        Nesting f   -> scan k (f 0:ds)-                        Columns f   -> scan k (f 80:ds)-                        Ribbon  f   -> scan k (f 80:ds)---------------------------------------------------------------- Displayers:  displayS and displayIO----------------------------------------------------------------- | @(displayS simpleDoc)@ takes the output @simpleDoc@ from a--- rendering function and transforms it to a 'ShowS' type (for use in--- the 'Show' class).------ > showWidth :: Int -> Doc -> String--- > showWidth w x   = displayS (renderPretty 0.4 w x) ""-displayS :: SimpleDoc e -> ShowS-displayS SEmpty             = id-displayS (SChar c x)        = showChar c . displayS x-displayS (SText _ s x)      = showString s . displayS x-displayS (SLine i x)        = showString ('\n':indentation i) . displayS x-displayS (SEffect _ t)      = displayS t---- | @(displayIO handle simpleDoc)@ writes @simpleDoc@ to the file--- handle @handle@. This function is used for example by 'hPutDoc':------ > hPutDoc handle doc  = displayIO handle (renderPretty 0.4 100 doc)-displayIO :: Handle -> SimpleDoc e -> IO ()-displayIO handle = go where-  go SEmpty        = return ()-  go (SChar c x)   = hPutChar handle c >> go x-  go (SText _ s x) = hPutStr handle s >> go x-  go (SLine i x)   = hPutStr handle ('\n':indentation i) >> go x-  go (SEffect _ t) = go t---------------------------------------------------------------- default pretty printers: show, putDoc and hPutDoc-------------------------------------------------------------instance Show (Doc e) where-  showsPrec _ doc = displayS (renderPretty 0.4 80 doc)---- | The action @(putDoc doc)@ pretty prints document @doc@ to the--- standard output, with a page width of 100 characters and a ribbon--- width of 40 characters.------ > main :: IO ()--- > main = do{ putDoc (text "hello" <+> text "world") }------ Which would output------ @--- hello world--- @-putDoc :: Doc e -> IO ()-putDoc doc = hPutDoc stdout doc---- | @(hPutDoc handle doc)@ pretty prints document @doc@ to the file--- handle @handle@ with a page width of 100 characters and a ribbon--- width of 40 characters.------ > main = do{ handle <- openFile "MyFile" WriteMode--- >          ; hPutDoc handle (vcat (map text--- >                            ["vertical","text"]))--- >          ; hClose handle--- >          }-hPutDoc :: Handle -> Doc e -> IO ()-hPutDoc handle doc = displayIO handle (renderPretty 0.4 80 doc)---------------------------------------------------------------- insert spaces--- "indentation" used to insert tabs but tabs seem to cause--- more trouble than they solve :-)-------------------------------------------------------------spaces :: Int -> String-spaces n | n <= 0    = ""-         | otherwise = replicate n ' '--indentation :: Int -> String-indentation n = spaces n----indentation n   | n >= 8    = '\t' : indentation (n-8)---                | otherwise = spaces n----  LocalWords:  PPrint combinators Wadler Wadler's encloseSep
+ src/Text/PrettyPrint/Free.hs view
@@ -0,0 +1,120 @@+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.PrettyPrint.Free+-- Copyright   :  Edward Kmett (c) 2011,+--                Daan Leijen (c) 2000+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Pretty print module based on Daan Leijen's implementation of Philip Wadler's +-- \"prettier printer\"+--+-- @+--      \"A prettier printer\"+--      Draft paper, April 1997, revised March 1998.+--      <http://homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf>+-- @+--+-- This is an implementation of the pretty printing combinators+-- described by Philip Wadler (1997). In their bare essence, the+-- combinators of Wadler are not expressive enough to describe some+-- commonly occurring layouts. The PPrint library adds new primitives+-- to describe these layouts and works well in practice.+--+-- The library is based on a single way to concatenate documents,+-- which is associative and has both a left and right unit.  This+-- simple design leads to an efficient and short implementation. The+-- simplicity is reflected in the predictable behaviour of the+-- combinators which make them easy to use in practice.+--+-- A thorough description of the primitive combinators and their+-- implementation can be found in Philip Wadler's paper+-- (1997). Additions and the main differences with his original paper+-- are:+--+-- * The nil document is called empty.+--+-- * The operator '</>' is used+-- for soft line breaks.+--+-- * There are three new primitives: 'align', 'fill' and+-- 'fillBreak'. These are very useful in practice.+--+-- * Lots of other useful combinators, like 'fillSep' and 'list'.+--+-- * There are two renderers, 'renderPretty' for pretty printing and+-- 'renderCompact' for compact output. The pretty printing algorithm+-- also uses a ribbon-width now for even prettier output.+--+-- * There are two displayers, 'displayS' for strings and 'displayIO' for+-- file based output.+--+-- * There is a 'Pretty' class.+--+-- * The implementation uses optimised representations and strictness+-- annotations.+--+-- * A type argument has been added and embedded 'effects' can be seen in+-- the SimpleDoc type.+-- +-- ++-----------------------------------------------------------+module Text.PrettyPrint.Free (+  -- * Documents+    Doc, putDoc, hPutDoc++  -- * Basic combinators+  , char, text, nest, line, linebreak, group, softline+  , softbreak++  -- * Alignment+  --+  -- The combinators in this section can not be described by Wadler's+  -- original combinators. 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+  -- combinators from being \`optimal\'. In practice however they+  -- prove to be very useful. The combinators in this section should+  -- be used with care, since they are more expensive than the other+  -- combinators. 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, semiBraces++  -- * Operators+  , (<+>), above, (</>), aboveBreak, (<//>)++  -- * List combinators+  , hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate++  -- * Fillers+  , fill, fillBreak++  -- * Bracketing combinators+  , enclose, squotes, dquotes, parens, angles, braces, brackets++  -- * Character documents+  , lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket+  , squote, dquote, semi, colon, comma, space, dot, backslash, equals++  -- * Pretty class+  , Pretty(..)++  -- * Rendering+  , SimpleDoc(..), renderPretty, renderCompact+  , displayS, displayIO++  -- * Undocumented++  , column, nesting, width, columns++  -- * Re-exported standard functions+  , empty, (<>)+  ) where++import Text.PrettyPrint.Free.Internal
+ src/Text/PrettyPrint/Free/Internal.hs view
@@ -0,0 +1,1076 @@+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.PrettyPrint.Free.Internal+-- Copyright   :  Edward Kmett (c) 2011,+--                Daan Leijen (c) 2000+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Pretty print module based on Daan Leijen's implementation of Philip Wadler's +-- \"prettier printer\"+--+-- @+--      \"A prettier printer\"+--      Draft paper, April 1997, revised March 1998.+--      <http://homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf>+-- @+--+-- This is an implementation of the pretty printing combinators+-- described by Philip Wadler (1997). In their bare essence, the+-- combinators of Wadler are not expressive enough to describe some+-- commonly occurring layouts. The PPrint library adds new primitives+-- to describe these layouts and works well in practice.+--+-- The library is based on a single way to concatenate documents,+-- which is associative and has both a left and right unit.  This+-- simple design leads to an efficient and short implementation. The+-- simplicity is reflected in the predictable behaviour of the+-- combinators which make them easy to use in practice.+--+-- A thorough description of the primitive combinators and their+-- implementation can be found in Philip Wadler's paper+-- (1997). Additions and the main differences with his original paper+-- are:+--+-- * The nil document is called empty.+--+-- * The operator '</>' is used+-- for soft line breaks.+--+-- * There are three new primitives: 'align', 'fill' and+-- 'fillBreak'. These are very useful in practice.+--+-- * Lots of other useful combinators, like 'fillSep' and 'list'.+--+-- * There are two renderers, 'renderPretty' for pretty printing and+-- 'renderCompact' for compact output. The pretty printing algorithm+-- also uses a ribbon-width now for even prettier output.+--+-- * There are two display routines, 'displayS' for strings and 'displayIO' +-- for file based output.+--+-- * There is a 'Pretty' class.+--+-- * The implementation uses optimised representations and strictness+-- annotations.+--+-- * A type argument has been added and embedded 'effects' can be seen in+-- the SimpleDoc type.+-- +-- ++-----------------------------------------------------------+module Text.PrettyPrint.Free.Internal (+  -- * Documents+    Doc(..), putDoc, hPutDoc++  -- * Basic combinators+  , char, text, nest, line, linebreak, group, softline+  , softbreak++  -- * Alignment+  --+  -- The combinators in this section can not be described by Wadler's+  -- original combinators. 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+  -- combinators from being \`optimal\'. In practice however they+  -- prove to be very useful. The combinators in this section should+  -- be used with care, since they are more expensive than the other+  -- combinators. 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, semiBraces++  -- * Operators+  , (<+>), above, (</>), aboveBreak, (<//>)++  -- * List combinators+  , hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate++  -- * Fillers+  , fill, fillBreak++  -- * Bracketing combinators+  , enclose, squotes, dquotes, parens, angles, braces, brackets++  -- * Character documents+  , lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket+  , squote, dquote, semi, colon, comma, space, dot, backslash, equals++  -- * Pretty class+  , Pretty(..)++  -- * Rendering+  , SimpleDoc(..), renderPretty, renderCompact+  , displayS, displayIO++  -- * Undocumented++  , column, nesting, width, columns, ribbon++  -- * Re-exported standard functions+  , empty, (<>)+  ) where++import Data.String+import Data.Foldable hiding (fold)+import Data.Traversable+import Data.Functor.Apply+import Data.Functor.Bind+import Data.Functor.Plus+import Data.Int+import Data.Word+import qualified Data.ByteString.UTF8 as Strict+import qualified Data.ByteString.Lazy.UTF8 as Lazy+import Data.List.NonEmpty (NonEmpty)+import Numeric.Natural (Natural)+import Control.Applicative+import Control.Monad+import Data.Sequence (Seq)+import Data.Semigroup+import System.IO (Handle,hPutStr,hPutChar,stdout)+import Prelude hiding (foldr1)++infixr 5 </>,<//>,`above`,`aboveBreak`+infixr 6 <+>++-----------------------------------------------------------+-- list, tupled and semiBraces pretty print a list of+-- documents either horizontally or vertically aligned.+-----------------------------------------------------------++-- | The document @(list xs)@ comma separates the documents @xs@ and+-- encloses them in square brackets. The documents are rendered+-- horizontally if that fits the page. Otherwise they are aligned+-- vertically. All comma separators are put in front of the elements.+list :: Foldable f => f (Doc e) -> Doc e+list = encloseSep lbracket rbracket comma++-- | The document @(tupled xs)@ comma separates the documents @xs@ and+-- encloses them in parenthesis. The documents are rendered+-- horizontally if that fits the page. Otherwise they are aligned+-- vertically. All comma separators are put in front of the elements.+tupled :: Foldable f => f (Doc e) -> Doc e +tupled = encloseSep lparen rparen comma++(<+>) :: Doc e -> Doc e -> Doc e+x <+> y = x <> space <> y++-- | The document @(semiBraces xs)@ separates the documents @xs@ with+-- semi colons and encloses them in braces. The documents are rendered+-- horizontally if that fits the page. Otherwise they are aligned+-- vertically. All semi colons are put in front of the elements.+semiBraces :: Foldable f => f (Doc e) -> Doc e+semiBraces = encloseSep lbrace rbrace semi++-- | The document @(encloseSep l r sep xs)@ concatenates the documents+-- @xs@ separated by @sep@ and encloses the resulting document by @l@+-- and @r@. The documents are rendered horizontally if that fits the+-- page. Otherwise they are aligned vertically. All separators are put+-- in front of the elements. For example, the combinator 'list' can be+-- defined with @encloseSep@:+--+-- > list xs = encloseSep lbracket rbracket comma xs+-- > test    = text "list" <+> (list (map int [10,200,3000]))+--+-- Which is layed out with a page width of 20 as:+--+-- @+-- list [10,200,3000]+-- @+--+-- But when the page width is 15, it is layed out as:+--+-- @+-- list [10+--      ,200+--      ,3000]+-- @+encloseSep :: Foldable f => Doc e -> Doc e -> Doc e -> f (Doc e) -> Doc e+encloseSep left right sp ds0+    = case toList ds0 of+        []  -> left <> right+        [d] -> left <> d <> right+        ds  -> align (cat (zipWith (<>) (left : repeat sp) ds) <> right) +++-----------------------------------------------------------+-- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn]+-----------------------------------------------------------+++-- | @(punctuate p xs)@ concatenates all documents in @xs@ with+-- document @p@ except for the last document.+--+-- > someText = map text ["words","in","a","tuple"]+-- > test     = parens (align (cat (punctuate comma someText)))+--+-- This is layed out on a page width of 20 as:+--+-- @+-- (words,in,a,tuple)+-- @+--+-- But when the page width is 15, it is layed out as:+--+-- @+-- (words,+--  in,+--  a,+--  tuple)+-- @+--+-- (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 :: Traversable f => Doc e -> f (Doc e) -> f (Doc e)+punctuate p xs = snd $ mapAccumL (\(d:ds) _ -> (ds, if null ds then d else (d <> p))) (toList xs) xs++-----------------------------------------------------------+-- high-level combinators+-----------------------------------------------------------+++-- | The document @(sep xs)@ concatenates all documents @xs@ either+-- horizontally with @(\<+\>)@, if it fits the page, or vertically with+-- @above@.+--+-- > sep xs  = group (vsep xs)+sep :: Foldable f => f (Doc e) -> Doc e+sep = group . vsep++-- | The document @(fillSep xs)@ concatenates documents @xs@+-- horizontally with @(\<+\>)@ as long as its fits the page, than+-- inserts a @line@ and continues doing that for all documents in+-- @xs@.+--+-- > fillSep xs  = foldr (</>) empty xs+fillSep :: Foldable f => f (Doc e) -> Doc e+fillSep = fold (</>)++-- | The document @(hsep xs)@ concatenates all documents @xs@+-- horizontally with @(\<+\>)@.+hsep :: Foldable f => f (Doc e) -> Doc e+hsep = fold (<+>)++-- | The document @(vsep xs)@ concatenates all documents @xs@+-- vertically with @above@. If a 'group' undoes the line breaks+-- inserted by @vsep@, all documents are separated with a space.+--+-- > someText = map text (words ("text to lay out"))+-- >+-- > test     = text "some" <+> vsep someText+--+-- This is layed out as:+--+-- @+-- some text+-- to+-- lay+-- out+-- @+--+-- The 'align' combinator can be used to align the documents under+-- their first element+--+-- > test = text "some" <+> align (vsep someText)+--+-- Which is printed as:+--+-- @+-- some text+--      to+--      lay+--      out+-- @+vsep :: Foldable f => f (Doc e) -> Doc e+vsep = fold above++-- | The document @(cat xs)@ concatenates all documents @xs@ either+-- horizontally with @(\<\>)@, if it fits the page, or vertically with+-- @aboveBreak@.+--+-- > cat xs  = group (vcat xs)+cat :: Foldable f => f (Doc e) -> Doc e+cat = group . vcat++-- | The document @(fillCat xs)@ concatenates documents @xs@+-- horizontally with @(\<\>)@ as long as its fits the page, than inserts+-- a @linebreak@ and continues doing that for all documents in @xs@.+--+-- > fillCat xs  = foldr (<//>) empty xs+fillCat :: Foldable f => f (Doc e) -> Doc e+fillCat = fold (<//>)++-- | The document @(hcat xs)@ concatenates all documents @xs@+-- horizontally with @(\<\>)@.+hcat :: Foldable f => f (Doc e) -> Doc e+hcat = fold (<>)++-- | The document @(vcat xs)@ concatenates all documents @xs@+-- vertically with @aboveBreak@. If a 'group' undoes the line breaks+-- inserted by @vcat@, all documents are directly concatenated.+vcat :: Foldable f => f (Doc e) -> Doc e+vcat = fold aboveBreak++fold :: Foldable f => (Doc e -> Doc e -> Doc e) -> f (Doc e) -> Doc e+fold f xs = case toList xs of +  [] -> empty+  _  -> foldr1 f xs++instance Semigroup (Doc e) where+  -- | The document @(x \<\> y)@ concatenates document @x@ and document+  -- @y@. It is an associative operation having 'empty' as a left and+  -- right unit.  (infixl 6)+  (<>) = Cat++instance Monoid (Doc e) where+  mappend = Cat+  mempty = empty++-- | The document @(x \<\/\> y)@ concatenates document @x@ and @y@ with a+-- 'softline' in between. This effectively puts @x@ and @y@ either+-- next to each other (with a @space@ in between) or underneath each+-- other. (infixr 5)+(</>) :: Doc e -> Doc e -> Doc e+x </> y = x <> softline <> y++-- | The document @(x \<\/\/\> y)@ concatenates document @x@ and @y@ with+-- a 'softbreak' in between. This effectively puts @x@ and @y@ either+-- right next to each other or underneath each other. (infixr 5)+(<//>) :: Doc e -> Doc e -> Doc e+x <//> y        = x <> softbreak <> y++-- | The document @above x y@ concatenates document @x@ and @y@ with a+-- 'line' in between. (infixr 5)+above :: Doc e -> Doc e -> Doc e+above x y         = x <> line <> y++-- | The document @aboveBreak x y@ concatenates document @x@ and @y@ with+-- a @linebreak@ in between. (infixr 5)+aboveBreak :: Doc e -> Doc e -> Doc e+aboveBreak x y        = x <> linebreak <> y++-- | The document @softline@ behaves like 'space' if the resulting+-- output fits the page, otherwise it behaves like 'line'.+--+-- > softline = group line+softline :: Doc e+softline = group line++-- | The document @softbreak@ behaves like 'empty' if the resulting+-- output fits the page, otherwise it behaves like 'line'.+--+-- > softbreak  = group linebreak+softbreak :: Doc e+softbreak = group linebreak++-- | Document @(squotes x)@ encloses document @x@ with single quotes+-- \"'\".+squotes :: Doc e -> Doc e+squotes = enclose squote squote++-- | Document @(dquotes x)@ encloses document @x@ with double quotes+-- '\"'.+dquotes :: Doc e -> Doc e+dquotes = enclose dquote dquote++-- | Document @(braces x)@ encloses document @x@ in braces, \"{\" and+-- \"}\".+braces :: Doc e -> Doc e+braces = enclose lbrace rbrace++-- | Document @(parens x)@ encloses document @x@ in parenthesis, \"(\"+-- and \")\".+parens :: Doc e -> Doc e+parens = enclose lparen rparen++-- | Document @(angles x)@ encloses document @x@ in angles, \"\<\" and+-- \"\>\".+angles :: Doc e -> Doc e+angles = enclose langle rangle++-- | Document @(brackets x)@ encloses document @x@ in square brackets,+-- \"[\" and \"]\".+brackets :: Doc e -> Doc e+brackets = enclose lbracket rbracket++-- | The document @(enclose l r x)@ encloses document @x@ between+-- documents @l@ and @r@ using @(\<\>)@.+--+-- > enclose l r x   = l <> x <> r+enclose :: Doc e -> Doc e -> Doc e -> Doc e+enclose l r x = l <> x <> r++-- | The document @lparen@ contains a left parenthesis, \"(\".+lparen :: Doc e+lparen = char '('++-- | The document @rparen@ contains a right parenthesis, \")\".+rparen :: Doc e+rparen = char ')'++-- | The document @langle@ contains a left angle, \"\<\".+langle :: Doc e+langle = char '<'++-- | The document @rangle@ contains a right angle, \">\".+rangle :: Doc e+rangle = char '>'++-- | The document @lbrace@ contains a left brace, \"{\".+lbrace :: Doc e+lbrace = char '{'++-- | The document @rbrace@ contains a right brace, \"}\".+rbrace :: Doc e+rbrace = char '}'++-- | The document @lbracket@ contains a left square bracket, \"[\".+lbracket :: Doc e+lbracket = char '['++-- | The document @rbracket@ contains a right square bracket, \"]\".+rbracket :: Doc e+rbracket = char ']'++-- | The document @squote@ contains a single quote, \"'\".+squote :: Doc e+squote = char '\''++-- | The document @dquote@ contains a double quote, '\"'.+dquote :: Doc e+dquote = char '"'++-- | The document @semi@ contains a semi colon, \";\".+semi :: Doc e+semi = char ';'++-- | The document @colon@ contains a colon, \":\".+colon :: Doc e+colon = char ':'++-- | The document @comma@ contains a comma, \",\".+comma :: Doc e+comma = char ','++-- | The document @space@ contains a single space, \" \".+--+-- > x <+> y   = x <> space <> y+space :: Doc e +space = char ' '++-- | The document @dot@ contains a single dot, \".\".+dot :: Doc e+dot = char '.'++-- | The document @backslash@ contains a back slash, \"\\\".+backslash :: Doc e+backslash = char '\\'++-- | The document @equals@ contains an equal sign, \"=\".+equals :: Doc e+equals = char '='++instance IsString (Doc e) where+  fromString = pretty++-----------------------------------------------------------+-- overloading "pretty"+-----------------------------------------------------------++-- | The member @prettyList@ is only used to define the @instance Pretty+-- a => Pretty [a]@. In normal circumstances only the @pretty@ function+-- is used.+class Pretty a where+  pretty     :: a   -> Doc e+  prettyList :: [a] -> Doc e+  prettyList = list . map pretty++instance Pretty a => Pretty [a] where+  pretty = prettyList++-- instance Pretty (Doc ()) where+--   pretty = id++instance Pretty Strict.ByteString where+  pretty = pretty . Strict.toString++instance Pretty Lazy.ByteString where+  pretty = pretty . Lazy.toString++instance Pretty () where+  pretty () = text "()"++instance Pretty Bool where+  pretty = text . show++instance Pretty Char where+  pretty = char+  prettyList "" = empty+  prettyList ('\n':s) = line <> prettyList s+  prettyList s = case span (/='\n') s of+             (xs,ys) -> text xs <> prettyList ys++instance Pretty a => Pretty (Seq a) where+  pretty = prettyList . toList++instance Pretty a => Pretty (NonEmpty a) where+  pretty = prettyList . toList++instance Pretty Int where+  pretty = text . show++instance Pretty Int8 where+  pretty = text . show++instance Pretty Int16 where+  pretty = text . show++instance Pretty Int32 where+  pretty = text . show++instance Pretty Int64 where+  pretty = text . show++instance Pretty Word where+  pretty = text . show++instance Pretty Word8 where+  pretty = text . show++instance Pretty Word16 where+  pretty = text . show++instance Pretty Word32 where+  pretty = text . show++instance Pretty Word64 where+  pretty = text . show++instance Pretty Integer where+  pretty = text . show++instance Pretty Natural where+  pretty = text . show++instance Pretty Float where+  pretty = text . show++instance Pretty Double where+  pretty = text . show++instance Pretty (Doc a) where+  pretty d = d *> empty++instance (Pretty a,Pretty b) => Pretty (a,b) where+  pretty (x,y) = tupled [pretty x, pretty y]++instance (Pretty a,Pretty b,Pretty c) => Pretty (a,b,c) where+  pretty (x,y,z)= tupled [pretty x, pretty y, pretty z]++instance Pretty a => Pretty (Maybe a) where+  pretty Nothing = empty+  pretty (Just x) = pretty x++-----------------------------------------------------------+-- semi primitive: fill and fillBreak+-----------------------------------------------------------++-- | The document @(fillBreak i x)@ first renders document @x@. It+-- than 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 previous example to use @fillBreak@, we get a useful+-- variation of the previous output:+--+-- > ptype (name,tp)+-- >        = fillBreak 6 (text name) <+> text "::" <+> text tp+--+-- The output will now be:+--+-- @+-- let empty  :: Doc e+--     nest   :: Int -> Doc e -> Doc e +--     linebreak+--            :: Doc e+-- @+fillBreak :: Int -> Doc e -> Doc e+fillBreak f x   = width x $ \w ->+                  if (w > f) then nest f linebreak+                             else text (spaces (f - w))+++-- | The document @(fill i x)@ renders document @x@. It than appends+-- @space@s until the width is equal to @i@. If the width of @x@ is+-- already larger, nothing is appended. This combinator is quite+-- useful in practice to output a list of bindings. The following+-- example demonstrates this.+--+-- > types  = [("empty","Doc e")+-- >          ,("nest","Int -> Doc e -> Doc e")+-- >          ,("linebreak","Doc e")]+-- >+-- > ptype (name,tp)+-- >        = fill 6 (text name) <+> text "::" <+> text tp+-- >+-- > test   = text "let" <+> align (vcat (map ptype types))+--+-- Which is layed out as:+--+-- @+-- let empty  :: Doc e+--     nest   :: Int -> Doc e -> Doc e+--     linebreak :: Doc e+-- @+fill :: Int -> Doc e -> Doc e+fill f d = width d $ \w ->+                     if (w >= f) +                     then empty+                     else text (spaces (f - w))++width :: Doc e -> (Int -> Doc e) -> Doc e+width d f = column (\k1 -> d <> column (\k2 -> f (k2 - k1)))+++-----------------------------------------------------------+-- semi primitive: Alignment and indentation+-----------------------------------------------------------++-- | The document @(indent i x)@ indents document @x@ with @i@ spaces.+--+-- > test  = indent 4 (fillSep (map text+-- >         (words "the indent combinator indents these words !")))+--+-- Which lays out with a page width of 20 as:+--+-- @+--     the indent+--     combinator+--     indents these+--     words !+-- @+indent :: Int -> Doc e -> Doc e+indent i d = hang i (text (spaces i) <> d)++-- | The hang combinator implements hanging indentation. The document+-- @(hang i x)@ renders document @x@ with a nesting level set to the+-- current column plus @i@. The following example uses hanging+-- indentation for some text:+--+-- > test  = hang 4 (fillSep (map text+-- >         (words "the hang combinator indents these words !")))+--+-- Which lays out on a page with a width of 20 characters as:+--+-- @+-- the hang combinator+--     indents these+--     words !+-- @+--+-- The @hang@ combinator is implemented as:+--+-- > hang i x  = align (nest i x)+hang :: Int -> Doc e -> Doc e+hang i d = align (nest i d)++-- | The document @(align x)@ renders 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:+--+-- > x $$ y  = align (above x y)+--+-- > test    = text "hi" <+> (text "nice" $$ text "world")+--+-- which will be layed out as:+--+-- @+-- hi nice+--    world+-- @+align :: Doc e -> Doc e+align d = column $ \k -> +         nesting $ \i -> nest (k - i) d   --nesting might be negative :-)++-----------------------------------------------------------+-- Primitives+-----------------------------------------------------------++-- | The abstract data type @Doc@ represents pretty documents.+--+-- @Doc@ is an instance of the 'Show' class. @(show doc)@ pretty+-- prints document @doc@ with a page width of 100 characters and a+-- ribbon width of 40 characters.+--+-- > show (text "hello" `above` text "world")+--+-- Which would return the string \"hello\\nworld\", i.e.+--+-- @+-- hello+-- world+-- @+data Doc e+  = Empty+  | Char {-# UNPACK #-} !Char       -- invariant: char is not '\n'+  | Text {-# UNPACK #-} !Int String -- invariant: text doesn't contain '\n'+  | Line !(Maybe Char)              -- Nothing <=> when undone by group, do not insert a space+  | Cat (Doc e) (Doc e)+  | Nest {-# UNPACK #-} !Int (Doc e)+  | Union (Doc e) (Doc e) -- invariant: first lines of first doc longer than the first lines of the second doc+  | Effect e+  | Column  (Int -> Doc e)+  | Nesting (Int -> Doc e)+  | Columns (Int -> Doc e)+  | Ribbon  (Int -> Doc e)++instance Functor Doc where+  fmap _ Empty = Empty+  fmap _ (Char c) = Char c+  fmap _ (Line b) = Line b+  fmap _ (Text i s) = Text i s+  fmap f (Cat l r) = Cat (fmap f l) (fmap f r)+  fmap f (Nest i d) = Nest i (fmap f d)+  fmap f (Union l r) = Union (fmap f l) (fmap f r)+  fmap f (Effect e) = Effect (f e)+  fmap f (Column k) = Column (fmap f . k)+  fmap f (Nesting k) = Nesting (fmap f . k)+  fmap f (Columns k) = Columns (fmap f . k)+  fmap f (Ribbon k) = Columns (fmap f . k)++instance Apply Doc where+  (<.>) = ap++instance Applicative Doc where+  pure = Effect+  (<*>) = ap++instance Bind Doc where+  (>>-) = (>>=)++instance Monad Doc where+  return = Effect+  Empty >>= _ = Empty+  Char c >>= _ = Char c+  Text i s >>= _ = Text i s+  Line b >>= _ = Line b+  Cat l r >>= k = Cat (l >>= k) (r >>= k)+  Nest i d >>= k = Nest i (d >>= k)+  Union l r >>= k = Union (l >>= k) (r >>= k)+  Effect e >>= k = k e+  Column f >>= k = Column (f >=> k)+  Nesting f >>= k = Nesting (f >=> k)+  Columns f >>= k = Columns (f >=> k)+  Ribbon f >>= k = Ribbon (f >=> k)+  fail _ = empty++instance Alt Doc where+  (<!>) = (<>)++instance Plus Doc where+  zero = empty++instance Alternative Doc where+  (<|>) = (<>)+  -- | The empty document is, indeed, empty. Although @empty@ has no+  -- content, it does have a \'height\' of 1 and behaves exactly like+  -- @(text \"\")@ (and is therefore not a unit of @above@).+  empty = Empty++instance MonadPlus Doc where+  mplus = (<>) +  mzero = empty+  +-- | The data type @SimpleDoc@ represents rendered documents and is+-- used by the display functions.+--+-- The @Int@ in @SText@ contains the length of the string. The @Int@+-- in @SLine@ contains the indentation for that line. The library+-- provides two default display functions 'displayS' and+-- 'displayIO'. You can provide your own display function by writing a+-- function from a @SimpleDoc@ to your own output format.+data SimpleDoc e +  = SEmpty+  | SChar {-# UNPACK #-} !Char (SimpleDoc e)+  | SText {-# UNPACK #-} !Int String (SimpleDoc e)+  | SLine {-# UNPACK #-} !Int (SimpleDoc e)+  | SEffect e (SimpleDoc e)++instance Functor SimpleDoc where+  fmap _ SEmpty = SEmpty+  fmap f (SChar c d) = SChar c (fmap f d)+  fmap f (SText i s d) = SText i s (fmap f d)+  fmap f (SLine i d) = SLine i (fmap f d)+  fmap f (SEffect e d) = SEffect (f e) (fmap f d)++instance Foldable SimpleDoc where+  foldMap _ SEmpty = mempty+  foldMap f (SChar _ d) = foldMap f d+  foldMap f (SText _ _ d) = foldMap f d+  foldMap f (SLine _ d) = foldMap f d+  foldMap f (SEffect e d) = f e `mappend` foldMap f d++instance Traversable SimpleDoc where+  traverse _ SEmpty = pure SEmpty+  traverse f (SChar c d) = SChar c <$> traverse f d+  traverse f (SText i s d) = SText i s <$> traverse f d+  traverse f (SLine i d) = SLine i <$> traverse f d+  traverse f (SEffect e d) = SEffect <$> f e <*> traverse f d++-- | The document @(char c)@ contains the literal character @c@. The+-- character shouldn't be a newline (@'\n'@), the function 'line'+-- should be used for line breaks.+char :: Char -> Doc e+char '\n' = line+char c = Char c++-- | The document @(text s)@ contains the literal string @s@. The+-- string shouldn't contain any newline (@'\n'@) characters. If the+-- string contains newline characters, the function 'string' should be+-- used.+text :: String -> Doc e+text "" = Empty+text s  = Text (length s) s++-- | The @line@ document advances to the next line and indents to the+-- current nesting level. Document @line@ behaves like @(text \" \")@+-- if the line break is undone by 'group'.+line :: Doc e+line = Line (Just ' ')++-- | The @linebreak@ document advances to the next line and indents to+-- the current nesting level. Document @linebreak@ behaves like+-- 'empty' if the line break is undone by 'group'.+linebreak :: Doc e+linebreak = Line Nothing++-- | The document @(nest i x)@ renders document @x@ with the current+-- indentation level increased by i (See also 'hang', 'align' and+-- 'indent').+--+-- > nest 2 (text "hello" `above` text "world") `above` text "!"+--+-- outputs as:+--+-- @+-- hello+--   world+-- !+-- @+nest :: Int -> Doc e -> Doc e+nest = Nest++column, nesting :: (Int -> Doc e) -> Doc e+column = Column+nesting = Nesting++columns :: (Int -> Doc e) -> Doc e+columns = Columns++ribbon :: (Int -> Doc e) -> Doc e+ribbon = Ribbon++-- | The @group@ combinator is used to specify alternative+-- layouts. The document @(group x)@ undoes all line breaks in+-- document @x@. The resulting line is added to the current line if+-- that fits the page. Otherwise, the document @x@ is rendered without+-- any changes.+group :: Doc e -> Doc e+group x = Union (flatten x) x++flatten :: Doc e -> Doc e+flatten (Cat x y)       = Cat (flatten x) (flatten y)+flatten (Nest i x)      = Nest i (flatten x)+flatten (Line brk)      = maybe Empty Char brk+flatten (Union x _)     = flatten x+flatten (Column f)      = Column (flatten . f)+flatten (Nesting f)     = Nesting (flatten . f)+flatten (Columns f)     = Columns (flatten . f)+flatten (Ribbon f)      = Ribbon (flatten . f)+flatten other           = other                     --Empty,Char,Text++++-----------------------------------------------------------+-- Renderers+-----------------------------------------------------------++-----------------------------------------------------------+-- renderPretty: the default pretty printing algorithm+-----------------------------------------------------------++-- list of indentation/document pairs; saves an indirection over [(Int,Doc)]+data Docs e = Nil+          | Cons {-# UNPACK #-} !Int (Doc e) (Docs e)++-- | This is the default pretty printer which is used by 'show',+-- 'putDoc' and 'hPutDoc'. @(renderPretty ribbonfrac width x)@ renders+-- document @x@ with a page width of @width@ and a ribbon width of+-- @(ribbonfrac * width)@ characters. The ribbon width is the maximal+-- amount of non-indentation characters on a line. The parameter+-- @ribbonfrac@ should be between @0.0@ and @1.0@. If it is lower or+-- higher, the ribbon width will be 0 or @width@ respectively.+renderPretty :: Float -> Int -> Doc e -> SimpleDoc e+renderPretty rfrac w x+    = best 0 0 (Cons 0 x Nil)+    where+      -- r :: the ribbon width in characters+      r  = max 0 (min w (round (fromIntegral w * rfrac)))++      -- best :: n = indentation of current line+      --         k = current column+      --        (ie. (k >= n) && (k - n == count of inserted characters)+      best _ _ Nil      = SEmpty+      best n k (Cons i d ds)+        = case d of+            Empty       -> best n k ds+            Char c      -> let k' = k+1 in seq k' (SChar c (best n k' ds))+            Text l s    -> let k' = k+l in seq k' (SText l s (best n k' ds))+            Line _      -> SLine i (best i i ds)+            Cat x' y     -> best n k (Cons i x' (Cons i y ds))+            Nest j x'    -> let i' = i+j in seq i' (best n k (Cons i' x' ds))+            Effect e    -> SEffect e (best n k ds)+            Union x' y   -> nicest n k (best n k (Cons i x' ds))+                                       (best n k (Cons i y ds))++            Column f    -> best n k (Cons i (f k) ds)+            Nesting f   -> best n k (Cons i (f i) ds)+            Columns f   -> best n k (Cons i (f w) ds)+            Ribbon f    -> best n k (Cons i (f r) ds)++      --nicest :: r = ribbon width, w = page width,+      --          n = indentation of current line, k = current column+      --          x and y, the (simple) documents to chose from.+      --          precondition: first line of x are longer than the first line of y.+      nicest n k x' y | fits wid x' = x'+                      | otherwise  = y+                        where+                          wid = min (w - k) (r - k + n)+++fits :: Int -> SimpleDoc e -> Bool+fits w _ | w < 0     = False+fits _ SEmpty        = True+fits w (SChar _ x)   = fits (w - 1) x+fits w (SText l _ x) = fits (w - l) x+fits _ (SLine _ _)   = True+fits w (SEffect _ x) = fits w x+++-----------------------------------------------------------+-- renderCompact: renders documents without indentation+--  fast and fewer characters output, good for machines+-----------------------------------------------------------+++-- | @(renderCompact x)@ renders document @x@ without adding any+-- indentation. Since no \'pretty\' printing is involved, this+-- renderer is very fast. The resulting output contains fewer+-- characters than a pretty printed version and can be used for output+-- that is read by other programs.+renderCompact :: Doc e -> SimpleDoc e+renderCompact x+    = scan 0 [x]+    where+      scan _ []     = SEmpty+      scan k (d:ds) = case d of+                        Empty       -> scan k ds+                        Char c      -> let k' = k+1 in seq k' (SChar c (scan k' ds))+                        Text l s    -> let k' = k+l in seq k' (SText l s (scan k' ds))+                        Effect e    -> SEffect e (scan k ds)+                        Line _      -> SLine 0 (scan 0 ds)+                        Cat y z     -> scan k (y:z:ds)+                        Nest _ y    -> scan k (y:ds)+                        Union _ y   -> scan k (y:ds)+                        Column f    -> scan k (f k:ds)+                        Nesting f   -> scan k (f 0:ds)+                        Columns f   -> scan k (f 80:ds)+                        Ribbon  f   -> scan k (f 80:ds)++-----------------------------------------------------------+-- Displayers:  displayS and displayIO+-----------------------------------------------------------+++-- | @(displayS simpleDoc)@ takes the output @simpleDoc@ from a+-- rendering function and transforms it to a 'ShowS' type (for use in+-- the 'Show' class).+--+-- > showWidth :: Int -> Doc -> String+-- > showWidth w x   = displayS (renderPretty 0.4 w x) ""+displayS :: SimpleDoc e -> ShowS+displayS SEmpty             = id+displayS (SChar c x)        = showChar c . displayS x+displayS (SText _ s x)      = showString s . displayS x+displayS (SLine i x)        = showString ('\n':indentation i) . displayS x+displayS (SEffect _ t)      = displayS t++-- | @(displayIO handle simpleDoc)@ writes @simpleDoc@ to the file+-- handle @handle@. This function is used for example by 'hPutDoc':+--+-- > hPutDoc handle doc  = displayIO handle (renderPretty 0.4 100 doc)+displayIO :: Handle -> SimpleDoc e -> IO ()+displayIO handle = go where+  go SEmpty        = return ()+  go (SChar c x)   = hPutChar handle c >> go x+  go (SText _ s x) = hPutStr handle s >> go x+  go (SLine i x)   = hPutStr handle ('\n':indentation i) >> go x+  go (SEffect _ t) = go t++-----------------------------------------------------------+-- default pretty printers: show, putDoc and hPutDoc+-----------------------------------------------------------+instance Show (Doc e) where+  showsPrec _ doc = displayS (renderPretty 0.4 80 doc)++-- | The action @(putDoc doc)@ pretty prints document @doc@ to the+-- standard output, with a page width of 100 characters and a ribbon+-- width of 40 characters.+--+-- > main :: IO ()+-- > main = do{ putDoc (text "hello" <+> text "world") }+--+-- Which would output+--+-- @+-- hello world+-- @+putDoc :: Doc e -> IO ()+putDoc doc = hPutDoc stdout doc++-- | @(hPutDoc handle doc)@ pretty prints document @doc@ to the file+-- handle @handle@ with a page width of 100 characters and a ribbon+-- width of 40 characters.+--+-- > main = do{ handle <- openFile "MyFile" WriteMode+-- >          ; hPutDoc handle (vcat (map text+-- >                            ["vertical","text"]))+-- >          ; hClose handle+-- >          }+hPutDoc :: Handle -> Doc e -> IO ()+hPutDoc handle doc = displayIO handle (renderPretty 0.4 80 doc)++-----------------------------------------------------------+-- insert spaces+-- "indentation" used to insert tabs but tabs seem to cause+-- more trouble than they solve :-)+-----------------------------------------------------------+spaces :: Int -> String+spaces n | n <= 0    = ""+         | otherwise = replicate n ' '++indentation :: Int -> String+indentation n = spaces n++--indentation n   | n >= 8    = '\t' : indentation (n-8)+--                | otherwise = spaces n++--  LocalWords:  PPrint combinators Wadler Wadler's encloseSep
wl-pprint-extras.cabal view
@@ -1,6 +1,6 @@ name:          wl-pprint-extras category:      Control, Monads, Text-version:       3.2+version:       3.3 cabal-version: >= 1.6 license:       BSD3 license-file:  LICENSE@@ -25,8 +25,9 @@   build-depends:     base          == 4.*,     containers    >= 0.4     && < 0.6,-    semigroups    >= 0.8.3.1 && < 0.9,-    semigroupoids == 3.0.*,+    nats          >= 0.1,+    semigroups    >= 0.9,+    semigroupoids >= 3,     utf8-string   >= 0.3.6   && < 0.4    exposed-modules:@@ -34,3 +35,4 @@     Text.PrettyPrint.Free.Internal    ghc-options:      -Wall+  hs-source-dirs:   src