GCCXML.hs

-- c-repl: a C read-eval-print loop.
-- Copyright (C) 2008 Evan Martin <martine@danga.com>

-- This module parses GCCXML output, giving you a parse tree of C code.

module GCCXML (
  Symbol(..),

  -- The main parser/driver, @symbols code@ returns either an error or a list of
  -- resolved Symbols.
  symbols,

  -- Print a user-friendly version of a Symbol.
  showSymbol
) where

import Prelude hiding (catch)
import Control.Monad.Error
import Control.Exception
import qualified Data.ByteString as BS
import Data.Maybe (mapMaybe)
import Data.List (intercalate)
import qualified Data.Map as M
import System.Exit
import System.IO
import System.Process
import qualified Text.XML.Expat.Tree as Expat

type XML = BS.ByteString
type XMLNode = Expat.Node String String

-- @runGCCXML code@ runs a gccxml process on |code|, returning the XML output
-- or an error string on error.
runGCCXML :: String -> IO (Either String XML)
runGCCXML code = run `catch` (\e -> do print (e :: IOException); undefined) where
  run = do
    let cmd = "gccxml - -fxml=/dev/stdout"
    (inp,out,err,pid) <- runInteractiveCommand cmd
    hPutStr inp code
    hClose inp
    output <- BS.hGetContents out
    error <- hGetContents err
    exit <- BS.length output `seq` waitForProcess pid
    return $ case exit of
      ExitSuccess      -> return output
      ExitFailure _code -> throwError error

-- Symbol resolution: gccxml outputs a DAG as a flat list of nodes with ids
-- and pointers to other nodes.  While parsing, we build a Map of symbol
-- id -> unresolved symbol info, and then once parsing is complete we resolve
-- all references into the real DAG.

-- The identity of a symbol as output by gccxml, such as "_341".
type SymbolId = String
-- A map from symbol id to unresolved symbol.
type SymbolMap = M.Map SymbolId UnrSym
-- An unresolved symbol is either a UnrSym, awaiting a complete SymbolMap,
-- or it's a ResSym, a base case child node like "int".
data UnrSym = UnrSym (SymbolMap -> Either String UnrSym)
            | ResSym Symbol

-- Description of a C-level type.
data CType = Array CType
           | Const CType
           | Enum String
           | Fundamental String
           | CFunction [CType]
           | Pointer CType
           | Struct String
           | Typedef String
           | Union String
           deriving Show

showCType (Array t)       = showCType t ++ "[]"
showCType (Const t)       = showCType t ++ " const"
showCType (Enum t)        = t
showCType (Fundamental t) = t
showCType (CFunction _t)   = "[function]"
showCType (Pointer t)     = showCType t ++ "*"
showCType (Struct t)      = t
showCType (Typedef t)     = t
showCType (Union t)       = t

-- The symbols we parse out of gccxml: currently just functions and types.
data Symbol = Function String [String]
            | Type CType
            deriving Show

showSymbol :: GCCXML.Symbol -> String
showSymbol (Function name args) = name ++ "(" ++ intercalate ", " args ++ ")"
showSymbol (Type typ) = showCType typ

-- Given a symbol map and an unresolved symbol, resolve it to a plain symbol
-- or throw an error.
resolve :: SymbolMap -> UnrSym -> Either String Symbol
resolve map (UnrSym f) = f map >>= resolve map
resolve _map (ResSym s) = return s

-- Given a symbol map and an unresolved symbol, resolve it to a type or throw
-- an error.
resolveType :: SymbolMap -> UnrSym -> Either String CType
resolveType map unr = do
  sym <- resolve map unr
  case sym of
    Type ct -> return ct
    x       -> throwError (show x)

-- Convert a plain symbol id to an UnrSym: the unresolved symbol the id
-- references.
symref :: SymbolId -> UnrSym
symref id = UnrSym (\symbolmap ->
  case M.lookup id symbolmap :: Maybe UnrSym of
    Nothing -> Left $ "lookup failed: " ++ id
    Just ok -> Right ok)

symbols :: String -> IO (Either String [Symbol])
symbols code = runErrorT $ do
  xml <- ErrorT $ runGCCXML code
  ErrorT $ return $ parseSymbols xml
  where
  parseSymbols :: XML -> Either String [Symbol]
  parseSymbols xml = do
    tree <- case Expat.parseTree' Nothing xml of
              Left err -> throwError (show err)
              Right (Expat.Element _root _attrs tree) -> return tree
    let nodes = mapMaybe parseNode tree
    let symbolmap = M.fromList nodes
    mapM (resolve symbolmap . snd) nodes
  parseNode :: XMLNode -> Maybe (SymbolId, UnrSym)
  parseNode (Expat.Element typ attrs kids) = do
    sym <- parseSymbol typ attrs kids
    id <- lookup "id" attrs
    return (id, sym)
  parseNode _ = Nothing

  parseSymbolType0Arg :: [(String,String)] -> (String -> CType) -> Maybe UnrSym
  parseSymbolType0Arg attrs constructor = do
    name <- lookup "name" attrs
    return $ ResSym $ Type $ constructor (prettify name)

  parseSymbolType1Arg :: [(String,String)] -> (CType -> CType) -> Maybe UnrSym
  parseSymbolType1Arg attrs constructor = do
    innertypeid <- lookup "type" attrs
    return $ UnrSym $ \symbolmap -> do
      innertype <- resolveType symbolmap (symref innertypeid)
      return $ ResSym $ Type $ constructor innertype

  parseSymbol :: String -> [(String,String)] -> [XMLNode] -> Maybe UnrSym
  parseSymbol "Function" attrs kids = do
    name <- lookup "name" attrs
    when (isInternal name) Nothing
    let args = mapMaybe parseFunctionArg kids
    return $ UnrSym $ \symbolmap -> do
      args' <- forM args $ \(unr, name) -> do
        ctype <- resolveType symbolmap unr
        return $ showCType ctype ++ " " ++ name
      return $ ResSym $ Function name args'
  parseSymbol "Union" attrs _kids = do
    name <- msum [lookup "name" attrs, lookup "demangled" attrs, Just "anon"]
    return $ ResSym $ Type $ Union (prettify name)
  parseSymbol "Struct" attrs _kids = do
    name <- msum [lookup "name" attrs, lookup "demangled" attrs, Just "anon"]
    return $ ResSym $ Type $ Struct (prettify name)
  parseSymbol "FunctionType" _attrs _kids = do
    return $ ResSym $ Type $ CFunction []
  parseSymbol "Enumeration"     attrs _ = parseSymbolType0Arg attrs Enum
  parseSymbol "FundamentalType" attrs _ = parseSymbolType0Arg attrs Fundamental
  parseSymbol "Typedef"         attrs _ = parseSymbolType0Arg attrs Typedef
  parseSymbol "ArrayType"       attrs _ = parseSymbolType1Arg attrs Array
  parseSymbol "CvQualifiedType" attrs _ = parseSymbolType1Arg attrs Const
  parseSymbol "PointerType"     attrs _ = parseSymbolType1Arg attrs Pointer
  parseSymbol _ _ _ = Nothing

  parseFunctionArg :: XMLNode -> Maybe (UnrSym, String)
  parseFunctionArg (Expat.Element "Argument" attrs _) = do
    name <- lookup "name" attrs
    typeid <- lookup "type" attrs
    return (symref typeid, prettify name)
  parseFunctionArg _ = Nothing

  isInternal :: String -> Bool
  isInternal ('_':_) = True
  isInternal _       = False

  prettify ('_':'_':name) = name
  prettify name           = name