module Doc.Pretty
( Doc
, putDoc, hPutDoc
, putDocM, putDocMLn
, (</>), (<//>)
, (<$$>)
, sep, fillSep, hsep, vsep
, cat, fillCat, hcat, DocLike.vcat
, align, hang, indent
, fill, fillBreak
, errorDoc, failDoc
, softline, softbreak
, line, linebreak, nest, group
, column, nesting, width
, SimpleDoc(..)
, renderPretty, renderCompact
, displayS, displayIO, displayM
, textProc, oob
) where
import System.IO (Handle,hPutStr,hPutChar,stdout)
import Doc.DocLike hiding(empty)
import qualified Doc.DocLike as DocLike
import Data.Monoid(Monoid(..))
infixr 5 </>,<//>,<$$>
encloseSep left right sep ds
= case ds of
[] -> left <> right
[d] -> left <> d <> right
_ -> align (cat (zipWith (<>) (left : repeat sep) ds) <> right)
errorDoc :: Doc -> a
errorDoc = error . ('\n':) . show
failDoc :: Monad m => Doc -> m a
failDoc = fail . ('\n':) . show
sep = group . vsep
fillSep = fold (</>)
vsep = fold (Doc.Pretty.<$>)
cat = group . Doc.Pretty.vcat
fillCat = fold (<//>)
vcat = fold (<$$>)
fold f [] = empty
fold f ds = foldr1 f ds
instance Monoid Doc where
mempty = Doc.Pretty.empty
mappend = beside
mconcat = fold beside
instance TextLike Doc where
empty = Doc.Pretty.empty
text = mytext
char x = mychar x
instance DocLike Doc where
x <> y = x `beside` y
x <+> y = x <> space <> y
encloseSep = Doc.Pretty.encloseSep
vcat = Doc.Pretty.vcat
x </> y = x <> softline <> y
x <//> y = x <> softbreak <> y
x <$> y = x <> line <> y
x <$$> y = x <> linebreak <> y
softline = group line
softbreak = group linebreak
fillBreak f x = width x (\w ->
if (w > f) then nest f linebreak
else text (spaces (f w)))
fill f d = width d (\w ->
if (w >= f) then empty
else text (spaces (f w)))
width d f = column (\k1 -> d <> column (\k2 -> f (k2 k1)))
indent i d = hang i (text (spaces i) <> d)
hang i d = align (nest i d)
align d = column (\k ->
nesting (\i -> nest (k i) d))
data Doc = Empty
| Char Char
| Text !Int String
| Line !Bool
| Cat Doc Doc
| Nest !Int Doc
| Union Doc Doc
| Column (Int -> Doc)
| Nesting (Int -> Doc)
data SimpleDoc = SEmpty
| SChar Char SimpleDoc
| SText !Int String SimpleDoc
| SLine !Int SimpleDoc
empty = Empty
mychar '\n' = line
mychar c = Char c
mytext "" = Empty
mytext s = Text (length s) s
oob :: String -> Doc
oob "" = Empty
oob s = Text 0 s
textProc :: (Char -> String) -> String -> Doc
textProc f "" = Empty
textProc f s = Text (length s) $ concatMap f s
line = Line False
linebreak = Line True
beside x y = Cat x y
nest i x = Nest i x
column f = Column f
nesting f = Nesting f
group :: Doc -> Doc
group x = Union (flatten x) x
flatten :: Doc -> Doc
flatten (Cat x y) = Cat (flatten x) (flatten y)
flatten (Nest i x) = Nest i (flatten x)
flatten (Line break) = if break then Empty else Text 1 " "
flatten (Union x y) = flatten x
flatten (Column f) = Column (flatten . f)
flatten (Nesting f) = Nesting (flatten . f)
flatten other = other --Empty,Char,Text
data Docs = Nil
| Cons !Int Doc Docs
renderPretty :: Float -> Int -> Doc -> SimpleDoc
renderPretty rfrac w x
= best 0 0 (Cons 0 x Nil)
where
r = max 0 (min w (round (fromIntegral w * rfrac)))
best n k Nil = SEmpty
best n k (Cons i d ds)
= case d of
Empty -> best n k ds
Char c -> let k' = k+1 in seq k' (SChar c (best n k' ds))
Text l s -> let k' = k+l in seq k' (SText l s (best n k' ds))
Line _ -> SLine i (best i i ds)
Cat x y -> best n k (Cons i x (Cons i y ds))
Nest j x -> let i' = i+j in seq i' (best n k (Cons i' x ds))
Union x y -> nicest n k (best n k (Cons i x ds))
(best n k (Cons i y ds))
Column f -> best n k (Cons i (f k) ds)
Nesting f -> best n k (Cons i (f i) ds)
nicest n k x y | fits width x = x
| otherwise = y
where
width = min (w k) (r k + n)
fits w x | w < 0 = False
fits w SEmpty = True
fits w (SChar c x) = fits (w 1) x
fits w (SText l s x) = fits (w l) x
fits w (SLine i x) = True
renderCompact :: Doc -> SimpleDoc
renderCompact x
= scan 0 [x]
where
scan k [] = SEmpty
scan k (d:ds) = case d of
Empty -> scan k ds
Char c -> let k' = k+1 in seq k' (SChar c (scan k' ds))
Text l s -> let k' = k+l in seq k' (SText l s (scan k' ds))
Line _ -> SLine 0 (scan 0 ds)
Cat x y -> scan k (x:y:ds)
Nest j x -> scan k (x:ds)
Union x y -> scan k (y:ds)
Column f -> scan k (f k:ds)
Nesting f -> scan k (f 0:ds)
displayS :: SimpleDoc -> ShowS
displayS SEmpty = id
displayS (SChar c x) = showChar c . displayS x
displayS (SText l s x) = showString s . displayS x
displayS (SLine i x) = showString ('\n':indentation i) . displayS x
displayIO :: Handle -> SimpleDoc -> IO ()
displayIO handle simpleDoc
= display simpleDoc
where
display SEmpty = return ()
display (SChar c x) = do{ hPutChar handle c; display x}
display (SText l s x) = do{ hPutStr handle s; display x}
display (SLine i x) = do{ hPutStr handle ('\n':indentation i); display x}
displayM :: Monad m => (String -> m ()) -> SimpleDoc -> m ()
displayM putStr simpleDoc = display simpleDoc where
display SEmpty = return ()
display (SChar c x) = do{ putStr [c]; display x}
display (SText l s x) = do{ putStr s; display x}
display (SLine i x) = do{ putStr ('\n':indentation i); display x}
instance Show Doc where
showsPrec d doc = displayS (renderPretty 0.4 80 doc)
putDoc :: Doc -> IO ()
putDoc doc = hPutDoc stdout doc
putDocM :: Monad m => (String -> m ()) -> Doc -> m ()
putDocM putStr d = displayM putStr (renderPretty 0.4 80 d)
putDocMLn :: Monad m => (String -> m ()) -> Doc -> m ()
putDocMLn putStr d = displayM putStr (renderPretty 0.4 80 d) >> putStr "\n"
hPutDoc :: Handle -> Doc -> IO ()
hPutDoc handle doc = displayIO handle (renderPretty 0.4 80 doc)
spaces n | n <= 0 = ""
| otherwise = replicate n ' '
indentation n = spaces n