{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Text.PrettyPrint.Leijen.Text
-- Copyright   :  Ivan Lazar Miljenovic (c) 2010,
--                Daan Leijen (c) 2000, http://www.cs.uu.nl/~daan
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Ivan.Miljenovic@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-- This library is a port of the /wl-pprint/ package to use 'Text' values rather than 'String's.
--
-- 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, 'displayT' for 'Text' values and 'displayIO'
--   for file based output.
--
-- * There is a 'Pretty' class.
--
-- * The implementation uses optimised representations and strictness
--   annotations.
--
-- Ways that this library differs from /wl-pprint/ (apart from using
-- 'Text' rather than 'String'):
--
-- * Smarter treatment of 'empty' sub-documents (partially copied over
--   from the /pretty/ library).
-----------------------------------------------------------
module Text.PrettyPrint.Leijen.Text (
   -- * Documents
   Doc,

   -- * Basic combinators
   empty, isEmpty, char, text, textStrict, beside, nest, line, linebreak, group,
   softline, softbreak, spacebreak,

   -- * 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, stringStrict, int, integer, float, double, rational, bool,

   -- * Position-based combinators
   column, nesting, width,

   -- * Pretty class
   Pretty(..),

   -- * Rendering
   SimpleDoc(..), renderPretty, renderCompact, renderOneLine,
   displayB, displayT, displayTStrict, displayIO, putDoc, hPutDoc

   ) where

import           Prelude                ()
import           Prelude.Compat         hiding ((<$>))

import           Data.String            (IsString (..))
import           System.IO              (Handle, hPutChar, stdout)

import           Data.Int               (Int64)
import           Data.List              (intersperse)
import qualified Data.Text              as TS
import           Data.Text.Lazy         (Text)
import qualified Data.Text.Lazy         as T
import           Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy.IO      as T

#if !MIN_VERSION_base (4,9,0)
import           Data.Monoid            ((<>))
#endif

infixr 5 </>,<//>,<$>,<$$>
infixr 6 <+>,<++>,`beside`


-----------------------------------------------------------
-- 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 :: [Doc] -> Doc
list = Doc -> Doc -> Doc -> [Doc] -> Doc
encloseSep Doc
lbracket Doc
rbracket Doc
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 :: [Doc] -> Doc
tupled = Doc -> Doc -> Doc -> [Doc] -> Doc
encloseSep Doc
lparen Doc
rparen Doc
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 :: [Doc] -> Doc
semiBraces = Doc -> Doc -> Doc -> [Doc] -> Doc
encloseSep Doc
lbrace Doc
rbrace Doc
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 laid out with a page width of 20 as:
--
--   @
--   list [10,200,3000]
--   @
--
--   But when the page width is 15, it is laid out as:
--
--   @
--   list [10
--        ,200
--        ,3000]
--   @
encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc
encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc
encloseSep Doc
left Doc
right Doc
sp [Doc]
ds
  = case [Doc]
ds of
      []  -> Doc
left Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
right
      [Doc
d] -> Doc
left Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
d Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
right
      [Doc]
_   -> Doc -> Doc
align ([Doc] -> Doc
cat ((Doc -> Doc -> Doc) -> [Doc] -> [Doc] -> [Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
(<>) (Doc
left Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: Doc -> [Doc]
forall a. a -> [a]
repeat Doc
sp) [Doc]
ds) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
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 laid out on a page width of 20 as:
--
--   @
--   (words,in,a,tuple)
--   @
--
--   But when the page width is 15, it is laid 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 :: Doc -> [Doc] -> [Doc]
punctuate Doc
_ []     = []
punctuate Doc
_ [Doc
d]    = [Doc
d]
punctuate Doc
p (Doc
d:[Doc]
ds) = (Doc
d Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
p) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: Doc -> [Doc] -> [Doc]
punctuate Doc
p [Doc]
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 :: [Doc] -> Doc
sep = Doc -> Doc
group (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
vsep

-- | The document @(fillSep xs)@ concatenates documents @xs@
--   horizontally with @(\<+\>)@ as long as its fits the page, then
--   inserts a @line@ and continues doing that for all documents in
--   @xs@.
--
--   > fillSep xs = foldr (</>) empty xs
fillSep :: [Doc] -> Doc
fillSep :: [Doc] -> Doc
fillSep = (Doc -> Doc -> Doc) -> [Doc] -> Doc
fold Doc -> Doc -> Doc
(</>)

-- | The document @(hsep xs)@ concatenates all documents @xs@
--   horizontally with @(\<+\>)@.
hsep :: [Doc] -> Doc
hsep :: [Doc] -> Doc
hsep = (Doc -> Doc -> Doc) -> [Doc] -> Doc
fold Doc -> Doc -> Doc
(<+>)

-- | 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 laid 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 :: [Doc] -> Doc
vsep = (Doc -> Doc -> Doc) -> [Doc] -> Doc
fold Doc -> Doc -> Doc
(<$>)

-- | 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 :: [Doc] -> Doc
cat = Doc -> Doc
group (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
vcat

-- | The document @(fillCat xs)@ concatenates documents @xs@
--   horizontally with @(\<\>)@ as long as its fits the page, then
--   inserts a @linebreak@ and continues doing that for all documents
--   in @xs@.
--
--   > fillCat xs = foldr (<//>) empty xs
fillCat :: [Doc] -> Doc
fillCat :: [Doc] -> Doc
fillCat = (Doc -> Doc -> Doc) -> [Doc] -> Doc
fold Doc -> Doc -> Doc
(<//>)

-- | The document @(hcat xs)@ concatenates all documents @xs@
--   horizontally with @(\<\>)@.
hcat :: [Doc] -> Doc
hcat :: [Doc] -> Doc
hcat = (Doc -> Doc -> Doc) -> [Doc] -> Doc
fold Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
(<>)

-- | 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 :: [Doc] -> Doc
vcat = (Doc -> Doc -> Doc) -> [Doc] -> Doc
fold Doc -> Doc -> Doc
(<$$>)

fold      :: (Doc -> Doc -> Doc) -> [Doc] -> Doc
fold :: (Doc -> Doc -> Doc) -> [Doc] -> Doc
fold Doc -> Doc -> Doc
_ [] = Doc
empty
fold Doc -> Doc -> Doc
f [Doc]
ds = (Doc -> Doc -> Doc) -> [Doc] -> Doc
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Doc -> Doc -> Doc
f [Doc]
ds

-- | The document @(x \<+\> y)@ concatenates document @x@ and @y@ with
--   a 'space' in between.  (infixr 6)
(<+>) :: Doc -> Doc -> Doc
Doc
Empty <+> :: Doc -> Doc -> Doc
<+> Doc
y     = Doc
y
Doc
x     <+> Doc
Empty = Doc
x
Doc
x     <+> Doc
y     = Doc
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
space Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
y

-- | The document @(x \<++\> y)@ concatenates document @x@ and @y@ with
--   a 'spacebreak' in between.  (infixr 6)
(<++>) :: Doc -> Doc -> Doc
Doc
Empty <++> :: Doc -> Doc -> Doc
<++> Doc
y     = Doc
y
Doc
x     <++> Doc
Empty = Doc
x
Doc
x     <++> Doc
y     = Doc
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
spacebreak Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
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
</> :: Doc -> Doc -> Doc
(</>) = Bool -> Doc -> Doc -> Doc
splitWithBreak Bool
False

-- | 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
<//> :: Doc -> Doc -> Doc
(<//>) = Bool -> Doc -> Doc -> Doc
splitWithBreak Bool
True

splitWithBreak               :: Bool -> Doc -> Doc -> Doc
splitWithBreak :: Bool -> Doc -> Doc -> Doc
splitWithBreak Bool
_ Doc
Empty Doc
b     = Doc
b
splitWithBreak Bool
_ Doc
a     Doc
Empty = Doc
a
splitWithBreak Bool
f Doc
a     Doc
b     = Doc
a Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
group (Bool -> Doc
Line Bool
f) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
b

-- | The document @(x \<$\> y)@ concatenates document @x@ and @y@ with
--   a 'line' in between. (infixr 5)
(<$>) :: Doc -> Doc -> Doc
<$> :: Doc -> Doc -> Doc
(<$>) = Bool -> Doc -> Doc -> Doc
splitWithLine Bool
False

-- | The document @(x \<$$\> y)@ concatenates document @x@ and @y@
--   with a 'linebreak' in between. (infixr 5)
(<$$>) :: Doc -> Doc -> Doc
<$$> :: Doc -> Doc -> Doc
(<$$>) = Bool -> Doc -> Doc -> Doc
splitWithLine Bool
True

splitWithLine               :: Bool -> Doc -> Doc -> Doc
splitWithLine :: Bool -> Doc -> Doc -> Doc
splitWithLine Bool
_ Doc
Empty Doc
b     = Doc
b
splitWithLine Bool
_ Doc
a     Doc
Empty = Doc
a
splitWithLine Bool
f Doc
a     Doc
b     = Doc
a Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Bool -> Doc
Line Bool
f Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
b

-- | The document @softline@ behaves like 'space' if the resulting
--   output fits the page, otherwise it behaves like 'line'.
--
--   > softline = group line
softline :: Doc
softline :: Doc
softline = Doc -> Doc
group Doc
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 :: Doc
softbreak = Doc -> Doc
group Doc
linebreak

-- | The document @spacebreak@ behaves like 'space' when rendered normally
-- but like 'empty' when using 'renderCompact' or 'renderOneLine'.
spacebreak :: Doc
spacebreak :: Doc
spacebreak = Int64 -> Doc
Spaces Int64
1

-- | Document @(squotes x)@ encloses document @x@ with single quotes
--   \"'\".
squotes :: Doc -> Doc
squotes :: Doc -> Doc
squotes = Doc -> Doc -> Doc -> Doc
enclose Doc
squote Doc
squote

-- | Document @(dquotes x)@ encloses document @x@ with double quotes
--   '\"'.
dquotes :: Doc -> Doc
dquotes :: Doc -> Doc
dquotes = Doc -> Doc -> Doc -> Doc
enclose Doc
dquote Doc
dquote

-- | Document @(braces x)@ encloses document @x@ in braces, \"{\" and
--   \"}\".
braces :: Doc -> Doc
braces :: Doc -> Doc
braces = Doc -> Doc -> Doc -> Doc
enclose Doc
lbrace Doc
rbrace

-- | Document @(parens x)@ encloses document @x@ in parenthesis, \"(\"
--   and \")\".
parens :: Doc -> Doc
parens :: Doc -> Doc
parens = Doc -> Doc -> Doc -> Doc
enclose Doc
lparen Doc
rparen

-- | Document @(angles x)@ encloses document @x@ in angles, \"\<\" and
--   \"\>\".
angles :: Doc -> Doc
angles :: Doc -> Doc
angles = Doc -> Doc -> Doc -> Doc
enclose Doc
langle Doc
rangle

-- | Document @(brackets x)@ encloses document @x@ in square brackets,
--   \"[\" and \"]\".
brackets :: Doc -> Doc
brackets :: Doc -> Doc
brackets = Doc -> Doc -> Doc -> Doc
enclose Doc
lbracket Doc
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 :: Doc -> Doc -> Doc -> Doc
enclose Doc
l Doc
r Doc
x = Doc
l Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
r

-- | The document @lparen@ contains a left parenthesis, \"(\".
lparen :: Doc
lparen :: Doc
lparen = Char -> Doc
char Char
'('

-- | The document @rparen@ contains a right parenthesis, \")\".
rparen :: Doc
rparen :: Doc
rparen = Char -> Doc
char Char
')'

-- | The document @langle@ contains a left angle, \"\<\".
langle :: Doc
langle :: Doc
langle = Char -> Doc
char Char
'<'

-- | The document @rangle@ contains a right angle, \">\".
rangle :: Doc
rangle :: Doc
rangle = Char -> Doc
char Char
'>'

-- | The document @lbrace@ contains a left brace, \"{\".
lbrace :: Doc
lbrace :: Doc
lbrace = Char -> Doc
char Char
'{'

-- | The document @rbrace@ contains a right brace, \"}\".
rbrace :: Doc
rbrace :: Doc
rbrace = Char -> Doc
char Char
'}'

-- | The document @lbracket@ contains a left square bracket, \"[\".
lbracket :: Doc
lbracket :: Doc
lbracket = Char -> Doc
char Char
'['

-- | The document @rbracket@ contains a right square bracket, \"]\".
rbracket :: Doc
rbracket :: Doc
rbracket = Char -> Doc
char Char
']'

-- | The document @squote@ contains a single quote, \"'\".
squote :: Doc
squote :: Doc
squote = Char -> Doc
char Char
'\''

-- | The document @dquote@ contains a double quote, '\"'.
dquote :: Doc
dquote :: Doc
dquote = Char -> Doc
char Char
'"'

-- | The document @semi@ contains a semi colon, \";\".
semi :: Doc
semi :: Doc
semi = Char -> Doc
char Char
';'

-- | The document @colon@ contains a colon, \":\".
colon :: Doc
colon :: Doc
colon = Char -> Doc
char Char
':'

-- | The document @comma@ contains a comma, \",\".
comma :: Doc
comma :: Doc
comma = Char -> Doc
char Char
','

-- | The document @space@ contains a single space, \" \".
--
--   > x <+> y = x <> space <> y
space :: Doc
space :: Doc
space = Char -> Doc
char Char
' '

-- | The document @dot@ contains a single dot, \".\".
dot :: Doc
dot :: Doc
dot = Char -> Doc
char Char
'.'

-- | The document @backslash@ contains a back slash, \"\\\".
backslash :: Doc
backslash :: Doc
backslash = Char -> Doc
char Char
'\\'

-- | The document @equals@ contains an equal sign, \"=\".
equals :: Doc
equals :: Doc
equals = Char -> Doc
char 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 :: Text -> Doc
string :: Text -> Doc
string = [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat ([Doc] -> Doc) -> (Text -> [Doc]) -> Text -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse Doc
line ([Doc] -> [Doc]) -> (Text -> [Doc]) -> Text -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Doc) -> [Text] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc
text ([Text] -> [Doc]) -> (Text -> [Text]) -> Text -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines

stringStrict :: TS.Text -> Doc
stringStrict :: Text -> Doc
stringStrict = [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat ([Doc] -> Doc) -> (Text -> [Doc]) -> Text -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse Doc
line ([Doc] -> [Doc]) -> (Text -> [Doc]) -> Text -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Doc) -> [Text] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc
textStrict ([Text] -> [Doc]) -> (Text -> [Text]) -> Text -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
TS.lines

-- | The document @(bool b)@ shows the literal boolean @b@ using
--   'text'.
bool   :: Bool -> Doc
bool :: Bool -> Doc
bool = Bool -> Doc
forall a. Show a => a -> Doc
text'

-- | The document @(int i)@ shows the literal integer @i@ using
--   'text'.
int   :: Int -> Doc
int :: Int -> Doc
int = Int -> Doc
forall a. Show a => a -> Doc
text'

-- | The document @(integer i)@ shows the literal integer @i@ using
--   'text'.
integer   :: Integer -> Doc
integer :: Integer -> Doc
integer = Integer -> Doc
forall a. Show a => a -> Doc
text'

-- | The document @(float f)@ shows the literal float @f@ using
--   'text'.
float   :: Float -> Doc
float :: Float -> Doc
float = Float -> Doc
forall a. Show a => a -> Doc
text'

-- | The document @(double d)@ shows the literal double @d@ using
--   'text'.
double   :: Double -> Doc
double :: Double -> Doc
double = Double -> Doc
forall a. Show a => a -> Doc
text'

-- | The document @(rational r)@ shows the literal rational @r@ using
--   'text'.
rational   :: Rational -> Doc
rational :: Rational -> Doc
rational = Rational -> Doc
forall a. Show a => a -> Doc
text'

text' :: (Show a) => a -> Doc
text' :: a -> Doc
text' = Text -> Doc
text (Text -> Doc) -> (a -> Text) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

-----------------------------------------------------------
-- 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 = [Doc] -> Doc
list ([Doc] -> Doc) -> ([a] -> [Doc]) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall a. Pretty a => a -> Doc
pretty

instance Pretty a => Pretty [a] where
  pretty :: [a] -> Doc
pretty = [a] -> Doc
forall a. Pretty a => [a] -> Doc
prettyList

instance Pretty Doc where
  pretty :: Doc -> Doc
pretty = Doc -> Doc
forall a. a -> a
id

instance Pretty Text where
  pretty :: Text -> Doc
pretty = Text -> Doc
string

instance Pretty TS.Text where
  pretty :: Text -> Doc
pretty = Text -> Doc
stringStrict

instance Pretty () where
  pretty :: () -> Doc
pretty () = () -> Doc
forall a. Show a => a -> Doc
text' ()

instance Pretty Bool where
  pretty :: Bool -> Doc
pretty = Bool -> Doc
bool

instance Pretty Char where
  pretty :: Char -> Doc
pretty = Char -> Doc
char

  prettyList :: String -> Doc
prettyList = Text -> Doc
string (Text -> Doc) -> (String -> Text) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

instance Pretty Int where
  pretty :: Int -> Doc
pretty = Int -> Doc
int

instance Pretty Integer where
  pretty :: Integer -> Doc
pretty = Integer -> Doc
integer

instance Pretty Float where
  pretty :: Float -> Doc
pretty = Float -> Doc
float

instance Pretty Double where
  pretty :: Double -> Doc
pretty = Double -> Doc
double

--instance Pretty Rational where
--  pretty r = rational r

instance (Pretty a, Pretty b) => Pretty (a,b) where
  pretty :: (a, b) -> Doc
pretty (a
x,b
y) = [Doc] -> Doc
tupled [a -> Doc
forall a. Pretty a => a -> Doc
pretty a
x, b -> Doc
forall a. Pretty a => a -> Doc
pretty b
y]

instance (Pretty a, Pretty b, Pretty c) => Pretty (a,b,c) where
  pretty :: (a, b, c) -> Doc
pretty (a
x,b
y,c
z)= [Doc] -> Doc
tupled [a -> Doc
forall a. Pretty a => a -> Doc
pretty a
x, b -> Doc
forall a. Pretty a => a -> Doc
pretty b
y, c -> Doc
forall a. Pretty a => a -> Doc
pretty c
z]

instance Pretty a => Pretty (Maybe a) where
  pretty :: Maybe a -> Doc
pretty Maybe a
Nothing  = Doc
empty

  pretty (Just a
x) = a -> Doc
forall a. Pretty a => a -> Doc
pretty a
x

-----------------------------------------------------------
-- semi primitive: fill and fillBreak
-----------------------------------------------------------

-- | The document @(fillBreak i x)@ first renders document @x@. It
--   then appends @space@s until the width is equal to @i@. If the
--   width of @x@ is already larger than @i@, the nesting level is
--   increased by @i@ and a @line@ is appended. When we redefine
--   @ptype@ in the 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 :: Int -> Doc -> Doc
fillBreak Int
f Doc
x = Doc -> (Int -> Doc) -> Doc
width Doc
x (\Int
w ->
                          if Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
f
                            then Int -> Doc -> Doc
nest Int
f Doc
linebreak
                            else Int -> Doc
spaced (Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
w)
                        )


-- | The document @(fill i x)@ renders document @x@. It then appends
--   @space@s until the width is equal to @i@. If the width of @x@ is
--   already larger, nothing is appended. This 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 laid out as:
--
--   @
--   let empty  :: Doc
--       nest   :: Int -> Doc -> Doc
--       linebreak :: Doc
--   @
fill     :: Int -> Doc -> Doc
fill :: Int -> Doc -> Doc
fill Int
f Doc
d = Doc -> (Int -> Doc) -> Doc
width Doc
d (\Int
w ->
                     if Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
f
                       then Doc
empty
                       else Int -> Doc
spaced (Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
w)
                   )


width     :: Doc -> (Int -> Doc) -> Doc
width :: Doc -> (Int -> Doc) -> Doc
width Doc
d Int -> Doc
f = (Int -> Doc) -> Doc
column (\Int
k1 -> Doc
d Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> (Int -> Doc) -> Doc
column (\Int
k2 -> Int -> Doc
f (Int
k2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
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 :: Int -> Doc -> Doc
indent Int
_ Doc
Empty = Doc
Empty
indent Int
i Doc
d     = Int -> Doc -> Doc
hang Int
i (Int -> Doc
spaced Int
i Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
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 :: Int -> Doc -> Doc
hang Int
i Doc
d = Doc -> Doc
align (Int -> Doc -> Doc
nest Int
i Doc
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 laid out as:
--
--   @
--   hi nice
--      world
--   @
align   :: Doc -> Doc
align :: Doc -> Doc
align Doc
d = (Int -> Doc) -> Doc
column (\Int
k ->
                   (Int -> Doc) -> Doc
nesting (\Int
i -> Int -> Doc -> Doc
nest (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) Doc
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 !Int64 Builder   -- invariant: text doesn't contain '\n'
         | Line !Bool            -- True <=> when undone by group, do not insert a space
         | Cat Doc Doc
         | Nest !Int64 Doc
         | Union Doc Doc         -- invariant: first lines of first doc longer than the first lines of the second doc
         | Column  (Int64 -> Doc)
         | Nesting (Int64 -> Doc)
         | Spaces !Int64

instance IsString Doc where
  fromString :: String -> Doc
fromString = Text -> Doc
string (Text -> Doc) -> (String -> Text) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

-- | In particular, note that 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)
#if MIN_VERSION_base (4,9,0)
instance Semigroup Doc where
    <> :: Doc -> Doc -> Doc
(<>) = Doc -> Doc -> Doc
beside

#endif
instance Monoid Doc where
    mempty :: Doc
mempty  = Doc
empty
    mappend :: Doc -> Doc -> Doc
mappend = Doc -> Doc -> Doc
beside

-- | 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 !Int64 Builder SimpleDoc
                | SLine !Int64 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 :: Doc
empty = Doc
Empty

-- | Determine if the document is empty or not.
isEmpty :: Doc -> Bool
isEmpty :: Doc -> Bool
isEmpty Doc
Empty = Bool
True
isEmpty Doc
_     = Bool
False

-- | 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 :: Char -> Doc
char Char
'\n' = Doc
line
char  Char
c   = Char -> Doc
Char 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 :: Text -> Doc
text :: Text -> Doc
text Text
s
  | Text -> Bool
T.null Text
s  = Doc
Empty
  | Bool
otherwise = Int64 -> Builder -> Doc
Text (Text -> Int64
T.length Text
s) (Text -> Builder
B.fromLazyText Text
s)

textStrict :: TS.Text -> Doc
textStrict :: Text -> Doc
textStrict Text
s
  | Text -> Bool
TS.null Text
s  = Doc
Empty
  | Bool
otherwise  = Int64 -> Builder -> Doc
Text (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> Int -> Int64
forall a b. (a -> b) -> a -> b
$ Text -> Int
TS.length Text
s) (Text -> Builder
B.fromText Text
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' or if rendered with
--   'renderOneLine'.
line :: Doc
line :: Doc
line = Bool -> Doc
Line Bool
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 :: Doc
linebreak = Bool -> Doc
Line Bool
True

-- | The document @(x `beside` y)@ concatenates document @x@ and @y@.
--   It is an associative operation having 'empty' as a left and right
--   unit.  (infixr 6)
--
--   It is equivalent to `<>`.
beside             :: Doc -> Doc -> Doc
beside :: Doc -> Doc -> Doc
beside Doc
Empty Doc
r     = Doc
r
beside Doc
l     Doc
Empty = Doc
l
beside Doc
l     Doc
r     = Doc -> Doc -> Doc
Cat Doc
l Doc
r

-- | 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 :: Int -> Doc -> Doc
nest Int
_ Doc
Empty = Doc
Empty
nest Int
i Doc
x     = Int64 -> Doc -> Doc
Nest (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i) Doc
x

-- | Specifies how to create the document based upon which column it is in.
column   :: (Int -> Doc) -> Doc
column :: (Int -> Doc) -> Doc
column Int -> Doc
f = (Int64 -> Doc) -> Doc
Column (Int -> Doc
f (Int -> Doc) -> (Int64 -> Int) -> Int64 -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral)

-- | Specifies how to nest the document based upon which column it is
--   being nested in.
nesting   :: (Int -> Doc) -> Doc
nesting :: (Int -> Doc) -> Doc
nesting Int -> Doc
f = (Int64 -> Doc) -> Doc
Nesting (Int -> Doc
f (Int -> Doc) -> (Int64 -> Int) -> Int64 -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral)

-- | 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 :: Doc -> Doc
group Doc
x = Doc -> Doc -> Doc
Union (Doc -> Doc
flatten Doc
x) Doc
x

flatten              :: Doc -> Doc
flatten :: Doc -> Doc
flatten (Cat Doc
x Doc
y)   = Doc -> Doc -> Doc
Cat (Doc -> Doc
flatten Doc
x) (Doc -> Doc
flatten Doc
y)
flatten (Nest Int64
i Doc
x)  = Int64 -> Doc -> Doc
Nest Int64
i (Doc -> Doc
flatten Doc
x)
flatten (Line Bool
brk)  = if Bool
brk then Doc
Empty else Int64 -> Builder -> Doc
Text Int64
1 (Char -> Builder
B.singleton Char
' ')
flatten (Union Doc
x Doc
_) = Doc -> Doc
flatten Doc
x
flatten (Column Int64 -> Doc
f)  = (Int64 -> Doc) -> Doc
Column (Doc -> Doc
flatten (Doc -> Doc) -> (Int64 -> Doc) -> Int64 -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Doc
f)
flatten (Nesting Int64 -> Doc
f) = (Int64 -> Doc) -> Doc
Nesting (Doc -> Doc
flatten (Doc -> Doc) -> (Int64 -> Doc) -> Int64 -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Doc
f)
flatten Doc
other       = Doc
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 !Int64 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 :: Float -> Int -> Doc -> SimpleDoc
renderPretty Float
rfrac Int
w Doc
doc
 = Int64 -> Int64 -> Docs -> SimpleDoc
best Int64
0 Int64
0 (Int64 -> Doc -> Docs -> Docs
Cons Int64
0 Doc
doc Docs
Nil)
    where
      -- r :: the ribbon width in characters
      r :: Int64
r = Int64 -> Int64 -> Int64
forall a. Ord a => a -> a -> a
max Int64
0 (Int64 -> Int64 -> Int64
forall a. Ord a => a -> a -> a
min Int64
w64 (Float -> Int64
forall a b. (RealFrac a, Integral b) => a -> b
round (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
rfrac)))

      w64 :: Int64
w64 = Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w

      -- best :: n = indentation of current line
      --         k = current column
      --        (ie. (k >= n) && (k - n == count of inserted characters)
      best :: Int64 -> Int64 -> Docs -> SimpleDoc
best Int64
_ Int64
_ Docs
Nil = SimpleDoc
SEmpty
      best Int64
n Int64
k (Cons Int64
i Doc
d Docs
ds)
        = case Doc
d of
            Doc
Empty     -> Int64 -> Int64 -> Docs -> SimpleDoc
best Int64
n Int64
k Docs
ds
            Char Char
c    -> let k' :: Int64
k' = Int64
kInt64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+Int64
1 in Int64 -> SimpleDoc -> SimpleDoc
seq Int64
k' (SimpleDoc -> SimpleDoc) -> SimpleDoc -> SimpleDoc
forall a b. (a -> b) -> a -> b
$ Char -> SimpleDoc -> SimpleDoc
SChar Char
c (Int64 -> Int64 -> Docs -> SimpleDoc
best Int64
n Int64
k' Docs
ds)
            Text Int64
l Builder
s  -> let k' :: Int64
k' = Int64
kInt64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+Int64
l in Int64 -> SimpleDoc -> SimpleDoc
seq Int64
k' (SimpleDoc -> SimpleDoc) -> SimpleDoc -> SimpleDoc
forall a b. (a -> b) -> a -> b
$ Int64 -> Builder -> SimpleDoc -> SimpleDoc
SText Int64
l Builder
s (Int64 -> Int64 -> Docs -> SimpleDoc
best Int64
n Int64
k' Docs
ds)
            Line Bool
_    -> Int64 -> SimpleDoc -> SimpleDoc
SLine Int64
i (Int64 -> Int64 -> Docs -> SimpleDoc
best Int64
i Int64
i Docs
ds)
            Cat Doc
x Doc
y   -> Int64 -> Int64 -> Docs -> SimpleDoc
best Int64
n Int64
k (Int64 -> Doc -> Docs -> Docs
Cons Int64
i Doc
x (Int64 -> Doc -> Docs -> Docs
Cons Int64
i Doc
y Docs
ds))
            Nest Int64
j Doc
x  -> let i' :: Int64
i' = Int64
iInt64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+Int64
j in Int64 -> SimpleDoc -> SimpleDoc
seq Int64
i' (Int64 -> Int64 -> Docs -> SimpleDoc
best Int64
n Int64
k (Int64 -> Doc -> Docs -> Docs
Cons Int64
i' Doc
x Docs
ds))
            Union Doc
x Doc
y -> Int64 -> Int64 -> SimpleDoc -> SimpleDoc -> SimpleDoc
nicest Int64
n Int64
k (Int64 -> Int64 -> Docs -> SimpleDoc
best Int64
n Int64
k (Docs -> SimpleDoc) -> Docs -> SimpleDoc
forall a b. (a -> b) -> a -> b
$ Int64 -> Doc -> Docs -> Docs
Cons Int64
i Doc
x Docs
ds)
                                    (Int64 -> Int64 -> Docs -> SimpleDoc
best Int64
n Int64
k (Docs -> SimpleDoc) -> Docs -> SimpleDoc
forall a b. (a -> b) -> a -> b
$ Int64 -> Doc -> Docs -> Docs
Cons Int64
i Doc
y Docs
ds)
            Column Int64 -> Doc
f  -> Int64 -> Int64 -> Docs -> SimpleDoc
best Int64
n Int64
k (Int64 -> Doc -> Docs -> Docs
Cons Int64
i (Int64 -> Doc
f Int64
k) Docs
ds)
            Nesting Int64 -> Doc
f -> Int64 -> Int64 -> Docs -> SimpleDoc
best Int64
n Int64
k (Int64 -> Doc -> Docs -> Docs
Cons Int64
i (Int64 -> Doc
f Int64
i) Docs
ds)
            Spaces Int64
l  -> let k' :: Int64
k' = Int64
kInt64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+Int64
l in Int64 -> SimpleDoc -> SimpleDoc
seq Int64
k' (SimpleDoc -> SimpleDoc) -> SimpleDoc -> SimpleDoc
forall a b. (a -> b) -> a -> b
$ Int64 -> Builder -> SimpleDoc -> SimpleDoc
SText Int64
l (Int64 -> Builder
spaces Int64
l) (Int64 -> Int64 -> Docs -> SimpleDoc
best Int64
n Int64
k' Docs
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 :: Int64 -> Int64 -> SimpleDoc -> SimpleDoc -> SimpleDoc
nicest Int64
n Int64
k SimpleDoc
x SimpleDoc
y
        | Int64 -> SimpleDoc -> Bool
fits Int64
wth SimpleDoc
x = SimpleDoc
x
        | Bool
otherwise    = SimpleDoc
y
          where
            wth :: Int64
wth = Int64 -> Int64 -> Int64
forall a. Ord a => a -> a -> a
min (Int64
w64 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
k) (Int64
r Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
k Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
n)

fits                 :: Int64 -> SimpleDoc -> Bool
fits :: Int64 -> SimpleDoc -> Bool
fits Int64
w SimpleDoc
_             | Int64
w Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
0     = Bool
False
fits Int64
_ SimpleDoc
SEmpty        = Bool
True
fits Int64
w (SChar Char
_ SimpleDoc
x)   = Int64 -> SimpleDoc -> Bool
fits (Int64
w Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
1) SimpleDoc
x
fits Int64
w (SText Int64
l Builder
_ SimpleDoc
x) = Int64 -> SimpleDoc -> Bool
fits (Int64
w Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
l) SimpleDoc
x
fits Int64
_ SLine{}       = Bool
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 :: Doc -> SimpleDoc
renderCompact Doc
dc
  = Int64 -> [Doc] -> SimpleDoc
scan Int64
0 [Doc
dc]
    where
      scan :: Int64 -> [Doc] -> SimpleDoc
scan Int64
_ [] = SimpleDoc
SEmpty
      scan Int64
k (Doc
d:[Doc]
ds)
        = case Doc
d of
            Doc
Empty     -> Int64 -> [Doc] -> SimpleDoc
scan Int64
k [Doc]
ds
            Char Char
c    -> let k' :: Int64
k' = Int64
kInt64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+Int64
1 in Int64 -> SimpleDoc -> SimpleDoc
seq Int64
k' (Char -> SimpleDoc -> SimpleDoc
SChar Char
c (Int64 -> [Doc] -> SimpleDoc
scan Int64
k' [Doc]
ds))
            Text Int64
l Builder
s  -> let k' :: Int64
k' = Int64
kInt64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+Int64
l in Int64 -> SimpleDoc -> SimpleDoc
seq Int64
k' (Int64 -> Builder -> SimpleDoc -> SimpleDoc
SText Int64
l Builder
s (Int64 -> [Doc] -> SimpleDoc
scan Int64
k' [Doc]
ds))
            Line Bool
_    -> Int64 -> SimpleDoc -> SimpleDoc
SLine Int64
0 (Int64 -> [Doc] -> SimpleDoc
scan Int64
0 [Doc]
ds)
            Cat Doc
x Doc
y   -> Int64 -> [Doc] -> SimpleDoc
scan Int64
k (Doc
xDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:Doc
yDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)
            Nest Int64
_ Doc
x  -> Int64 -> [Doc] -> SimpleDoc
scan Int64
k (Doc
xDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)
            Union Doc
_ Doc
y -> Int64 -> [Doc] -> SimpleDoc
scan Int64
k (Doc
yDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)
            Column Int64 -> Doc
f  -> Int64 -> [Doc] -> SimpleDoc
scan Int64
k (Int64 -> Doc
f Int64
kDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)
            Nesting Int64 -> Doc
f -> Int64 -> [Doc] -> SimpleDoc
scan Int64
k (Int64 -> Doc
f Int64
0Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)
            Spaces Int64
_  -> Int64 -> [Doc] -> SimpleDoc
scan Int64
k [Doc]
ds

-- | @(renderOneLine x)@ renders document @x@ without adding any
--   indentation or newlines.
renderOneLine :: Doc -> SimpleDoc
renderOneLine :: Doc -> SimpleDoc
renderOneLine Doc
dc
  = Int64 -> [Doc] -> SimpleDoc
scan Int64
0 [Doc
dc]
    where
      scan :: Int64 -> [Doc] -> SimpleDoc
scan Int64
_ [] = SimpleDoc
SEmpty
      scan Int64
k (Doc
d:[Doc]
ds)
        = case Doc
d of
            Doc
Empty      -> Int64 -> [Doc] -> SimpleDoc
scan Int64
k [Doc]
ds
            Char Char
c     -> let k' :: Int64
k' = Int64
kInt64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+Int64
1 in Int64 -> SimpleDoc -> SimpleDoc
seq Int64
k' (Char -> SimpleDoc -> SimpleDoc
SChar Char
c (Int64 -> [Doc] -> SimpleDoc
scan Int64
k' [Doc]
ds))
            Text Int64
l Builder
s   -> let k' :: Int64
k' = Int64
kInt64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+Int64
l in Int64 -> SimpleDoc -> SimpleDoc
seq Int64
k' (Int64 -> Builder -> SimpleDoc -> SimpleDoc
SText Int64
l Builder
s (Int64 -> [Doc] -> SimpleDoc
scan Int64
k' [Doc]
ds))
            Line Bool
False -> let k' :: Int64
k' = Int64
kInt64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+Int64
1 in Int64 -> SimpleDoc -> SimpleDoc
seq Int64
k' (Char -> SimpleDoc -> SimpleDoc
SChar Char
' ' (Int64 -> [Doc] -> SimpleDoc
scan Int64
k' [Doc]
ds))
            Line Bool
_     -> Int64 -> [Doc] -> SimpleDoc
scan Int64
k [Doc]
ds
            Cat Doc
x Doc
y    -> Int64 -> [Doc] -> SimpleDoc
scan Int64
k (Doc
xDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:Doc
yDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)
            Nest Int64
_ Doc
x   -> Int64 -> [Doc] -> SimpleDoc
scan Int64
k (Doc
xDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)
            Union Doc
_ Doc
y  -> Int64 -> [Doc] -> SimpleDoc
scan Int64
k (Doc
yDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)
            Column Int64 -> Doc
f   -> Int64 -> [Doc] -> SimpleDoc
scan Int64
k (Int64 -> Doc
f Int64
kDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)
            Nesting Int64 -> Doc
f  -> Int64 -> [Doc] -> SimpleDoc
scan Int64
k (Int64 -> Doc
f Int64
0Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)
            Spaces Int64
_   -> Int64 -> [Doc] -> SimpleDoc
scan Int64
k [Doc]
ds

-----------------------------------------------------------
-- Displayers:  displayS and displayIO
-----------------------------------------------------------


-- | @(displayB simpleDoc)@ takes the output @simpleDoc@ from a
--   rendering function and transforms it to a 'Builder' type (for
--   further manipulation before converting to a lazy 'Text').
displayB               :: SimpleDoc -> Builder
displayB :: SimpleDoc -> Builder
displayB SimpleDoc
SEmpty        = Builder
forall a. Monoid a => a
mempty
displayB (SChar Char
c SimpleDoc
x)   = Char
c Char -> Builder -> Builder
`consB` SimpleDoc -> Builder
displayB SimpleDoc
x
displayB (SText Int64
_ Builder
s SimpleDoc
x) = Builder
s Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` SimpleDoc -> Builder
displayB SimpleDoc
x
displayB (SLine Int64
i SimpleDoc
x)   = Char
'\n' Char -> Builder -> Builder
`consB` (Int64 -> Builder
indentation Int64
i Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` SimpleDoc -> Builder
displayB SimpleDoc
x)

consB       :: Char -> Builder -> Builder
Char
c consB :: Char -> Builder -> Builder
`consB` Builder
b = Char -> Builder
B.singleton Char
c Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
b

-- | @(displayT simpleDoc)@ takes the output @simpleDoc@ from a
--   rendering function and transforms it to a lazy 'Text' value.
--
--   > showWidth :: Int -> Doc -> Text
--   > showWidth w x = displayT (renderPretty 0.4 w x)
displayT :: SimpleDoc -> Text
displayT :: SimpleDoc -> Text
displayT = Builder -> Text
B.toLazyText (Builder -> Text) -> (SimpleDoc -> Builder) -> SimpleDoc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDoc -> Builder
displayB

displayTStrict :: SimpleDoc -> TS.Text
displayTStrict :: SimpleDoc -> Text
displayTStrict = Text -> Text
T.toStrict (Text -> Text) -> (SimpleDoc -> Text) -> SimpleDoc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDoc -> Text
displayT

-- | @(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 -> IO ()
displayIO Handle
handle = SimpleDoc -> IO ()
display
    where
      display :: SimpleDoc -> IO ()
display SimpleDoc
SEmpty        = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      display (SChar Char
c SimpleDoc
x)   = Handle -> Char -> IO ()
hPutChar Handle
handle Char
c IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SimpleDoc -> IO ()
display SimpleDoc
x
      display (SText Int64
_ Builder
s SimpleDoc
x) = Handle -> Text -> IO ()
T.hPutStr Handle
handle (Builder -> Text
B.toLazyText Builder
s) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SimpleDoc -> IO ()
display SimpleDoc
x
      display (SLine Int64
i SimpleDoc
x)   = Handle -> Text -> IO ()
T.hPutStr Handle
handle Text
newLine IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SimpleDoc -> IO ()
display SimpleDoc
x
        where
          newLine :: Text
newLine = Builder -> Text
B.toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Char
'\n' Char -> Builder -> Builder
`consB` Int64 -> Builder
indentation Int64
i

-----------------------------------------------------------
-- default pretty printers: show, putDoc and hPutDoc
-----------------------------------------------------------

instance Show Doc where
  showsPrec :: Int -> Doc -> ShowS
showsPrec Int
d Doc
doc = Int -> Text -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
d (SimpleDoc -> Text
displayT (SimpleDoc -> Text) -> SimpleDoc -> Text
forall a b. (a -> b) -> a -> b
$ Float -> Int -> Doc -> SimpleDoc
renderPretty Float
0.4 Int
80 Doc
doc)
  show :: Doc -> String
show Doc
doc = Text -> String
T.unpack (SimpleDoc -> Text
displayT (SimpleDoc -> Text) -> SimpleDoc -> Text
forall a b. (a -> b) -> a -> b
$ Float -> Int -> Doc -> SimpleDoc
renderPretty Float
0.4 Int
80 Doc
doc)

instance Show SimpleDoc where
  show :: SimpleDoc -> String
show SimpleDoc
simpleDoc = Text -> String
T.unpack (SimpleDoc -> Text
displayT SimpleDoc
simpleDoc)

-- | 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 -> IO ()
putDoc = Handle -> Doc -> IO ()
hPutDoc Handle
stdout

-- | @(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'
--   >                           ['T.pack' "vertical", 'T.pack' "text"]))
--   >           'hClose' handle
hPutDoc :: Handle -> Doc -> IO ()
hPutDoc :: Handle -> Doc -> IO ()
hPutDoc Handle
handle Doc
doc = Handle -> SimpleDoc -> IO ()
displayIO Handle
handle (Float -> Int -> Doc -> SimpleDoc
renderPretty Float
0.4 Int
80 Doc
doc)

-----------------------------------------------------------
-- insert spaces
-- "indentation" used to insert tabs but tabs seem to cause
-- more trouble than they solve :-)
-----------------------------------------------------------
spaces :: Int64 -> Builder
spaces :: Int64 -> Builder
spaces Int64
n
  | Int64
n Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
0 = Builder
forall a. Monoid a => a
mempty
  | Bool
otherwise = Text -> Builder
B.fromLazyText (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ Int64 -> Text -> Text
T.replicate Int64
n (Char -> Text
T.singleton Char
' ')

spaced   :: Int -> Doc
spaced :: Int -> Doc
spaced Int
l = Int64 -> Doc
Spaces Int64
l'
  where
    l' :: Int64
l' = Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l

-- An alias for readability purposes
indentation :: Int64 -> Builder
indentation :: Int64 -> Builder
indentation = Int64 -> Builder
spaces

--  LocalWords:  PPrint combinators Wadler Wadler's encloseSep