wl-pprint-1.2: Text/PrettyPrint/Leijen.hs
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Text.PrettyPrint.Leijen
-- Copyright : Daan Leijen (c) 2000, http://www.cs.uu.nl/~daan
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : otakar.smrz cmu.edu
-- Stability : provisional
-- Portability : portable
--
-- Pretty print module based on Philip Wadler's \"prettier printer\"
--
-- @
-- \"A prettier printer\"
-- Draft paper, April 1997, revised March 1998.
-- <http://cm.bell-labs.com/cm/cs/who/wadler/papers/prettier/prettier.ps>
-- @
--
-- PPrint 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 above combinator is called '<$>'. 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.
--
-- Full documentation available at <http://www.cs.uu.nl/~daan/download/pprint/pprint.html>.
-----------------------------------------------------------
module Text.PrettyPrint.Leijen (
-- * Documents
Doc, putDoc, hPutDoc,
-- * Basic combinators
empty, 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
(<+>), (<$>), (</>), (<$$>), (<//>),
-- * 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,
-- * Primitive type documents
string, int, integer, float, double, rational,
-- * Pretty class
Pretty(..),
-- * Rendering
SimpleDoc(..), renderPretty, renderCompact, displayS, displayIO
-- * Undocumented
, bool
, column, nesting, width
) where
import System.IO (Handle,hPutStr,hPutChar,stdout)
#if MIN_VERSION_base(4,8,0)
import Prelude hiding ((<$>))
#endif
infixr 5 </>,<//>,<$>,<$$>
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 :: [Doc] -> Doc
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 :: [Doc] -> Doc
tupled = encloseSep lparen rparen comma
-- | 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 :: [Doc] -> Doc
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 :: Doc -> Doc -> Doc -> [Doc] -> Doc
encloseSep left right sep ds
= case ds of
[] -> left <> right
[d] -> left <> d <> right
_ -> align (cat (zipWith (<>) (left : repeat sep) 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 :: Doc -> [Doc] -> [Doc]
punctuate p [] = []
punctuate p [d] = [d]
punctuate p (d:ds) = (d <> p) : punctuate p ds
-----------------------------------------------------------
-- high-level combinators
-----------------------------------------------------------
-- | The document @(sep xs)@ concatenates all documents @xs@ either
-- horizontally with @(\<+\>)@, if it fits the page, or vertically with
-- @(\<$\>)@.
--
-- > sep xs = group (vsep xs)
sep :: [Doc] -> Doc
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 :: [Doc] -> Doc
fillSep = fold (</>)
-- | The document @(hsep xs)@ concatenates all documents @xs@
-- horizontally with @(\<+\>)@.
hsep :: [Doc] -> Doc
hsep = fold (<+>)
-- | The document @(vsep xs)@ concatenates all documents @xs@
-- vertically with @(\<$\>)@. 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 :: [Doc] -> Doc
vsep = fold (<$>)
-- | The document @(cat xs)@ concatenates all documents @xs@ either
-- horizontally with @(\<\>)@, if it fits the page, or vertically with
-- @(\<$$\>)@.
--
-- > cat xs = group (vcat xs)
cat :: [Doc] -> Doc
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 :: [Doc] -> Doc
fillCat = fold (<//>)
-- | The document @(hcat xs)@ concatenates all documents @xs@
-- horizontally with @(\<\>)@.
hcat :: [Doc] -> Doc
hcat = fold (<>)
-- | The document @(vcat xs)@ concatenates all documents @xs@
-- vertically with @(\<$$\>)@. If a 'group' undoes the line breaks
-- inserted by @vcat@, all documents are directly concatenated.
vcat :: [Doc] -> Doc
vcat = fold (<$$>)
fold f [] = empty
fold f ds = foldr1 f ds
-- | The document @(x \<\> y)@ concatenates document @x@ and document
-- @y@. It is an associative operation having 'empty' as a left and
-- right unit. (infixr 6)
(<>) :: Doc -> Doc -> Doc
x <> y = x `beside` y
-- | The document @(x \<+\> y)@ concatenates document @x@ and @y@ with a
-- @space@ in between. (infixr 6)
(<+>) :: Doc -> Doc -> Doc
x <+> y = x <> space <> y
-- | 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 -> Doc -> Doc
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 -> Doc -> Doc
x <//> y = x <> softbreak <> y
-- | The document @(x \<$\> y)@ concatenates document @x@ and @y@ with a
-- 'line' in between. (infixr 5)
(<$>) :: Doc -> Doc -> Doc
x <$> y = x <> line <> y
-- | The document @(x \<$$\> y)@ concatenates document @x@ and @y@ with
-- a @linebreak@ in between. (infixr 5)
(<$$>) :: Doc -> Doc -> Doc
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
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
softbreak = group linebreak
-- | Document @(squotes x)@ encloses document @x@ with single quotes
-- \"'\".
squotes :: Doc -> Doc
squotes = enclose squote squote
-- | Document @(dquotes x)@ encloses document @x@ with double quotes
-- '\"'.
dquotes :: Doc -> Doc
dquotes = enclose dquote dquote
-- | Document @(braces x)@ encloses document @x@ in braces, \"{\" and
-- \"}\".
braces :: Doc -> Doc
braces = enclose lbrace rbrace
-- | Document @(parens x)@ encloses document @x@ in parenthesis, \"(\"
-- and \")\".
parens :: Doc -> Doc
parens = enclose lparen rparen
-- | Document @(angles x)@ encloses document @x@ in angles, \"\<\" and
-- \"\>\".
angles :: Doc -> Doc
angles = enclose langle rangle
-- | Document @(brackets x)@ encloses document @x@ in square brackets,
-- \"[\" and \"]\".
brackets :: Doc -> Doc
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 -> Doc -> Doc -> Doc
enclose l r x = l <> x <> r
-- | The document @lparen@ contains a left parenthesis, \"(\".
lparen :: Doc
lparen = char '('
-- | The document @rparen@ contains a right parenthesis, \")\".
rparen :: Doc
rparen = char ')'
-- | The document @langle@ contains a left angle, \"\<\".
langle :: Doc
langle = char '<'
-- | The document @rangle@ contains a right angle, \">\".
rangle :: Doc
rangle = char '>'
-- | The document @lbrace@ contains a left brace, \"{\".
lbrace :: Doc
lbrace = char '{'
-- | The document @rbrace@ contains a right brace, \"}\".
rbrace :: Doc
rbrace = char '}'
-- | The document @lbracket@ contains a left square bracket, \"[\".
lbracket :: Doc
lbracket = char '['
-- | The document @rbracket@ contains a right square bracket, \"]\".
rbracket :: Doc
rbracket = char ']'
-- | The document @squote@ contains a single quote, \"'\".
squote :: Doc
squote = char '\''
-- | The document @dquote@ contains a double quote, '\"'.
dquote :: Doc
dquote = char '"'
-- | The document @semi@ contains a semi colon, \";\".
semi :: Doc
semi = char ';'
-- | The document @colon@ contains a colon, \":\".
colon :: Doc
colon = char ':'
-- | The document @comma@ contains a comma, \",\".
comma :: Doc
comma = char ','
-- | The document @space@ contains a single space, \" \".
--
-- > x <+> y = x <> space <> y
space :: Doc
space = char ' '
-- | The document @dot@ contains a single dot, \".\".
dot :: Doc
dot = char '.'
-- | The document @backslash@ contains a back slash, \"\\\".
backslash :: Doc
backslash = char '\\'
-- | The document @equals@ contains an equal sign, \"=\".
equals :: Doc
equals = char '='
-----------------------------------------------------------
-- Combinators for prelude types
-----------------------------------------------------------
-- string is like "text" but replaces '\n' by "line"
-- | The document @(string s)@ concatenates all characters in @s@
-- using @line@ for newline characters and @char@ for all other
-- characters. It is used instead of 'text' whenever the text contains
-- newline characters.
string :: String -> Doc
string "" = empty
string ('\n':s) = line <> string s
string s = case (span (/='\n') s) of
(xs,ys) -> text xs <> string ys
bool :: Bool -> Doc
bool b = text (show b)
-- | The document @(int i)@ shows the literal integer @i@ using
-- 'text'.
int :: Int -> Doc
int i = text (show i)
-- | The document @(integer i)@ shows the literal integer @i@ using
-- 'text'.
integer :: Integer -> Doc
integer i = text (show i)
-- | The document @(float f)@ shows the literal float @f@ using
-- 'text'.
float :: Float -> Doc
float f = text (show f)
-- | The document @(double d)@ shows the literal double @d@ using
-- 'text'.
double :: Double -> Doc
double d = text (show d)
-- | The document @(rational r)@ shows the literal rational @r@ using
-- 'text'.
rational :: Rational -> Doc
rational r = text (show r)
-----------------------------------------------------------
-- 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
prettyList :: [a] -> Doc
prettyList = list . map pretty
instance Pretty a => Pretty [a] where
pretty = prettyList
instance Pretty Doc where
pretty = id
instance Pretty () where
pretty () = text "()"
instance Pretty Bool where
pretty b = bool b
instance Pretty Char where
pretty c = char c
prettyList s = string s
instance Pretty Int where
pretty i = int i
instance Pretty Integer where
pretty i = integer i
instance Pretty Float where
pretty f = float f
instance Pretty Double where
pretty d = double d
--instance Pretty Rational where
-- pretty r = rational r
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
-- nest :: Int -> Doc -> Doc
-- linebreak
-- :: Doc
-- @
fillBreak :: Int -> Doc -> Doc
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")
-- > ,("nest","Int -> Doc -> Doc")
-- > ,("linebreak","Doc")]
-- >
-- > 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
-- nest :: Int -> Doc -> Doc
-- linebreak :: Doc
-- @
fill :: Int -> Doc -> Doc
fill f d = width d (\w ->
if (w >= f) then empty
else text (spaces (f - w)))
width :: Doc -> (Int -> Doc) -> Doc
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 -> Doc
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 -> Doc
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 (x <$> y)
--
-- > test = text "hi" <+> (text "nice" $$ text "world")
--
-- which will be layed out as:
--
-- @
-- hi nice
-- world
-- @
align :: Doc -> Doc
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" <$> text "world")
--
-- Which would return the string \"hello\\nworld\", i.e.
--
-- @
-- hello
-- world
-- @
data Doc = Empty
| Char Char -- invariant: char is not '\n'
| Text !Int String -- invariant: text doesn't contain '\n'
| Line !Bool -- True <=> when undone by group, do not insert a space
| Cat Doc Doc
| Nest !Int Doc
| Union Doc Doc -- invariant: first lines of first doc longer than the first lines of the second doc
| Column (Int -> Doc)
| Nesting (Int -> Doc)
-- | 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 = SEmpty
| SChar Char SimpleDoc
| SText !Int String SimpleDoc
| SLine !Int SimpleDoc
-- | 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 @\<$\>@).
empty :: Doc
empty = Empty
-- | 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
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
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
line = Line False
-- | 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
linebreak = Line True
beside x y = Cat x y
-- | 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" <$> text "world") <$> text "!"
--
-- outputs as:
--
-- @
-- hello
-- world
-- !
-- @
nest :: Int -> Doc -> Doc
nest i x = Nest i x
column, nesting :: (Int -> Doc) -> Doc
column f = Column f
nesting f = Nesting f
-- | 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 -> Doc
group x = Union (flatten x) x
flatten :: Doc -> Doc
flatten (Cat x y) = Cat (flatten x) (flatten y)
flatten (Nest i x) = Nest i (flatten x)
flatten (Line break) = if break then Empty else Text 1 " "
flatten (Union x y) = flatten x
flatten (Column f) = Column (flatten . f)
flatten (Nesting f) = Nesting (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 = Nil
| Cons !Int Doc Docs
-- | 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 -> SimpleDoc
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 n k 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))
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)
--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 lines of x are longer than the first lines of y.
nicest n k x y | fits width x = x
| otherwise = y
where
width = min (w - k) (r - k + n)
fits w x | w < 0 = False
fits w SEmpty = True
fits w (SChar c x) = fits (w - 1) x
fits w (SText l s x) = fits (w - l) x
fits w (SLine i x) = True
-----------------------------------------------------------
-- 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 -> SimpleDoc
renderCompact x
= scan 0 [x]
where
scan k [] = 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))
Line _ -> SLine 0 (scan 0 ds)
Cat x y -> scan k (x:y:ds)
Nest j x -> scan k (x:ds)
Union x y -> scan k (y:ds)
Column f -> scan k (f k:ds)
Nesting f -> scan k (f 0: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 -> ShowS
displayS SEmpty = id
displayS (SChar c x) = showChar c . displayS x
displayS (SText l s x) = showString s . displayS x
displayS (SLine i x) = showString ('\n':indentation i) . displayS x
-- | @(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 -> IO ()
displayIO handle simpleDoc
= display simpleDoc
where
display SEmpty = return ()
display (SChar c x) = do{ hPutChar handle c; display x}
display (SText l s x) = do{ hPutStr handle s; display x}
display (SLine i x) = do{ hPutStr handle ('\n':indentation i); display x}
-----------------------------------------------------------
-- default pretty printers: show, putDoc and hPutDoc
-----------------------------------------------------------
instance Show Doc where
showsPrec d 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 -> 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 -> 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 n | n <= 0 = ""
| otherwise = replicate n ' '
indentation n = spaces n
--indentation n | n >= 8 = '\t' : indentation (n-8)
-- | otherwise = spaces n
-- LocalWords: PPrint combinators Wadler Wadler's encloseSep