pp.
> module Pretty ( Pretty(..), Txt, > -- basic functions > char, str, block, cblock, sequ, brk, nl, > pretty, > -- derived functions > pp, ppStyle, pps, ppsStyle, ppsBy, > ppShow, ppParen, ppSurround, > ppSepBy, ppSepByComma, ppSepBySpace, > display, displays > ) > where
> import Support ( spaces, intersperse, intersperses ) > import IOSupport ( putLine )
> class Pretty a where > ppStylePrec :: Int -> Int -> a -> Txt > ppStyleList :: Int -> [a] -> Txt > ppPrec :: Int -> a -> Txt > ppList :: [a] -> Txt > -- default methods > ppStylePrec s = ppPrec > ppStyleList s x = ppSurround "[" (ppSepByComma > [ ppStyle s a | a<-x ]) "]" > ppPrec = ppStylePrec 1 > ppList = ppStyleList 1Note that the default methods are defined in terms of each other. Hence the user must provide either
ppStylePrec or ppPrec.
Nearly all of the predefined types are declared instances of Pretty.
> instance Pretty (a -> b) where
> ppPrec d = ppShow
> instance Pretty Bool where
> ppPrec d = ppShow
> instance Pretty Char where
> ppPrec d = ppShow
> ppList = ppShow
> instance Pretty Int where
> ppPrec d = ppShow
> instance Pretty Integer where
> ppPrec d = ppShow
> instance Pretty Float where
> ppPrec d = ppShow
> instance Pretty Double where
> ppPrec d = ppShow
> instance Pretty a => Pretty [a] where
> ppStylePrec s d = ppStyleList s
> instance Pretty () where
> ppPrec _ = ppShow
> instance (Pretty a, Pretty b) => Pretty (a,b) where
> ppStylePrec s _ (a,b) = sequ [char '(',
> ppStyle s a, char ',', brk 1,
> ppStyle s b, char ')']
> instance (Pretty a, Pretty b, Pretty c) => Pretty (a,b,c) where
> ppStylePrec s _ (a,b,c) = sequ [char '(',
> ppStyle s a, char ',', brk 1,
> ppStyle s b, char ',', brk 1,
> ppStyle s c, char ')']
> instance (Pretty a, Pretty b, Pretty c, Pretty d) => Pretty (a,b,c,d) where
> ppStylePrec s _ (a,b,c,d)
> = sequ [char '(',
> ppStyle s a, char ',', brk 1,
> ppStyle s b, char ',', brk 1,
> ppStyle s c, char ',', brk 1,
> ppStyle s d, char ')']
> instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e)
> => Pretty (a,b,c,d,e) where
> ppStylePrec s _ (a,b,c,d,e)
> = sequ [char '(',
> ppStyle s a, char ',', brk 1,
> ppStyle s b, char ',', brk 1,
> ppStyle s c, char ',', brk 1,
> ppStyle s d, char ',', brk 1,
> ppStyle s e, char ')']
> instance (Integral a, Pretty a) => Pretty (Ratio a) where
> ppPrec d = ppShow
> instance (RealFloat a, Pretty a) => Pretty (Complex a) where
> ppPrec d = ppShow
> instance (Pretty a, Pretty b) => Pretty (Assoc a b) where
> ppStylePrec s d (a:=b) = sequ [ppStyle s a, str " :=", brk 1,
> ppStyle s b]
> instance (Ix a, Pretty a, Pretty b) => Pretty (Array a b) where
> ppStylePrec s d a = ppStyle s (assocs a)
> data Txt = Str [Char] Int -- string > | Block Bool Int [Txt] Int -- indented block > | Sequ [Txt] -- sequence > | Brk Int -- optional line break > | NL -- hard line breakConstructing a text element.
> char :: Char -> Txt > char c = Str [c] 1 > > str :: [Char] -> Txt > str s = Str s (length s) > > block, cblock :: Int -> [Txt] -> Txt > block = block' False > cblock = block' True
> block' f bi ts = Block f bi ts' (sum [ width t | t<-ts' ]) > where ts' = flattens ts []
> sequ :: [Txt] -> Txt > sequ ts = Sequ ts
> brk :: Int -> Txt > brk = Brk > > nl :: Txt > nl = NLThe (maximal) width of a text element.
> width (Str _ l) = l > width (Block _ _ _ l) = l > width (Brk n) = n > width NL = 0Flattening
Sequ elements out.
> flattens :: [Txt] -> ([Txt] -> [Txt]) > flattens ts = compose [ flatten t | t<-ts ]
> flatten :: Txt -> ([Txt] -> [Txt]) > flatten (Sequ ts) = flattens ts > flatten t = put tDisplaying an text element within a given width.
> pretty :: Int -> Txt -> String > pretty width t = print 0 [ (t', 0) | t'<-flatten t [] ] > where > print c [] = "" > print c ((Str s l, i):ts) = s ++ print (c + l) ts > print c ((Block False bi us l, i):ts) > = print c ([ (u, c + bi) | u<-us ] ++ ts) > print c ((Block True bi us l, i):ts) > | c + l + dist <= width = print c ([ (soft u, c + bi) | u<-us ] ++ ts) > | otherwise = print c ([ (hard u, c + bi) | u<-us ] ++ ts) > where > dist = brkdist [ t | (t, _)<-ts ] > print c ((Brk n, i):ts) > | c + n + dist <= width = spaces n ++ print (c + n) ts > | otherwise = "\n" ++ spaces i ++ print i ts > where > dist = brkdist [ t | (t, _)<-ts ] > print c ((NL, i):ts) = "\n" ++ spaces i ++ print i ts
> soft (Brk n) = str (spaces n) > soft t = t
> hard (Brk _) = NL > hard t = tDistance to the next (optional) line break. Indented text blocks are intentionally not inspected.
> brkdist [] = 0 > brkdist (Str _ l:ts) = l + brkdist ts > brkdist (Block _ _ _ l:ts) = l + brkdist ts > brkdist (Brk _:ts) = 0 > brkdist (NL:ts) = 0
> pp :: Pretty a => a -> Txt > pp = ppPrec 0 > > ppStyle :: Pretty a => Int -> a -> Txt > ppStyle s = ppStylePrec s 0
> pps :: Pretty a => [a] -> Txt > pps = ppSepBySpace . map pp > > ppsStyle :: Pretty a => Int -> [a] -> Txt > ppsStyle s = ppSepBySpace . map (ppStyle s)
> ppsBy :: (a -> Txt) -> [a] -> Txt > ppsBy pp = ppSepBySpace . map pp
> ppShow :: Text a => a -> Txt > ppShow a = str (show a)
> ppParen :: Bool -> Txt -> Txt
> ppParen flag x | flag = sequ [char '(', x, char ')']
> | otherwise = x
> ppSurround :: String -> Txt -> String -> Txt > ppSurround l t r = sequ [str l, t, str r]
> ppSepBy :: Txt -> [Txt] -> Txt > ppSepBy s = sequ . intersperse s
> ppSepByComma, ppSepBySpace :: [Txt] -> Txt > ppSepByComma = ppSepBy (sequ [char ',', brk 1]) > ppSepBySpace = ppSepBy (brk 1)
> display :: Pretty a => Int -> a -> IO () > display width = putLine . pretty width . pp
> displays :: Pretty a => Int -> [a] -> IO () > displays width = putLine . pretty width . ppSepBy nl. map pp
> put = (:) > compose = foldr (.) id