PrettyM redefines the combinators in Pretty, so that they pass an environment around. This can be used to adust the behaviour of the layout, spacing etc., without parameterising the whole pretty printer. To the user it all appears the same.
May be useful to rewrite this as a state transformer, rather than a state reader monad. Could then set different display conditions for subsections of the Parser.
See Pretty.lhs for description of the combinators.
module PrettyM (module PrettyM, module PrettyEnv, P.Mode, P.TextDetails) where import qualified Pretty as P import Ratio import Monad(liftM2,liftM) import MUtils import PrettyEnv -- So that pp code still looks the same -- this means we lose some generality though type Doc = DocM P.Doc -- The pretty printing combinators empty :: Doc empty = return P.empty isEmpty :: Doc -> Bool isEmpty d = P.isEmpty $ unDocM d defaultMode nest :: Int -> Doc -> Doc nest i m = fmap (P.nest i) m classNest, doNest, caseNest, letNest, funNest, dataNest :: Printable a => a -> Doc classNest = nest' classIndent doNest = nest' doIndent caseNest = nest' caseIndent letNest = nest' letIndent funNest = nest' funIndent dataNest = nest' dataIndent nest' p d = do { e <- getPPEnv ; nest (p e) (ppi d) } -- Literals text, ptext :: String -> Doc text = return . P.text ptext = return . P.text char :: Char -> Doc char = return . P.char litChar :: Char -> Doc litChar = return . P.litChar litString :: String -> Doc litString = return . P.litString int :: Int -> Doc int = return . P.int integer :: Integer -> Doc integer = return . P.integer float :: Float -> Doc float = return . P.float double :: Double -> Doc double = return . P.double rational :: Integral a => Ratio a -> Doc rational = return . P.rational -- Simple Combining Forms quotes, charQuotes, backQuotes, doubleQuotes, parens, brackets, curlies, braces :: Printable a => a -> Doc quotes = lift1 P.quotes charQuotes = lift1 P.charQuotes backQuotes = lift1 P.backQuotes doubleQuotes = lift1 P.doubleQuotes parens = lift1 P.parens brackets = lift1 P.brackets curlies = lift1 P.curlies braces = curlies lift1 f d = fmap f (ppi d) -- Constants quote, backQuote, doubleQuote :: Doc quote = return P.quote backQuote = return P.backQuote doubleQuote = return P.doubleQuote semi, comma, colon, space, equals :: Doc semi = return P.semi comma = return P.comma colon = return P.colon space = return P.space equals = return P.equals lparen, rparen, lbrack, rbrack, lcurly, rcurly :: Doc lparen = return P.lparen rparen = return P.rparen lbrack = return P.lbrack rbrack = return P.rbrack lcurly = return P.lcurly rcurly = return P.rcurly -- Combinators (<>), (<+>), ($$), ($+$) :: (Printable a,Printable b) => a -> b -> Doc (<>) = lift2 (P.<>) (<+>) = lift2 (P.<+>) ($$) = lift2 (P.$$) ($+$) = lift2 (P.$+$) lift2 op m1 m2 = liftM2 op (ppi m1) (ppi m2) hcat, hsep, vcat, sep, cat, fsep, fcat :: Printable a => [a] -> Doc hcat = liftList P.hcat hsep = liftList P.hsep vcat = liftList P.vcat sep = liftList P.sep cat = liftList P.cat fsep = liftList P.fsep fcat = liftList P.fcat liftList f ds = fmap f (mapM ppi ds) -- Some More hang :: Doc -> Int -> Doc -> Doc hang dM i rM = do { d <- dM ; r <- rM ; return $ P.hang d i r } -- Yuk, had to cut-n-paste this one from Pretty.hs --punctuate :: Doc -> [Doc] -> [Doc] punctuate p [] = [] punctuate p (d:ds) = go d ds where go d [] = [ppi d] go d (e:es) = (d <> p) : go e es -- this is the equivalent of runM now. renderWithMode :: PPHsMode -> Doc -> String renderWithMode ppMode d = P.render . unDocM d $ ppMode render :: Doc -> String render = renderWithMode defaultMode fullRenderWithMode :: PPHsMode -> P.Mode -> Int -> Float -> (P.TextDetails -> a -> a) -> a -> Doc -> a fullRenderWithMode ppMode m i f fn e mD = P.fullRender m i f fn e $ (unDocM mD) ppMode fullRender :: P.Mode -> Int -> Float -> (P.TextDetails -> a -> a) -> a -> Doc -> a fullRender = fullRenderWithMode defaultMode withPPEnv :: PPHsMode -> Doc -> Doc withPPEnv mode d = return $ (unDocM d) mode updPPEnv f d = do e <- getPPEnv; withPPEnv (f e) d doNotation :: Doc -> Doc doNotation = updPPEnv (\e->e { insideDo = True }) doElseNest d = do e <- getPPEnv if insideDo e then nest (doElseIndent e) (ppi d) else ppi d -- An attempt at intelligent recovery of parentheses in applications (used -- currently only for types). The first time appParens is called, it does not -- parenthesize the given document, but changes the environment to ensure that -- subsequent applications are. {- appParens d = do e <- getPPEnv if insideApp e then parens d else withPPEnv (e { insideApp = True }) d -} -- This sets insideApp to True without adding parens as well. --appParensOn = id --updPPEnv (\e->e { insideApp = True }) -- This sets insideApp to False without adding parens as well. Used when other -- forms serve to parenthesize, e.g., to prevent [(M a)]. --appParensOff = id -- updPPEnv (\e->e { insideApp = False }) -- This is only used for lists where people most commonly put their _own_ -- curlies and semis. It is not intended to recreate correct explicit layout -- for Haskell programs, but merely to allow for pretty printing with curlies -- and semis. It might possibly be extendible into something to create -- explicit layout. {- layout :: [Doc] -> Doc layout [] = empty layout docs = do e <- getPPEnv case layoutType e of PPSemiColon -> let (ds, d) = (init docs, last docs) in lcurly <+> (vcat $ (map (\ d -> d <+> semi) ds) ++ [ d <+> rcurly ]) PPUtrecht -> let (d:ds) = docs in vcat $ (lcurly <+> d) : map (semi <+>) ds ++ [ rcurly ] _ -> vcat docs -- all others done as for classic (for the moment) -} blankline :: Doc -> Doc blankline d = do e <- getPPEnv if spacing e && layoutType e /= PPNoLayout then d $$ space else d ppIfDebug debug = ifM (debugInfo # getPPEnv) (ppi debug) empty ppIfUnicode unicode ascii = ifM (useUnicode # getPPEnv) (ppi unicode) (ppi ascii) withUnicode d = updPPEnv (\e->e{useUnicode=True}) d withDebug d = updPPEnv (\e->e{debugInfo=True}) d -------------------------------------------------------------------------------- {- The Printable class is due to Urban Boquist. We define instances for those types we want to pretty print. It should also make the job of extensiblilty much easier. -} class (Show a{-, Eq a-}) => Printable a where -- pp :: a -> String -- Prettyprint ppi :: a -> Doc -- Prettyprint Intelligently ppiList :: [a] -> Doc -- Specialized for Char/String ppis :: a -> [Doc] -- To allow for cases in which we -- can generate a list of Docs from -- a given type wrap :: a -> Doc -- for bracketing -- pp = render . ppi ppi = text . show ppiList = brackets . ppiFSeq ppis a = [ ppi a ] wrap = parens . ppi pp d = render (ppi d) -- pp used to be a method, but no instance defined it... instance Show Doc where show = render instance Printable Doc where ppi = id ppiSeq :: Printable a => [a] -> Doc ppiSeq = ppiSet comma ppiSet :: Printable a => Doc -> [a] -> Doc ppiSet = ppiSep0 sep ppiSep0 :: Printable a => ([Doc] -> Doc) -> Doc -> [a] -> Doc ppiSep0 sepOp separator [] = empty ppiSep0 sepOp separator [d] = ppi d ppiSep0 sepOp separator ds = sepOp $ punctuate separator $ map ppi ds ppiFSeq :: Printable a => [a] -> Doc ppiFSeq = ppiFSet comma ppiFSet :: Printable a => Doc -> [a] -> Doc ppiFSet = ppiSep0 fsep