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