module DDC.Base.Pretty
( module Text.PrettyPrint.Leijen
, Pretty(..)
, pprParen
, RenderMode (..)
, render
, renderPlain
, renderIndent
, putDoc, putDocLn)
where
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Text.PrettyPrint.Leijen as P
import Text.PrettyPrint.Leijen
hiding (Pretty(..), renderPretty, putDoc)
pprParen :: Bool -> Doc -> Doc
pprParen b c
= if b then parens c
else c
class Pretty a where
ppr :: a -> Doc
ppr = pprPrec 0
pprPrec :: Int -> a -> Doc
pprPrec _ = ppr
instance Pretty () where
ppr = text . show
instance Pretty Bool where
ppr = text . show
instance Pretty Int where
ppr = text . show
instance Pretty Integer where
ppr = text . show
instance Pretty Char where
ppr = text . show
instance Pretty a => Pretty [a] where
ppr xs = encloseSep lbracket rbracket comma
$ map ppr xs
instance Pretty a => Pretty (Set a) where
ppr xs = encloseSep lbracket rbracket comma
$ map ppr $ Set.toList xs
instance (Pretty a, Pretty b) => Pretty (a, b) where
ppr (a, b) = parens $ ppr a <> comma <> ppr b
data RenderMode
= RenderPlain
| RenderIndent
deriving (Eq, Show)
render :: RenderMode -> Doc -> String
render mode doc
= case mode of
RenderPlain -> eatSpace True $ displayS (renderCompact doc) ""
RenderIndent -> displayS (P.renderPretty 0.8 100000 doc) ""
where eatSpace :: Bool -> String -> String
eatSpace _ [] = []
eatSpace True (c:cs)
= case c of
' ' -> eatSpace True cs
'\n' -> eatSpace True cs
_ -> c : eatSpace False cs
eatSpace False (c:cs)
= case c of
' ' -> ' ' : eatSpace True cs
'\n' -> ' ' : eatSpace True cs
_ -> c : eatSpace False cs
renderPlain :: Doc -> String
renderPlain = render RenderPlain
renderIndent :: Doc -> String
renderIndent = render RenderIndent
putDoc :: RenderMode -> Doc -> IO ()
putDoc mode doc
= putStr $ render mode doc
putDocLn :: RenderMode -> Doc -> IO ()
putDocLn mode doc
= putStrLn $ render mode doc