module PrettyPrint2 where import qualified PrettyDoc as P(Doc) import PrettyDoc hiding (Doc) import PrettyEnv import TokenTags import MUtils type Doc = DocM P.Doc class Show a => Printable a where 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 ppi = plain ppiList = brackets . ppiFSeq ppis a = [ ppi a ] wrap = parens . ppi -- Essential instances: instance Show Doc where show (DocM d) = show (d defaultMode) -- useless? instance Printable Doc where ppi = id instance Printable Char where ppi c = char c ppiList = text -- this defines how strings are printed, since String=[Char] wrap = ppi instance Printable a => Printable [a] where ppi = ppiList ppis = map ppi wrap = ppi -- A class to make it easier to print Haskell infix operators correctly: class Printable a => PrintableOp a where isOp :: a -> Bool ppiOp :: a -> Doc {- How to print operators "mod" and "+": ppi should produce "mod" and "+". wrap should produce "mod" and "(+)". ppiOp should produce "`mod`" and "+". -} -- A class to make it easier to print type applications like (,) a b and -- [] Int in the normal way, (a,b) and [Int]. class Printable fun => PrintableApp fun arg where wrapApp,ppiApp :: fun -> [arg] -> Doc cdoc = DocM . const -- Hughes/SimonPJ style pretty printing operators: char = cdoc . Char text = cdoc . Text empty = cdoc Empty group l ds = DocM $ \e->Group l [de|DocM d<-map ppi ds,let de=d e,nonEmpty de] nest n = fmap (nest' n) . ppi where nest' n (Nest n' d) = nest' (n+n') d nest' n d = Nest n d -- Eta expansions because of the annying monomorphism restriction! attr a = fmap (Attr a) . ppi kw d = attr Reserved d var d = attr Var d con d = attr Con d varop d = attr VarOp d conop d = attr ConOp d tcon d = attr TCon d lit d = attr Lit d cmnt d = attr Comment d modn d = attr ModName d a<>b = hcat [ppi a,ppi b] a<+>b = hsep [ppi a,ppi b] a$$b = vcat [ppi a,ppi b] hcat ds = group (Horiz Cat) ds hsep ds = group (Horiz Sep) ds vcat ds = group Vert ds cat ds = group (HorizOrVert Cat) ds sep ds = group (HorizOrVert Sep) ds fcat ds = group (Fill Cat) ds fsep ds = group (Fill Sep) ds plain x = text (show x) punctuate p [] = [] punctuate p (d:ds) = go d ds where go d [] = [ppi d] go d (e:es) = (d <> p) : go e es -- Additional pretty printing functions: {- ppiSeq :: Printable a => [a] -> Doc ppiSet :: Printable a => Doc -> [a] -> Doc ppiSep0 :: Printable a => ([Doc] -> Doc) -> Doc -> [a] -> Doc ppiFSeq :: Printable a => [a] -> Doc ppiFSet :: Printable a => Doc -> [a] -> Doc ppiTuple :: Printable a => [a] -> Doc ppiFTuple :: Printable a => [a] -> Doc wrapTuple :: Printable a => [a] -> Doc wrapSeq :: Printable a => [a] -> Doc wrapSet :: Printable a => Doc -> [a] -> Doc wrapFTuple :: Printable a => [a] -> Doc wrapFSeq :: Printable a => [a] -> Doc wrapFSet :: Printable a => Doc -> [a] -> Doc wrapSep0 :: Printable a => ([Doc] -> Doc) -> Doc -> [a] -> Doc -} ppiSeq ds = ppiSet ',' ds ppiSet s ds = ppiSep0 sep s ds ppiSep0 sepOp separator [] = empty ppiSep0 sepOp separator [d] = ppi d ppiSep0 sepOp separator ds = sepOp $ punctuate separator $ map ppi ds ppiFSeq ds = ppiFSet ',' ds ppiFSet s ds = ppiSep0 fsep s ds ppiTuple ds = parens (ppiSeq ds) ppiFTuple ds = parens (ppiFSeq ds) wrapTuple ds = parens (wrapSeq ds) wrapSeq ds = wrapSet ',' ds wrapSet s ds = wrapSep0 sep s ds wrapFTuple ds = parens (wrapFSeq ds) wrapFSeq ds = wrapFSet ',' ds wrapFSet s ds = wrapSep0 fsep s ds wrapSep0 sepOp separator [] = empty wrapSep0 sepOp separator [d] = wrap d wrapSep0 sepOp separator ds = sepOp $ punctuate separator $ map wrap ds --maybepp :: (a -> Doc) -> Maybe a -> Doc maybepp pf (Just a) = pf a maybepp _ Nothing = empty optpp b x = if b then ppi x else empty ppiBinOp lhs op rhs = sep [lhs<+>op,letNest rhs] parenBinOp x op y = parens (ppiBinOp x op y) -- should consult infixParens!! -- These are rather pointless, but kept around for backwards compatibility: lparen = kw '(' rparen = kw ')' lbrack = kw '[' rbrack = kw ']' lbrace = kw '{' rbrace = kw '}' quote = kw '\'' dquote = kw '"' bquote = kw '`' equals = kw '=' comma = kw ',' float = plain :: Float->Doc double = plain :: Double->Doc space = ppi ' ' parens d = lparen<>d<>rparen brackets d = lbrack<>d<>rbrack braces d = lbrace<>d<>rbrace doubleQuotes d = dquote<>d<>dquote backQuotes d = bquote<>d<>bquote {- quotes, charQuotes, backQuotes, doubleQuotes, quote, backQuote, doubleQuote, semi, comma, colon, space, equals, hang, punctuate, -} -- Environment manipulating functions: 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 ppIfDebug debug = ifM (debugInfo # getPPEnv) (ppi debug) empty ppIfTypeInfo tinfo = ifM (typeInfo # getPPEnv) (ppi tinfo) 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 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) } blankline :: Doc -> Doc blankline d = do e <- getPPEnv if spacing e && layoutType e /= PPNoLayout then d $$ space else d layout ds = do e <- getPPEnv case layoutType e of --PPSemiColon -> --PPUtrecht -> PPNoLayout -> braces . hsep . punctuate ';' $ ds _ -> vcat ds -- Obsolete: appParensOn = id appParensOff = id