c2hsc (empty) → 0.1.0
raw patch · 5 files changed
+519/−0 lines, 5 filesdep +HStringTemplatedep +basedep +containerssetup-changed
Dependencies added: HStringTemplate, base, containers, directory, filepath, language-c, mtl, pretty, transformers
Files
- LICENSE +28/−0
- Main.hs +444/−0
- README.md +10/−0
- Setup.hs +2/−0
- c2hsc.cabal +35/−0
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2012, John Wiegley. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++- Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++- Neither the name of New Artisans LLC nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,444 @@+module Main where++import Control.Applicative+import Control.Monad hiding (sequence)+import Control.Monad.Trans.State+import Data.Char+import Data.Foldable+import Data.List hiding (concat)+import qualified Data.Map as M+import Data.Maybe+import Data.Traversable+import Language.C.Data.Ident+import Language.C.Data.InputStream+import Language.C.Data.Node+import Language.C.Data.Position+import Language.C.Parser+import Language.C.Pretty+import Language.C.Syntax.AST+import Language.C.System.GCC+import Language.C.System.Preprocess+import Prelude hiding (concat, sequence)+import System.Directory+import System.Environment+import System.FilePath+import System.IO+import Text.PrettyPrint as P+import Text.StringTemplate++------------------------------ IMPURE FUNCTIONS ------------------------------++-- Parsing of C headers begins with finding gcc so we can run the+-- preprocessor.++main :: IO ()+main = do+ gccExe <- findExecutable "gcc"+ case gccExe of+ Nothing -> error "Cannot find 'gcc' executable on the PATH"+ Just gccPath -> getArgs >>= parseFile gccPath++-- Once gcc is found, setup to parse the C file by running the preprocessor.+-- Then, identify the input file absolutely so we know which declarations to+-- print out at the end.++parseFile :: FilePath -> [String] -> IO ()+parseFile gccPath args = do+ fileName <- canonicalizePath $ last args+ result <- runPreprocessor (newGCC gccPath)+ (rawCppArgs (tail . init $ args) fileName)+ case result of+ Left err -> error $ "Failed to run cpp: " ++ show err+ Right stream -> do+ let HscOutput hscs helpercs _ =+ execState (parseCFile stream fileName (initPos fileName))+ newHscState+ writeProducts (head args) fileName hscs helpercs++-- Write out the gathered data++writeProducts :: String -> FilePath -> [String] -> [String] -> IO ()+writeProducts libName fileName hscs helpercs = do+ let tmpl = unlines [ "#include <bindings.dsl.h>"+ , "#include <git2.h>"+ , "module $libName$.$cFileName$ where"+ , "#strict_import"+ , "" ]+ vars = [ ("libName", libName)+ , ("cFileName", cap) ]+ code = newSTMP tmpl+ base = dropExtension . takeFileName $ fileName+ cap = capitalize base++ let target = cap ++ ".hsc"+ handle <- openFile target WriteMode++ hPutStrLn handle $ toString $ setManyAttrib vars code++ -- Sniff through the file again, but looking only for local #include's+ contents <- readFile fileName+ let includes = filter ("#include \"" `isPrefixOf`) (lines contents)++ for_ includes $ \inc ->+ hPutStrLn handle $ "import "+ ++ libName ++ "."+ ++ (capitalize . takeWhile (/= '.') . drop 10 $ inc)++ traverse_ (hPutStrLn handle) hscs++ hClose handle+ putStrLn $ "Wrote " ++ target++ when (length helpercs > 0) $ do+ let targetc = cap ++ ".hsc.helper.c"+ handlec <- openFile targetc WriteMode++ hPutStrLn handlec "#include <bindings.cmacros.h>"+ traverse_ (hPutStrLn handlec) includes+ hPutStrLn handlec ""+ traverse_ (hPutStrLn handlec) helpercs++ hClose handlec+ putStrLn $ "Wrote " ++ targetc++ where capitalize [] = []+ capitalize (x:xs) = toTitle x : xs++------------------------------- PURE FUNCTIONS -------------------------------++-- Rather than writing to the .hsc and .hsc.helper.c files directly from the+-- IO monad, they are collected in an HscOutput value in the State monad. The+-- actual writing is done by writeProducts. This keeps all the code below+-- pure, and since the data sets involved are relatively small, performance is+-- not a critical issue.++type TypeMap = M.Map String String+data HscOutput = HscOutput [String] [String] TypeMap+type Output = State HscOutput++newHscState :: HscOutput+newHscState = HscOutput [] [] M.empty++appendHsc :: String -> Output ()+appendHsc hsc = do+ HscOutput hscs xs types <- get+ put $ HscOutput (hscs ++ [hsc]) xs types++appendHelper :: String -> Output ()+appendHelper helperc = do+ HscOutput xs helpercs types <- get+ put $ HscOutput xs (helpercs ++ [helperc]) types++defineType :: String -> String -> Output ()+defineType key value = do+ HscOutput xs ys types <- get+ put $ HscOutput xs ys (M.insert key value types)++lookupType :: String -> Output (Maybe String)+lookupType key = do+ HscOutput _ _ types <- get+ return $ M.lookup key types++-- Now we are ready to parse the C code from the preprocessed input stream,+-- located in the given file and starting at the specified position. The+-- result of a parse is a list of global declarations, so filter the list down+-- to those occurring in the target file, and then print the declarations in+-- Bindings-DSL format.++parseCFile :: InputStream -> FilePath -> Position -> Output ()+parseCFile stream fileName pos =+ case parseC stream pos of+ Left err -> error $ "Failed to compile: " ++ show err+ Right (CTranslUnit decls _) -> generateHsc decls++ where+ generateHsc :: [CExtDecl] -> Output ()+ generateHsc = traverse_ (appendNode fileName)++declInFile :: FilePath -> CExtDecl -> Bool+declInFile fileName = (fileName ==) . infoFile . declInfo++infoFile :: NodeInfo -> String+infoFile = posFile . posOfNode++declInfo :: CExtDecl -> NodeInfo+declInfo (CDeclExt (CDecl _ _ info)) = info+declInfo (CFDefExt (CFunDef _ _ _ _ info)) = info+declInfo (CAsmExt _ info) = info++-- These are the top-level printing routines. We are only interested in+-- declarations and function defitions (which almost always means inline+-- functions if the target file is a header file).+--+-- We will end up printing the following constructs:+--+-- - Structure definitions+-- - Opaque types (i.e., forward declarations of pointer type)+-- - Enums+-- - Extern Functions+-- - Inline Functions++appendNode :: FilePath -> CExtDecl -> Output ()++appendNode fp dx@(CDeclExt (CDecl declSpecs items _)) =+ for_ items $ \(declrtr, _, _) -> do+ for_ (splitDecl declrtr) $ \(d, ddrs, name) ->+ case ddrs of+ CFunDeclr (Right (_, _)) _ _ : _ ->+ when (declInFile fp dx) $+ appendFunc "#ccall" declSpecs d++ _ -> do+ when (declInFile fp dx) $ do+ appendHsc $ "{- " ++ P.render (pretty dx) ++ " -}"+ appendType declSpecs name++ -- If the type is a typedef, record the equivalence so we can look+ -- it up later+ case head declSpecs of+ CStorageSpec (CTypedef _) -> do+ -- jww (2012-09-04): Types which are typedefs of functions+ -- pointers are not working, since declSpecTypeName only gives+ -- the function return type, not the function type+ dname <- declSpecTypeName declSpecs+ case dname of+ "" -> return ()+ _ -> defineType name dname+ _ -> return ()++ where splitDecl declrtr = do+ -- Take advantage of the Maybe monad to save us some effort+ d@(CDeclr ident ddrs _ _ _) <- declrtr+ (Ident name _ _) <- ident+ return (d, ddrs, name)++appendNode fp dx@(CFDefExt (CFunDef declSpecs declrtr _ _ _)) =+ -- Assume functions defined in headers are inline functions+ when (declInFile fp dx) $ do+ appendFunc "#cinline" declSpecs declrtr++ case declrtr of+ (CDeclr ident ddrs _ _ _) ->+ for_ ident $ \(Ident name _ _) ->+ case head ddrs of+ (CFunDeclr (Right (decls, _)) _ _) -> do+ let argsList =+ concat . intersperse ", " . map (P.render . pretty) $ decls+ retType <- derDeclrTypeName' True declSpecs (tail ddrs)+ if retType /= ""+ then appendHelper $ "BC_INLINE" ++ show (length decls)+ ++ "(" ++ name ++ ", " ++ argsList+ ++ ", " ++ retType ++ ")"+ else appendHelper $ "BC_INLINE" ++ show (length decls)+ ++ "VOID(" ++ name ++ ", " ++ argsList ++ ")"+ _ -> return ()++appendNode _ (CAsmExt _ _) = return ()++-- Print out a function as #ccall or #cinline. The syntax is the same for+-- both externs and inlines, except that we want to do extra work for inline+-- and create a helper file with some additional macros.++appendFunc :: String -> [CDeclarationSpecifier a] -> CDeclarator a -> Output ()+appendFunc marker declSpecs (CDeclr ident ddrs _ _ _) = do+ retType <- derDeclrTypeName declSpecs (tail ddrs)+ argTypes <- sequence $ getArgTypes (head ddrs)++ let name' = nameFromIdent ident+ tmpl = "$marker$ $name$ , $argTypes;separator=' -> '$ -> IO ($retType$)"+ code = newSTMP tmpl+ -- I have to this separately since argTypes :: [String]+ code' = setAttribute "argTypes" argTypes code+ vars = [ ("marker", marker)+ , ("name", name')+ , ("retType", retType) ]++ appendHsc $ toString $ setManyAttrib vars code'++ where+ getArgTypes (CFunDeclr (Right (decls, _)) _ _) = map cdeclTypeName decls+ getArgTypes _ = []++ nameFromIdent :: Maybe Ident -> String+ nameFromIdent name = case name of+ Just (Ident n _ _) -> n+ _ -> "<no name>"++appendType :: [CDeclarationSpecifier a] -> String -> Output ()+appendType declSpecs declrName = traverse_ appendType' declSpecs+ where+ appendType' (CTypeSpec (CSUType (CStruct _ ident decls _ _) _)) = do+ let name' = identName ident+ when (isNothing decls) $+ appendHsc $ "#opaque_t " ++ name'++ for_ decls $ \xs -> do+ appendHsc $ "#starttype " ++ name'+ for_ xs $ \x ->+ for_ (cdeclName x) $ \declName -> do+ tname <- cdeclTypeName x+ appendHsc $ "#field " ++ declName ++ " , " ++ tname+ appendHsc "#stoptype"++ appendType' (CTypeSpec (CEnumType (CEnum ident defs _ _) _)) = do+ let name' = identName ident+ appendHsc $ "#integral_t " ++ name'++ for_ defs $ \ds ->+ for_ ds $ \((Ident name _ _), _) -> do+ appendHsc $ "#num " ++ name++ appendType' _ = return ()++ identName ident = case ident of+ Nothing -> declrName+ Just (Ident name _ _) -> name++-- The remainder of this file is some hairy code for turning various+-- constructs into Bindings-DSL type names, such as turning "int ** foo" into+-- the type name "Ptr (Ptr CInt)".++data Signedness = None | Signed | Unsigned deriving (Eq, Show, Enum)++cdeclName :: CDeclaration a -> Maybe String+cdeclName (CDecl _ more _) =+ case more of+ (Just (CDeclr (Just (Ident name _ _)) _ _ _ _), _, _) : _ -> Just name+ _ -> Nothing++cdeclTypeName :: CDeclaration a -> Output String+cdeclTypeName (CDecl declSpecs more _) =+ case more of+ (Just x, _, _) : _ -> declrTypeName declSpecs x+ _ -> declSpecTypeName declSpecs++declSpecTypeName :: [CDeclarationSpecifier a] -> Output String+declSpecTypeName = flip derDeclrTypeName []++declrTypeName :: [CDeclarationSpecifier a] -> CDeclarator a -> Output String+declrTypeName declSpecs (CDeclr _ ddrs _ _ _) = derDeclrTypeName declSpecs ddrs++derDeclrTypeName :: [CDeclarationSpecifier a] -> [CDerivedDeclarator a]+ -> Output String+derDeclrTypeName = derDeclrTypeName' False++derDeclrTypeName' :: Bool -> [CDeclarationSpecifier a] -> [CDerivedDeclarator a]+ -> Output String+derDeclrTypeName' cStyle declSpecs ddrs =+ applyPointers <$> fullTypeName' None declSpecs <*> pure ddrs+ where+ fullTypeName' :: Signedness -> [CDeclarationSpecifier a] -> Output String+ fullTypeName' _ [] = return ""+ fullTypeName' s (x:xs) =+ case x of+ CTypeSpec (CSignedType _) -> fullTypeName' Signed xs+ CTypeSpec (CUnsigType _) -> fullTypeName' Unsigned xs+ CTypeSpec tspec -> if cStyle+ then cTypeName tspec s+ else typeName tspec s+ _ -> fullTypeName' s xs++ applyPointers :: String -> [CDerivedDeclarator a] -> String+ applyPointers baseType [] = baseType+ applyPointers baseType (x:[]) =+ case x of+ CPtrDeclr _ _ ->+ if cStyle+ then if baseType == ""+ then "void *"+ else baseType ++ " *"+ else if baseType == ""+ then "Ptr ()"+ else "Ptr " ++ baseType+ _ -> ""+ applyPointers baseType (x:xs) =+ case x of+ CPtrDeclr _ _ ->+ if cStyle+ then applyPointers baseType xs ++ " *"+ else "Ptr (" ++ applyPointers baseType xs ++ ")"+ _ -> ""++-- Simple translation from C types to Foreign.C.Types types. We represent+-- Void as the empty string so that returning void becomes IO (), and passing+-- a void star becomes Ptr ().++typeName :: CTypeSpecifier a -> Signedness -> Output String++typeName (CVoidType _) _ = return $ ""+typeName (CFloatType _) _ = return $ "CFloat"+typeName (CDoubleType _) _ = return $ "CDouble"+typeName (CBoolType _) _ = return $ "CInt"++typeName (CCharType _) s = case s of+ Signed -> return $ "CSChar"+ Unsigned -> return $ "CUChar"+ _ -> return $ "CChar"+typeName (CShortType _) s = case s of+ Signed -> return $ "CShort"+ Unsigned -> return $ "CUShort"+ _ -> return $ "CShort"+typeName (CIntType _) s = case s of+ Signed -> return $ "CInt"+ Unsigned -> return $ "CUInt"+ _ -> return $ "CInt"+typeName (CLongType _) s = case s of+ Signed -> return $ "CLong"+ Unsigned -> return $ "CULong"+ _ -> return $ "CLong"++typeName (CTypeDef (Ident name _ _) _) _ = do+ definition <- lookupType name+ return $ fromMaybe ("<" ++ name ++ ">") definition++typeName (CComplexType _) _ = return $ ""+typeName (CSUType _ _) _ = return $ ""+typeName (CEnumType _ _) _ = return $ ""+typeName (CTypeOfExpr _ _) _ = return $ ""+typeName (CTypeOfType _ _) _ = return $ ""++typeName _ _ = return $ ""++-- Translation from C back to C. Needed because there's no good way to pretty+-- print a function's return type (including pointers on the declarator) in+-- language-c.++cTypeName :: CTypeSpecifier a -> Signedness -> Output String++cTypeName (CVoidType _) _ = return $ ""+cTypeName (CFloatType _) _ = return $ "float"+cTypeName (CDoubleType _) _ = return $ "double"+cTypeName (CBoolType _) _ = return $ "int"++cTypeName (CCharType _) s = case s of+ Signed -> return $ "signed char"+ Unsigned -> return $ "unsigned char"+ _ -> return $ "char"+cTypeName (CShortType _) s = case s of+ Signed -> return $ "signed short"+ Unsigned -> return $ "unsigned short"+ _ -> return $ "hort"+cTypeName (CIntType _) s = case s of+ Signed -> return $ "signed int"+ Unsigned -> return $ "unsigned int"+ _ -> return $ "int"+cTypeName (CLongType _) s = case s of+ Signed -> return $ "signed long"+ Unsigned -> return $ "unsigned long"+ _ -> return $ "long"++cTypeName (CTypeDef (Ident name _ _) _) _ = do+ definition <- lookupType name+ return $ fromMaybe name definition++cTypeName (CComplexType _) _ = return $ ""+cTypeName (CSUType _ _) _ = return $ ""+cTypeName (CEnumType _ _) _ = return $ ""+cTypeName (CTypeOfExpr _ _) _ = return $ ""+cTypeName (CTypeOfType _ _) _ = return $ ""++cTypeName _ _ = return $ ""++-- parseFile "/usr/bin/gcc" ["-U__BLOCKS__", "/Users/johnw/src/hlibgit2/libgit2/include/git2/types.h"]++-- c2hsc.hs
+ README.md view
@@ -0,0 +1,10 @@+Converts C API header files to `.hsc` and `.hsc.helper.c` files++ Usage: c2hsc <Lib Prefix> [cpp options...] <FILE>.h++This will create `<FILE>.hsc`, and `<FILE>.hsc.helper.c` if the header file+contains inline functions.++For example, in `hlibgit2` on the Mac I'm using:++ c2hsc Bindings.Libgit2 -U__BLOCKS__ libgit2/include/git2/tree.h
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ c2hsc.cabal view
@@ -0,0 +1,35 @@+Name: c2hsc++Version: 0.1.0+Synopsis: Convert C API header files to .hsc and .hsc.helper.c files++Description: Convert C API header files to .hsc and .hsc.helper.c files++Homepage: https://github.com/jwiegley/c2hsc+License: BSD3+License-file: LICENSE+Author: John Wiegley+Maintainer: John Wiegley <johnw@newartisans.com>+Category: Utilities+Build-type: Simple+Cabal-version: >= 1.8++Extra-Source-Files: README.md++Executable c2hs+ Main-is: Main.hs+ Ghc-options: -Wall++ Build-depends: base >= 4 && < 5+ , mtl >= 1.1 && < 2.1+ , containers+ , transformers+ , directory+ , language-c+ , HStringTemplate+ , pretty+ , filepath++Source-repository head+ type: git+ location: https://github.com/jwiegley/c2hsc