clua-0.3: CAnalyze.hs

{-# LANGUAGE NoMonomorphismRestriction, FlexibleInstances,
    FunctionalDependencies, MultiParamTypeClasses, TypeSynonymInstances #-}

module CAnalyze(reportC,
                aKeys,
                packedStructs,
                enums,  -- :: GobalDecls -> Map Ident Expr
                members,
                evalC,
                globalDecls) where

import qualified Data.ByteString.Char8  -- input for Language.C parser
import qualified Text.Show.Pretty       -- cabal install pretty-show

import Language.C                       -- cabal install language-c
import Language.C.Pretty                -- pretty-show
import Language.C.Data.Ident
import Language.C.Analysis.AstAnalysis
import Language.C.Analysis.TravMonad
import Language.C.Analysis.SemRep
-- import Language.C.Syntax.AST
-- import Language.C.Data.Position   

import Data.Map               -- Language.C.Analysis output
import Control.Monad

import System

import Char

import Data.Bits

-- FIXME:
-- 1.  No "Left" error handling: pattern matches will just fail.
-- 2.  Not every corner case is supported.

-------- AST analysis --------


-- Convert translation unit to GlobalDecls, using the Trav () monad
-- for analysis.
globalDecls tu = fst ds where
  Right ds = runTrav_ $ analyseAST tu


-- Filter out enums
enums :: GlobalDecls -> Map Ident Expr
enums = (Data.Map.mapMaybe getEnum) . gObjs where 
  unId (Ident id _ _) = id
  getEnum = p where
    p (EnumeratorDef (Enumerator (Ident id _ _) ex _ _)) = Just ex
    p _ = Nothing


-- Filter out packed structs from GlobalDecls.  All structure
-- definitions are in the gTags member of GlobalDecls.
packedStructs :: GlobalDecls -> Map SUERef TagDef
packedStructs = (Data.Map.filter isPacked) . gTags where
  isPacked = p where
    p (CompDef (CompType _ StructTag _ attrs _)) = packedAttr attrs
    p _ = False
  packedAttr = not . Prelude.null . (Prelude.filter f) where
    f (Attr (Ident id _ _) _ _) = 
      any (id ==) ["packed", "__packed__"]

-- For inspection of globalDecls analysis: get a list of keys of the
-- Map elements of GlobalDecls structure as a list of strings.
aKeys f = (Prelude.map show) . Data.Map.keys . f . globalDecls

members typ = mems where
  var (VarName (Ident id _ _) _) = id  
  mems = sequence . (Prelude.map mem)
  mem (MemberDecl (VarDecl v _ t) _ _) =
    case (typ t) of
      (Right td) -> Right (td, var v)
      (Left err) -> Left err




-- Simple expression evaluator.  Only supports const int and enums.
evalC syms = ex where
  ex (CVar id _) = ex $ syms Data.Map.! id
  ex (CConst (CIntConst (CInteger i _ _) _)) = Right $ i
  ex (CConst (CCharConst (CChar c _) _)) = Right $ toInteger $ ord c
  
  ex (CUnary op e _) = do
    e' <- ex e
    return $ (unop op) e'
    
  ex (CBinary op e1 e2 _) = do
    e1' <- ex e1
    e2' <- ex e2
    return $ (binop op) e1' e2'
    
  -- FIXME: This shouldn't be too hard..    
  -- ex (CSizeofType typ _) = sizeOf syms typ

  ex  e = Left $ "CExpr evaluation not supported: " ++ show e

  -- sizeOf syms (CDecl [CTypeSpec (CTypeDef nam _)] _ _) = Right 0
   
  binop CAddOp a b = a + b
  binop CShlOp a b = a * (2 ^ b)
  binop COrOp a b  = a .|. b
  binop op a b = error $ "Binop not supported: " ++ (show op)

  unop CMinOp a = -a

-------- Parsing and prettyprinting --------

-- Convert name and file contents to translation unit.
parseC' filename text = ast where
  (Right ast) = parseC (Data.ByteString.Char8.pack text) $ initPos filename

-- Same, but tied to filesystem in IO monad.
parseCFile' filename = do
  s <- readFile filename
  return $ parseC' filename s
  
-------- REPORTING --------

-- Print out report of analysis for a specific file.
reportC process file = do
  ast <- parseCFile' file
  case process ast of
    (Right rep) -> putStrLn rep
    (Left err) -> error err

-------- INTERACTIVE DEBUGGING --------

-- Clear the node info slot.
strip = fmap $ \_ -> ()

-- Prettyprinting AST.
ppAst = Text.Show.Pretty.ppShow . strip
ast = putStrLn . show. ppAst
pp = putStr . Text.Show.Pretty.ppShow
ppm m = do { v <- m ; pp v }


kObjs     = aKeys gObjs
kTypeDefs = aKeys gTypeDefs
kTags     = aKeys gTags  
kPacked   = aKeys packedStructs   -- is a filtered gTags


-- TEST
-- x f = reportC f "/tmp/test.c"