language-c-0.3.2: src/Language/C/Pretty.hs
{-# OPTIONS #-}
-----------------------------------------------------------------------------
-- |
-- Module : Language.C.Pretty
-- Copyright : Copyright (c) 2007 Bertram Felgenhauer
-- (c) 2008 Benedikt Huber
-- License : BSD-style
-- Maintainer : benedikt.huber@gmail.com
-- Stability : experimental
-- Portability : portable
--
-- This module provides a pretty printer for the parse tree
-- ('Language.C.Syntax.AST').
-----------------------------------------------------------------------------
module Language.C.Pretty (
-- * Pretty Printing
Pretty (..),
-- * Testing
prettyUsingInclude
) where
import Data.List (partition,nub,isSuffixOf)
import qualified Data.Set as Set
import Text.PrettyPrint.HughesPJ
import Debug.Trace {- for warnings -}
import Language.C.Data
import Language.C.Syntax
-- | A class of types which can be pretty printed
class Pretty p where
-- | pretty print the given value
pretty :: p -> Doc
-- | @prettyPrec prec p@ pretty prints p assuming
-- that the surrounding context has a precedence of
-- @prec@
prettyPrec :: Int -> p -> Doc
pretty = prettyPrec 0
prettyPrec _ = pretty
-- pretty print optional chunk
maybeP :: (p -> Doc) -> Maybe p -> Doc
maybeP = maybe empty
-- pretty print when flag is true
ifP :: Bool -> Doc -> Doc
ifP flag doc = if flag then doc else empty
-- pretty print _optional_ list, i.e. [] ~ Nothing and (x:xs) ~ Just (x:xs)
mlistP :: ([p] -> Doc) -> [p] -> Doc
mlistP pp xs = maybeP pp (if null xs then Nothing else Just xs)
-- pretty print identifier
identP :: Ident -> Doc
identP = text . identToString
-- pretty print attribute annotations
attrlistP :: [CAttr] -> Doc
attrlistP [] = empty
attrlistP attrs = text "__attribute__" <> parens (parens (hcat . punctuate comma . map pretty $ attrs))
-- analogous to showParen
parenPrec :: Int -> Int -> Doc -> Doc
parenPrec prec prec2 t = if prec <= prec2 then t else parens t
-- indent a chunk of code
ii :: Doc -> Doc
ii = nest 4
-- Pretty instances
instance Pretty CTranslUnit where
pretty (CTranslUnit edecls _) = vcat (map pretty edecls)
-- | Pretty print the given tranlation unit, but replace declarations from header files with @#include@ directives.
--
-- The resulting file may not compile (because of missing @#define@ directives and similar things), but is very usefull
-- for testing, as otherwise the pretty printed file will be cluttered with declarations from system headers.
prettyUsingInclude :: CTranslUnit -> Doc
prettyUsingInclude (CTranslUnit edecls _) =
includeWarning headerFiles
$$
(vcat $ map (either includeHeader pretty) mappedDecls)
where
(headerFiles,mappedDecls) = foldr addDecl (Set.empty,[]) $ map tagIncludedDecls edecls
tagIncludedDecls edecl | isHeaderFile ((posFile . posOf) edecl) = Left ((posFile . posOf) edecl)
| otherwise = Right edecl
addDecl decl@(Left headerRef) (headerSet, ds)
| Set.member headerRef headerSet = (headerSet, ds)
| otherwise = (Set.insert headerRef headerSet, decl : ds)
addDecl decl (headerSet,ds) = (headerSet, decl : ds)
includeHeader hFile = text "#include" <+> doubleQuotes (text hFile)
isHeaderFile = (".h" `isSuffixOf`)
includeWarning hs | Set.null hs = empty
| otherwise = text "/* Warning: The #include directives in this file aren't neccessarily correct. */"
-- TODO: Check need of __extension__
instance Pretty CExtDecl where
pretty (CDeclExt decl) = pretty decl <> semi
pretty (CFDefExt fund) = pretty fund
pretty (CAsmExt asmStmt) = text "asm" <> parens (pretty asmStmt) <> semi
-- TODO: Check that old-style and new-style aren't mixed
instance Pretty CFunDef where
pretty (CFunDef declspecs declr decls stat _) = -- Example:
hsep (map pretty declspecs) -- __attribute__((noreturn)) static long
<+> pretty declr -- foo(b)
$+$ (ii . vcat . map (<> semi) . map pretty) decls -- register long b;
$$ prettyPrec (-1) stat -- { ...
-- }
instance Pretty CStat where
pretty (CLabel ident stat cattrs _) = identP ident <> text ":" <+> attrlistP cattrs $$ pretty stat
pretty (CCase expr stat _) =
text "case" <+> pretty expr <> text ":" $$ pretty stat
pretty (CCases expr1 expr2 stat _) =
text "case" <+> pretty expr1 <+> text "..."
<+> pretty expr2 <> text ":" $$ pretty stat
pretty (CDefault stat _) = text "default:" $$ pretty stat
pretty (CExpr expr _) = ii $ maybeP pretty expr <> semi
pretty c@(CCompound _ _ _) = prettyPrec 0 c
pretty (CIf expr stat estat _) =
ii $ text "if" <+> text "(" <> pretty expr <> text ")"
$+$ prettyThen stat
$$ maybeP prettyElse estat
where
prettyThen stat@(CIf _ _ _ _) = text "{" $+$ prettyPrec (-1) stat $$ text "}"
prettyThen stat = prettyPrec (-1) stat
prettyElse (CIf else_if_expr else_if_stat else_stat _) =
text "else if" <+> text "(" <> pretty else_if_expr <> text ")"
$+$ prettyPrec (-1) else_if_stat
$$ maybeP prettyElse else_stat
prettyElse else_stmt =
text "else" $+$ prettyPrec (-1) else_stmt
pretty (CSwitch expr stat _) =
ii $ text "switch" <+> text "(" <> pretty expr <> text ")"
$+$ prettyPrec (-1) stat
pretty (CWhile expr stat False _) =
ii $ text "while" <+> text "(" <> pretty expr <> text ")"
$+$ prettyPrec (-1) stat
pretty (CWhile expr stat True _) =
ii $ text "do" $+$ prettyPrec (-1) stat
$$ text "while" <+> text "(" <> pretty expr <> text ");"
pretty (CFor for_init cond step stat _) =
ii $ text "for" <+> text "("
<> either (maybeP pretty) pretty for_init <> semi
<+> maybeP pretty cond <> semi
<+> maybeP pretty step <> text ")" $+$ prettyPrec (-1) stat
pretty (CGoto ident _) = ii $ text "goto" <+> identP ident <> semi
pretty (CGotoPtr expr _) = ii $ text "goto" <+> text "*" <+> prettyPrec 30 expr <> semi
pretty (CCont _) = ii $ text "continue" <> semi
pretty (CBreak _) = ii $ text "break" <> semi
pretty (CReturn Nothing _) = ii $ text "return" <> semi
pretty (CReturn (Just e) _) = ii $ text "return" <+> pretty e <> semi
pretty (CAsm asmStmt _) = pretty asmStmt
prettyPrec p (CCompound localLabels bis _) =
let inner = text "{" $+$ mlistP ppLblDecls localLabels $+$ vcat (map pretty bis) $$ text "}"
in if p == -1 then inner else ii inner
where ppLblDecls = vcat . map (\l -> text "__label__" <+> identP l <+> semi)
prettyPrec _ p = pretty p
instance Pretty CAsmStmt where
pretty (CAsmStmt tyQual expr outOps inOps clobbers _) =
ii $ text "__asm__" <+>
maybeP pretty tyQual <>
parens asmStmt <> semi
where
asmStmt = pretty expr <+>
(if all null [inOps,outOps] && null clobbers then empty else ops)
ops = text ":" <+> hcat (punctuate comma (map pretty outOps)) <+>
text ":" <+> hcat (punctuate comma (map pretty inOps)) <+>
(if null clobbers then empty else clobs)
clobs = text ":" <+> hcat (punctuate comma (map pretty clobbers))
instance Pretty CAsmOperand where
-- asm_operand :~ [operand-name] "constraint" ( expr )
pretty (CAsmOperand mArgName cnstr expr _) =
maybeP (\argName -> text "[" <> identP argName <> text "]") mArgName <+>
pretty cnstr <+>
parens (pretty expr)
-- TODO: Check need of __extension__
instance Pretty CBlockItem where
pretty (CBlockStmt stat) = pretty stat
pretty (CBlockDecl decl) = ii $ pretty decl <> semi
pretty (CNestedFunDef fundef) = ii $ pretty fundef
instance Pretty CDecl where
-- CAVEAT:
-- we may not print __attribute__s directly after typespecs,
-- as this may change the semantics of the declaration.
-- The parser fixes this, but to avoid hard-to-track code generator
-- errors, we enforce this invariant on the AST level.
pretty (CDecl specs divs _) =
hsep (map pretty checked_specs) <+> hsep (punctuate comma (map p divs))
where
-- possible hint for AST improvement - (declr, initializer, expr, attrs)
-- currently there are no sensible attributes for unnamed bitfields though
p (declr, initializer, expr) =
maybeP (prettyDeclr False 0) declr <+>
maybeP ((text ":" <+>) . pretty) expr <+>
attrlistP (getAttrs declr) <+>
maybeP ((text "=" <+>) . pretty) initializer
checked_specs =
case any isAttrAfterSUE (zip specs (tail specs)) of
True -> trace
("Warning: AST Invariant violated: __attribute__ specifier following struct/union/enum:"++
(show $ map pretty specs))
specs
False -> specs
isAttrAfterSUE (CTypeSpec ty,CTypeQual (CAttrQual _)) = isSUEDef ty
isAttrAfterSUE _ = False
getAttrs Nothing = []
getAttrs (Just (CDeclr _ _ _ cattrs _)) = cattrs
instance Pretty CDeclSpec where
pretty (CStorageSpec sp) = pretty sp
pretty (CTypeSpec sp) = pretty sp
pretty (CTypeQual qu) = pretty qu
instance Pretty CStorageSpec where
pretty (CAuto _) = text "auto"
pretty (CRegister _) = text "register"
pretty (CStatic _) = text "static"
pretty (CExtern _) = text "extern"
pretty (CTypedef _) = text "typedef"
pretty (CThread _) = text "__thread"
instance Pretty CTypeSpec where
pretty (CVoidType _) = text "void"
pretty (CCharType _) = text "char"
pretty (CShortType _) = text "short"
pretty (CIntType _) = text "int"
pretty (CLongType _) = text "long"
pretty (CFloatType _) = text "float"
pretty (CDoubleType _) = text "double"
pretty (CSignedType _) = text "signed"
pretty (CUnsigType _) = text "unsigned"
pretty (CBoolType _) = text "_Bool"
pretty (CComplexType _) = text "_Complex"
pretty (CSUType union _) = pretty union
pretty (CEnumType enum _) = pretty enum
pretty (CTypeDef ident _) = identP ident
pretty (CTypeOfExpr expr _) =
text "typeof" <> text "(" <> pretty expr <> text ")"
pretty (CTypeOfType decl _) =
text "typeof" <> text "(" <> pretty decl <> text ")"
instance Pretty CTypeQual where
pretty (CConstQual _) = text "const"
pretty (CVolatQual _) = text "volatile"
pretty (CRestrQual _) = text "__restrict"
pretty (CInlineQual _) = text "inline"
pretty (CAttrQual a) = attrlistP [a]
instance Pretty CStructUnion where
pretty (CStruct tag ident Nothing cattrs _) = pretty tag <+> attrlistP cattrs <+> maybeP identP ident
pretty (CStruct tag ident (Just []) cattrs _) =
pretty tag <+> attrlistP cattrs <+> maybeP identP ident <+> text "{ }"
pretty (CStruct tag ident (Just decls) cattrs _) = vcat [
pretty tag <+> attrlistP cattrs <+> maybeP identP ident <+> text "{",
ii $ sep (map (<> semi) (map pretty decls)),
text "}"]
instance Pretty CStructTag where
pretty CStructTag = text "struct"
pretty CUnionTag = text "union"
instance Pretty CEnum where
pretty (CEnum enum_ident Nothing cattrs _) = text "enum" <+> attrlistP cattrs <+> maybeP identP enum_ident
pretty (CEnum enum_ident (Just vals) cattrs _) = vcat [
text "enum" <+> attrlistP cattrs <+> maybeP identP enum_ident <+> text "{",
ii $ sep (punctuate comma (map p vals)),
text "}"] where
p (ident, expr) = identP ident <+> maybeP ((text "=" <+>) . pretty) expr
-- Analyze a declarator and return a human-readable description
-- See C99 Spec p 115ff.
-- describeDeclr :: CDeclr -> Doc
-- describeDeclr declr =
-- let declrs = reverse (declrChain declr) in
-- endDescr (foldl descrDeclr undefined declrs)
--
-- where
-- declrChain declr@(CVarDeclr _ _ _ _) = [declr]
-- declrChain declr@(CPtrDeclr _ ideclr _) = declr : declrChain ideclr
-- declrChain declr@(CArrDeclr ideclr _ _ _) = declr : declrChain ideclr
-- declrChain declr@(CFunDeclr ideclr _ _ _) = declr : declrChain ideclr
--
-- descrDeclr _ (CVarDeclr ident asm cattrs _) = single False $ \_ ->
-- maybe (text "<anonymous>") identP ident <+>
-- maybeP (\asmname -> parens (text "asm:" <+> pretty asmname)) asm <+>
-- text "is" <+> (if null cattrs then empty else prettyList (map CAttrQual cattrs) <> comma)
-- descrDeclr (pre,isPlural) (CPtrDeclr quals declr _) = single isPlural $ \pluralize ->
-- pre <+> indefArticle isPlural <> prettyList quals <+> pluralize "pointer to" "pointers to"
-- descrDeclr (pre,isPlural) (CArrDeclr declr quals expr _) = plural isPlural $ \pluralize ->
-- pre <+> indefArticle' isPlural <> prettyList quals <+> pluralize "array of" "arrays of"
-- descrDeclr (pre,isPlural) (CFunDeclr declr params cattrs _) = single isPlural $ \pluralize ->
-- pre <+> indefArticle isPlural <> prettyList (map CAttrQual cattrs) <+> pluralize "function returning" "functions returning"
-- endDescr (pre, isPlural) = pre <+> text (if isPlural then "<typed objects>" else "a <typed object>")
-- single :: Bool -> ( (String -> String -> Doc) -> a ) -> (a, Bool)
-- single isPlural mkDescr = (mkDescr (pluralize isPlural), isPlural)
-- plural :: Bool -> ( (String -> String -> Doc) -> a ) -> (a, Bool)
-- plural isPlural mkDescr = (mkDescr (pluralize isPlural), True)
-- indefArticle isPlural = text$ if isPlural then "" else "a "
-- indefArticle' isPlural = text$ if isPlural then "" else "an "
-- pluralize isPlural s p = text (if isPlural then p else s)
-- prettyList :: (Pretty a) => [a] -> Doc
-- prettyList = hsep . punctuate comma . map pretty
instance Pretty CDeclr where
prettyPrec prec declr = prettyDeclr True prec declr
prettyDeclr :: Bool -> Int -> CDeclr -> Doc
prettyDeclr show_attrs prec (CDeclr name derived_declrs asmname cattrs _) =
ppDeclr prec (reverse derived_declrs) <+> prettyAsmName asmname <+> ifP show_attrs (attrlistP cattrs)
where
ppDeclr _ [] = maybeP identP name
--'*' __attribute__? qualifiers declarator
ppDeclr p (CPtrDeclr quals _ : declrs) =
parenPrec p 5 $ text "*" <+> hsep (map pretty quals) <+> ppDeclr 5 declrs
-- declarator[ __attribute__? qualifiers expr ]
ppDeclr p (CArrDeclr quals size _ : declrs) =
parenPrec p 6 $ ppDeclr 6 declrs <> brackets (hsep (map pretty quals) <+> pretty size)
-- declarator ( arguments )
-- or (__attribute__ declarator) (arguments)
ppDeclr _ (CFunDeclr params fun_attrs _ : declrs) =
(if not (null fun_attrs) then parens (attrlistP fun_attrs <+> ppDeclr 5 declrs) else ppDeclr 6 declrs)
<> parens (prettyParams params)
prettyParams (Right (decls, isVariadic)) =
sep (punctuate comma (map pretty decls))
<> (if isVariadic then text "," <+> text "..." else empty)
prettyParams (Left oldStyleIds) =
hsep (punctuate comma (map identP oldStyleIds))
prettyAsmName asm_name_opt
= maybe empty (\asm_name -> text "__asm__" <> parens (pretty asm_name)) asm_name_opt
instance Pretty CArrSize where
pretty (CNoArrSize completeType) = ifP completeType (text "*")
pretty (CArrSize staticMod expr) = ifP staticMod (text "static") <+> pretty expr
-- initializer :: { CInit }
-- initializer :- assignment_expression
-- | '{' (designation? initializer)_cs_list '}'
instance Pretty CInit where
pretty (CInitExpr expr _) = pretty expr
pretty (CInitList initl _) =
text "{" <+> hsep (punctuate comma (map p initl)) <+> text "}" where
p ([], initializer) = pretty initializer
p (desigs, initializer) = hsep (map pretty desigs) <+> text "=" <+> pretty initializer
-- designation :- designator_list '='
-- | array_range_designator
-- arr_designator :- '[' constant_expression ']'
-- member_designator :- '.' identifier
-- arr_range _designator :- '[' constant_expression "..." constant_expression ']'
instance Pretty CDesignator where
pretty (CArrDesig expr _) = text "[" <> pretty expr <> text "]"
pretty (CMemberDesig ident _) = text "." <> identP ident
pretty (CRangeDesig expr1 expr2 _) =
text "[" <> pretty expr1 <+> text "..." <+> pretty expr2 <> text "]"
instance Pretty CAttr where
pretty (CAttr attrName [] _) = identP attrName
pretty (CAttr attrName attrParams _) = identP attrName <> parens (hsep . punctuate comma . map pretty $ attrParams)
instance Pretty CExpr where
prettyPrec p (CComma exprs _) =
parenPrec p (-1) $ hsep (punctuate comma (map (prettyPrec 2) exprs))
prettyPrec p (CAssign op expr1 expr2 _) =
parenPrec p 2 $ prettyPrec 3 expr1 <+> pretty op <+> prettyPrec 2 expr2
prettyPrec p (CCond expr1 expr2 expr3 _) =
parenPrec p 2 $ prettyPrec 4 expr1 <+> text "?" -- NB: assignment only has a higher precedence if cond is on the rhs
<+> maybeP pretty expr2 <+> text ":" <+> prettyPrec 4 expr3
prettyPrec p (CBinary op expr1 expr2 _) =
let prec = binPrec op
in parenPrec p prec $ prettyPrec prec expr1
<+> pretty op <+> prettyPrec (prec + 1) expr2
prettyPrec p (CCast decl expr _) =
parenPrec p 25 $ text "(" <> pretty decl <> text ")"
<+> prettyPrec 25 expr
prettyPrec p (CUnary CPostIncOp expr _) =
parenPrec p 26 $ prettyPrec 26 expr <> text "++"
prettyPrec p (CUnary CPostDecOp expr _) =
parenPrec p 26 $ prettyPrec 26 expr <> text "--"
prettyPrec p (CUnary op expr@(CUnary _ _ _) _) =
-- parens aren't neccessary, but look nicer imho
parenPrec p 25 $ pretty op <+> parens (prettyPrec 25 expr)
prettyPrec p (CUnary op expr _) =
parenPrec p 25 $ pretty op <> prettyPrec 25 expr
prettyPrec p (CSizeofExpr expr _) =
parenPrec p 25 $ text "sizeof" <> parens (pretty expr)
prettyPrec p (CSizeofType decl _) =
parenPrec p 25 $ text "sizeof" <> parens (pretty decl)
prettyPrec p (CAlignofExpr expr _) =
parenPrec p 25 $ text "__alignof" <> parens (pretty expr)
prettyPrec p (CAlignofType decl _) =
parenPrec p 25 $ text "__alignof" <> parens (pretty decl)
prettyPrec p (CComplexReal expr _) =
parenPrec p 25 $ text "__real" <+> prettyPrec 25 expr
prettyPrec p (CComplexImag expr _) =
parenPrec p 25 $ text "__imag" <+> prettyPrec 25 expr
prettyPrec p (CIndex expr1 expr2 _) =
parenPrec p 26 $ prettyPrec 26 expr1
<> text "[" <> pretty expr2 <> text "]"
prettyPrec p (CCall expr args _) =
parenPrec p 30 $ prettyPrec 30 expr <> text "("
<> (sep . punctuate comma . map pretty) args <> text ")"
prettyPrec p (CMember expr ident deref _) =
parenPrec p 26 $ prettyPrec 26 expr
<> text (if deref then "->" else ".") <> identP ident
prettyPrec _p (CVar ident _) = identP ident
prettyPrec _p (CConst constant) = pretty constant
prettyPrec _p (CCompoundLit decl initl _) =
parens (pretty decl) <+> (braces . hsep . punctuate comma) (map p initl) where
p ([], initializer) = pretty initializer
p (mems, initializer) = hcat (punctuate (text ".") (map pretty mems)) <+> text "=" <+> pretty initializer
prettyPrec _p (CStatExpr stat _) =
text "(" <> pretty stat <> text ")"
-- unary_expr :- && ident {- address of label -}
prettyPrec _p (CLabAddrExpr ident _) = text "&&" <> identP ident
prettyPrec _p (CBuiltinExpr builtin) = pretty builtin
instance Pretty CBuiltin where
pretty (CBuiltinVaArg expr ty_name _) =
text "__builtin_va_arg" <+>
(parens $ pretty expr <> comma <+> pretty ty_name)
-- The first desig has to be a member field.
pretty (CBuiltinOffsetOf ty_name (CMemberDesig field1 _ : desigs) _) =
text "__builtin_offsetof" <+>
(parens $ pretty ty_name <> comma <+> identP field1 <> hcat (map pretty desigs) )
pretty (CBuiltinOffsetOf _ty_name otherDesigs _) =
error $ "Inconsistent AST: Cannot interpret designators in offsetOf: "++ show (hcat$ map pretty otherDesigs)
pretty (CBuiltinTypesCompatible ty1 ty2 _) =
text "__builtin_types_compatible_p" <+>
(parens $ pretty ty1 <> comma <+> pretty ty2)
instance Pretty CAssignOp where
pretty = text . show
instance Pretty CBinaryOp where
pretty = text . show
instance Pretty CUnaryOp where
pretty = text . show
instance Pretty CConst where
pretty (CIntConst int_const _) = text (show int_const)
pretty (CCharConst chr _) = text (show chr)
pretty (CFloatConst flt _) = text (show flt)
pretty (CStrConst str _) = text (show str)
instance Pretty CStrLit where
pretty (CStrLit str _) = text (show str)
-- precedence of C operators
binPrec :: CBinaryOp -> Int
binPrec CMulOp = 20
binPrec CDivOp = 20
binPrec CRmdOp = 20
binPrec CAddOp = 19
binPrec CSubOp = 19
binPrec CShlOp = 18
binPrec CShrOp = 18
binPrec CLeOp = 17
binPrec CGrOp = 17
binPrec CLeqOp = 17
binPrec CGeqOp = 17
binPrec CEqOp = 16
binPrec CNeqOp = 16
binPrec CAndOp = 15
binPrec CXorOp = 14
binPrec COrOp = 13
binPrec CLndOp = 12
binPrec CLorOp = 11