{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- 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 (isSuffixOf)
import qualified Data.Set as Set
import Text.PrettyPrint.HughesPJ
import Debug.Trace {- for warnings -}
import Prelude hiding ((<>))

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       = forall p. Pretty p => Int -> p -> Doc
prettyPrec Int
0
    prettyPrec Int
_ = forall p. Pretty p => p -> Doc
pretty

-- pretty print optional chunk
maybeP :: (p -> Doc) -> Maybe p -> Doc
maybeP :: forall p. (p -> Doc) -> Maybe p -> Doc
maybeP = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty

-- pretty print when flag is true
ifP :: Bool -> Doc -> Doc
ifP :: Bool -> Doc -> Doc
ifP Bool
flag Doc
doc = if Bool
flag then Doc
doc else Doc
empty

-- pretty print _optional_ list, i.e. [] ~ Nothing and (x:xs) ~ Just (x:xs)
mlistP :: ([p] -> Doc) -> [p] -> Doc
mlistP :: forall p. ([p] -> Doc) -> [p] -> Doc
mlistP [p] -> Doc
pp [p]
xs = forall p. (p -> Doc) -> Maybe p -> Doc
maybeP [p] -> Doc
pp (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [p]
xs then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just [p]
xs)

-- pretty print identifier
identP :: Ident -> Doc
identP :: Ident -> Doc
identP = String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> String
identToString

-- pretty print attribute annotations
attrlistP :: [CAttr] -> Doc
attrlistP :: [CAttr] -> Doc
attrlistP [] = Doc
empty
attrlistP [CAttr]
attrs = String -> Doc
text String
"__attribute__" Doc -> Doc -> Doc
<> Doc -> Doc
parens (Doc -> Doc
parens ([Doc] -> Doc
hcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall p. Pretty p => p -> Doc
pretty forall a b. (a -> b) -> a -> b
$ [CAttr]
attrs))

-- analogous to showParen
parenPrec :: Int -> Int -> Doc -> Doc
parenPrec :: Int -> Int -> Doc -> Doc
parenPrec Int
prec Int
prec2 Doc
t = if Int
prec forall a. Ord a => a -> a -> Bool
<= Int
prec2 then Doc
t else Doc -> Doc
parens Doc
t

-- indent a chunk of code
ii :: Doc -> Doc
ii :: Doc -> Doc
ii = Int -> Doc -> Doc
nest Int
4

-- Pretty instances
instance Pretty CTranslUnit where
    pretty :: CTranslUnit -> Doc
pretty (CTranslUnit [CExtDecl]
edecls NodeInfo
_) = [Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall p. Pretty p => p -> Doc
pretty [CExtDecl]
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 useful
-- for testing, as otherwise the pretty printed file will be cluttered with declarations from system headers.
prettyUsingInclude :: CTranslUnit -> Doc
prettyUsingInclude :: CTranslUnit -> Doc
prettyUsingInclude (CTranslUnit [CExtDecl]
edecls NodeInfo
_) =
  forall {a}. Set a -> Doc
includeWarning Set String
headerFiles
    Doc -> Doc -> Doc
$$
  [Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Doc
includeHeader forall p. Pretty p => p -> Doc
pretty) [Either String CExtDecl]
mappedDecls)
  where
    (Set String
headerFiles,[Either String CExtDecl]
mappedDecls) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall {a} {b}.
Ord a =>
Either a b -> (Set a, [Either a b]) -> (Set a, [Either a b])
addDecl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. (CNode b, Pos b) => b -> Either String b
tagIncludedDecls) (forall a. Set a
Set.empty,[]) [CExtDecl]
edecls
    tagIncludedDecls :: b -> Either String b
tagIncludedDecls b
edecl | forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False String -> Bool
isHeaderFile (forall a. CNode a => a -> Maybe String
fileOfNode b
edecl) = forall a b. a -> Either a b
Left ((Position -> String
posFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pos a => a -> Position
posOf) b
edecl)
                           | Bool
otherwise = forall a b. b -> Either a b
Right b
edecl
    addDecl :: Either a b -> (Set a, [Either a b]) -> (Set a, [Either a b])
addDecl decl :: Either a b
decl@(Left a
headerRef) (Set a
headerSet, [Either a b]
ds)
      | forall a. Ord a => a -> Set a -> Bool
Set.member a
headerRef Set a
headerSet = (Set a
headerSet, [Either a b]
ds)
      | Bool
otherwise = (forall a. Ord a => a -> Set a -> Set a
Set.insert a
headerRef Set a
headerSet, Either a b
decl forall a. a -> [a] -> [a]
: [Either a b]
ds)
    addDecl Either a b
decl (Set a
headerSet,[Either a b]
ds) = (Set a
headerSet, Either a b
decl forall a. a -> [a] -> [a]
: [Either a b]
ds)
    includeHeader :: String -> Doc
includeHeader String
hFile = String -> Doc
text String
"#include" Doc -> Doc -> Doc
<+> Doc -> Doc
doubleQuotes (String -> Doc
text String
hFile)
    isHeaderFile :: String -> Bool
isHeaderFile = (String
".h" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`)
    includeWarning :: Set a -> Doc
includeWarning Set a
hs | forall a. Set a -> Bool
Set.null Set a
hs = Doc
empty
                      | Bool
otherwise = String -> Doc
text String
"/* Warning: The #include directives in this file aren't necessarily correct. */"

-- TODO: Check need of __extension__
instance Pretty CExtDecl where
    pretty :: CExtDecl -> Doc
pretty (CDeclExt CDecl
decl) = forall p. Pretty p => p -> Doc
pretty CDecl
decl Doc -> Doc -> Doc
<> Doc
semi
    pretty (CFDefExt CFunDef
fund) = forall p. Pretty p => p -> Doc
pretty CFunDef
fund
    pretty (CAsmExt  CStrLit
asmStmt NodeInfo
_) = String -> Doc
text String
"asm" Doc -> Doc -> Doc
<> Doc -> Doc
parens (forall p. Pretty p => p -> Doc
pretty CStrLit
asmStmt) Doc -> Doc -> Doc
<> Doc
semi

-- TODO: Check that old-style and new-style aren't mixed
instance Pretty CFunDef where
    pretty :: CFunDef -> Doc
pretty (CFunDef [CDeclSpec]
declspecs CDeclr
declr [CDecl]
decls CStatement NodeInfo
stat NodeInfo
_) =          -- Example:
            [Doc] -> Doc
hsep (forall a b. (a -> b) -> [a] -> [b]
map forall p. Pretty p => p -> Doc
pretty [CDeclSpec]
declspecs)                      -- __attribute__((noreturn)) static long
        Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty CDeclr
declr                                     -- foo(b)
        Doc -> Doc -> Doc
$+$ (Doc -> Doc
ii forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
vcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((Doc -> Doc -> Doc
<> Doc
semi) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. Pretty p => p -> Doc
pretty)) [CDecl]
decls     --     register long b;
        Doc -> Doc -> Doc
$$ forall p. Pretty p => Int -> p -> Doc
prettyPrec (-Int
1) CStatement NodeInfo
stat                              -- {  ...
                                                             -- }

instance Pretty CStat where
    pretty :: CStatement NodeInfo -> Doc
pretty (CLabel Ident
ident CStatement NodeInfo
stat [CAttr]
cattrs NodeInfo
_) = Ident -> Doc
identP Ident
ident Doc -> Doc -> Doc
<> String -> Doc
text String
":" Doc -> Doc -> Doc
<+> [CAttr] -> Doc
attrlistP [CAttr]
cattrs Doc -> Doc -> Doc
$$ forall p. Pretty p => p -> Doc
pretty CStatement NodeInfo
stat
    pretty (CCase CExpr
expr CStatement NodeInfo
stat NodeInfo
_) =
        String -> Doc
text String
"case" Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty CExpr
expr Doc -> Doc -> Doc
<> String -> Doc
text String
":" Doc -> Doc -> Doc
$$ forall p. Pretty p => p -> Doc
pretty CStatement NodeInfo
stat
    pretty (CCases CExpr
expr1 CExpr
expr2 CStatement NodeInfo
stat NodeInfo
_) =
        String -> Doc
text String
"case" Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty CExpr
expr1 Doc -> Doc -> Doc
<+> String -> Doc
text String
"..."
                    Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty CExpr
expr2 Doc -> Doc -> Doc
<> String -> Doc
text String
":" Doc -> Doc -> Doc
$$ forall p. Pretty p => p -> Doc
pretty CStatement NodeInfo
stat
    pretty (CDefault CStatement NodeInfo
stat NodeInfo
_) = String -> Doc
text String
"default:" Doc -> Doc -> Doc
$$ forall p. Pretty p => p -> Doc
pretty CStatement NodeInfo
stat
    pretty (CExpr Maybe CExpr
expr NodeInfo
_) = Doc -> Doc
ii forall a b. (a -> b) -> a -> b
$ forall p. (p -> Doc) -> Maybe p -> Doc
maybeP forall p. Pretty p => p -> Doc
pretty Maybe CExpr
expr Doc -> Doc -> Doc
<> Doc
semi
    pretty c :: CStatement NodeInfo
c@(CCompound [Ident]
_ [CBlockItem]
_ NodeInfo
_) = forall p. Pretty p => Int -> p -> Doc
prettyPrec Int
0 CStatement NodeInfo
c
    pretty (CIf CExpr
expr CStatement NodeInfo
stat Maybe (CStatement NodeInfo)
estat NodeInfo
_) =
        Doc -> Doc
ii forall a b. (a -> b) -> a -> b
$  String -> Doc
text String
"if" Doc -> Doc -> Doc
<+> Doc -> Doc
parens (forall p. Pretty p => p -> Doc
pretty CExpr
expr)
                Doc -> Doc -> Doc
$+$ forall {a}. Pretty (CStatement a) => CStatement a -> Doc
prettyBody CStatement NodeInfo
stat
                Doc -> Doc -> Doc
$$  forall p. (p -> Doc) -> Maybe p -> Doc
maybeP forall {a}.
(Pretty (CExpression a), Pretty (CStatement a)) =>
CStatement a -> Doc
prettyElse Maybe (CStatement NodeInfo)
estat
      where
        prettyBody :: CStatement a -> Doc
prettyBody c :: CStatement a
c@(CCompound [Ident]
_ [CCompoundBlockItem a]
_ a
_) = forall p. Pretty p => Int -> p -> Doc
prettyPrec (-Int
1) CStatement a
c
        prettyBody CStatement a
nonCompound         = forall p. Pretty p => Int -> p -> Doc
prettyPrec (-Int
1) (forall a. [Ident] -> [CCompoundBlockItem a] -> a -> CStatement a
CCompound [] [forall a. CStatement a -> CCompoundBlockItem a
CBlockStmt CStatement a
nonCompound] forall a. HasCallStack => a
undefined)
        prettyElse :: CStatement a -> Doc
prettyElse (CIf CExpression a
else_if_expr CStatement a
else_if_stat Maybe (CStatement a)
else_stat a
_) =
          String -> Doc
text String
"else if" Doc -> Doc -> Doc
<+> Doc -> Doc
parens (forall p. Pretty p => p -> Doc
pretty CExpression a
else_if_expr)
            Doc -> Doc -> Doc
$+$ forall {a}. Pretty (CStatement a) => CStatement a -> Doc
prettyBody CStatement a
else_if_stat
            Doc -> Doc -> Doc
$$  forall p. (p -> Doc) -> Maybe p -> Doc
maybeP CStatement a -> Doc
prettyElse Maybe (CStatement a)
else_stat
        prettyElse CStatement a
else_stmt =
          String -> Doc
text String
"else"
            Doc -> Doc -> Doc
$+$ forall {a}. Pretty (CStatement a) => CStatement a -> Doc
prettyBody CStatement a
else_stmt

    pretty (CSwitch CExpr
expr CStatement NodeInfo
stat NodeInfo
_) =
        Doc -> Doc
ii forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"switch" Doc -> Doc -> Doc
<+> String -> Doc
text String
"(" Doc -> Doc -> Doc
<> forall p. Pretty p => p -> Doc
pretty CExpr
expr Doc -> Doc -> Doc
<> String -> Doc
text String
")"
               Doc -> Doc -> Doc
$+$ forall p. Pretty p => Int -> p -> Doc
prettyPrec (-Int
1) CStatement NodeInfo
stat
    pretty (CWhile CExpr
expr CStatement NodeInfo
stat Bool
False NodeInfo
_) =
        Doc -> Doc
ii forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"while" Doc -> Doc -> Doc
<+> String -> Doc
text String
"(" Doc -> Doc -> Doc
<> forall p. Pretty p => p -> Doc
pretty CExpr
expr Doc -> Doc -> Doc
<> String -> Doc
text String
")"
               Doc -> Doc -> Doc
$+$ forall p. Pretty p => Int -> p -> Doc
prettyPrec (-Int
1) CStatement NodeInfo
stat
    pretty (CWhile CExpr
expr CStatement NodeInfo
stat Bool
True NodeInfo
_) =
        Doc -> Doc
ii forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"do" Doc -> Doc -> Doc
$+$ forall p. Pretty p => Int -> p -> Doc
prettyPrec (-Int
1) CStatement NodeInfo
stat
               Doc -> Doc -> Doc
$$ String -> Doc
text String
"while" Doc -> Doc -> Doc
<+> String -> Doc
text String
"(" Doc -> Doc -> Doc
<> forall p. Pretty p => p -> Doc
pretty CExpr
expr Doc -> Doc -> Doc
<> String -> Doc
text String
");"
    pretty (CFor Either (Maybe CExpr) CDecl
for_init Maybe CExpr
cond Maybe CExpr
step CStatement NodeInfo
stat NodeInfo
_) =
        Doc -> Doc
ii forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"for" Doc -> Doc -> Doc
<+> String -> Doc
text String
"("
               Doc -> Doc -> Doc
<> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall p. (p -> Doc) -> Maybe p -> Doc
maybeP forall p. Pretty p => p -> Doc
pretty) forall p. Pretty p => p -> Doc
pretty Either (Maybe CExpr) CDecl
for_init Doc -> Doc -> Doc
<> Doc
semi
               Doc -> Doc -> Doc
<+> forall p. (p -> Doc) -> Maybe p -> Doc
maybeP forall p. Pretty p => p -> Doc
pretty Maybe CExpr
cond Doc -> Doc -> Doc
<> Doc
semi
               Doc -> Doc -> Doc
<+> forall p. (p -> Doc) -> Maybe p -> Doc
maybeP forall p. Pretty p => p -> Doc
pretty Maybe CExpr
step Doc -> Doc -> Doc
<> String -> Doc
text String
")" Doc -> Doc -> Doc
$+$ forall p. Pretty p => Int -> p -> Doc
prettyPrec (-Int
1) CStatement NodeInfo
stat
    pretty (CGoto Ident
ident NodeInfo
_) = Doc -> Doc
ii forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"goto" Doc -> Doc -> Doc
<+> Ident -> Doc
identP Ident
ident Doc -> Doc -> Doc
<> Doc
semi
    pretty (CGotoPtr CExpr
expr NodeInfo
_) = Doc -> Doc
ii forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"goto" Doc -> Doc -> Doc
<+> String -> Doc
text String
"*" Doc -> Doc -> Doc
<+> forall p. Pretty p => Int -> p -> Doc
prettyPrec Int
30 CExpr
expr Doc -> Doc -> Doc
<> Doc
semi
    pretty (CCont NodeInfo
_) = Doc -> Doc
ii forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"continue" Doc -> Doc -> Doc
<> Doc
semi
    pretty (CBreak NodeInfo
_) = Doc -> Doc
ii forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"break" Doc -> Doc -> Doc
<> Doc
semi
    pretty (CReturn Maybe CExpr
Nothing NodeInfo
_) = Doc -> Doc
ii forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"return" Doc -> Doc -> Doc
<> Doc
semi
    pretty (CReturn (Just CExpr
e) NodeInfo
_) = Doc -> Doc
ii forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"return" Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty CExpr
e Doc -> Doc -> Doc
<> Doc
semi
    pretty (CAsm CAsmStmt
asmStmt NodeInfo
_) = forall p. Pretty p => p -> Doc
pretty CAsmStmt
asmStmt
    prettyPrec :: Int -> CStatement NodeInfo -> Doc
prettyPrec Int
p (CCompound [Ident]
localLabels [CBlockItem]
bis NodeInfo
_) =
        let inner :: Doc
inner = String -> Doc
text String
"{" Doc -> Doc -> Doc
$+$ forall p. ([p] -> Doc) -> [p] -> Doc
mlistP [Ident] -> Doc
ppLblDecls [Ident]
localLabels Doc -> Doc -> Doc
$+$ [Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall p. Pretty p => p -> Doc
pretty [CBlockItem]
bis) Doc -> Doc -> Doc
$$ String -> Doc
text String
"}"
        in  if Int
p forall a. Eq a => a -> a -> Bool
== -Int
1 then Doc
inner else Doc -> Doc
ii Doc
inner
        where ppLblDecls :: [Ident] -> Doc
ppLblDecls =  [Doc] -> Doc
vcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\Ident
l -> String -> Doc
text String
"__label__" Doc -> Doc -> Doc
<+> Ident -> Doc
identP Ident
l Doc -> Doc -> Doc
<+> Doc
semi)
    prettyPrec Int
_ CStatement NodeInfo
p = forall p. Pretty p => p -> Doc
pretty CStatement NodeInfo
p

instance Pretty CAsmStmt where
    pretty :: CAsmStmt -> Doc
pretty (CAsmStmt Maybe CTypeQual
tyQual CStrLit
expr [CAsmOperand]
outOps [CAsmOperand]
inOps [CStrLit]
clobbers NodeInfo
_) =
        Doc -> Doc
ii forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"__asm__" Doc -> Doc -> Doc
<+>
             forall p. (p -> Doc) -> Maybe p -> Doc
maybeP forall p. Pretty p => p -> Doc
pretty Maybe CTypeQual
tyQual Doc -> Doc -> Doc
<>
             Doc -> Doc
parens Doc
asmStmt Doc -> Doc -> Doc
<> Doc
semi
      where
        asmStmt :: Doc
asmStmt = forall p. Pretty p => p -> Doc
pretty CStrLit
expr Doc -> Doc -> Doc
<+>
                  (if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[CAsmOperand]
inOps,[CAsmOperand]
outOps] Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CStrLit]
clobbers then Doc
empty else Doc
ops)
        ops :: Doc
ops     =  String -> Doc
text String
":" Doc -> Doc -> Doc
<+> [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate Doc
comma (forall a b. (a -> b) -> [a] -> [b]
map forall p. Pretty p => p -> Doc
pretty [CAsmOperand]
outOps)) Doc -> Doc -> Doc
<+>
                   String -> Doc
text String
":" Doc -> Doc -> Doc
<+> [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate Doc
comma (forall a b. (a -> b) -> [a] -> [b]
map forall p. Pretty p => p -> Doc
pretty [CAsmOperand]
inOps)) Doc -> Doc -> Doc
<+>
                   (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CStrLit]
clobbers then Doc
empty else Doc
clobs)
        clobs :: Doc
clobs   =  String -> Doc
text String
":" Doc -> Doc -> Doc
<+> [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate Doc
comma (forall a b. (a -> b) -> [a] -> [b]
map forall p. Pretty p => p -> Doc
pretty [CStrLit]
clobbers))

instance Pretty CAsmOperand where
    -- asm_operand :~ [operand-name] "constraint" ( expr )
    pretty :: CAsmOperand -> Doc
pretty (CAsmOperand Maybe Ident
mArgName CStrLit
cnstr CExpr
expr NodeInfo
_) =
        forall p. (p -> Doc) -> Maybe p -> Doc
maybeP (\Ident
argName -> String -> Doc
text String
"[" Doc -> Doc -> Doc
<> Ident -> Doc
identP Ident
argName Doc -> Doc -> Doc
<> String -> Doc
text String
"]") Maybe Ident
mArgName Doc -> Doc -> Doc
<+>
        forall p. Pretty p => p -> Doc
pretty CStrLit
cnstr Doc -> Doc -> Doc
<+>
        Doc -> Doc
parens (forall p. Pretty p => p -> Doc
pretty CExpr
expr)

-- TODO: Check need of __extension__
instance Pretty CBlockItem where
    pretty :: CBlockItem -> Doc
pretty (CBlockStmt CStatement NodeInfo
stat) = forall p. Pretty p => p -> Doc
pretty CStatement NodeInfo
stat
    pretty (CBlockDecl CDecl
decl) = Doc -> Doc
ii forall a b. (a -> b) -> a -> b
$ forall p. Pretty p => p -> Doc
pretty CDecl
decl Doc -> Doc -> Doc
<> Doc
semi
    pretty (CNestedFunDef CFunDef
fundef) = Doc -> Doc
ii forall a b. (a -> b) -> a -> b
$ forall p. Pretty p => p -> Doc
pretty CFunDef
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 -> Doc
pretty (CDecl [CDeclSpec]
specs [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
divs NodeInfo
_) =
        [Doc] -> Doc
hsep (forall a b. (a -> b) -> [a] -> [b]
map forall p. Pretty p => p -> Doc
pretty [CDeclSpec]
checked_specs) Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
punctuate Doc
comma (forall a b. (a -> b) -> [a] -> [b]
map forall {p} {p}.
(Pretty p, Pretty p) =>
(Maybe CDeclr, Maybe p, Maybe p) -> Doc
p [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
divs))
            where
            -- possible hint for AST improvement - (declr, initializer, expr, attrs)
            -- currently there are no sensible attributes for unnamed bitfields though
            p :: (Maybe CDeclr, Maybe p, Maybe p) -> Doc
p (Maybe CDeclr
declr, Maybe p
initializer, Maybe p
expr) =
                forall p. (p -> Doc) -> Maybe p -> Doc
maybeP (Bool -> Int -> CDeclr -> Doc
prettyDeclr Bool
False Int
0) Maybe CDeclr
declr Doc -> Doc -> Doc
<+>
                forall p. (p -> Doc) -> Maybe p -> Doc
maybeP ((String -> Doc
text String
":" Doc -> Doc -> Doc
<+>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. Pretty p => p -> Doc
pretty) Maybe p
expr Doc -> Doc -> Doc
<+>
                [CAttr] -> Doc
attrlistP (forall {a}. Maybe (CDeclarator a) -> [CAttribute a]
getAttrs Maybe CDeclr
declr) Doc -> Doc -> Doc
<+>
                forall p. (p -> Doc) -> Maybe p -> Doc
maybeP ((String -> Doc
text String
"=" Doc -> Doc -> Doc
<+>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. Pretty p => p -> Doc
pretty) Maybe p
initializer
            checked_specs :: [CDeclSpec]
checked_specs =
                if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall {a} {a}.
(CDeclarationSpecifier a, CDeclarationSpecifier a) -> Bool
isAttrAfterSUE  (forall a b. [a] -> [b] -> [(a, b)]
zip [CDeclSpec]
specs (forall a. [a] -> [a]
tail [CDeclSpec]
specs))
                    then forall a. String -> a -> a
trace
                           (String
"Warning: AST Invariant violated: __attribute__ specifier following struct/union/enum:" forall a. [a] -> [a] -> [a]
++
                            forall a. Show a => a -> String
show (forall a b. (a -> b) -> [a] -> [b]
map forall p. Pretty p => p -> Doc
pretty [CDeclSpec]
specs))
                           [CDeclSpec]
specs
                    else [CDeclSpec]
specs
            isAttrAfterSUE :: (CDeclarationSpecifier a, CDeclarationSpecifier a) -> Bool
isAttrAfterSUE (CTypeSpec CTypeSpecifier a
ty,CTypeQual (CAttrQual CAttribute a
_)) = forall a. CTypeSpecifier a -> Bool
isSUEDef CTypeSpecifier a
ty
            isAttrAfterSUE (CDeclarationSpecifier a, CDeclarationSpecifier a)
_ = Bool
False
            getAttrs :: Maybe (CDeclarator a) -> [CAttribute a]
getAttrs Maybe (CDeclarator a)
Nothing = []
            getAttrs (Just (CDeclr Maybe Ident
_ [CDerivedDeclarator a]
_ Maybe (CStringLiteral a)
_ [CAttribute a]
cattrs a
_)) = [CAttribute a]
cattrs
    pretty (CStaticAssert CExpr
expr CStrLit
str NodeInfo
_) =
      String -> Doc
text String
"_Static_assert" Doc -> Doc -> Doc
<> Doc -> Doc
parens ([Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
punctuate Doc
comma [forall p. Pretty p => p -> Doc
pretty CExpr
expr, forall p. Pretty p => p -> Doc
pretty CStrLit
str]))

instance Pretty CDeclSpec where
    pretty :: CDeclSpec -> Doc
pretty (CStorageSpec CStorageSpec
sp) = forall p. Pretty p => p -> Doc
pretty CStorageSpec
sp
    pretty (CTypeSpec CTypeSpec
sp) = forall p. Pretty p => p -> Doc
pretty CTypeSpec
sp
    pretty (CTypeQual CTypeQual
qu) = forall p. Pretty p => p -> Doc
pretty CTypeQual
qu
    pretty (CFunSpec CFunSpec
fs) = forall p. Pretty p => p -> Doc
pretty CFunSpec
fs
    pretty (CAlignSpec CAlignSpec
sa) = forall p. Pretty p => p -> Doc
pretty CAlignSpec
sa

instance Pretty CAlignSpec where
    pretty :: CAlignSpec -> Doc
pretty (CAlignAsType CDecl
decl NodeInfo
_) =
        String -> Doc
text String
"_Alignas" Doc -> Doc -> Doc
<> Doc -> Doc
parens (forall p. Pretty p => p -> Doc
pretty CDecl
decl)
    pretty (CAlignAsExpr CExpr
expr NodeInfo
_) =
        String -> Doc
text String
"_Alignas" Doc -> Doc -> Doc
<> Doc -> Doc
parens (forall p. Pretty p => p -> Doc
pretty CExpr
expr)

instance Pretty CStorageSpec where
    pretty :: CStorageSpec -> Doc
pretty (CAuto NodeInfo
_) = String -> Doc
text String
"auto"
    pretty (CRegister NodeInfo
_) = String -> Doc
text String
"register"
    pretty (CStatic NodeInfo
_) = String -> Doc
text String
"static"
    pretty (CExtern NodeInfo
_) = String -> Doc
text String
"extern"
    pretty (CTypedef NodeInfo
_) = String -> Doc
text String
"typedef"
    pretty (CThread NodeInfo
_) = String -> Doc
text String
"_Thread_local"
    pretty (CClKernel NodeInfo
_) = String -> Doc
text String
"__kernel"
    pretty (CClGlobal NodeInfo
_) = String -> Doc
text String
"__global"
    pretty (CClLocal NodeInfo
_)  = String -> Doc
text String
"__local"

instance Pretty CTypeSpec where
    pretty :: CTypeSpec -> Doc
pretty (CVoidType NodeInfo
_)        = String -> Doc
text String
"void"
    pretty (CCharType NodeInfo
_)        = String -> Doc
text String
"char"
    pretty (CShortType NodeInfo
_)       = String -> Doc
text String
"short"
    pretty (CIntType NodeInfo
_)         = String -> Doc
text String
"int"
    pretty (CLongType NodeInfo
_)        = String -> Doc
text String
"long"
    pretty (CFloatType NodeInfo
_)       = String -> Doc
text String
"float"
    pretty (CFloatNType Int
n Bool
x NodeInfo
_)  = String -> Doc
text String
"_Float" Doc -> Doc -> Doc
<> String -> Doc
text (forall a. Show a => a -> String
show Int
n) Doc -> Doc -> Doc
<>
                                  (if Bool
x then String -> Doc
text String
"x" else Doc
empty)
    pretty (CDoubleType NodeInfo
_)      = String -> Doc
text String
"double"
    pretty (CSignedType NodeInfo
_)      = String -> Doc
text String
"signed"
    pretty (CUnsigType NodeInfo
_)       = String -> Doc
text String
"unsigned"
    pretty (CBoolType NodeInfo
_)        = String -> Doc
text String
"_Bool"
    pretty (CComplexType NodeInfo
_)     = String -> Doc
text String
"_Complex"
    pretty (CInt128Type NodeInfo
_)      = String -> Doc
text String
"__int128"
    pretty (CUInt128Type NodeInfo
_)     = String -> Doc
text String
"__uint128"
    pretty (CSUType CStructUnion
union NodeInfo
_)    = forall p. Pretty p => p -> Doc
pretty CStructUnion
union
    pretty (CEnumType CEnum
enum NodeInfo
_)   = forall p. Pretty p => p -> Doc
pretty CEnum
enum
    pretty (CTypeDef Ident
ident NodeInfo
_)   = Ident -> Doc
identP Ident
ident
    pretty (CTypeOfExpr CExpr
expr NodeInfo
_) =
        String -> Doc
text String
"typeof" Doc -> Doc -> Doc
<> Doc -> Doc
parens (forall p. Pretty p => p -> Doc
pretty CExpr
expr)
    pretty (CTypeOfType CDecl
decl NodeInfo
_) =
        String -> Doc
text String
"typeof" Doc -> Doc -> Doc
<> Doc -> Doc
parens (forall p. Pretty p => p -> Doc
pretty CDecl
decl)
    pretty (CAtomicType CDecl
decl NodeInfo
_) =
        String -> Doc
text String
"_Atomic" Doc -> Doc -> Doc
<> Doc -> Doc
parens (forall p. Pretty p => p -> Doc
pretty CDecl
decl)

instance Pretty CTypeQual where
    pretty :: CTypeQual -> Doc
pretty (CConstQual NodeInfo
_) = String -> Doc
text String
"const"
    pretty (CVolatQual NodeInfo
_) = String -> Doc
text String
"volatile"
    pretty (CRestrQual NodeInfo
_) = String -> Doc
text String
"__restrict"
    pretty (CAtomicQual NodeInfo
_) = String -> Doc
text String
"_Atomic"
    pretty (CAttrQual CAttr
a)  = [CAttr] -> Doc
attrlistP [CAttr
a]
    pretty (CNullableQual NodeInfo
_) = String -> Doc
text String
"_Nullable"
    pretty (CNonnullQual NodeInfo
_) = String -> Doc
text String
"_Nonnull"
    pretty (CClRdOnlyQual NodeInfo
_) = String -> Doc
text String
"__read_only"
    pretty (CClWrOnlyQual NodeInfo
_) = String -> Doc
text String
"__write_only"

instance Pretty CFunSpec where
    pretty :: CFunSpec -> Doc
pretty (CInlineQual NodeInfo
_) = String -> Doc
text String
"inline"
    pretty (CNoreturnQual NodeInfo
_) = String -> Doc
text String
"_Noreturn"

instance Pretty CStructUnion where
    pretty :: CStructUnion -> Doc
pretty (CStruct CStructTag
tag Maybe Ident
ident Maybe [CDecl]
Nothing [CAttr]
cattrs NodeInfo
_) = forall p. Pretty p => p -> Doc
pretty CStructTag
tag Doc -> Doc -> Doc
<+> [CAttr] -> Doc
attrlistP [CAttr]
cattrs Doc -> Doc -> Doc
<+> forall p. (p -> Doc) -> Maybe p -> Doc
maybeP Ident -> Doc
identP Maybe Ident
ident
    pretty (CStruct CStructTag
tag Maybe Ident
ident (Just []) [CAttr]
cattrs NodeInfo
_) =
        forall p. Pretty p => p -> Doc
pretty CStructTag
tag Doc -> Doc -> Doc
<+> [CAttr] -> Doc
attrlistP [CAttr]
cattrs Doc -> Doc -> Doc
<+> forall p. (p -> Doc) -> Maybe p -> Doc
maybeP Ident -> Doc
identP Maybe Ident
ident Doc -> Doc -> Doc
<+> String -> Doc
text String
"{ }"
    pretty (CStruct CStructTag
tag Maybe Ident
ident (Just [CDecl]
decls) [CAttr]
cattrs NodeInfo
_) = [Doc] -> Doc
vcat [
        forall p. Pretty p => p -> Doc
pretty CStructTag
tag Doc -> Doc -> Doc
<+> [CAttr] -> Doc
attrlistP [CAttr]
cattrs Doc -> Doc -> Doc
<+> forall p. (p -> Doc) -> Maybe p -> Doc
maybeP Ident -> Doc
identP Maybe Ident
ident Doc -> Doc -> Doc
<+> String -> Doc
text String
"{",
        Doc -> Doc
ii forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep (forall a b. (a -> b) -> [a] -> [b]
map ((Doc -> Doc -> Doc
<> Doc
semi) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. Pretty p => p -> Doc
pretty) [CDecl]
decls),
        String -> Doc
text String
"}"]

instance Pretty CStructTag where
    pretty :: CStructTag -> Doc
pretty CStructTag
CStructTag = String -> Doc
text String
"struct"
    pretty CStructTag
CUnionTag  = String -> Doc
text String
"union"

instance Pretty CEnum where
    pretty :: CEnum -> Doc
pretty (CEnum Maybe Ident
enum_ident Maybe [(Ident, Maybe CExpr)]
Nothing [CAttr]
cattrs NodeInfo
_) = String -> Doc
text String
"enum" Doc -> Doc -> Doc
<+> [CAttr] -> Doc
attrlistP [CAttr]
cattrs Doc -> Doc -> Doc
<+> forall p. (p -> Doc) -> Maybe p -> Doc
maybeP Ident -> Doc
identP Maybe Ident
enum_ident
    pretty (CEnum Maybe Ident
enum_ident (Just [(Ident, Maybe CExpr)]
vals) [CAttr]
cattrs NodeInfo
_) = [Doc] -> Doc
vcat [
        String -> Doc
text String
"enum" Doc -> Doc -> Doc
<+> [CAttr] -> Doc
attrlistP [CAttr]
cattrs Doc -> Doc -> Doc
<+> forall p. (p -> Doc) -> Maybe p -> Doc
maybeP Ident -> Doc
identP Maybe Ident
enum_ident Doc -> Doc -> Doc
<+> String -> Doc
text String
"{",
        Doc -> Doc
ii forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep (Doc -> [Doc] -> [Doc]
punctuate Doc
comma (forall a b. (a -> b) -> [a] -> [b]
map forall {p}. Pretty p => (Ident, Maybe p) -> Doc
p [(Ident, Maybe CExpr)]
vals)),
        String -> Doc
text String
"}"] where
        p :: (Ident, Maybe p) -> Doc
p (Ident
ident, Maybe p
expr) = Ident -> Doc
identP Ident
ident Doc -> Doc -> Doc
<+> forall p. (p -> Doc) -> Maybe p -> Doc
maybeP ((String -> Doc
text String
"=" Doc -> Doc -> Doc
<+>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. Pretty p => p -> Doc
pretty) Maybe p
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 :: Int -> CDeclr -> Doc
prettyPrec Int
prec CDeclr
declr = Bool -> Int -> CDeclr -> Doc
prettyDeclr Bool
True Int
prec CDeclr
declr

prettyDeclr :: Bool -> Int -> CDeclr -> Doc
prettyDeclr :: Bool -> Int -> CDeclr -> Doc
prettyDeclr Bool
show_attrs Int
prec (CDeclr Maybe Ident
name [CDerivedDeclarator NodeInfo]
derived_declrs Maybe CStrLit
asmname [CAttr]
cattrs NodeInfo
_) =
    Int -> [CDerivedDeclarator NodeInfo] -> Doc
ppDeclr Int
prec (forall a. [a] -> [a]
reverse [CDerivedDeclarator NodeInfo]
derived_declrs) Doc -> Doc -> Doc
<+> forall {p}. Pretty p => Maybe p -> Doc
prettyAsmName Maybe CStrLit
asmname Doc -> Doc -> Doc
<+> Bool -> Doc -> Doc
ifP Bool
show_attrs ([CAttr] -> Doc
attrlistP [CAttr]
cattrs)
    where
    ppDeclr :: Int -> [CDerivedDeclarator NodeInfo] -> Doc
ppDeclr Int
_ [] = forall p. (p -> Doc) -> Maybe p -> Doc
maybeP Ident -> Doc
identP Maybe Ident
name
    --'*' __attribute__? qualifiers declarator
    ppDeclr Int
p (CPtrDeclr [CTypeQual]
quals NodeInfo
_ : [CDerivedDeclarator NodeInfo]
declrs) =
        Int -> Int -> Doc -> Doc
parenPrec Int
p Int
5 forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"*" Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (forall a b. (a -> b) -> [a] -> [b]
map forall p. Pretty p => p -> Doc
pretty [CTypeQual]
quals) Doc -> Doc -> Doc
<+> Int -> [CDerivedDeclarator NodeInfo] -> Doc
ppDeclr Int
5 [CDerivedDeclarator NodeInfo]
declrs

    -- declarator[ __attribute__? qualifiers expr ]
    ppDeclr Int
p (CArrDeclr [CTypeQual]
quals CArrSize
size NodeInfo
_ : [CDerivedDeclarator NodeInfo]
declrs) =
        Int -> Int -> Doc -> Doc
parenPrec Int
p Int
6 forall a b. (a -> b) -> a -> b
$ Int -> [CDerivedDeclarator NodeInfo] -> Doc
ppDeclr Int
6 [CDerivedDeclarator NodeInfo]
declrs Doc -> Doc -> Doc
<> Doc -> Doc
brackets ([Doc] -> Doc
hsep (forall a b. (a -> b) -> [a] -> [b]
map forall p. Pretty p => p -> Doc
pretty [CTypeQual]
quals) Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty CArrSize
size)
    -- declarator ( arguments )
    -- or (__attribute__ declarator) (arguments)
    ppDeclr Int
_ (CFunDeclr Either [Ident] ([CDecl], Bool)
params [CAttr]
fun_attrs NodeInfo
_ : [CDerivedDeclarator NodeInfo]
declrs) =
        (if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CAttr]
fun_attrs) then Doc -> Doc
parens ([CAttr] -> Doc
attrlistP [CAttr]
fun_attrs Doc -> Doc -> Doc
<+> Int -> [CDerivedDeclarator NodeInfo] -> Doc
ppDeclr Int
5 [CDerivedDeclarator NodeInfo]
declrs) else Int -> [CDerivedDeclarator NodeInfo] -> Doc
ppDeclr Int
6 [CDerivedDeclarator NodeInfo]
declrs)
        Doc -> Doc -> Doc
<> Doc -> Doc
parens (forall {a}. Pretty a => Either [Ident] ([a], Bool) -> Doc
prettyParams Either [Ident] ([CDecl], Bool)
params)
    prettyParams :: Either [Ident] ([a], Bool) -> Doc
prettyParams (Right ([a]
decls, Bool
isVariadic)) =
     [Doc] -> Doc
sep (Doc -> [Doc] -> [Doc]
punctuate Doc
comma (forall a b. (a -> b) -> [a] -> [b]
map forall p. Pretty p => p -> Doc
pretty [a]
decls))
     Doc -> Doc -> Doc
<> (if Bool
isVariadic then String -> Doc
text String
"," Doc -> Doc -> Doc
<+> String -> Doc
text String
"..." else Doc
empty)
    prettyParams (Left [Ident]
oldStyleIds) =
     [Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
punctuate Doc
comma (forall a b. (a -> b) -> [a] -> [b]
map Ident -> Doc
identP [Ident]
oldStyleIds))
    prettyAsmName :: Maybe p -> Doc
prettyAsmName Maybe p
asm_name_opt
        = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty (\p
asm_name -> String -> Doc
text String
"__asm__" Doc -> Doc -> Doc
<> Doc -> Doc
parens (forall p. Pretty p => p -> Doc
pretty p
asm_name)) Maybe p
asm_name_opt

instance Pretty CArrSize where
  pretty :: CArrSize -> Doc
pretty (CNoArrSize Bool
completeType) = Bool -> Doc -> Doc
ifP Bool
completeType (String -> Doc
text String
"*")
  pretty (CArrSize Bool
staticMod CExpr
expr) = Bool -> Doc -> Doc
ifP Bool
staticMod (String -> Doc
text String
"static") Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty CExpr
expr
-- initializer :: { CInit }
-- initializer :- assignment_expression
--              | '{' (designation? initializer)_cs_list '}'
instance Pretty CInit where
    pretty :: CInit -> Doc
pretty (CInitExpr CExpr
expr NodeInfo
_) = forall p. Pretty p => p -> Doc
pretty CExpr
expr
    pretty (CInitList CInitializerList NodeInfo
initl NodeInfo
_) =
        String -> Doc
text String
"{" Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
punctuate Doc
comma (forall a b. (a -> b) -> [a] -> [b]
map forall {p} {a}. (Pretty p, Pretty a) => ([a], p) -> Doc
p CInitializerList NodeInfo
initl)) Doc -> Doc -> Doc
<+> String -> Doc
text String
"}" where
        p :: ([a], p) -> Doc
p ([], p
initializer)     = forall p. Pretty p => p -> Doc
pretty p
initializer
        p ([a]
desigs, p
initializer) = [Doc] -> Doc
hsep (forall a b. (a -> b) -> [a] -> [b]
map forall p. Pretty p => p -> Doc
pretty [a]
desigs) Doc -> Doc -> Doc
<+> String -> Doc
text String
"=" Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty p
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 :: CDesignator -> Doc
pretty (CArrDesig CExpr
expr NodeInfo
_) = String -> Doc
text String
"[" Doc -> Doc -> Doc
<> forall p. Pretty p => p -> Doc
pretty CExpr
expr Doc -> Doc -> Doc
<> String -> Doc
text String
"]"
    pretty (CMemberDesig Ident
ident NodeInfo
_) = String -> Doc
text String
"." Doc -> Doc -> Doc
<> Ident -> Doc
identP Ident
ident
    pretty (CRangeDesig CExpr
expr1 CExpr
expr2 NodeInfo
_) =
        String -> Doc
text String
"[" Doc -> Doc -> Doc
<> forall p. Pretty p => p -> Doc
pretty CExpr
expr1 Doc -> Doc -> Doc
<+> String -> Doc
text String
"..." Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty CExpr
expr2 Doc -> Doc -> Doc
<> String -> Doc
text String
"]"

instance Pretty CAttr where
    pretty :: CAttr -> Doc
pretty (CAttr Ident
attrName [] NodeInfo
_) = Ident -> Doc
identP Ident
attrName
    pretty (CAttr Ident
attrName [CExpr]
attrParams NodeInfo
_) = Ident -> Doc
identP Ident
attrName Doc -> Doc -> Doc
<> Doc -> Doc
parens ([Doc] -> Doc
hsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall p. Pretty p => p -> Doc
pretty forall a b. (a -> b) -> a -> b
$ [CExpr]
attrParams)

instance Pretty CExpr where
    prettyPrec :: Int -> CExpr -> Doc
prettyPrec Int
p (CComma [CExpr]
exprs NodeInfo
_) =
        Int -> Int -> Doc -> Doc
parenPrec Int
p (-Int
1) forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
punctuate Doc
comma (forall a b. (a -> b) -> [a] -> [b]
map (forall p. Pretty p => Int -> p -> Doc
prettyPrec Int
2) [CExpr]
exprs))
    prettyPrec Int
p (CAssign CAssignOp
op CExpr
expr1 CExpr
expr2 NodeInfo
_) =
        Int -> Int -> Doc -> Doc
parenPrec Int
p Int
2 forall a b. (a -> b) -> a -> b
$ forall p. Pretty p => Int -> p -> Doc
prettyPrec Int
3 CExpr
expr1 Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty CAssignOp
op Doc -> Doc -> Doc
<+> forall p. Pretty p => Int -> p -> Doc
prettyPrec Int
2 CExpr
expr2
    prettyPrec Int
p (CCond CExpr
expr1 Maybe CExpr
expr2 CExpr
expr3 NodeInfo
_) =
        Int -> Int -> Doc -> Doc
parenPrec Int
p Int
2 forall a b. (a -> b) -> a -> b
$ forall p. Pretty p => Int -> p -> Doc
prettyPrec Int
4 CExpr
expr1 Doc -> Doc -> Doc
<+> String -> Doc
text String
"?" -- NB: assignment only has a higher precedence if cond is on the rhs
           Doc -> Doc -> Doc
<+> forall p. (p -> Doc) -> Maybe p -> Doc
maybeP forall p. Pretty p => p -> Doc
pretty Maybe CExpr
expr2 Doc -> Doc -> Doc
<+> String -> Doc
text String
":" Doc -> Doc -> Doc
<+> forall p. Pretty p => Int -> p -> Doc
prettyPrec Int
4 CExpr
expr3
    prettyPrec Int
p (CBinary CBinaryOp
op CExpr
expr1 CExpr
expr2 NodeInfo
_) =
        let prec :: Int
prec = CBinaryOp -> Int
binPrec CBinaryOp
op
        in  Int -> Int -> Doc -> Doc
parenPrec Int
p Int
prec forall a b. (a -> b) -> a -> b
$ forall p. Pretty p => Int -> p -> Doc
prettyPrec Int
prec CExpr
expr1
                             Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty CBinaryOp
op Doc -> Doc -> Doc
<+> forall p. Pretty p => Int -> p -> Doc
prettyPrec (Int
prec forall a. Num a => a -> a -> a
+ Int
1) CExpr
expr2
    prettyPrec Int
p (CCast CDecl
decl CExpr
expr NodeInfo
_) =
        Int -> Int -> Doc -> Doc
parenPrec Int
p Int
25 forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"(" Doc -> Doc -> Doc
<> forall p. Pretty p => p -> Doc
pretty CDecl
decl Doc -> Doc -> Doc
<> String -> Doc
text String
")"
                       Doc -> Doc -> Doc
<+> forall p. Pretty p => Int -> p -> Doc
prettyPrec Int
25 CExpr
expr
    prettyPrec Int
p (CUnary CUnaryOp
CPostIncOp CExpr
expr NodeInfo
_) =
        Int -> Int -> Doc -> Doc
parenPrec Int
p Int
26 forall a b. (a -> b) -> a -> b
$ forall p. Pretty p => Int -> p -> Doc
prettyPrec Int
26 CExpr
expr Doc -> Doc -> Doc
<> String -> Doc
text String
"++"
    prettyPrec Int
p (CUnary CUnaryOp
CPostDecOp CExpr
expr NodeInfo
_) =
        Int -> Int -> Doc -> Doc
parenPrec Int
p Int
26 forall a b. (a -> b) -> a -> b
$ forall p. Pretty p => Int -> p -> Doc
prettyPrec Int
26 CExpr
expr Doc -> Doc -> Doc
<> String -> Doc
text String
"--"
    prettyPrec Int
p (CUnary CUnaryOp
op expr :: CExpr
expr@(CUnary CUnaryOp
_ CExpr
_ NodeInfo
_) NodeInfo
_) =
        --                             parens aren't necessary, but look nicer imho
        Int -> Int -> Doc -> Doc
parenPrec Int
p Int
25 forall a b. (a -> b) -> a -> b
$ forall p. Pretty p => p -> Doc
pretty CUnaryOp
op Doc -> Doc -> Doc
<+> Doc -> Doc
parens (forall p. Pretty p => Int -> p -> Doc
prettyPrec Int
25 CExpr
expr)
    prettyPrec Int
p (CUnary CUnaryOp
op CExpr
expr NodeInfo
_) =
        Int -> Int -> Doc -> Doc
parenPrec Int
p Int
25 forall a b. (a -> b) -> a -> b
$ forall p. Pretty p => p -> Doc
pretty CUnaryOp
op Doc -> Doc -> Doc
<> forall p. Pretty p => Int -> p -> Doc
prettyPrec Int
25 CExpr
expr
    prettyPrec Int
p (CSizeofExpr CExpr
expr NodeInfo
_) =
        Int -> Int -> Doc -> Doc
parenPrec Int
p Int
25 forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"sizeof" Doc -> Doc -> Doc
<> Doc -> Doc
parens (forall p. Pretty p => p -> Doc
pretty CExpr
expr)
    prettyPrec Int
p (CSizeofType CDecl
decl NodeInfo
_) =
        Int -> Int -> Doc -> Doc
parenPrec Int
p Int
25 forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"sizeof" Doc -> Doc -> Doc
<> Doc -> Doc
parens (forall p. Pretty p => p -> Doc
pretty CDecl
decl)
    prettyPrec Int
p (CAlignofExpr CExpr
expr NodeInfo
_) =
        Int -> Int -> Doc -> Doc
parenPrec Int
p Int
25 forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"__alignof" Doc -> Doc -> Doc
<> Doc -> Doc
parens (forall p. Pretty p => p -> Doc
pretty CExpr
expr)
    prettyPrec Int
p (CAlignofType CDecl
decl NodeInfo
_) =
        Int -> Int -> Doc -> Doc
parenPrec Int
p Int
25 forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"__alignof" Doc -> Doc -> Doc
<> Doc -> Doc
parens (forall p. Pretty p => p -> Doc
pretty CDecl
decl)
    prettyPrec Int
p (CComplexReal CExpr
expr NodeInfo
_) =
        Int -> Int -> Doc -> Doc
parenPrec Int
p Int
25 forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"__real" Doc -> Doc -> Doc
<+> forall p. Pretty p => Int -> p -> Doc
prettyPrec Int
25 CExpr
expr
    prettyPrec Int
p (CComplexImag CExpr
expr NodeInfo
_) =
        Int -> Int -> Doc -> Doc
parenPrec Int
p Int
25 forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"__imag" Doc -> Doc -> Doc
<+> forall p. Pretty p => Int -> p -> Doc
prettyPrec Int
25 CExpr
expr
    prettyPrec Int
p (CIndex CExpr
expr1 CExpr
expr2 NodeInfo
_) =
        Int -> Int -> Doc -> Doc
parenPrec Int
p Int
26 forall a b. (a -> b) -> a -> b
$ forall p. Pretty p => Int -> p -> Doc
prettyPrec Int
26 CExpr
expr1
                       Doc -> Doc -> Doc
<> String -> Doc
text String
"[" Doc -> Doc -> Doc
<> forall p. Pretty p => p -> Doc
pretty CExpr
expr2 Doc -> Doc -> Doc
<> String -> Doc
text String
"]"
    prettyPrec Int
p (CCall CExpr
expr [CExpr]
args NodeInfo
_) =
        Int -> Int -> Doc -> Doc
parenPrec Int
p Int
30 forall a b. (a -> b) -> a -> b
$ forall p. Pretty p => Int -> p -> Doc
prettyPrec Int
30 CExpr
expr Doc -> Doc -> Doc
<> String -> Doc
text String
"("
            Doc -> Doc -> Doc
<> ([Doc] -> Doc
sep forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall p. Pretty p => p -> Doc
pretty) [CExpr]
args Doc -> Doc -> Doc
<> String -> Doc
text String
")"
    prettyPrec Int
p (CMember CExpr
expr Ident
ident Bool
deref NodeInfo
_) =
        Int -> Int -> Doc -> Doc
parenPrec Int
p Int
26 forall a b. (a -> b) -> a -> b
$ forall p. Pretty p => Int -> p -> Doc
prettyPrec Int
26 CExpr
expr
                       Doc -> Doc -> Doc
<> String -> Doc
text (if Bool
deref then String
"->" else String
".") Doc -> Doc -> Doc
<> Ident -> Doc
identP Ident
ident
    prettyPrec Int
_p (CVar Ident
ident NodeInfo
_) = Ident -> Doc
identP Ident
ident
    prettyPrec Int
_p (CConst CConst
constant) = forall p. Pretty p => p -> Doc
pretty CConst
constant
    prettyPrec Int
_p (CCompoundLit CDecl
decl CInitializerList NodeInfo
initl NodeInfo
_) =
        Doc -> Doc
parens (forall p. Pretty p => p -> Doc
pretty CDecl
decl) Doc -> Doc -> Doc
<+> (Doc -> Doc
braces forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
hsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma) (forall a b. (a -> b) -> [a] -> [b]
map forall {p} {a}. (Pretty p, Pretty a) => ([a], p) -> Doc
p CInitializerList NodeInfo
initl) where
        p :: ([a], p) -> Doc
p ([], p
initializer)           = forall p. Pretty p => p -> Doc
pretty p
initializer
        p ([a]
mems, p
initializer) = [Doc] -> Doc
hcat (forall a b. (a -> b) -> [a] -> [b]
map forall p. Pretty p => p -> Doc
pretty [a]
mems) Doc -> Doc -> Doc
<+> String -> Doc
text String
"=" Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty p
initializer

    prettyPrec Int
_p (CStatExpr CStatement NodeInfo
stat NodeInfo
_) =
        String -> Doc
text String
"(" Doc -> Doc -> Doc
<> forall p. Pretty p => p -> Doc
pretty CStatement NodeInfo
stat Doc -> Doc -> Doc
<> String -> Doc
text String
")"

    -- unary_expr :- && ident  {- address of label -}
    prettyPrec Int
_p (CLabAddrExpr Ident
ident NodeInfo
_) = String -> Doc
text String
"&&" Doc -> Doc -> Doc
<> Ident -> Doc
identP Ident
ident
    prettyPrec Int
_p (CGenericSelection CExpr
expr [(Maybe CDecl, CExpr)]
assoc_list NodeInfo
_) =
      String -> Doc
text String
"_Generic" Doc -> Doc -> Doc
<> (Doc -> Doc
parensforall b c a. (b -> c) -> (a -> b) -> a -> c
.[Doc] -> Doc
hsepforall b c a. (b -> c) -> (a -> b) -> a -> c
.Doc -> [Doc] -> [Doc]
punctuate Doc
comma) (forall p. Pretty p => p -> Doc
pretty CExpr
expr forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall {a} {p}. (Pretty a, Pretty p) => (Maybe a, p) -> Doc
pAssoc [(Maybe CDecl, CExpr)]
assoc_list)
      where
        pAssoc :: (Maybe a, p) -> Doc
pAssoc (Maybe a
mty, p
expr1) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Doc
text String
"default") forall p. Pretty p => p -> Doc
pretty Maybe a
mty Doc -> Doc -> Doc
<> String -> Doc
text String
":" Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty p
expr1
    prettyPrec Int
_p (CBuiltinExpr CBuiltin
builtin) = forall p. Pretty p => p -> Doc
pretty CBuiltin
builtin

instance Pretty CBuiltin where
    pretty :: CBuiltin -> Doc
pretty (CBuiltinVaArg CExpr
expr CDecl
ty_name NodeInfo
_) =
        String -> Doc
text String
"__builtin_va_arg" Doc -> Doc -> Doc
<+>
        Doc -> Doc
parens (forall p. Pretty p => p -> Doc
pretty CExpr
expr Doc -> Doc -> Doc
<> Doc
comma Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty CDecl
ty_name)
    -- The first desig has to be a member field.
    pretty (CBuiltinOffsetOf CDecl
ty_name (CMemberDesig Ident
field1 NodeInfo
_ : [CDesignator]
desigs) NodeInfo
_) =
        String -> Doc
text String
"__builtin_offsetof" Doc -> Doc -> Doc
<+>
        Doc -> Doc
parens (forall p. Pretty p => p -> Doc
pretty CDecl
ty_name Doc -> Doc -> Doc
<> Doc
comma Doc -> Doc -> Doc
<+> Ident -> Doc
identP Ident
field1 Doc -> Doc -> Doc
<> [Doc] -> Doc
hcat (forall a b. (a -> b) -> [a] -> [b]
map forall p. Pretty p => p -> Doc
pretty [CDesignator]
desigs) )
    pretty (CBuiltinOffsetOf CDecl
_ty_name [CDesignator]
otherDesigs NodeInfo
_) =
        forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Inconsistent AST: Cannot interpret designators in offsetOf: " forall a. [a] -> [a] -> [a]
++
                forall a. Show a => a -> String
show ([Doc] -> Doc
hcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall p. Pretty p => p -> Doc
pretty [CDesignator]
otherDesigs)
    pretty (CBuiltinTypesCompatible CDecl
ty1 CDecl
ty2 NodeInfo
_) =
        String -> Doc
text String
"__builtin_types_compatible_p" Doc -> Doc -> Doc
<+>
        Doc -> Doc
parens (forall p. Pretty p => p -> Doc
pretty CDecl
ty1 Doc -> Doc -> Doc
<> Doc
comma Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty CDecl
ty2)
    pretty (CBuiltinConvertVector CExpr
expr CDecl
ty NodeInfo
_)  =
        String -> Doc
text String
"__builtin_convertvector" Doc -> Doc -> Doc
<+>
        Doc -> Doc
parens (forall p. Pretty p => p -> Doc
pretty CExpr
expr Doc -> Doc -> Doc
<> Doc
comma Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty CDecl
ty)

instance Pretty CAssignOp where
  pretty :: CAssignOp -> Doc
pretty CAssignOp
op = String -> Doc
text forall a b. (a -> b) -> a -> b
$ case CAssignOp
op of
    CAssignOp
CAssignOp -> String
"="
    CAssignOp
CMulAssOp -> String
"*="
    CAssignOp
CDivAssOp -> String
"/="
    CAssignOp
CRmdAssOp -> String
"%="
    CAssignOp
CAddAssOp -> String
"+="
    CAssignOp
CSubAssOp -> String
"-="
    CAssignOp
CShlAssOp -> String
"<<="
    CAssignOp
CShrAssOp -> String
">>="
    CAssignOp
CAndAssOp -> String
"&="
    CAssignOp
CXorAssOp -> String
"^="
    CAssignOp
COrAssOp  -> String
"|="

instance Pretty CBinaryOp where
  pretty :: CBinaryOp -> Doc
pretty CBinaryOp
op = String -> Doc
text forall a b. (a -> b) -> a -> b
$ case CBinaryOp
op of
    CBinaryOp
CMulOp -> String
"*"
    CBinaryOp
CDivOp -> String
"/"
    CBinaryOp
CRmdOp -> String
"%"
    CBinaryOp
CAddOp -> String
"+"
    CBinaryOp
CSubOp -> String
"-"
    CBinaryOp
CShlOp -> String
"<<"
    CBinaryOp
CShrOp -> String
">>"
    CBinaryOp
CLeOp  -> String
"<"
    CBinaryOp
CGrOp  -> String
">"
    CBinaryOp
CLeqOp -> String
"<="
    CBinaryOp
CGeqOp -> String
">="
    CBinaryOp
CEqOp  -> String
"=="
    CBinaryOp
CNeqOp -> String
"!="
    CBinaryOp
CAndOp -> String
"&"
    CBinaryOp
CXorOp -> String
"^"
    CBinaryOp
COrOp  -> String
"|"
    CBinaryOp
CLndOp -> String
"&&"
    CBinaryOp
CLorOp -> String
"||"

instance Pretty CUnaryOp where
  pretty :: CUnaryOp -> Doc
pretty CUnaryOp
op = String -> Doc
text forall a b. (a -> b) -> a -> b
$ case CUnaryOp
op of
    CUnaryOp
CPreIncOp  -> String
"++"
    CUnaryOp
CPreDecOp  -> String
"--"
    CUnaryOp
CPostIncOp -> String
"++"
    CUnaryOp
CPostDecOp -> String
"--"
    CUnaryOp
CAdrOp     -> String
"&"
    CUnaryOp
CIndOp     -> String
"*"
    CUnaryOp
CPlusOp    -> String
"+"
    CUnaryOp
CMinOp     -> String
"-"
    CUnaryOp
CCompOp    -> String
"~"
    CUnaryOp
CNegOp     -> String
"!"

instance Pretty CConst where
    pretty :: CConst -> Doc
pretty (CIntConst   CInteger
int_const NodeInfo
_) = String -> Doc
text (forall a. Show a => a -> String
show CInteger
int_const)
    pretty (CCharConst  CChar
chr NodeInfo
_) = String -> Doc
text (forall a. Show a => a -> String
show CChar
chr)
    pretty (CFloatConst CFloat
flt NodeInfo
_) = String -> Doc
text (forall a. Show a => a -> String
show CFloat
flt)
    pretty (CStrConst   CString
str NodeInfo
_) = String -> Doc
text (forall a. Show a => a -> String
show CString
str)

instance Pretty CStrLit where
    pretty :: CStrLit -> Doc
pretty (CStrLit   CString
str NodeInfo
_) = String -> Doc
text (forall a. Show a => a -> String
show CString
str)

-- precedence of C operators
binPrec :: CBinaryOp -> Int
binPrec :: CBinaryOp -> Int
binPrec CBinaryOp
CMulOp = Int
20
binPrec CBinaryOp
CDivOp = Int
20
binPrec CBinaryOp
CRmdOp = Int
20
binPrec CBinaryOp
CAddOp = Int
19
binPrec CBinaryOp
CSubOp = Int
19
binPrec CBinaryOp
CShlOp = Int
18
binPrec CBinaryOp
CShrOp = Int
18
binPrec CBinaryOp
CLeOp  = Int
17
binPrec CBinaryOp
CGrOp  = Int
17
binPrec CBinaryOp
CLeqOp = Int
17
binPrec CBinaryOp
CGeqOp = Int
17
binPrec CBinaryOp
CEqOp  = Int
16
binPrec CBinaryOp
CNeqOp = Int
16
binPrec CBinaryOp
CAndOp = Int
15
binPrec CBinaryOp
CXorOp = Int
14
binPrec CBinaryOp
COrOp  = Int
13
binPrec CBinaryOp
CLndOp = Int
12
binPrec CBinaryOp
CLorOp = Int
11