diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -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}" diff --git a/Text/PrettyPrint/Free.hs b/Text/PrettyPrint/Free.hs deleted file mode 100644 --- a/Text/PrettyPrint/Free.hs +++ /dev/null @@ -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. --- --- @ --- --- 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 diff --git a/Text/PrettyPrint/Free/Internal.hs b/Text/PrettyPrint/Free/Internal.hs deleted file mode 100644 --- a/Text/PrettyPrint/Free/Internal.hs +++ /dev/null @@ -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. --- --- @ --- --- 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 diff --git a/src/Text/PrettyPrint/Free.hs b/src/Text/PrettyPrint/Free.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/Free.hs @@ -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. +-- +-- @ +-- +-- 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 diff --git a/src/Text/PrettyPrint/Free/Internal.hs b/src/Text/PrettyPrint/Free/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/Free/Internal.hs @@ -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. +-- +-- @ +-- +-- 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 diff --git a/wl-pprint-extras.cabal b/wl-pprint-extras.cabal --- a/wl-pprint-extras.cabal +++ b/wl-pprint-extras.cabal @@ -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