clua-0.2: BStruct.hs

module BStruct (BSigned(..), BType(..), BStruct(..), bStructs, BEnum(..), bEnums) where
import CAnalyze

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 Data.List
import Control.Monad

import System

-- Simple enum dictionary type to complement BStruct.
data BEnum = BEnum [(String, Integer)] deriving (Show, Eq)

bEnums top = bes where
  syms = enums $ globalDecls top
  bes = liftM (BEnum . sort) $ sequence $ Prelude.map be $ assocs syms
  be (Ident id _ _, e) = 
    case evalC syms e of
      Right val -> Right (id, val)
      Left err  -> Left err


  

-- Binary representable types.  No pointers!
data BSigned = S | U deriving (Show, Eq)
data BType = BInt BSigned Integer
             | BFloat Integer
             | BArr Integer BType               
             | BComp SUERef      -- open recursion
             deriving (Show, Eq)
  
data BStruct = BStruct String [(BType, String)]
          deriving (Show, Eq)
                   
                
-- Base type representation.  Note that the point of parsing these
-- structs is to parse binary blobs, which do not contain pointer or
-- function pointers.

-- http://hackage.haskell.org/packages/archive/language-c/0.4.2/doc/html/Language-C-Analysis-SemRep.html#t:Type
flatType syms = typ where
  
  oops msg x = error $ "\n" ++ msg ++ "\n" ++ (show x)
  
  typ (DirectType name quals attrs) = nam name
  typ (TypeDefType ref quals attrs) = tdnam ref
  typ (ArrayType t s quals attrs) = do
    s' <- as s
    t' <- typ t
    return $ BArr s' t'
  -- PtrType Type TypeQuals Attributes	
  -- FunctionType FunType Attributes	
  typ _ = Left $ "PtrTpe or FunctionType are not flat types"

  as (ArraySize _ e) = evalC syms e

  -- tdnam (TypeDefRef (Ident id _ _) Nothing _) = id 
  tdnam (TypeDefRef  _ (Just t) _) = typ t  -- recurse down typedefs
  tdnam _ = Left $ "TypeDefRef: no type"

  nam (TyIntegral t) = Right $ int t
  nam (TyFloating t) = Right $ float t
  nam (TyComp (CompTypeRef sueref kind _)) = Right $ BComp sueref

  
  -- FIXME: support when needed                       
  nam TyVoid        = Left $ "TyVoid not supported"
  nam (TyComplex _) = Left $ "TyComplex not supported"
  nam (TyEnum    _) = Left $ "TyEnum not supported"
  nam (TyBuiltin _) = Left $ "TyBuiltin not supported"

  -- IntType
  int TyBool   = BInt U 1
  
  int TyUChar  = BInt U 8
  int TyUShort = BInt U 16
  int TyUInt   = BInt U 32
  int TyULong  = BInt U 32
  int TyULLong = BInt U 64
  
  int TyChar   = BInt S 8
  int TySChar  = BInt S 8
  int TyShort  = BInt S 16
  int TyInt    = BInt S 32
  int TyLong   = BInt S 32
  int TyLLong  = BInt S 64

  -- FloatType
  float TyFloat  = BFloat 32
  float TyDouble = BFloat 64


flat syms = sequence . Data.Map.elems . (Data.Map.map f)  where
  f (CompDef (CompType r StructTag ms _ _)) = rv where
    rv = case members (flatType syms) ms of
      Right m -> Right $ BStruct (ref r) m
      Left err -> Left err
    
  ref (NamedRef (Ident id _ _)) = id

                                       


-- Distill binary packed structs.
bStructs toplevel = flt where
  gs = globalDecls toplevel
  es = enums gs
  ss = packedStructs gs
  flt = flat es ss
  
-- bEnums toplevel   

                   
-- TEST
-- x f = report f "/tmp/test.c"
-- x (aKeys packedStructs)