{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Text.PrettyPrint.ANSI.Leijen.Internal
-- Copyright   :  Daan Leijen (c) 2000, http://www.cs.uu.nl/~daan
--                Max Bolingbroke (c) 2008, http://blog.omega-prime.co.uk
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  portable
--
--
-- __WARNING:__ Internal module. The contents of this file may vary arbitrarily
-- between any two versions. Use the public API if you care about stability.
module Text.PrettyPrint.ANSI.Leijen.Internal where

import System.IO (Handle,hPutStr,hPutChar,stdout)

import System.Console.ANSI (Color(..), ColorIntensity(..), ConsoleLayer(..),
                            Underlining(..), ConsoleIntensity(..),
                            SGR(..), hSetSGR, setSGRCode)

import Data.String (IsString(..))
import Data.Maybe (catMaybes)

-- NB: if you import more from Data.Semigroup make sure the
--     build-depends version range is still accurate
-- NB2: if you consider re-exporting Semigroup((<>)) take into account
--      that only starting with semigroup-0.8 `infixr 6 <>` was used!
import qualified Data.Semigroup as Semi (Semigroup((<>)))

#if __GLASGOW_HASKELL__ >= 710
import Data.Monoid ((<>))
#elif __GLASGOW_HASKELL__ >= 704
import Data.Monoid (Monoid, mappend, mconcat, mempty, (<>))
#else
import Data.Monoid (Monoid, mappend, mconcat, mempty)
infixr 6 <>
#endif

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



-----------------------------------------------------------
-- 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
-- semicolons and encloses them in braces. The documents are rendered
-- horizontally if that fits the page. Otherwise they are aligned
-- vertically. All semicolons 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 layed out with a page width of 20 as:
--
-- @
-- list [10,200,3000]
-- @
--
-- But when the page width is 15, it is layed out as:
--
-- @
-- list [10
--      ,200
--      ,3000]
-- @
encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc
encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc
encloseSep Doc
left Doc
right Doc
sep [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
sep) [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 layed out on a page width of 20 as:
--
-- @
-- (words,in,a,tuple)
-- @
--
-- But when the page width is 15, it is layed out as:
--
-- @
-- (words,
--  in,
--  a,
--  tuple)
-- @
--
-- (If you want put the commas in front of their elements instead of
-- at the end, you should use 'tupled' or, in general, 'encloseSep'.)
punctuate :: Doc -> [Doc] -> [Doc]
punctuate :: Doc -> [Doc] -> [Doc]
punctuate Doc
p []      = []
punctuate Doc
p [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, than
-- 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 layed out as:
--
-- @
-- some text
-- to
-- lay
-- out
-- @
--
-- The 'align' combinator can be used to align the documents under
-- their first element
--
-- > test     = text "some" <+> align (vsep someText)
--
-- Which is printed as:
--
-- @
-- some text
--      to
--      lay
--      out
-- @
vsep :: [Doc] -> Doc
vsep :: [Doc] -> Doc
vsep            = (Doc -> Doc -> Doc) -> [Doc] -> Doc
fold Doc -> Doc -> Doc
(Text.PrettyPrint.ANSI.Leijen.Internal.<$>)

-- | 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, than 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
f []       = 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

#if __GLASGOW_HASKELL__ < 704
-- | The document @(x \<\> y)@ concatenates document @x@ and document
-- @y@. It is an associative operation having 'empty' as a left and
-- right unit.  (infixr 6)
(<>) :: Doc -> Doc -> Doc
x <> y          = x `beside` y
#endif

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

-- | The document @(x \<\/\/\> y)@ concatenates document @x@ and @y@ with
-- a 'softbreak' in between. This effectively puts @x@ and @y@ either
-- right next to each other or underneath each other. (infixr 5)
(<//>) :: Doc -> Doc -> Doc
Doc
x <//> :: Doc -> Doc -> Doc
<//> Doc
y        = Doc
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
softbreak Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
y

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

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

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

-- | 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 semicolon, \";\".
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 :: String -> Doc
string :: String -> Doc
string String
""       = Doc
empty
string (Char
'\n':String
s) = Doc
line Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
string String
s
string String
s        = case ((Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\n') String
s) of
                    (String
xs,String
ys) -> String -> Doc
text String
xs Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
string String
ys

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

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

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

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

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

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

-----------------------------------------------------------
-- overloading "pretty"
-----------------------------------------------------------

-- | The member @prettyList@ is only used to define the @instance Pretty
-- a => Pretty [a]@. In normal circumstances only the @pretty@ function
-- is used.
class Pretty a where
  pretty        :: a -> Doc
  prettyList    :: [a] -> Doc
  prettyList    = [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 () where
  pretty :: () -> Doc
pretty ()     = String -> Doc
text String
"()"

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

instance Pretty Char where
  pretty :: Char -> Doc
pretty Char
c      = Char -> Doc
char Char
c
  prettyList :: String -> Doc
prettyList String
s  = String -> Doc
string String
s

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

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

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

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

--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
-- than appends @space@s until the width is equal to @i@. If the
-- width of @x@ is already larger than @i@, the nesting level is
-- increased by @i@ and a @line@ is appended. When we redefine @ptype@
-- in the previous example to use @fillBreak@, we get a useful
-- variation of the previous output:
--
-- > ptype (name,tp)
-- >        = fillBreak 6 (text name) <+> text "::" <+> text tp
--
-- The output will now be:
--
-- @
-- let empty  :: Doc
--     nest   :: Int -> Doc -> Doc
--     linebreak
--            :: Doc
-- @
fillBreak :: Int -> Doc -> Doc
fillBreak :: 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 String -> Doc
text (Int -> String
spaces (Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
w)))

-- | The document @(fill i x)@ renders document @x@. It than appends
-- @space@s until the width is equal to @i@. If the width of @x@ is
-- already larger, nothing is appended. This combinator is quite
-- useful in practice to output a list of bindings. The following
-- example demonstrates this.
--
-- > types  = [("empty","Doc")
-- >          ,("nest","Int -> Doc -> Doc")
-- >          ,("linebreak","Doc")]
-- >
-- > ptype (name,tp)
-- >        = fill 6 (text name) <+> text "::" <+> text tp
-- >
-- > test   = text "let" <+> align (vcat (map ptype types))
--
-- Which is layed out as:
--
-- @
-- let empty  :: Doc
--     nest   :: Int -> Doc -> Doc
--     linebreak :: Doc
-- @
fill :: Int -> Doc -> Doc
fill :: 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 String -> Doc
text (Int -> String
spaces (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
i Doc
d      = Int -> Doc -> Doc
hang Int
i (String -> Doc
text (Int -> String
spaces 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 layed 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.
--
-- More specifically, a value of type @Doc@ represents a non-empty set of
-- possible renderings of a document.  The rendering functions select one of
-- these possibilities.
--
-- @Doc@ is an instance of the 'Show' class. @(show doc)@ pretty
-- prints document @doc@ with a page width of 80 characters and a
-- ribbon width of 32 characters.
--
-- > show (text "hello" <$> text "world")
--
-- Which would return the string \"hello\\nworld\", i.e.
--
-- @
-- hello
-- world
-- @
data Doc        = Fail
                | Empty
                | Char Char             -- invariant: char is not '\n'
                | Text !Int String      -- invariant: text doesn't contain '\n'
                | Line
                | FlatAlt Doc Doc       -- Render the first doc, but when
                                        -- flattened, render the second.
                | Cat Doc Doc
                | Nest !Int Doc
                | Union Doc Doc         -- invariant: first lines of first doc longer than the first lines of the second doc
                | Column  (Int -> Doc)
                | Columns (Maybe Int -> Doc)
                | Nesting (Int -> Doc)
                | Color ConsoleLayer ColorIntensity -- Introduces coloring /around/ the embedded document
                        Color Doc
                | Intensify ConsoleIntensity Doc
                | Italicize Bool Doc
                | Underline Underlining Doc
                | RestoreFormat (Maybe (ColorIntensity, Color))  -- Only used during the rendered phase, to signal a SGR should be issued to restore the terminal formatting.
                                (Maybe (ColorIntensity, Color))  -- These are the colors to revert the current forecolor/backcolor to (i.e. those from before the start of the Color block).
                                (Maybe ConsoleIntensity)         -- Intensity to revert to.
                                (Maybe Bool)                     -- Italicization to revert to.
                                (Maybe Underlining)              -- Underlining to revert to.

-- | The data type @SimpleDoc@ represents rendered documents and is
-- used by the display functions.
--
-- Whereas values of the data type 'Doc' represent non-empty sets of possible
-- renderings of a document, values of the data type @SimpleDoc@ represent
-- single renderings of a document.
--
-- 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  = SFail
                | SEmpty
                | SChar Char SimpleDoc
                | SText !Int String SimpleDoc
                | SLine !Int SimpleDoc
                | SSGR [SGR] SimpleDoc

-- MCB: Not in the wl-pprint package that we forked from. I added this when the "pretty" package
-- from base gained a Monoid instance (<http://hackage.haskell.org/trac/ghc/ticket/4378>):
instance Monoid Doc where
    mempty :: Doc
mempty = Doc
empty
    mappend :: Doc -> Doc -> Doc
mappend = Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
(Semi.<>)
    mconcat :: [Doc] -> Doc
mconcat = [Doc] -> Doc
hcat

instance Semi.Semigroup Doc where
    <> :: Doc -> Doc -> Doc
(<>) = Doc -> Doc -> Doc
beside

-- MCB: also added when "pretty" got the corresponding instances:
instance IsString Doc where
    fromString :: String -> Doc
fromString = String -> Doc
text

-- | 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

-- | 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 :: String -> Doc
text :: String -> Doc
text String
""         = Doc
Empty
text String
s          = Int -> String -> Doc
Text (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) String
s

-- | The @line@ document advances to the next line and indents to the
-- current nesting level. Document @line@ behaves like @(text \" \")@
-- if the line break is undone by 'group'.
line :: Doc
line :: Doc
line            = Doc -> Doc -> Doc
FlatAlt Doc
Line Doc
space

-- | 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       = Doc -> Doc -> Doc
FlatAlt Doc
Line Doc
empty

-- | A linebreak that will never be flattened; it is guaranteed to render
-- as a newline.
hardline :: Doc
hardline :: Doc
hardline = Doc
Line

beside :: Doc -> Doc -> Doc
beside :: Doc -> Doc -> Doc
beside Doc
x Doc
y      = Doc -> Doc -> Doc
Cat Doc
x Doc
y

-- | The document @(nest i x)@ renders document @x@ with the current
-- indentation level increased by i (See also 'hang', 'align' and
-- 'indent').
--
-- > nest 2 (text "hello" <$> text "world") <$> text "!"
--
-- outputs as:
--
-- @
-- hello
--   world
-- !
-- @
nest :: Int -> Doc -> Doc
nest :: Int -> Doc -> Doc
nest Int
i Doc
x        = Int -> Doc -> Doc
Nest Int
i Doc
x

column, nesting :: (Int -> Doc) -> Doc
column :: (Int -> Doc) -> Doc
column Int -> Doc
f        = (Int -> Doc) -> Doc
Column Int -> Doc
f
nesting :: (Int -> Doc) -> Doc
nesting Int -> Doc
f       = (Int -> Doc) -> Doc
Nesting Int -> Doc
f

columns :: (Maybe Int -> Doc) -> Doc
columns :: (Maybe Int -> Doc) -> Doc
columns Maybe Int -> Doc
f       = (Maybe Int -> Doc) -> Doc
Columns Maybe Int -> Doc
f

-- | The @group@ combinator is used to specify alternative
-- layouts. The document @(group x)@ undoes all line breaks in
-- document @x@. The resulting line is added to the current line if
-- that fits the page. Otherwise, the document @x@ is rendered without
-- any changes.
group :: Doc -> Doc
group :: Doc -> Doc
group Doc
x         = Doc -> Doc -> Doc
Union (Doc -> Doc
flatten Doc
x) Doc
x

-- | A document that is normally rendered as the first argument, but
-- when flattened, is rendered as the second document.
flatAlt :: Doc -> Doc -> Doc
flatAlt :: Doc -> Doc -> Doc
flatAlt = Doc -> Doc -> Doc
FlatAlt

flatten :: Doc -> Doc
flatten :: Doc -> Doc
flatten (FlatAlt Doc
x Doc
y)    = Doc
y
flatten (Cat Doc
x Doc
y)        = Doc -> Doc -> Doc
Cat (Doc -> Doc
flatten Doc
x) (Doc -> Doc
flatten Doc
y)
flatten (Nest Int
i Doc
x)       = Int -> Doc -> Doc
Nest Int
i (Doc -> Doc
flatten Doc
x)
flatten  Doc
Line            = Doc
Fail
flatten (Union Doc
x Doc
y)      = Doc -> Doc
flatten Doc
x
flatten (Column Int -> Doc
f)       = (Int -> Doc) -> Doc
Column (Doc -> Doc
flatten (Doc -> Doc) -> (Int -> Doc) -> Int -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc
f)
flatten (Columns Maybe Int -> Doc
f)      = (Maybe Int -> Doc) -> Doc
Columns (Doc -> Doc
flatten (Doc -> Doc) -> (Maybe Int -> Doc) -> Maybe Int -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> Doc
f)
flatten (Nesting Int -> Doc
f)      = (Int -> Doc) -> Doc
Nesting (Doc -> Doc
flatten (Doc -> Doc) -> (Int -> Doc) -> Int -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc
f)
flatten (Color ConsoleLayer
l ColorIntensity
i Color
c Doc
x)  = ConsoleLayer -> ColorIntensity -> Color -> Doc -> Doc
Color ConsoleLayer
l ColorIntensity
i Color
c (Doc -> Doc
flatten Doc
x)
flatten (Intensify ConsoleIntensity
i Doc
x)  = ConsoleIntensity -> Doc -> Doc
Intensify ConsoleIntensity
i (Doc -> Doc
flatten Doc
x)
flatten (Italicize Bool
b Doc
x)  = Bool -> Doc -> Doc
Italicize Bool
b (Doc -> Doc
flatten Doc
x)
flatten (Underline Underlining
u Doc
x)  = Underlining -> Doc -> Doc
Underline Underlining
u (Doc -> Doc
flatten Doc
x)
flatten Doc
other            = Doc
other                     --Empty,Char,Text,RestoreFormat

-----------------------------------------------------------
-- Colors
-----------------------------------------------------------

-- | Displays a document with the black forecolor
black :: Doc -> Doc
-- | Displays a document with the red forecolor
red :: Doc -> Doc
-- | Displays a document with the green forecolor
green :: Doc -> Doc
-- | Displays a document with the yellow forecolor
yellow :: Doc -> Doc
-- | Displays a document with the blue forecolor
blue :: Doc -> Doc
-- | Displays a document with the magenta forecolor
magenta :: Doc -> Doc
-- | Displays a document with the cyan forecolor
cyan :: Doc -> Doc
-- | Displays a document with the white forecolor
white :: Doc -> Doc
-- | Displays a document with the dull black forecolor
dullblack :: Doc -> Doc
-- | Displays a document with the dull red forecolor
dullred :: Doc -> Doc
-- | Displays a document with the dull green forecolor
dullgreen :: Doc -> Doc
-- | Displays a document with the dull yellow forecolor
dullyellow :: Doc -> Doc
-- | Displays a document with the dull blue forecolor
dullblue :: Doc -> Doc
-- | Displays a document with the dull magenta forecolor
dullmagenta :: Doc -> Doc
-- | Displays a document with the dull cyan forecolor
dullcyan :: Doc -> Doc
-- | Displays a document with the dull white forecolor
dullwhite :: Doc -> Doc
(Doc -> Doc
black, Doc -> Doc
dullblack)     = Color -> (Doc -> Doc, Doc -> Doc)
colorFunctions Color
Black
(Doc -> Doc
red, Doc -> Doc
dullred)         = Color -> (Doc -> Doc, Doc -> Doc)
colorFunctions Color
Red
(Doc -> Doc
green, Doc -> Doc
dullgreen)     = Color -> (Doc -> Doc, Doc -> Doc)
colorFunctions Color
Green
(Doc -> Doc
yellow, Doc -> Doc
dullyellow)   = Color -> (Doc -> Doc, Doc -> Doc)
colorFunctions Color
Yellow
(Doc -> Doc
blue, Doc -> Doc
dullblue)       = Color -> (Doc -> Doc, Doc -> Doc)
colorFunctions Color
Blue
(Doc -> Doc
magenta, Doc -> Doc
dullmagenta) = Color -> (Doc -> Doc, Doc -> Doc)
colorFunctions Color
Magenta
(Doc -> Doc
cyan, Doc -> Doc
dullcyan)       = Color -> (Doc -> Doc, Doc -> Doc)
colorFunctions Color
Cyan
(Doc -> Doc
white, Doc -> Doc
dullwhite)     = Color -> (Doc -> Doc, Doc -> Doc)
colorFunctions Color
White

-- | Displays a document with a forecolor given in the first parameter
color :: Color -> Doc -> Doc
-- | Displays a document with a dull forecolor given in the first parameter
dullcolor :: Color -> Doc -> Doc
color :: Color -> Doc -> Doc
color     = ConsoleLayer -> ColorIntensity -> Color -> Doc -> Doc
Color ConsoleLayer
Foreground ColorIntensity
Vivid
dullcolor :: Color -> Doc -> Doc
dullcolor = ConsoleLayer -> ColorIntensity -> Color -> Doc -> Doc
Color ConsoleLayer
Foreground ColorIntensity
Dull

colorFunctions :: Color -> (Doc -> Doc, Doc -> Doc)
colorFunctions :: Color -> (Doc -> Doc, Doc -> Doc)
colorFunctions Color
what = (Color -> Doc -> Doc
color Color
what, Color -> Doc -> Doc
dullcolor Color
what)

-- | Displays a document with the black backcolor
onblack :: Doc -> Doc
-- | Displays a document with the red backcolor
onred :: Doc -> Doc
-- | Displays a document with the green backcolor
ongreen :: Doc -> Doc
-- | Displays a document with the yellow backcolor
onyellow :: Doc -> Doc
-- | Displays a document with the blue backcolor
onblue :: Doc -> Doc
-- | Displays a document with the magenta backcolor
onmagenta :: Doc -> Doc
-- | Displays a document with the cyan backcolor
oncyan :: Doc -> Doc
-- | Displays a document with the white backcolor
onwhite :: Doc -> Doc
-- | Displays a document with the dull black backcolor
ondullblack :: Doc -> Doc
-- | Displays a document with the dull red backcolor
ondullred :: Doc -> Doc
-- | Displays a document with the dull green backcolor
ondullgreen :: Doc -> Doc
-- | Displays a document with the dull yellow backcolor
ondullyellow :: Doc -> Doc
-- | Displays a document with the dull blue backcolor
ondullblue :: Doc -> Doc
-- | Displays a document with the dull magenta backcolor
ondullmagenta :: Doc -> Doc
-- | Displays a document with the dull cyan backcolor
ondullcyan :: Doc -> Doc
-- | Displays a document with the dull white backcolor
ondullwhite :: Doc -> Doc
(Doc -> Doc
onblack, Doc -> Doc
ondullblack)     = Color -> (Doc -> Doc, Doc -> Doc)
oncolorFunctions Color
Black
(Doc -> Doc
onred, Doc -> Doc
ondullred)         = Color -> (Doc -> Doc, Doc -> Doc)
oncolorFunctions Color
Red
(Doc -> Doc
ongreen, Doc -> Doc
ondullgreen)     = Color -> (Doc -> Doc, Doc -> Doc)
oncolorFunctions Color
Green
(Doc -> Doc
onyellow, Doc -> Doc
ondullyellow)   = Color -> (Doc -> Doc, Doc -> Doc)
oncolorFunctions Color
Yellow
(Doc -> Doc
onblue, Doc -> Doc
ondullblue)       = Color -> (Doc -> Doc, Doc -> Doc)
oncolorFunctions Color
Blue
(Doc -> Doc
onmagenta, Doc -> Doc
ondullmagenta) = Color -> (Doc -> Doc, Doc -> Doc)
oncolorFunctions Color
Magenta
(Doc -> Doc
oncyan, Doc -> Doc
ondullcyan)       = Color -> (Doc -> Doc, Doc -> Doc)
oncolorFunctions Color
Cyan
(Doc -> Doc
onwhite, Doc -> Doc
ondullwhite)     = Color -> (Doc -> Doc, Doc -> Doc)
oncolorFunctions Color
White

-- | Displays a document with a backcolor given in the first parameter
oncolor :: Color -> Doc -> Doc
-- | Displays a document with a dull backcolor given in the first parameter
ondullcolor :: Color -> Doc -> Doc
oncolor :: Color -> Doc -> Doc
oncolor     = ConsoleLayer -> ColorIntensity -> Color -> Doc -> Doc
Color ConsoleLayer
Background ColorIntensity
Vivid
ondullcolor :: Color -> Doc -> Doc
ondullcolor = ConsoleLayer -> ColorIntensity -> Color -> Doc -> Doc
Color ConsoleLayer
Background ColorIntensity
Dull

oncolorFunctions :: Color -> (Doc -> Doc, Doc -> Doc)
oncolorFunctions :: Color -> (Doc -> Doc, Doc -> Doc)
oncolorFunctions Color
what = (Color -> Doc -> Doc
oncolor Color
what, Color -> Doc -> Doc
ondullcolor Color
what)

-----------------------------------------------------------
-- Console Intensity
-----------------------------------------------------------

-- | Displays a document in a heavier font weight
bold :: Doc -> Doc
bold :: Doc -> Doc
bold = ConsoleIntensity -> Doc -> Doc
Intensify ConsoleIntensity
BoldIntensity

-- | Displays a document in the normal font weight
debold :: Doc -> Doc
debold :: Doc -> Doc
debold = ConsoleIntensity -> Doc -> Doc
Intensify ConsoleIntensity
NormalIntensity

-- NB: I don't support FaintIntensity here because it is not widely supported by terminals.

-----------------------------------------------------------
-- Italicization
-----------------------------------------------------------

{-

I'm in two minds about providing these functions, since italicization is so rarely implemented.
It is especially bad because "italicization" may cause the meaning of colors to flip, which will
look a bit weird, to say the least...

-- | Displays a document in italics. This is not widely supported, and it's use is not recommended
italicize :: Doc -> Doc
italicize = Italicize True

-- | Displays a document with no italics
deitalicize :: Doc -> Doc
deitalicize = Italicize False

-}

-----------------------------------------------------------
-- Underlining
-----------------------------------------------------------

-- | Displays a document with underlining
underline :: Doc -> Doc
underline :: Doc -> Doc
underline = Underlining -> Doc -> Doc
Underline Underlining
SingleUnderline

-- | Displays a document with no underlining
deunderline :: Doc -> Doc
deunderline :: Doc -> Doc
deunderline = Underlining -> Doc -> Doc
Underline Underlining
NoUnderline

-- NB: I don't support DoubleUnderline here because it is not widely supported by terminals.

-----------------------------------------------------------
-- Removing formatting
-----------------------------------------------------------

-- | Removes all colorisation, emboldening and underlining from a document
plain :: Doc -> Doc
plain :: Doc -> Doc
plain Doc
Fail            = Doc
Fail
plain e :: Doc
e@Doc
Empty         = Doc
e
plain c :: Doc
c@(Char Char
_)      = Doc
c
plain t :: Doc
t@(Text Int
_ String
_)    = Doc
t
plain l :: Doc
l@Doc
Line          = Doc
l
plain (FlatAlt Doc
x Doc
y)   = Doc -> Doc -> Doc
FlatAlt (Doc -> Doc
plain Doc
x) (Doc -> Doc
plain Doc
y)
plain (Cat Doc
x Doc
y)       = Doc -> Doc -> Doc
Cat (Doc -> Doc
plain Doc
x) (Doc -> Doc
plain Doc
y)
plain (Nest Int
i Doc
x)      = Int -> Doc -> Doc
Nest Int
i (Doc -> Doc
plain Doc
x)
plain (Union Doc
x Doc
y)     = Doc -> Doc -> Doc
Union (Doc -> Doc
plain Doc
x) (Doc -> Doc
plain Doc
y)
plain (Column Int -> Doc
f)      = (Int -> Doc) -> Doc
Column (Doc -> Doc
plain (Doc -> Doc) -> (Int -> Doc) -> Int -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc
f)
plain (Columns Maybe Int -> Doc
f)     = (Maybe Int -> Doc) -> Doc
Columns (Doc -> Doc
plain (Doc -> Doc) -> (Maybe Int -> Doc) -> Maybe Int -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> Doc
f)
plain (Nesting Int -> Doc
f)     = (Int -> Doc) -> Doc
Nesting (Doc -> Doc
plain (Doc -> Doc) -> (Int -> Doc) -> Int -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc
f)
plain (Color ConsoleLayer
_ ColorIntensity
_ Color
_ Doc
x) = Doc -> Doc
plain Doc
x
plain (Intensify ConsoleIntensity
_ Doc
x) = Doc -> Doc
plain Doc
x
plain (Italicize Bool
_ Doc
x) = Doc -> Doc
plain Doc
x
plain (Underline Underlining
_ Doc
x) = Doc -> Doc
plain Doc
x
plain (RestoreFormat Maybe (ColorIntensity, Color)
_ Maybe (ColorIntensity, Color)
_ Maybe ConsoleIntensity
_ Maybe Bool
_ Maybe Underlining
_) = Doc
Empty

-----------------------------------------------------------
-- Renderers
-----------------------------------------------------------

-----------------------------------------------------------
-- renderPretty: the default pretty printing algorithm
-----------------------------------------------------------

-- list of indentation/document pairs; saves an indirection over [(Int,Doc)]
data Docs   = Nil
            | Cons !Int Doc Docs

-- | This is the default pretty printer which is used by 'show',
-- 'putDoc' and 'hPutDoc'. @(renderPretty ribbonfrac width x)@ renders
-- document @x@ with a page width of @width@ and a ribbon width of
-- @(ribbonfrac * width)@ characters. The ribbon width is the maximal
-- amount of non-indentation characters on a line. The parameter
-- @ribbonfrac@ should be between @0.0@ and @1.0@. If it is lower or
-- higher, the ribbon width will be 0 or @width@ respectively.
renderPretty :: Float -> Int -> Doc -> SimpleDoc
renderPretty :: Float -> Int -> Doc -> SimpleDoc
renderPretty = (Int -> Int -> Int -> SimpleDoc -> Bool)
-> Float -> Int -> Doc -> SimpleDoc
renderFits Int -> Int -> Int -> SimpleDoc -> Bool
fits1

-- | A slightly smarter rendering algorithm with more lookahead. It provides
-- provide earlier breaking on deeply nested structures
-- For example, consider this python-ish pseudocode:
-- @fun(fun(fun(fun(fun([abcdefg, abcdefg])))))@
-- If we put a softbreak (+ nesting 2) after each open parenthesis, and align
-- the elements of the list to match the opening brackets, this will render with
-- @renderPretty@ and a page width of 20 as:
-- @
-- fun(fun(fun(fun(fun([
--                     | abcdef,
--                     | abcdef,
--                     ]
--   )))))             |
-- @
-- Where the 20c. boundary has been marked with |.
-- Because @renderPretty@ only uses one-line lookahead, it sees that the first
-- line fits, and is stuck putting the second and third lines after the 20-c
-- mark. In contrast, @renderSmart@ will continue to check that the potential
-- document up to the end of the indentation level. Thus, it will format the
-- document as:
--
-- @
-- fun(                |
--   fun(              |
--     fun(            |
--       fun(          |
--         fun([       |
--               abcdef,
--               abcdef,
--             ]       |
--   )))))             |
-- @
-- Which fits within the 20c. boundary.
renderSmart :: Float -> Int -> Doc -> SimpleDoc
renderSmart :: Float -> Int -> Doc -> SimpleDoc
renderSmart = (Int -> Int -> Int -> SimpleDoc -> Bool)
-> Float -> Int -> Doc -> SimpleDoc
renderFits Int -> Int -> Int -> SimpleDoc -> Bool
fitsR

renderFits :: (Int -> Int -> Int -> SimpleDoc -> Bool)
           -> Float -> Int -> Doc -> SimpleDoc
renderFits :: (Int -> Int -> Int -> SimpleDoc -> Bool)
-> Float -> Int -> Doc -> SimpleDoc
renderFits Int -> Int -> Int -> SimpleDoc -> Bool
fits Float
rfrac Int
w Doc
x
    -- I used to do a @SSGR [Reset]@ here, but if you do that it will result
    -- in any rendered @Doc@ containing at least some ANSI control codes. This
    -- may be undesirable if you want to render to non-ANSI devices by simply
    -- not making use of the ANSI color combinators I provide.
    --
    -- What I "really" want to do here is do an initial Reset iff there is some
    -- ANSI color within the Doc, but that's a bit fiddly. I'll fix it if someone
    -- complains!
    = Int
-> Int
-> Maybe (ColorIntensity, Color)
-> Maybe (ColorIntensity, Color)
-> Maybe ConsoleIntensity
-> Maybe Bool
-> Maybe Underlining
-> Docs
-> SimpleDoc
best Int
0 Int
0 Maybe (ColorIntensity, Color)
forall a. Maybe a
Nothing Maybe (ColorIntensity, Color)
forall a. Maybe a
Nothing Maybe ConsoleIntensity
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe Underlining
forall a. Maybe a
Nothing (Int -> Doc -> Docs -> Docs
Cons Int
0 Doc
x Docs
Nil)
    where
      -- r :: the ribbon width in characters
      r :: Int
r  = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
w (Float -> Int
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)))

      -- best :: n = indentation of current line
      --         k = current column
      --        (ie. (k >= n) && (k - n == count of inserted characters)
      best :: Int
-> Int
-> Maybe (ColorIntensity, Color)
-> Maybe (ColorIntensity, Color)
-> Maybe ConsoleIntensity
-> Maybe Bool
-> Maybe Underlining
-> Docs
-> SimpleDoc
best Int
n Int
k Maybe (ColorIntensity, Color)
mb_fc Maybe (ColorIntensity, Color)
mb_bc Maybe ConsoleIntensity
mb_in Maybe Bool
mb_it Maybe Underlining
mb_un Docs
Nil = SimpleDoc
SEmpty
      best Int
n Int
k Maybe (ColorIntensity, Color)
mb_fc Maybe (ColorIntensity, Color)
mb_bc Maybe ConsoleIntensity
mb_in Maybe Bool
mb_it Maybe Underlining
mb_un (Cons Int
i Doc
d Docs
ds)
        = case Doc
d of
            Doc
Fail          -> SimpleDoc
SFail
            Doc
Empty         -> Int -> Int -> Docs -> SimpleDoc
best_typical Int
n Int
k Docs
ds
            Char Char
c        -> let k' :: Int
k' = Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 in Int -> SimpleDoc -> SimpleDoc
seq Int
k' (Char -> SimpleDoc -> SimpleDoc
SChar Char
c (Int -> Int -> Docs -> SimpleDoc
best_typical Int
n Int
k' Docs
ds))
            Text Int
l String
s      -> let k' :: Int
k' = Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
l in Int -> SimpleDoc -> SimpleDoc
seq Int
k' (Int -> String -> SimpleDoc -> SimpleDoc
SText Int
l String
s (Int -> Int -> Docs -> SimpleDoc
best_typical Int
n Int
k' Docs
ds))
            Doc
Line          -> Int -> SimpleDoc -> SimpleDoc
SLine Int
i (Int -> Int -> Docs -> SimpleDoc
best_typical Int
i Int
i Docs
ds)
            FlatAlt Doc
x Doc
_   -> Int -> Int -> Docs -> SimpleDoc
best_typical Int
n Int
k (Int -> Doc -> Docs -> Docs
Cons Int
i Doc
x Docs
ds)
            Cat Doc
x Doc
y       -> Int -> Int -> Docs -> SimpleDoc
best_typical Int
n Int
k (Int -> Doc -> Docs -> Docs
Cons Int
i Doc
x (Int -> Doc -> Docs -> Docs
Cons Int
i Doc
y Docs
ds))
            Nest Int
j Doc
x      -> let i' :: Int
i' = Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
j in Int -> SimpleDoc -> SimpleDoc
seq Int
i' (Int -> Int -> Docs -> SimpleDoc
best_typical Int
n Int
k (Int -> Doc -> Docs -> Docs
Cons Int
i' Doc
x Docs
ds))
            Union Doc
x Doc
y     -> Int -> Int -> SimpleDoc -> SimpleDoc -> SimpleDoc
nicest Int
n Int
k (Int -> Int -> Docs -> SimpleDoc
best_typical Int
n Int
k (Int -> Doc -> Docs -> Docs
Cons Int
i Doc
x Docs
ds))
                                        (Int -> Int -> Docs -> SimpleDoc
best_typical Int
n Int
k (Int -> Doc -> Docs -> Docs
Cons Int
i Doc
y Docs
ds))
            Column Int -> Doc
f      -> Int -> Int -> Docs -> SimpleDoc
best_typical Int
n Int
k (Int -> Doc -> Docs -> Docs
Cons Int
i (Int -> Doc
f Int
k) Docs
ds)
            Columns Maybe Int -> Doc
f     -> Int -> Int -> Docs -> SimpleDoc
best_typical Int
n Int
k (Int -> Doc -> Docs -> Docs
Cons Int
i (Maybe Int -> Doc
f (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
w)) Docs
ds)
            Nesting Int -> Doc
f     -> Int -> Int -> Docs -> SimpleDoc
best_typical Int
n Int
k (Int -> Doc -> Docs -> Docs
Cons Int
i (Int -> Doc
f Int
i) Docs
ds)
            Color ConsoleLayer
l ColorIntensity
t Color
c Doc
x -> [SGR] -> SimpleDoc -> SimpleDoc
SSGR [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
l ColorIntensity
t Color
c] (Int
-> Int
-> Maybe (ColorIntensity, Color)
-> Maybe (ColorIntensity, Color)
-> Maybe ConsoleIntensity
-> Maybe Bool
-> Maybe Underlining
-> Docs
-> SimpleDoc
best Int
n Int
k Maybe (ColorIntensity, Color)
mb_fc' Maybe (ColorIntensity, Color)
mb_bc' Maybe ConsoleIntensity
mb_in Maybe Bool
mb_it Maybe Underlining
mb_un (Int -> Doc -> Docs -> Docs
Cons Int
i Doc
x Docs
ds_restore))
              where
                mb_fc' :: Maybe (ColorIntensity, Color)
mb_fc' = case ConsoleLayer
l of { ConsoleLayer
Background -> Maybe (ColorIntensity, Color)
mb_fc; ConsoleLayer
Foreground -> (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
t, Color
c) }
                mb_bc' :: Maybe (ColorIntensity, Color)
mb_bc' = case ConsoleLayer
l of { ConsoleLayer
Background -> (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
t, Color
c); ConsoleLayer
Foreground -> Maybe (ColorIntensity, Color)
mb_bc }
            Intensify ConsoleIntensity
t Doc
x -> [SGR] -> SimpleDoc -> SimpleDoc
SSGR [ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
t] (Int
-> Int
-> Maybe (ColorIntensity, Color)
-> Maybe (ColorIntensity, Color)
-> Maybe ConsoleIntensity
-> Maybe Bool
-> Maybe Underlining
-> Docs
-> SimpleDoc
best Int
n Int
k Maybe (ColorIntensity, Color)
mb_fc Maybe (ColorIntensity, Color)
mb_bc (ConsoleIntensity -> Maybe ConsoleIntensity
forall a. a -> Maybe a
Just ConsoleIntensity
t) Maybe Bool
mb_it Maybe Underlining
mb_un (Int -> Doc -> Docs -> Docs
Cons Int
i Doc
x Docs
ds_restore))
            Italicize Bool
t Doc
x -> [SGR] -> SimpleDoc -> SimpleDoc
SSGR [Bool -> SGR
SetItalicized Bool
t] (Int
-> Int
-> Maybe (ColorIntensity, Color)
-> Maybe (ColorIntensity, Color)
-> Maybe ConsoleIntensity
-> Maybe Bool
-> Maybe Underlining
-> Docs
-> SimpleDoc
best Int
n Int
k Maybe (ColorIntensity, Color)
mb_fc Maybe (ColorIntensity, Color)
mb_bc Maybe ConsoleIntensity
mb_in (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
t) Maybe Underlining
mb_un (Int -> Doc -> Docs -> Docs
Cons Int
i Doc
x Docs
ds_restore))
            Underline Underlining
u Doc
x -> [SGR] -> SimpleDoc -> SimpleDoc
SSGR [Underlining -> SGR
SetUnderlining Underlining
u] (Int
-> Int
-> Maybe (ColorIntensity, Color)
-> Maybe (ColorIntensity, Color)
-> Maybe ConsoleIntensity
-> Maybe Bool
-> Maybe Underlining
-> Docs
-> SimpleDoc
best Int
n Int
k Maybe (ColorIntensity, Color)
mb_fc Maybe (ColorIntensity, Color)
mb_bc Maybe ConsoleIntensity
mb_in Maybe Bool
mb_it (Underlining -> Maybe Underlining
forall a. a -> Maybe a
Just Underlining
u) (Int -> Doc -> Docs -> Docs
Cons Int
i Doc
x Docs
ds_restore))
            RestoreFormat Maybe (ColorIntensity, Color)
mb_fc' Maybe (ColorIntensity, Color)
mb_bc' Maybe ConsoleIntensity
mb_in' Maybe Bool
mb_it' Maybe Underlining
mb_un' -> [SGR] -> SimpleDoc -> SimpleDoc
SSGR [SGR]
sgrs (Int
-> Int
-> Maybe (ColorIntensity, Color)
-> Maybe (ColorIntensity, Color)
-> Maybe ConsoleIntensity
-> Maybe Bool
-> Maybe Underlining
-> Docs
-> SimpleDoc
best Int
n Int
k Maybe (ColorIntensity, Color)
mb_fc' Maybe (ColorIntensity, Color)
mb_bc' Maybe ConsoleIntensity
mb_in' Maybe Bool
mb_it' Maybe Underlining
mb_un' Docs
ds)
              where
                -- We need to be able to restore the entire SGR state, hence we carry around what we believe
                -- that state should be in all the arguments to this function. Note that in some cases we could
                -- avoid the Reset of the entire state, but not in general.
                sgrs :: [SGR]
sgrs = SGR
Reset SGR -> [SGR] -> [SGR]
forall a. a -> [a] -> [a]
: [Maybe SGR] -> [SGR]
forall a. [Maybe a] -> [a]
catMaybes [
                    ((ColorIntensity, Color) -> SGR)
-> Maybe (ColorIntensity, Color) -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ColorIntensity -> Color -> SGR) -> (ColorIntensity, Color) -> SGR
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground)) Maybe (ColorIntensity, Color)
mb_fc',
                    ((ColorIntensity, Color) -> SGR)
-> Maybe (ColorIntensity, Color) -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ColorIntensity -> Color -> SGR) -> (ColorIntensity, Color) -> SGR
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Background)) Maybe (ColorIntensity, Color)
mb_bc',
                    (ConsoleIntensity -> SGR) -> Maybe ConsoleIntensity -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConsoleIntensity -> SGR
SetConsoleIntensity Maybe ConsoleIntensity
mb_in',
                    (Bool -> SGR) -> Maybe Bool -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> SGR
SetItalicized Maybe Bool
mb_it',
                    (Underlining -> SGR) -> Maybe Underlining -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Underlining -> SGR
SetUnderlining Maybe Underlining
mb_un'
                  ]
        where
          best_typical :: Int -> Int -> Docs -> SimpleDoc
best_typical Int
n' Int
k' Docs
ds' = Int
-> Int
-> Maybe (ColorIntensity, Color)
-> Maybe (ColorIntensity, Color)
-> Maybe ConsoleIntensity
-> Maybe Bool
-> Maybe Underlining
-> Docs
-> SimpleDoc
best Int
n' Int
k' Maybe (ColorIntensity, Color)
mb_fc Maybe (ColorIntensity, Color)
mb_bc Maybe ConsoleIntensity
mb_in Maybe Bool
mb_it Maybe Underlining
mb_un Docs
ds'
          ds_restore :: Docs
ds_restore = Int -> Doc -> Docs -> Docs
Cons Int
i (Maybe (ColorIntensity, Color)
-> Maybe (ColorIntensity, Color)
-> Maybe ConsoleIntensity
-> Maybe Bool
-> Maybe Underlining
-> Doc
RestoreFormat Maybe (ColorIntensity, Color)
mb_fc Maybe (ColorIntensity, Color)
mb_bc Maybe ConsoleIntensity
mb_in Maybe Bool
mb_it Maybe Underlining
mb_un) 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 :: Int -> Int -> SimpleDoc -> SimpleDoc -> SimpleDoc
nicest Int
n Int
k SimpleDoc
x SimpleDoc
y    | Int -> Int -> Int -> SimpleDoc -> Bool
fits Int
w (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n Int
k) Int
width SimpleDoc
x  = SimpleDoc
x
                        | Bool
otherwise     = SimpleDoc
y
                        where
                          width :: Int
width = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k) (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)

-- @fits1@ does 1 line lookahead.
fits1 :: Int -> Int -> Int -> SimpleDoc -> Bool
fits1 :: Int -> Int -> Int -> SimpleDoc -> Bool
fits1 Int
_ Int
_ Int
w SimpleDoc
x        | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0         = Bool
False
fits1 Int
_ Int
_ Int
w SimpleDoc
SFail                    = Bool
False
fits1 Int
_ Int
_ Int
w SimpleDoc
SEmpty                   = Bool
True
fits1 Int
p Int
m Int
w (SChar Char
c SimpleDoc
x)              = Int -> Int -> Int -> SimpleDoc -> Bool
fits1 Int
p Int
m (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) SimpleDoc
x
fits1 Int
p Int
m Int
w (SText Int
l String
s SimpleDoc
x)            = Int -> Int -> Int -> SimpleDoc -> Bool
fits1 Int
p Int
m (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) SimpleDoc
x
fits1 Int
_ Int
_ Int
w (SLine Int
i SimpleDoc
x)              = Bool
True
fits1 Int
p Int
m Int
w (SSGR [SGR]
_ SimpleDoc
x)               = Int -> Int -> Int -> SimpleDoc -> Bool
fits1 Int
p Int
m Int
w SimpleDoc
x

-- @fitsR@ has a little more lookahead: assuming that nesting roughly
-- corresponds to syntactic depth, @fitsR@ checks that not only the current line
-- fits, but the entire syntactic structure being formatted at this level of
-- indentation fits. If we were to remove the second case for @SLine@, we would
-- check that not only the current structure fits, but also the rest of the
-- document, which would be slightly more intelligent but would have exponential
-- runtime (and is prohibitively expensive in practice).
-- p = pagewidth
-- m = minimum nesting level to fit in
-- w = the width in which to fit the first line
fitsR :: Int -> Int -> Int -> SimpleDoc -> Bool
fitsR :: Int -> Int -> Int -> SimpleDoc -> Bool
fitsR Int
p Int
m Int
w SimpleDoc
x        | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0         = Bool
False
fitsR Int
p Int
m Int
w SimpleDoc
SFail                    = Bool
False
fitsR Int
p Int
m Int
w SimpleDoc
SEmpty                   = Bool
True
fitsR Int
p Int
m Int
w (SChar Char
c SimpleDoc
x)              = Int -> Int -> Int -> SimpleDoc -> Bool
fitsR Int
p Int
m (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) SimpleDoc
x
fitsR Int
p Int
m Int
w (SText Int
l String
s SimpleDoc
x)            = Int -> Int -> Int -> SimpleDoc -> Bool
fitsR Int
p Int
m (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) SimpleDoc
x
fitsR Int
p Int
m Int
w (SLine Int
i SimpleDoc
x) | Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
i      = Int -> Int -> Int -> SimpleDoc -> Bool
fitsR Int
p Int
m (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) SimpleDoc
x
                        | Bool
otherwise  = Bool
True
fitsR Int
p Int
m Int
w (SSGR [SGR]
_ SimpleDoc
x)               = Int -> Int -> Int -> SimpleDoc -> Bool
fitsR Int
p Int
m Int
w SimpleDoc
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.
--
-- This rendering function does not add any colorisation information.
renderCompact :: Doc -> SimpleDoc
renderCompact :: Doc -> SimpleDoc
renderCompact Doc
x
    = Int -> [Doc] -> SimpleDoc
scan Int
0 [Doc
x]
    where
      scan :: Int -> [Doc] -> SimpleDoc
scan Int
k []     = SimpleDoc
SEmpty
      scan Int
k (Doc
d:[Doc]
ds) = case Doc
d of
                        Doc
Fail                    -> SimpleDoc
SFail
                        Doc
Empty                   -> Int -> [Doc] -> SimpleDoc
scan Int
k [Doc]
ds
                        Char Char
c                  -> let k' :: Int
k' = Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 in Int -> SimpleDoc -> SimpleDoc
seq Int
k' (Char -> SimpleDoc -> SimpleDoc
SChar Char
c (Int -> [Doc] -> SimpleDoc
scan Int
k' [Doc]
ds))
                        Text Int
l String
s                -> let k' :: Int
k' = Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
l in Int -> SimpleDoc -> SimpleDoc
seq Int
k' (Int -> String -> SimpleDoc -> SimpleDoc
SText Int
l String
s (Int -> [Doc] -> SimpleDoc
scan Int
k' [Doc]
ds))
                        FlatAlt Doc
x Doc
_             -> Int -> [Doc] -> SimpleDoc
scan Int
k (Doc
xDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)
                        Doc
Line                    -> Int -> SimpleDoc -> SimpleDoc
SLine Int
0 (Int -> [Doc] -> SimpleDoc
scan Int
0 [Doc]
ds)
                        Cat Doc
x Doc
y                 -> Int -> [Doc] -> SimpleDoc
scan Int
k (Doc
xDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:Doc
yDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)
                        Nest Int
j Doc
x                -> Int -> [Doc] -> SimpleDoc
scan Int
k (Doc
xDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)
                        Union Doc
x Doc
y               -> Int -> [Doc] -> SimpleDoc
scan Int
k (Doc
yDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)
                        Column Int -> Doc
f                -> Int -> [Doc] -> SimpleDoc
scan Int
k (Int -> Doc
f Int
kDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)
                        Columns Maybe Int -> Doc
f               -> Int -> [Doc] -> SimpleDoc
scan Int
k (Maybe Int -> Doc
f Maybe Int
forall a. Maybe a
NothingDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)
                        Nesting Int -> Doc
f               -> Int -> [Doc] -> SimpleDoc
scan Int
k (Int -> Doc
f Int
0Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)
                        Color ConsoleLayer
_ ColorIntensity
_ Color
_ Doc
x           -> Int -> [Doc] -> SimpleDoc
scan Int
k (Doc
xDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)
                        Intensify ConsoleIntensity
_ Doc
x           -> Int -> [Doc] -> SimpleDoc
scan Int
k (Doc
xDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)
                        Italicize Bool
_ Doc
x           -> Int -> [Doc] -> SimpleDoc
scan Int
k (Doc
xDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)
                        Underline Underlining
_ Doc
x           -> Int -> [Doc] -> SimpleDoc
scan Int
k (Doc
xDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)
                        RestoreFormat Maybe (ColorIntensity, Color)
_ Maybe (ColorIntensity, Color)
_ Maybe ConsoleIntensity
_ Maybe Bool
_ Maybe Underlining
_ -> Int -> [Doc] -> SimpleDoc
scan Int
k [Doc]
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) ""
--
-- ANSI color information will be discarded by this function unless
-- you are running on a Unix-like operating system. This is due to
-- a technical limitation in Windows ANSI support.
displayS :: SimpleDoc -> ShowS
displayS :: SimpleDoc -> ShowS
displayS SimpleDoc
SFail              = String -> ShowS
forall a. HasCallStack => String -> a
error (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"@SFail@ can not appear uncaught in a " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                              String
"rendered @SimpleDoc@"
displayS SimpleDoc
SEmpty             = ShowS
forall a. a -> a
id
displayS (SChar Char
c SimpleDoc
x)        = Char -> ShowS
showChar Char
c ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDoc -> ShowS
displayS SimpleDoc
x
displayS (SText Int
l String
s SimpleDoc
x)      = String -> ShowS
showString String
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDoc -> ShowS
displayS SimpleDoc
x
displayS (SLine Int
i SimpleDoc
x)        = String -> ShowS
showString (Char
'\n'Char -> ShowS
forall a. a -> [a] -> [a]
:Int -> String
indentation Int
i) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDoc -> ShowS
displayS SimpleDoc
x
displayS (SSGR [SGR]
s SimpleDoc
x)         = String -> ShowS
showString ([SGR] -> String
setSGRCode [SGR]
s) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDoc -> ShowS
displayS SimpleDoc
x

-- | @(displayIO handle simpleDoc)@ writes @simpleDoc@ to the file
-- handle @handle@. This function is used for example by 'hPutDoc':
--
-- > hPutDoc handle doc  = displayIO handle (renderPretty 0.4 80 doc)
--
-- Any ANSI colorisation in @simpleDoc@ will be output.
displayIO :: Handle -> SimpleDoc -> IO ()
displayIO :: Handle -> SimpleDoc -> IO ()
displayIO Handle
handle SimpleDoc
simpleDoc
    = SimpleDoc -> IO ()
display SimpleDoc
simpleDoc
    where
      display :: SimpleDoc -> IO ()
display SimpleDoc
SFail         = String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"@SFail@ can not appear uncaught in a " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                              String
"rendered @SimpleDoc@"
      display SimpleDoc
SEmpty         = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      display (SChar Char
c SimpleDoc
x)    = do{ Handle -> Char -> IO ()
hPutChar Handle
handle Char
c; SimpleDoc -> IO ()
display SimpleDoc
x}
      display (SText Int
l String
s SimpleDoc
x)  = do{ Handle -> String -> IO ()
hPutStr Handle
handle String
s; SimpleDoc -> IO ()
display SimpleDoc
x}
      display (SLine Int
i SimpleDoc
x)    = do{ Handle -> String -> IO ()
hPutStr Handle
handle (Char
'\n'Char -> ShowS
forall a. a -> [a] -> [a]
:Int -> String
indentation Int
i); SimpleDoc -> IO ()
display SimpleDoc
x}
      display (SSGR [SGR]
s SimpleDoc
x)     = do{ Handle -> [SGR] -> IO ()
hSetSGR Handle
handle [SGR]
s; SimpleDoc -> IO ()
display SimpleDoc
x}

-----------------------------------------------------------
-- default pretty printers: show, putDoc and hPutDoc
-----------------------------------------------------------
instance Show Doc where
  showsPrec :: Int -> Doc -> ShowS
showsPrec Int
d Doc
doc       = SimpleDoc -> ShowS
displayS (Float -> Int -> Doc -> SimpleDoc
renderPretty Float
0.4 Int
80 Doc
doc)

-- | The action @(putDoc doc)@ pretty prints document @doc@ to the
-- standard output, with a page width of 80 characters and a ribbon
-- width of 32 characters.
--
-- > main :: IO ()
-- > main = do{ putDoc (text "hello" <+> text "world") }
--
-- Which would output
--
-- @
-- hello world
-- @
--
-- Any ANSI colorisation in @doc@ will be output.
putDoc :: Doc -> IO ()
putDoc :: Doc -> IO ()
putDoc Doc
doc              = Handle -> Doc -> IO ()
hPutDoc Handle
stdout Doc
doc

-- | @(hPutDoc handle doc)@ pretty prints document @doc@ to the file
-- handle @handle@ with a page width of 80 characters and a ribbon
-- width of 32 characters.
--
-- > main = do{ handle <- openFile "MyFile" WriteMode
-- >          ; hPutDoc handle (vcat (map text
-- >                            ["vertical","text"]))
-- >          ; hClose handle
-- >          }
--
-- Any ANSI colorisation in @doc@ will be output.
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 :: Int -> String
spaces :: Int -> String
spaces Int
n        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0    = String
""
                | Bool
otherwise = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' '

indentation :: Int -> String
indentation :: Int -> String
indentation Int
n   = Int -> String
spaces Int
n

--indentation n   | n >= 8    = '\t' : indentation (n-8)
--                | otherwise = spaces n

--  LocalWords:  PPrint combinators Wadler Wadler's encloseSep