%
% Derived pretty printing functionality
%
The @PP@ interface augments the standard @Pretty@ interface
a little for the task at hand.
\begin{code}
module PP
(
PPDoc
, showPPDoc
, getPPEnv
, setPPEnv
, vsep
, joinedBy
, ppDecls
, withSemi
, ppTuple
, ppTupleVert
, ppList
, ppListVert
, empty
, isEmpty
, nest
, text
, ptext
, char
, int
, integer
, float
, double
, rational
, parens
, brackets
, braces
, quotes
, doubleQuotes
, semi
, comma
, colon
, space
, equals
, lparen, rparen
, lbrack, rbrack
, lbrace, rbrace
, (<>)
, (<+>)
, hcat
, hsep
, ($$)
, ($+$)
, vcat
, sep
, cat
, fsep
, fcat
, hang
, punctuate
, render
) where
import qualified Text.PrettyPrint as P
type PPDoc a = a -> P.Doc
showPPDoc ::PPDoc a -> a -> String
showPPDoc f v = show (f v)
\end{code}
\begin{code}
vsep :: [PPDoc a] -> PPDoc a
vsep ds = ds `joinedBy` ($+$)
joinedBy :: [PPDoc a] -> (PPDoc a -> PPDoc a -> PPDoc a) -> PPDoc a
[] `joinedBy` _ = empty
xs `joinedBy` sep1 = foldr1 sep1 xs
ppDecls :: [PPDoc a] -> PPDoc a
ppDecls [] = empty
ppDecls ls = vsep (punctuate semi ls) <> semi
withSemi :: PPDoc a -> PPDoc a
withSemi d
| isEmpty d = d
| otherwise = d <> semi
ppTuple :: [PPDoc a] -> PPDoc a
ppTuple ls = parens (hsep (punctuate comma ls))
ppTupleVert :: [PPDoc a] -> PPDoc a
ppTupleVert [] = ppTuple []
ppTupleVert (a:as) =
vsep (char '(' <+> a : map ((<+>) comma) as) <+> char ')'
ppListVert :: [PPDoc a] -> PPDoc a
ppListVert [] = brackets empty
ppListVert [a] = brackets ( a )
ppListVert (a:as) =
vsep (char '[' <+> a : map ((<+>) comma) as) $$
char ']'
ppList :: [PPDoc a] -> PPDoc a
ppList ls = brackets (hsep (punctuate comma ls))
getPPEnv :: (a -> PPDoc a) -> PPDoc a
getPPEnv f = \ v -> (f v) v
setPPEnv :: a -> PPDoc a -> PPDoc b
setPPEnv v f = \ _ -> f v
\end{code}
Lifting Pretty's functionality up into PPDocs.
\begin{code}
empty :: PPDoc a
empty _ = P.empty
isEmpty :: PPDoc a -> Bool
isEmpty d = P.isEmpty (d undefined)
nest :: Int -> PPDoc a -> PPDoc a
nest i d = \ v -> P.nest i (d v)
text :: String -> PPDoc a
text nm = \ _ -> P.text nm
ptext :: String -> PPDoc a
ptext nm = \ _ -> P.ptext nm
char :: Char -> PPDoc a
char c = \ _ -> P.char c
int :: Int -> PPDoc a
int i = \ _ -> P.int i
integer :: Integer -> PPDoc a
integer i = \ _ -> P.integer i
float :: Float -> PPDoc a
float f = \ _ -> P.float f
double :: Double -> PPDoc a
double d = \ _ -> P.double d
rational :: Rational -> PPDoc a
rational r = \ _ -> P.rational r
parens :: PPDoc a -> PPDoc a
parens d = \ v -> P.parens (d v)
brackets :: PPDoc a -> PPDoc a
brackets d = \ v -> P.brackets (d v)
braces :: PPDoc a -> PPDoc a
braces d = \ v -> P.braces (d v)
quotes :: PPDoc a -> PPDoc a
quotes d = \ v -> P.quotes (d v)
doubleQuotes :: PPDoc a -> PPDoc a
doubleQuotes d = \ v -> P.doubleQuotes (d v)
semi :: PPDoc a
semi = \ _ -> P.semi
comma :: PPDoc a
comma = \ _ -> P.comma
colon :: PPDoc a
colon = \ _ -> P.colon
space :: PPDoc a
space = \ _ -> P.space
equals :: PPDoc a
equals = \ _ -> P.equals
lparen :: PPDoc a
lparen = \ _ -> P.lparen
rparen :: PPDoc a
rparen = \ _ -> P.rparen
lbrack :: PPDoc a
lbrack = \ _ -> P.lbrack
rbrack :: PPDoc a
rbrack = \ _ -> P.rbrack
lbrace :: PPDoc a
lbrace = \ _ -> P.lbrace
rbrace :: PPDoc a
rbrace = \ _ -> P.rbrace
(<>) :: PPDoc a -> PPDoc a -> PPDoc a
(<>) d1 d2 = \ v -> (P.<>) (d1 v) (d2 v)
(<+>) :: PPDoc a -> PPDoc a -> PPDoc a
(<+>) d1 d2 = \ v -> (P.<+>) (d1 v) (d2 v)
hcat :: [PPDoc a] -> PPDoc a
hcat ds = \ v -> P.hcat (map ($ v) ds)
hsep :: [PPDoc a] -> PPDoc a
hsep ds = \ v -> P.hsep (map ($ v) ds)
($$) :: PPDoc a -> PPDoc a -> PPDoc a
($$) d1 d2 = \ v -> (P.$$) (d1 v) (d2 v)
($+$) :: PPDoc a -> PPDoc a -> PPDoc a
($+$) d1 d2 = \ v -> (P.$+$) (d1 v) (d2 v)
vcat :: [PPDoc a] -> PPDoc a
vcat ds = \ v -> P.vcat (map ($ v) ds)
sep :: [PPDoc a] -> PPDoc a
sep ds = \ v -> P.sep (map ($ v) ds)
cat :: [PPDoc a] -> PPDoc a
cat ds = \ v -> P.cat (map ($ v) ds)
fsep :: [PPDoc a] -> PPDoc a
fsep ds = \ v -> P.fsep (map ($ v) ds)
fcat :: [PPDoc a] -> PPDoc a
fcat ds = \ v -> P.fcat (map ($ v) ds)
hang :: PPDoc a -> Int -> PPDoc a -> PPDoc a
hang d1 i d2 = \ v -> P.hang (d1 v) i (d2 v)
render :: PPDoc a -> a -> String
render d = \ v -> P.render (d v)
punctuate :: PPDoc a -> [PPDoc a] -> [PPDoc a]
punctuate _ [] = []
punctuate p (d:ds) = go d ds
where
go s [] = [s]
go s (e:es) = (s <> p) : go e es
\end{code}