clua 0.1 → 0.2
raw patch · 4 files changed
+345/−2 lines, 4 files
Files
- BStruct.hs +128/−0
- CAnalyze.hs +135/−0
- PrintLua.hs +80/−0
- clua.cabal +2/−2
+ BStruct.hs view
@@ -0,0 +1,128 @@+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)
+ CAnalyze.hs view
@@ -0,0 +1,135 @@+{-# 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++-- 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 (CBinary op e1 e2 _) = do+ e1' <- ex e1+ e2' <- ex e2+ return $ (binop op) e1' e2'++ ex e = Left $ "CExpr evaluation not supported: " ++ show e+ + binop CAddOp a b = a + b+ binop CShlOp a b = a * (2 ^ b)++-------- 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"+
+ PrintLua.hs view
@@ -0,0 +1,80 @@+module PrintLua(packedLua, LuaData(..)) where+import CAnalyze+import BStruct+import Text.PrettyPrint.HughesPJ+import Control.Monad++-- (useful subset of) Lua data syntax.+data LuaData = LuaStr String+ | LuaNum String+ | LuaTable [(LuaData, LuaData)] deriving (Eq)+ +-- Prettyprinting with Text.PrettyPrint.HughesPJ+instance Show LuaData where+ show = (++"\n") . show . docLua++docLua (LuaNum s) = text s+docLua (LuaStr s) = quotes $ text s+docLua (LuaTable xs) = doc where+ doc = nest 2 $ braces $ cat $ punctuate comma $ list xs+ list xs = zipWith pair [1..] xs+ pair i (k,v) = docPair i k $ docLua v++-- If i is in sequence, don't print index.+docPair i (LuaNum n) sv | show i == n = sv+docPair _ n@(LuaNum _) sv = cat [ brackets $ docLua n, sv ]+docPair _ (LuaStr s) sv = cat [cat [text s, equals], sv]+docPair _ (LuaTable t) sv = error $ "Table as key."++++-- Compile BStruct list to Lua++-- List as table.+luaList :: [LuaData] -> LuaData+luaList es = LuaTable $ zipWith entry [1..] es where+ entry i e = (LuaNum $ show i, e)++-- We only use string-indexed pairs. For index: use luaList.+luaPair s e = (LuaStr s, e) ++-- Can't use keys because order is important, so we just use the first+-- element of an array as the tag.+luaTagList tag ls = luaList (LuaStr tag : ls)++luaBStructs = LuaTable . (map pair) where+ + pair (BStruct name mems) = luaPair name $ luaList $ map mem mems+ mem (t, n) = luaList [typ t, LuaStr n]+ + typ (BInt s b) = luaTagList "int" [sign s, bits b]+ typ (BFloat b) = luaTagList "float" [bits b]+ typ (BComp r) = luaTagList "struct" [ref r]+ typ (BArr s t) = luaTagList "array" [size s, typ t]+ + sign = LuaStr . show+ bits = LuaNum . show+ size = LuaNum . show+ ref = LuaStr . show+ +luaBEnums (BEnum ls) = LuaTable $ map be ls where+ be (nam, val) = luaPair nam $ LuaNum $ show val+ ++-- Wrap around C analyser.+packedLua = reportC process where+ process ast = do+ bs <- bStructs ast+ be <- bEnums ast+ let + ls = luaBStructs bs+ es = luaBEnums be+ tab = LuaTable [(LuaStr "struct", ls),+ (LuaStr "enum", es)]+ in do + return $ ("return\n" ++) $ show $ tab++ +-- TEST +-- x = packedLua "/tmp/test.c"+-- x = packedLua "/home/tom/structs.E.c"
clua.cabal view
@@ -1,5 +1,5 @@ Name: clua-Version: 0.1+Version: 0.2 Synopsis: C to Lua data wrapper generator Homepage: http://zwizwa.be/-/meta License: BSD3@@ -8,7 +8,7 @@ Maintainer: tom@zwizwa.be Category: Language Build-type: Simple-Extra-source-files: README, parse-bin.lua+Extra-source-files: README, parse-bin.lua, BStruct.hs, CAnalyze.hs, PrintLua.hs Cabal-version: >=1.2 Description: Gather enums and packed struct definitions from a C file