1{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
2{-# OPTIONS -fno-warn-orphans #-}
3-----------------------------------------------------------------------------
4-- |
5-- Module      :  Language.C.Analysis.Debug
6-- Copyright   :  (c) 2008 Benedikt Huber
7-- License     :  BSD-style
8-- Maintainer  :  benedikt.huber@gmail.com
9-- Stability   :  prototype
10-- Portability :  ghc
11--
12-- Pretty printing the semantic analysis representation.
13-- This is currently only intended for debugging purposes.
14-----------------------------------------------------------------------------
15module Language.C.Analysis.Debug (
16globalDeclStats,
17prettyAssocs, prettyAssocsWith,
18-- and many pretty instances
19)
20where
21import Language.C.Analysis.SemRep
22import Language.C.Analysis.Export
23import Language.C.Analysis.DefTable
24import Language.C.Analysis.NameSpaceMap
25
26import Language.C.Data
27import Language.C.Pretty
28
29import Prelude hiding ((<>))
30import Text.PrettyPrint.HughesPJ
31import Data.Map (Map) ; import qualified Data.Map as Map
32
33prettyAssocs :: (Pretty k, Pretty v) => String -> [(k,v)] -> Doc
34prettyAssocs label = prettyAssocsWith label pretty pretty
35prettyAssocsWith :: String -> (k -> Doc) -> (v -> Doc) -> [(k,v)] -> Doc
36prettyAssocsWith label prettyKey prettyVal theMap =
37    text label $$ nest 8 (vcat $ map prettyEntry theMap)
38    where
39    prettyEntry (k,v) = prettyKey k <+> text " ~> " <+> prettyVal v
40
41instance Pretty DefTable where
42    pretty dt = text "DefTable" $$ nest 4 (vcat defMaps)
43        where
44        defMaps = [ prettyNSMap "idents" identDecls
45                  , prettyNSMap "tags" tagDecls
46                  , prettyNSMap "labels" labelDefs
47                  , prettyNSMap "members" memberDecls
48                  ]
49        prettyNSMap label f = prettyAssocs label . nsMapToList $ f dt
50
51instance Pretty GlobalDecls where
52    pretty gd = text "Global Declarations" $$ (nest 4 $ vcat declMaps)
53        where
54        declMaps = [ prettyMap "enumerators" theEnums, prettyMap "declarations" theDecls,
55                     prettyMap "objects" theObjs,  prettyMap "functions" theFuns,
56                     prettyMap "tags"    $ gTags gd,  prettyMap "typeDefs"  $ gTypeDefs gd ]
57        prettyMap :: (Pretty t, Pretty k) => String -> Map k t -> Doc
58        prettyMap label = prettyAssocs label . Map.assocs
59        (theDecls, (theEnums, theObjs, theFuns)) = splitIdentDecls False (gObjs gd)
60
61globalDeclStats :: (FilePath -> Bool) -> GlobalDecls -> [(String,Int)]
62globalDeclStats file_filter gmap =
63    [ ("Enumeration Constants",Map.size enumerators),
64      ("Total Object/Function Declarations",Map.size all_decls),
65      ("Object definitions", Map.size objDefs),
66      ("Function Definitions", Map.size funDefs),
67      ("Tag definitions", Map.size tagDefs),
68      ("TypeDefs", Map.size typeDefs)
69    ]
70    where
71    gmap' = filterGlobalDecls filterFile gmap
72    (all_decls,(enumerators,objDefs,funDefs)) = splitIdentDecls True (gObjs gmap')
73    (tagDefs,typeDefs) = (gTags gmap', gTypeDefs gmap')
74    filterFile :: (CNode n) => n -> Bool
75    filterFile = maybe True file_filter . fileOfNode . nodeInfo
76
77instance (Pretty a, Pretty b) => Pretty (Either a b) where
78    pretty = either pretty pretty
79instance Pretty TagFwdDecl where
80    pretty (CompDecl ct) = pretty ct
81    pretty (EnumDecl et) = pretty et
82instance Pretty CompTyKind where
83    pretty StructTag = text "struct"
84    pretty UnionTag = text "union"
85instance Pretty CompTypeRef where
86    pretty (CompTypeRef sue kind _) = pretty kind <+> pretty sue
87instance Pretty EnumTypeRef where
88    pretty (EnumTypeRef sue _ ) = text "enum" <+> pretty sue
89instance Pretty Ident where
90    pretty = text . identToString
91instance Pretty SUERef where
92    pretty (AnonymousRef name) = text $ "$" ++ show (nameId name)
93    pretty (NamedRef ident) = pretty ident
94instance Pretty TagDef where
95    pretty (CompDef compty) = pretty compty
96    pretty (EnumDef enumty) = pretty enumty
97instance Pretty IdentDecl where
98    pretty (Declaration decl) = pretty decl
99    pretty (ObjectDef odef) = pretty odef
100    pretty (FunctionDef fdef) = pretty fdef
101    pretty (EnumeratorDef enumerator) = pretty enumerator
102instance Pretty Decl where
103    pretty (Decl vardecl _) =
104        text "declaration" <+>
105        pretty vardecl
106instance Pretty TypeDef where
107    pretty (TypeDef ident ty attrs _) =
108        text "typedef" <+> pretty ident <+> text "as"  <+>
109        pretty attrs <+> pretty ty
110instance Pretty ObjDef where
111    pretty (ObjDef vardecl init_opt _) =
112        text "object" <+>
113        pretty vardecl <+> maybe empty (((text "=") <+>) . pretty) init_opt
114instance Pretty FunDef where
115    pretty (FunDef vardecl _stmt _) =
116        text "function" <+>
117        pretty vardecl
118instance Pretty VarDecl where
119    pretty (VarDecl name attrs ty) =
120        ((hsep . punctuate (text " |")) [pretty name, pretty attrs, pretty ty])
121instance Pretty ParamDecl where
122    pretty (ParamDecl (VarDecl name declattrs ty) _) =
123        pretty declattrs <+> pretty name <+> text "::" <+> pretty ty
124    pretty (AbstractParamDecl (VarDecl name declattrs ty) _) =
125        text "abstract" <+> pretty declattrs <+> pretty name <+>
126             text "::" <+> pretty ty
127instance Pretty DeclAttrs where
128    pretty (DeclAttrs fun_attrs storage attrs) =
129        hsep [ pretty fun_attrs, pretty storage, pretty attrs]
130
131instance Pretty Type where
132  pretty ty = pretty (exportTypeDecl ty)
133instance Pretty TypeQuals where
134    pretty tyQuals = hsep $ map showAttr [ ("const",constant),("volatile",volatile),("restrict",restrict) ]
135        where showAttr (str,select) | select tyQuals = text str
136                                    | otherwise      = empty
137
138instance Pretty CompType where
139    pretty (CompType sue_ref tag members attrs _node) =
140        (text.show) tag <+> pretty sue_ref <+>
141        braces (terminateSemi members) <+>
142        pretty attrs
143
144instance Pretty MemberDecl where
145    pretty (MemberDecl (VarDecl name declattrs ty) bitfield _) =
146        pretty declattrs <+> pretty name <+> text "::" <+> pretty ty <+>
147        (maybe empty (\bf -> text ":" <+> pretty bf) bitfield)
148    pretty (AnonBitField ty bitfield_sz _) =
149        pretty ty <+> text ":" <+> pretty bitfield_sz
150
151instance Pretty EnumType where
152    pretty (EnumType sue_ref enumerators attrs _) =
153      text "enum" <+> pretty sue_ref <+> braces (terminateSemi_ $ map prettyEnr enumerators) <+> pretty attrs
154      where
155      prettyEnr (Enumerator ident expr _enumty _) = pretty ident <+> text " = " <+> pretty expr
156
157instance Pretty Enumerator where
158    pretty (Enumerator ident expr enumty _) = text "<" <> text "econst" <+> pretty (sueRef enumty) <> text ">" <+>
159                                              pretty ident <+> text " = " <+> pretty expr
160
161instance Pretty FunctionAttrs where
162    pretty fattrs = hsep [pIf isInline "inline", pIf isNoreturn "_Noreturn"]
163      where
164        pIf isMatch txt = if isMatch fattrs then text txt else empty
165
166instance Pretty Storage where
167    pretty NoStorage = empty
168    pretty (Auto reg) = text$ if reg then "auto/register" else "auto"
169    pretty (Static linkage thread_local) =
170        (hcat . punctuate (text "/") $ [ text "static",pretty linkage ])
171        <+> (if thread_local then text ", __thread" else empty)
172    pretty (FunLinkage linkage) = text "function/" <> pretty linkage
173instance Pretty Linkage where
174    pretty InternalLinkage = text "internal"
175    pretty ExternalLinkage = text "external"
176    pretty NoLinkage       = text "local"
177instance Pretty VarName where
178    pretty NoName = text "<anonymous>"
179    pretty (VarName ident asmname_opt) = pretty ident <+> (maybe empty pAsmName asmname_opt)
180        where pAsmName asmname = text "" <+> parens (text "asmname" <+> pretty asmname)
181instance Pretty Attributes where
182    pretty = joinComma
183instance Pretty Attr where
184    pretty (Attr ident es _) = pretty ident <+> (if null es then empty else text "(...)")
185
186joinComma :: (Pretty a) => [a] -> Doc
187joinComma = hsep . punctuate comma . map pretty
188terminateSemi :: (Pretty a) => [a] -> Doc
189terminateSemi = terminateSemi_ . map pretty
190terminateSemi_ :: [Doc] -> Doc
191terminateSemi_ = hsep . map (<> semi)
192
193