{-# LANGUAGE Rank2Types, ScopedTypeVariables, FlexibleInstances #-}
module GenericTree where
import Language.C
import Language.C.Syntax.AST
import Data.Tree
import Data.Typeable
import Data.Maybe
data AstNode =
AstNode String (TypeRep, forall a. (Typeable a) => a -> (Maybe a)) (Maybe NodeInfo)
| ListNode String
| ConstNode CConst
| IdentNode Ident
| InfoNode String
dynRep :: (Typeable a) => a -> (TypeRep, forall b. (Typeable b) => b -> (Maybe b))
dynRep a = (typeOf a, \_ -> cast a)
leaf :: AstNode -> Tree AstNode
leaf n = Node n []
constLeaf :: CConst -> Tree AstNode
constLeaf = leaf . ConstNode
identLeaf = leaf . IdentNode
infoLeaf :: String -> Tree AstNode
infoLeaf = leaf . InfoNode
renderLeaf :: (Typeable a, CNode a, Pretty v) => String -> a -> v -> Tree AstNode
renderLeaf lab t v = leaf $ AstNode (addLab.show.pretty $ v) (dynRep t) (Just $ nodeInfo t)
where addLab s | null lab = s
| otherwise = lab ++ ": " ++ s
emptyList :: Tree AstNode
emptyList = Node (ListNode "<empty>") []
listNode :: (TreeView a) => String -> [a] -> Tree AstNode
listNode lab = Node (ListNode lab) . map (treeView (init lab))
attrsNode :: [CAttr] -> Tree AstNode
attrsNode = listNode "attributes"
node :: (Typeable t, CNode t) => String -> t -> [Tree AstNode] -> Tree AstNode
node lab v kids = Node (AstNode lab (dynRep v) (Just $ nodeInfo v)) (filter (not.isEmptyList) kids) where
isEmptyList (Node (ListNode _) []) = True
isEmptyList _ = False
instance Show AstNode where
show (AstNode name _ _) = name
show (ListNode str) = str
show (ConstNode c) = (show.pretty) c
show (IdentNode i) = show i
show (InfoNode s) = s
class TreeView n where
treeView :: String -> n -> Tree AstNode
treeView' :: n -> Tree AstNode
treeView' n = treeView (defaultLabel n) n
defaultLabel :: n -> String
defaultLabel _ = "ast-node"
instance TreeView (Tree AstNode) where
treeView _ = id
instance TreeView Ident where
treeView _ = leaf . IdentNode
defaultLabel = identToString
instance TreeView CTranslUnit where
treeView name t@(CTranslUnit decls ni) =
node name t $ map treeView' decls
defaultLabel (CTranslUnit _ ni) = maybe "<nofile>" id (fileOfNode ni)
instance TreeView CExtDecl where
treeView _ (CDeclExt decl) = treeView "ext-decl" decl
treeView _ (CFDefExt fundef) = treeView "ext-fundef" fundef
treeView _ t@(CAsmExt asm ni) = node "ext-asm" t [constLeaf $ liftStrLit asm]
instance TreeView CFunDef where
treeView lab t@(CFunDef specs declr params stat ni) =
node (addName declr) t $
[ listNode "fun-def-specs" specs,
treeView "fun-def-declr" declr,
listNode "old-style-param-decls" params,
treeView "fun-def-stmt" stat ]
where
addName (CDeclr (Just ide) _ _ _ _) = lab ++ " " ++ show ide
addName _ = lab
instance TreeView CDecl where
treeView lab t@(CDecl specs decllist ni) = node (addNames lab) t $
[ listNode "decl-specs" specs,
listNode "declaration-body" (map declListEntry decllist)
]
where
declListEntry (Just declr,Nothing,Nothing) = treeView "declr" declr
declListEntry (declr,initi,bitsize) = listNode "decl-entry" $
catMaybes
[ fmap (treeView "declr") declr,
fmap (treeView "initializer") initi,
fmap (treeView "bitsize") bitsize
]
addNames lab = case catMaybes (map nameOfEntry decllist) of
[] -> lab
names -> lab ++ " {" ++ unwords (map show names) ++ "}"
nameOfEntry (Just (CDeclr (Just ide) _ _ _ _),_,_) = Just ide
nameOfEntry _ = Nothing
instance TreeView CDeclr where
treeView lab t@(CDeclr ide derived asm attrs ni) =
node (addName lab ide) t $
[ maybe emptyList identLeaf ide,
listNode "type-derivations" derived,
attrsNode attrs
]
where
addName lab = maybe lab (\s -> lab ++ " " ++ show s)
instance TreeView CDerivedDeclr where
treeView lab t@(CPtrDeclr quals ni) = node "ptr-deriv" t $ map (treeView "ptr-qual") quals
treeView lab t@(CArrDeclr quals sz ni) = node "arr-deriv" t $
[ listNode "arr-quals" quals,
treeView "arr-size" sz ]
treeView lab t@(CFunDeclr params attrs ni) = node "fun-deriv" t (paramsView++attrsView)
where
paramsView =
case params of
Right (params,variadic) -> [listNode "params" params] ++ (if variadic then [infoLeaf "variadic"] else [])
Left oldStyle -> [listNode "old-style-param-names" oldStyle]
attrsView = [listNode "fun-attrs" attrs]
instance TreeView CArrSize where
treeView _ (CNoArrSize True) = infoLeaf $ "variable size"
treeView _ (CNoArrSize False) = emptyList
treeView lab (CArrSize False c) = treeView lab c
treeView lab (CArrSize True c) = Node (ListNode lab) [ infoLeaf "static size", treeView "size" c ]
instance TreeView CStat where
treeView _ t =
case t of
CLabel ide stat attrs _ -> node "label" t [treeView "label-ident" ide,attrsNode attrs,treeView "label-stmt" stat]
CCase e s _ -> node "case" t [treeView "case" e, treeView "case-body" s]
CCases el eu s _ -> node "cases" t [treeView "case-lower" el, treeView "case-upper" eu, treeView "case-body" s]
CCompound i bis _ -> node "block" t [listNode "idents" i,listNode "block-items" bis]
CDefault s _ -> node "case-default" t [treeView "default-body" s]
CExpr Nothing _ -> node "empty-stmt" t []
CExpr (Just e) _ -> node "expr-stmt" t [ treeView "expr" e ]
CIf ife thens elses _ -> node "if-stmt" t $ [ treeView "if" ife, treeView "then-stmt" thens ] ++
(maybe [] return $ fmap (treeView "else-stmt") elses)
CSwitch es s _ -> node "switch-stmt" t $ [treeView "switch-body" s]
CWhile e s doWhile _ -> node (if doWhile then "do-while" else "while") t $
[treeView "while-guard" e, treeView "while-body" s]
CFor eInit eGuard eUpd stat _ -> node "for" t $ [ maybe (infoLeaf "no-for-init") id (initTree eInit),
maybe (infoLeaf "no-for-guard") (treeView "for-guard") eGuard,
maybe (infoLeaf "no-for-update") (treeView "for-update") eUpd]
CGoto ide _ -> node "goto" t [treeView "goto-label" ide]
CGotoPtr expr _ -> node "goto-ptr" t [treeView "goto" expr]
CCont _ -> node "continue" t []
CBreak _ -> node "break" t []
CReturn e _ -> node "return" t $ maybe [] return $ fmap (treeView "return") e
CAsm asm _ -> node "asm-stmt" t [treeView "asm" asm]
where
initTree (Left eInit) = fmap (treeView "for-init") eInit
initTree (Right initStmt) = Just (treeView "for-c99-init" initStmt)
instance TreeView CBlockItem where
treeView lab (CBlockStmt stmt) = treeView "block-stmt" stmt
treeView lab (CBlockDecl decl) = treeView "block-decl" decl
treeView lab (CNestedFunDef fundef) = treeView "nested-fun-def" fundef
instance TreeView CDeclSpec where
treeView _ t@(CStorageSpec v) = renderLeaf "" t v
treeView _ t@(CTypeSpec v) = renderLeaf "" t v
treeView _ t@(CTypeQual v) = renderLeaf "" t v
addLab "" = id
addLab s = ((s++).(" "++))
instance TreeView CExpr where
treeView mlab t =
let lab = case mlab of "" -> (\s -> s ++ "-expr"); l -> (\s -> l ++ " " ++ s ++ "-expr") in
case t of
CComma es _ -> node (lab "comma") t $ map (treeView "expr") es
CAssign op e1 e2 _ -> node (lab "assign-expr") t [ treeView "assign-op" op, treeView "lhs" e1, treeView "rhs" e2]
CCond guardE mTrueE falseE _ -> node (lab "cond") t [ treeView "guard" guardE,
maybe (infoLeaf "ommited-true") (treeView "true") mTrueE,
treeView "false" falseE]
CBinary op e1 e2 _ -> node (lab "bin") t [treeView "binary-op" op, treeView "left" e1, treeView "right" e2 ]
CCast decl expr _ -> node (lab "cast") t [ treeView "cast-type" decl, treeView "cast" expr]
CUnary unop expr _ -> node (lab "") t [treeView "unary-op" unop, treeView "sub" expr]
CSizeofExpr expr _ -> node (lab "sizeof") t [ treeView "expr" expr ]
CSizeofType decl _ -> node (lab "sizeof") t [ treeView "type-decl" decl ]
CAlignofExpr expr _ -> node (lab "alignof") t [ treeView "expr" expr]
CAlignofType decl _ -> node (lab "alignof-type") t [ treeView "type-decl" decl]
CComplexReal expr _ -> node (lab "complex-real") t [ treeView "expr" expr]
CComplexImag expr _ -> node (lab "complex-imag") t [ treeView "expr" expr]
CIndex target ix _ -> node (lab "index") t [ treeView "target" target, treeView "index" ix]
CCall fun args _ -> node (lab "call") t [ treeView "callee" fun, listNode "call-args" args ]
CMember expr member False _ -> node "member-of-struct" t [ treeView "struct" expr, treeView "member" member]
CMember expr member True _ -> node "member-of-ptr" t [ treeView "ptr" expr, treeView "member" member]
CVar ide _ -> node (lab "var") t [ identLeaf ide ]
CConst c -> treeView "const" c
CCompoundLit decl initList _ -> node (lab "compound-literal") t [ treeView "compound-type" decl,
initListTree "compound-lit" initList ]
CStatExpr stat _ -> node (lab "stmt") t [ treeView "expr-stmt" stat ]
CLabAddrExpr label _ -> node (lab "address-of-label") t [ treeView "label" label ]
CBuiltinExpr builtin -> treeView "builtin" builtin
instance TreeView CBuiltin where
treeView lab t@(CBuiltinVaArg expr decl _) = node "builtin-va-arg" t [ treeView "arg-ptr" expr, treeView "type" decl ]
treeView lab t@(CBuiltinOffsetOf typ desigs _) = node "builtin-offset-of" t [ treeView "type" typ, listNode "designators" desigs ]
treeView lab t@(CBuiltinTypesCompatible ty1 ty2 _) = node "builtin-types-compatible" t [ treeView "type-1" ty1, treeView "type-2" ty2]
instance TreeView CDesignator where
treeView lab t = renderLeaf lab t t
instance TreeView CAttr where
treeView lab t = renderLeaf lab t t
instance TreeView CTypeQual where
treeView lab t = renderLeaf "" t t
instance TreeView CInit where
treeView _ (CInitExpr e _) = treeView "init" e
treeView lab t@(CInitList l _) = renderLeaf lab t t
initListTree :: String -> CInitList -> Tree AstNode
initListTree lab = listNode lab . map initComp where
initComp (desigs,init) = listNode "member-init" [ listNode "designators" desigs, treeView "sub-init" init ]
instance TreeView CAsmStmt where
treeView lab t = renderLeaf lab t t
instance TreeView CAssignOp where
treeView _ t = infoLeaf $ (show.pretty) t
instance TreeView CBinaryOp where
treeView _ t = infoLeaf $ (show.pretty) t
instance TreeView CUnaryOp where
treeView _ t = infoLeaf $ (show.pretty) t
instance TreeView CConst where
treeView lab t = renderLeaf lab t t