{-# LANGUAGE CPP #-}

--------------------------------------------------------------------------------
{-| Module      :  PPrint
    Copyright   :  (c) Daan Leijen 2000, <http://www.cs.uu.nl/~daan>
    Version      : $version: $

    Maintainer  :  daan@cs.uu.nl
    Stability   :  provisional
    Portability :  portable

    Pretty print library based on Philip Wadlers "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>

    Haskell98 compatible
-}
---------------------------------------------------------------------------------
module UU.PPrint
        ( Doc
        , Pretty, pretty

        , show, putDoc, hPutDoc

        , (<>)
        , (<+>)
        , (</>), (<//>)
        , (<$>), (<$$>)

        , sep, fillSep, hsep, vsep
        , cat, fillCat, hcat, vcat
        , punctuate

        , align, hang, indent
        , fill, fillBreak

        , list, tupled, semiBraces, encloseSep
        , angles, langle, rangle
        , parens, lparen, rparen
        , braces, lbrace, rbrace
        , brackets, lbracket, rbracket
        , dquotes, dquote, squotes, squote

        , comma, space, dot, backslash
        , semi, colon, equals

        , string, bool, int, integer, float, double, rational

        , softline, softbreak
        , empty, char, text, line, linebreak, nest, group
        , column, nesting, width

        , SimpleDoc(..)
        , renderPretty, renderCompact
        , displayS, displayIO
        ) where


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

#if __GLASGOW_HASKELL__ >= 800
import Prelude hiding ((<$>),(<>))
#elif __GLASGOW_HASKELL__ >= 710
import Prelude hiding ((<$>))
#endif

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


-----------------------------------------------------------
-- list, tupled and semiBraces pretty print a list of
-- documents either horizontally or vertically aligned.
-----------------------------------------------------------
list :: [Doc] -> Doc
list            = Doc -> Doc -> Doc -> [Doc] -> Doc
encloseSep Doc
lbracket Doc
rbracket Doc
comma
tupled :: [Doc] -> Doc
tupled          = Doc -> Doc -> Doc -> [Doc] -> Doc
encloseSep Doc
lparen   Doc
rparen  Doc
comma
semiBraces :: [Doc] -> Doc
semiBraces      = Doc -> Doc -> Doc -> [Doc] -> Doc
encloseSep Doc
lbrace   Doc
rbrace  Doc
semi

encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc
encloseSep Doc
left Doc
right Doc
sep [Doc]
ds
    = case [Doc]
ds of
        []  -> Doc
left Doc -> Doc -> Doc
<> Doc
right
        [Doc
d] -> Doc
left Doc -> Doc -> Doc
<> Doc
d Doc -> Doc -> Doc
<> 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
(<>) (Doc
left Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: Doc -> [Doc]
forall a. a -> [a]
repeat Doc
sep) [Doc]
ds) Doc -> Doc -> Doc
<> Doc
right)


-----------------------------------------------------------
-- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn]
-----------------------------------------------------------
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
<> Doc
p) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: Doc -> [Doc] -> [Doc]
punctuate Doc
p [Doc]
ds


-----------------------------------------------------------
-- high-level combinators
-----------------------------------------------------------
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
fillSep :: [Doc] -> Doc
fillSep         = (Doc -> Doc -> Doc) -> [Doc] -> Doc
fold Doc -> Doc -> Doc
(</>)
hsep :: [Doc] -> Doc
hsep            = (Doc -> Doc -> Doc) -> [Doc] -> Doc
fold Doc -> Doc -> Doc
(<+>)
vsep :: [Doc] -> Doc
vsep            = (Doc -> Doc -> Doc) -> [Doc] -> Doc
fold Doc -> 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
fillCat :: [Doc] -> Doc
fillCat         = (Doc -> Doc -> Doc) -> [Doc] -> Doc
fold Doc -> Doc -> Doc
(<//>)
hcat :: [Doc] -> Doc
hcat            = (Doc -> Doc -> Doc) -> [Doc] -> Doc
fold Doc -> 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
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

Doc
x <> :: Doc -> Doc -> Doc
<> Doc
y          = Doc
x Doc -> Doc -> Doc
`beside` Doc
y
Doc
x <+> :: Doc -> Doc -> Doc
<+> Doc
y         = Doc
x Doc -> Doc -> Doc
<> Doc
space Doc -> Doc -> Doc
<> Doc
y
Doc
x </> :: Doc -> Doc -> Doc
</> Doc
y         = Doc
x Doc -> Doc -> Doc
<> Doc
softline Doc -> Doc -> Doc
<> Doc
y
Doc
x <//> :: Doc -> Doc -> Doc
<//> Doc
y        = Doc
x Doc -> Doc -> Doc
<> Doc
softbreak Doc -> Doc -> Doc
<> Doc
y
Doc
x <$> :: Doc -> Doc -> Doc
<$> Doc
y         = Doc
x Doc -> Doc -> Doc
<> Doc
line Doc -> Doc -> Doc
<> Doc
y
Doc
x <$$> :: Doc -> Doc -> Doc
<$$> Doc
y        = Doc
x Doc -> Doc -> Doc
<> Doc
linebreak Doc -> Doc -> Doc
<> Doc
y

softline :: Doc
softline        = Doc -> Doc
group Doc
line
softbreak :: Doc
softbreak       = Doc -> Doc
group Doc
linebreak

squotes :: Doc -> Doc
squotes         = Doc -> Doc -> Doc -> Doc
enclose Doc
squote Doc
squote
dquotes :: Doc -> Doc
dquotes         = Doc -> Doc -> Doc -> Doc
enclose Doc
dquote Doc
dquote
braces :: Doc -> Doc
braces          = Doc -> Doc -> Doc -> Doc
enclose Doc
lbrace Doc
rbrace
parens :: Doc -> Doc
parens          = Doc -> Doc -> Doc -> Doc
enclose Doc
lparen Doc
rparen
angles :: Doc -> Doc
angles          = Doc -> Doc -> Doc -> Doc
enclose Doc
langle Doc
rangle
brackets :: Doc -> Doc
brackets        = Doc -> Doc -> Doc -> Doc
enclose Doc
lbracket Doc
rbracket
enclose :: Doc -> Doc -> Doc -> Doc
enclose Doc
l Doc
r Doc
x   = Doc
l Doc -> Doc -> Doc
<> Doc
x Doc -> Doc -> Doc
<> Doc
r

lparen :: Doc
lparen          = Char -> Doc
char Char
'('
rparen :: Doc
rparen          = Char -> Doc
char Char
')'
langle :: Doc
langle          = Char -> Doc
char Char
'<'
rangle :: Doc
rangle          = Char -> Doc
char Char
'>'
lbrace :: Doc
lbrace          = Char -> Doc
char Char
'{'
rbrace :: Doc
rbrace          = Char -> Doc
char Char
'}'
lbracket :: Doc
lbracket        = Char -> Doc
char Char
'['
rbracket :: Doc
rbracket        = Char -> Doc
char Char
']'

squote :: Doc
squote          = Char -> Doc
char Char
'\''
dquote :: Doc
dquote          = Char -> Doc
char Char
'"'
semi :: Doc
semi            = Char -> Doc
char Char
';'
colon :: Doc
colon           = Char -> Doc
char Char
':'
comma :: Doc
comma           = Char -> Doc
char Char
','
space :: Doc
space           = Char -> Doc
char Char
' '
dot :: Doc
dot             = Char -> Doc
char Char
'.'
backslash :: Doc
backslash       = Char -> Doc
char Char
'\\'
equals :: Doc
equals          = Char -> Doc
char Char
'='


-----------------------------------------------------------
-- Combinators for prelude types
-----------------------------------------------------------

-- string is like "text" but replaces '\n' by "line"
string :: [Char] -> Doc
string [Char]
""       = Doc
empty
string (Char
'\n':[Char]
s) = Doc
line Doc -> Doc -> Doc
<> [Char] -> Doc
string [Char]
s
string [Char]
s        = case ((Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\n') [Char]
s) of
                    ([Char]
xs,[Char]
ys) -> [Char] -> Doc
text [Char]
xs Doc -> Doc -> Doc
<> [Char] -> Doc
string [Char]
ys

bool :: Bool -> Doc
bool :: Bool -> Doc
bool Bool
b          = [Char] -> Doc
text (Bool -> [Char]
forall a. Show a => a -> [Char]
show Bool
b)

int :: Int -> Doc
int :: Int -> Doc
int Int
i           = [Char] -> Doc
text (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i)

integer :: Integer -> Doc
integer :: Integer -> Doc
integer Integer
i       = [Char] -> Doc
text (Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
i)

float :: Float -> Doc
float :: Float -> Doc
float Float
f         = [Char] -> Doc
text (Float -> [Char]
forall a. Show a => a -> [Char]
show Float
f)

double :: Double -> Doc
double :: Double -> Doc
double Double
d        = [Char] -> Doc
text (Double -> [Char]
forall a. Show a => a -> [Char]
show Double
d)

rational :: Rational -> Doc
rational :: Rational -> Doc
rational Rational
r      = [Char] -> Doc
text (Rational -> [Char]
forall a. Show a => a -> [Char]
show Rational
r)


-----------------------------------------------------------
-- overloading "pretty"
-----------------------------------------------------------
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 ()     = [Char] -> Doc
text [Char]
"()"

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 :: [Char] -> Doc
prettyList [Char]
s  = [Char] -> Doc
string [Char]
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
-----------------------------------------------------------
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 [Char] -> Doc
text (Int -> [Char]
spaces (Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
w)))

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 [Char] -> Doc
text (Int -> [Char]
spaces (Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
w)))

width :: Doc -> (Int -> Doc) -> Doc
width Doc
d Int -> Doc
f       = (Int -> Doc) -> Doc
column (\Int
k1 -> Doc
d Doc -> Doc -> Doc
<> (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
-----------------------------------------------------------
indent :: Int -> Doc -> Doc
indent Int
i Doc
d      = Int -> Doc -> Doc
hang Int
i ([Char] -> Doc
text (Int -> [Char]
spaces Int
i) Doc -> Doc -> Doc
<> Doc
d)

hang :: Int -> Doc -> Doc
hang Int
i Doc
d        = Doc -> Doc
align (Int -> Doc -> Doc
nest Int
i Doc
d)

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
-----------------------------------------------------------
data Doc        = Empty
                | Char Char             -- invariant: char is not '\n'
                | Text !Int String      -- invariant: text doesn't contain '\n'
                | Line !Bool            -- True <=> when undone by group, do not insert a space
                | Cat Doc Doc
                | Nest !Int Doc
                | Union Doc Doc         -- invariant: first lines of first doc longer than the first lines of the second doc
                | Column  (Int -> Doc)
                | Nesting (Int -> Doc)

data SimpleDoc  = SEmpty
                | SChar Char SimpleDoc
                | SText !Int String SimpleDoc
                | SLine !Int SimpleDoc


empty :: Doc
empty           = Doc
Empty

char :: Char -> Doc
char Char
'\n'       = Doc
line
char Char
c          = Char -> Doc
Char Char
c

text :: [Char] -> Doc
text [Char]
""         = Doc
Empty
text [Char]
s          = Int -> [Char] -> Doc
Text ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s) [Char]
s

line :: Doc
line            = Bool -> Doc
Line Bool
False
linebreak :: Doc
linebreak       = Bool -> Doc
Line Bool
True

beside :: Doc -> Doc -> Doc
beside Doc
x Doc
y      = Doc -> Doc -> Doc
Cat Doc
x Doc
y
nest :: Int -> Doc -> Doc
nest Int
i Doc
x        = Int -> Doc -> Doc
Nest Int
i Doc
x
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
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 Int
i Doc
x)      = Int -> Doc -> Doc
Nest Int
i (Doc -> Doc
flatten Doc
x)
flatten (Line Bool
break)    = if Bool
break then Doc
Empty else Int -> [Char] -> Doc
Text Int
1 [Char]
" "
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 (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 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 !Int Doc Docs

renderPretty :: Float -> Int -> Doc -> SimpleDoc
renderPretty :: Float -> Int -> Doc -> SimpleDoc
renderPretty Float
rfrac Int
w Doc
x
    = Int -> Int -> Docs -> SimpleDoc
best Int
0 Int
0 (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 -> Docs -> SimpleDoc
best Int
n Int
k Docs
Nil      = SimpleDoc
SEmpty
      best Int
n Int
k (Cons Int
i Doc
d Docs
ds)
        = case Doc
d of
            Doc
Empty       -> Int -> Int -> Docs -> SimpleDoc
best 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 Int
n Int
k' Docs
ds))
            Text Int
l [Char]
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 -> [Char] -> SimpleDoc -> SimpleDoc
SText Int
l [Char]
s (Int -> Int -> Docs -> SimpleDoc
best Int
n Int
k' Docs
ds))
            Line Bool
_      -> Int -> SimpleDoc -> SimpleDoc
SLine Int
i (Int -> Int -> Docs -> SimpleDoc
best Int
i Int
i Docs
ds)
            Cat Doc
x Doc
y     -> Int -> Int -> Docs -> SimpleDoc
best 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 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 Int
n Int
k (Int -> Doc -> Docs -> Docs
Cons Int
i Doc
x Docs
ds))
                                      (Int -> Int -> Docs -> SimpleDoc
best Int
n Int
k (Int -> Doc -> Docs -> Docs
Cons Int
i Doc
y Docs
ds))

            Column Int -> Doc
f    -> Int -> Int -> Docs -> SimpleDoc
best Int
n Int
k (Int -> Doc -> Docs -> Docs
Cons Int
i (Int -> Doc
f Int
k) Docs
ds)
            Nesting Int -> Doc
f   -> Int -> Int -> Docs -> SimpleDoc
best Int
n Int
k (Int -> Doc -> Docs -> Docs
Cons Int
i (Int -> Doc
f Int
i) 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 -> SimpleDoc -> Bool
fits 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)


fits :: Int -> SimpleDoc -> Bool
fits Int
w SimpleDoc
x        | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0         = Bool
False
fits Int
w SimpleDoc
SEmpty                   = Bool
True
fits Int
w (SChar Char
c SimpleDoc
x)              = Int -> SimpleDoc -> Bool
fits (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) SimpleDoc
x
fits Int
w (SText Int
l [Char]
s SimpleDoc
x)            = Int -> SimpleDoc -> Bool
fits (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) SimpleDoc
x
fits Int
w (SLine Int
i SimpleDoc
x)              = Bool
True


-----------------------------------------------------------
-- renderCompact: renders documents without indentation
--  fast and fewer characters output, good for machines
-----------------------------------------------------------
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
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 [Char]
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 -> [Char] -> SimpleDoc -> SimpleDoc
SText Int
l [Char]
s (Int -> [Doc] -> SimpleDoc
scan Int
k' [Doc]
ds))
                        Line Bool
_      -> 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)
                        Nesting Int -> Doc
f   -> Int -> [Doc] -> SimpleDoc
scan Int
k (Int -> Doc
f Int
0Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds)



-----------------------------------------------------------
-- Displayers:  displayS and displayIO
-----------------------------------------------------------
displayS :: SimpleDoc -> ShowS
displayS :: SimpleDoc -> ShowS
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 [Char]
s SimpleDoc
x)      = [Char] -> ShowS
showString [Char]
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)        = [Char] -> ShowS
showString (Char
'\n'Char -> ShowS
forall a. a -> [a] -> [a]
:Int -> [Char]
indentation Int
i) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDoc -> ShowS
displayS SimpleDoc
x

displayIO :: Handle -> SimpleDoc -> IO ()
displayIO :: Handle -> SimpleDoc -> IO ()
displayIO Handle
handle SimpleDoc
simpleDoc
    = SimpleDoc -> IO ()
display SimpleDoc
simpleDoc
    where
      display :: SimpleDoc -> IO ()
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 [Char]
s SimpleDoc
x) = do{ Handle -> [Char] -> IO ()
hPutStr Handle
handle [Char]
s; SimpleDoc -> IO ()
display SimpleDoc
x}
      display (SLine Int
i SimpleDoc
x)   = do{ Handle -> [Char] -> IO ()
hPutStr Handle
handle (Char
'\n'Char -> ShowS
forall a. a -> [a] -> [a]
:Int -> [Char]
indentation Int
i); 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)

putDoc :: Doc -> IO ()
putDoc :: Doc -> IO ()
putDoc Doc
doc              = Handle -> Doc -> IO ()
hPutDoc Handle
stdout Doc
doc

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 -> [Char]
spaces Int
n        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0    = [Char]
""
                | Bool
otherwise = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
n Char
' '

indentation :: Int -> [Char]
indentation Int
n   = Int -> [Char]
spaces Int
n

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