module Text.PrettyPrint.Class (
P.Doc
, Document(..)
, P.isEmpty
, P.render
, P.renderStyle
, defaultStyle
, P.Style(..)
, P.Mode(..)
, ($--$)
, emptyDoc
, (<>)
, semi
, colon
, comma
, space
, equals
, lparen
, rparen
, lbrack
, rbrack
, lbrace
, rbrace
, int
, integer
, float
, double
, rational
, quotes
, doubleQuotes
, parens
, brackets
, braces
, hang
, punctuate
, nestBetween
, nestShort
, nestShort'
, nestShortNonEmpty
, nestShortNonEmpty'
, fixedWidthText
, symbol
, numbered
, numbered'
) where
import Control.DeepSeq (NFData(..))
import Data.List (intersperse)
import Extension.Data.Monoid (Monoid(..), (<>))
import Extension.Prelude (flushRight)
import qualified Text.PrettyPrint.HughesPJ as P
infixr 6 <->
infixl 5 $$, $-$, $--$
class (Monoid d, NFData d) => Document d where
char :: Char -> d
text :: String -> d
zeroWidthText :: String -> d
(<->) :: d -> d -> d
hcat :: [d] -> d
hsep :: [d] -> d
($$) :: d -> d -> d
($-$) :: d -> d -> d
vcat :: [d] -> d
sep :: [d] -> d
cat :: [d] -> d
fsep :: [d] -> d
fcat :: [d] -> d
nest :: Int -> d -> d
caseEmptyDoc :: d -> d -> d -> d
defaultStyle :: P.Style
defaultStyle = P.style
emptyDoc :: Document d => d
emptyDoc = mempty
($--$) :: Document d => d -> d -> d
d1 $--$ d2 =
caseEmptyDoc d2 (caseEmptyDoc d1 (d1 $-$ text "" $-$ d2) d2) d1
semi, colon, comma, space, equals,
lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Document d => d
semi = char ';'
colon = char ':'
comma = char ','
space = char ' '
equals = char '='
lparen = char '('
rparen = char ')'
lbrack = char '['
rbrack = char ']'
lbrace = char '{'
rbrace = char '}'
int :: Document d => Int -> d
int n = text (show n)
integer :: Document d => Integer -> d
integer n = text (show n)
float :: Document d => Float -> d
float n = text (show n)
double :: Document d => Double -> d
double n = text (show n)
rational :: Document d => Rational -> d
rational n = text (show n)
quotes, doubleQuotes, parens, brackets, braces :: Document d => d -> d
quotes p = char '\'' <> p <> char '\''
doubleQuotes p = char '"' <> p <> char '"'
parens p = char '(' <> p <> char ')'
brackets p = char '[' <> p <> char ']'
braces p = char '{' <> p <> char '}'
hang :: Document d => d -> Int -> d -> d
hang d1 n d2 = sep [d1, nest n d2]
punctuate :: Document d => d -> [d] -> [d]
punctuate _ [] = []
punctuate p (d:ds) = go d ds
where
go d' [] = [d']
go d' (e:es) = (d' <> p) : go e es
instance NFData P.Doc where
rnf = rnf . P.render
instance Document P.Doc where
char = P.char
text = P.text
zeroWidthText = P.zeroWidthText
(<->) = (P.<+>)
hcat = P.hcat
hsep = P.hsep
($$) = (P.$$)
($-$) = (P.$+$)
vcat = P.vcat
sep = P.sep
cat = P.cat
fsep = P.fsep
fcat = P.fcat
nest = P.nest
caseEmptyDoc yes no d = if P.isEmpty d then yes else no
nestBetween :: Document d =>
Int
-> d
-> d
-> d
-> d
nestBetween n l r x = sep [l, nest n x, r]
nestShort :: Document d =>
Int
-> d
-> d
-> d
-> d
nestShort n lead finish body = sep [lead $$ nest n body, finish]
nestShort' :: Document d => String -> String -> d -> d
nestShort' lead finish =
nestShort (length lead + 1) (text lead) (text finish)
nestShortNonEmpty :: Document d => Int -> d -> d -> d -> d
nestShortNonEmpty n lead finish body =
caseEmptyDoc emptyDoc (nestShort n lead finish body) body
nestShortNonEmpty' :: Document d => String -> String -> d -> d
nestShortNonEmpty' lead finish =
nestShortNonEmpty (length lead + 1) (text lead) (text finish)
fixedWidthText :: Document d => Int -> String -> d
fixedWidthText n cs
| length cs <= n = text cs
| otherwise = text as <> zeroWidthText bs
where
(as,bs) = splitAt n cs
symbol :: Document d => String -> d
symbol = fixedWidthText 1
numbered :: Document d => d -> [d] -> d
numbered _ [] = emptyDoc
numbered vsep ds =
foldr1 ($-$) $ intersperse vsep $ map pp $ zip [(1::Int)..] ds
where
n = length ds
nWidth = length (show n)
pp (i, d) = text (flushRight nWidth (show i)) <> d
numbered' :: Document d => [d] -> d
numbered' = numbered (text "") . map (text ". " <>)