diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,14 +1,17 @@ +{-# LANGUAGE DeriveDataTypeable #-} + 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 Data.Foldable hiding (concat) +import Data.List import qualified Data.Map as M import Data.Maybe import Data.Traversable +--import Debug.Trace import Language.C.Data.Ident import Language.C.Data.InputStream import Language.C.Data.Node @@ -19,6 +22,7 @@ import Language.C.System.GCC import Language.C.System.Preprocess import Prelude hiding (concat, sequence) +import System.Console.CmdArgs import System.Directory import System.Environment import System.FilePath @@ -26,79 +30,128 @@ import Text.PrettyPrint as P import Text.StringTemplate +version :: String +version = "0.2.0" + +copyright :: String +copyright = "2012" + +c2hscSummary :: String +c2hscSummary = "c2hsc v" ++ version ++ ", (C) John Wiegley " ++ copyright + +data C2HscOptions = C2HscOptions + { gcc :: FilePath + , cppopts :: String + , prefix :: String + , useStdout :: Bool + , verbose :: Bool + , debug :: Bool + , files :: [FilePath] } + deriving (Data, Typeable, Show, Eq) + +c2hscOptions :: C2HscOptions +c2hscOptions = C2HscOptions + { gcc = def &= typFile + &= help "Specify explicit path to gcc or cpp" + , cppopts = def &= typ "OPTS" + &= help "Pass OPTS to the preprocessor" + , prefix = def &= typ "PREFIX" + &= help "Use PREFIX when naming modules" + , useStdout = def &= name "stdout" + &= help "Send all output to stdout (for testing)" + , verbose = def &= name "v" + &= help "Report progress verbosely" + , debug = def &= name "D" + &= help "Report debug information" + , files = def &= args &= typFile } &= + summary c2hscSummary &= + program "c2hsc" &= + help "Create an .hsc Bindings-DSL file from a C API header file" + ------------------------------ IMPURE FUNCTIONS ------------------------------ -- Parsing of C headers begins with finding gcc so we can run the -- preprocessor. main :: IO () -main = do - gccExe <- findExecutable "gcc" +main = getArgs >>= runArgs + +runArgs :: [String] -> IO() +runArgs mainArgs = do + opts <- withArgs (if null mainArgs then ["--help"] else mainArgs) + (cmdArgs c2hscOptions) + when (prefix opts == "") $ + error "Please specify a module prefix to use with --prefix" + + gccExe <- findExecutable $ case gcc opts of "" -> "gcc"; x -> x case gccExe of - Nothing -> error "Cannot find 'gcc' executable on the PATH" - Just gccPath -> getArgs >>= parseFile gccPath + Nothing -> error $ "Cannot find executable '" ++ gcc opts ++ "'" + Just gccPath -> parseFile gccPath opts -- 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 +parseFile :: FilePath -> C2HscOptions -> IO () +parseFile gccPath opts = + for_ (files opts) $ \fileName -> do + result <- runPreprocessor (newGCC gccPath) + (rawCppArgs [(cppopts opts)] 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 opts fileName hscs helpercs -- Write out the gathered data -writeProducts :: String -> FilePath -> [String] -> [String] -> IO () -writeProducts libName fileName hscs helpercs = do +writeProducts :: C2HscOptions -> FilePath -> [String] -> [String] -> IO () +writeProducts opts fileName hscs helpercs = do let tmpl = unlines [ "#include " , "#include " , "module $libName$.$cFileName$ where" , "#strict_import" , "" ] - vars = [ ("libName", libName) + vars = [ ("libName", prefix opts) , ("cFileName", cap) ] code = newSTMP tmpl base = dropExtension . takeFileName $ fileName cap = capitalize base let target = cap ++ ".hsc" - handle <- openFile target WriteMode + handle <- if useStdout opts + then return System.IO.stdout + else 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) - + let includes = filter ("#include \"" `isPrefixOf`) . lines $ contents for_ includes $ \inc -> hPutStrLn handle $ "import " - ++ libName ++ "." + ++ prefix opts ++ "." ++ (capitalize . takeWhile (/= '.') . drop 10 $ inc) traverse_ (hPutStrLn handle) hscs - hClose handle + unless (useStdout opts) $ hClose handle putStrLn $ "Wrote " ++ target when (length helpercs > 0) $ do let targetc = cap ++ ".hsc.helper.c" - handlec <- openFile targetc WriteMode + handlec <- if useStdout opts + then return System.IO.stdout + else openFile targetc WriteMode hPutStrLn handlec "#include " traverse_ (hPutStrLn handlec) includes hPutStrLn handlec "" traverse_ (hPutStrLn handlec) helpercs - hClose handlec + unless (useStdout opts) $ hClose handlec putStrLn $ "Wrote " ++ targetc where capitalize [] = [] @@ -150,16 +203,13 @@ 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 +declInFile fileName = + (== takeFileName fileName) . takeFileName . posFile . posOfNode . declInfo declInfo :: CExtDecl -> NodeInfo declInfo (CDeclExt (CDecl _ _ info)) = info @@ -181,8 +231,8 @@ appendNode :: FilePath -> CExtDecl -> Output () appendNode fp dx@(CDeclExt (CDecl declSpecs items _)) = - for_ items $ \(declrtr, _, _) -> do - for_ (splitDecl declrtr) $ \(d, ddrs, name) -> + for_ items $ \(declrtr, _, _) -> + for_ (splitDecl declrtr) $ \(d, ddrs, nm) -> case ddrs of CFunDeclr (Right (_, _)) _ _ : _ -> when (declInFile fp dx) $ @@ -191,7 +241,7 @@ _ -> do when (declInFile fp dx) $ do appendHsc $ "{- " ++ P.render (pretty dx) ++ " -}" - appendType declSpecs name + appendType declSpecs nm -- If the type is a typedef, record the equivalence so we can look -- it up later @@ -203,36 +253,34 @@ dname <- declSpecTypeName declSpecs case dname of "" -> return () - _ -> defineType name dname + _ -> defineType nm 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) + (Ident nm _ _) <- ident + return (d, ddrs, nm) 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 () + let (CDeclr ident ddrs _ _ _) = declrtr + for_ ident $ \(Ident nm _ _) -> + case head ddrs of + (CFunDeclr (Right (decls, _)) _ _) -> do + retType <- derDeclrTypeName' True declSpecs (tail ddrs) + funType <- applyDeclrs True retType ddrs + if retType /= "" + then appendHelper $ "BC_INLINE" ++ show (length decls) + ++ "(" ++ nm ++ ", " ++ funType ++ ")" + else appendHelper $ "BC_INLINE" ++ show (length decls) + ++ "VOID(" ++ nm ++ ", " ++ funType ++ ")" + _ -> return () + appendNode _ (CAsmExt _ _) = return () -- Print out a function as #ccall or #cinline. The syntax is the same for @@ -242,25 +290,26 @@ appendFunc :: String -> [CDeclarationSpecifier a] -> CDeclarator a -> Output () appendFunc marker declSpecs (CDeclr ident ddrs _ _ _) = do retType <- derDeclrTypeName declSpecs (tail ddrs) - argTypes <- sequence $ getArgTypes (head ddrs) + argTypes <- (++) <$> (filter (/= "") <$> sequence (getArgTypes (head ddrs))) + <*> pure [ "IO (" ++ retType ++ ")" ] let name' = nameFromIdent ident - tmpl = "$marker$ $name$ , $argTypes;separator=' -> '$ -> IO ($retType$)" + tmpl = "$marker$ $name$ , $argTypes;separator=' -> '$" code = newSTMP tmpl -- I have to this separately since argTypes :: [String] code' = setAttribute "argTypes" argTypes code vars = [ ("marker", marker) - , ("name", name') - , ("retType", retType) ] + , ("name", name') ] appendHsc $ toString $ setManyAttrib vars code' where + getArgTypes :: CDerivedDeclarator a -> [Output String] getArgTypes (CFunDeclr (Right (decls, _)) _ _) = map cdeclTypeName decls getArgTypes _ = [] nameFromIdent :: Maybe Ident -> String - nameFromIdent name = case name of + nameFromIdent nm = case nm of Just (Ident n _ _) -> n _ -> "" @@ -285,14 +334,14 @@ appendHsc $ "#integral_t " ++ name' for_ defs $ \ds -> - for_ ds $ \((Ident name _ _), _) -> do - appendHsc $ "#num " ++ name + for_ ds $ \(Ident nm _ _, _) -> + appendHsc $ "#num " ++ nm appendType' _ = return () identName ident = case ident of Nothing -> declrName - Just (Ident name _ _) -> name + Just (Ident nm _ _) -> nm -- The remainder of this file is some hairy code for turning various -- constructs into Bindings-DSL type names, such as turning "int ** foo" into @@ -303,32 +352,51 @@ cdeclName :: CDeclaration a -> Maybe String cdeclName (CDecl _ more _) = case more of - (Just (CDeclr (Just (Ident name _ _)) _ _ _ _), _, _) : _ -> Just name + (Just (CDeclr (Just (Ident nm _ _)) _ _ _ _), _, _) : _ -> Just nm _ -> Nothing cdeclTypeName :: CDeclaration a -> Output String -cdeclTypeName (CDecl declSpecs more _) = +cdeclTypeName = cdeclTypeName' False + +cdeclTypeName' :: Bool -> CDeclaration a -> Output String +cdeclTypeName' cStyle (CDecl declSpecs more _) = case more of - (Just x, _, _) : _ -> declrTypeName declSpecs x - _ -> declSpecTypeName declSpecs + (Just x, _, _) : _ -> declrTypeName' cStyle declSpecs x + _ -> declSpecTypeName' cStyle declSpecs declSpecTypeName :: [CDeclarationSpecifier a] -> Output String -declSpecTypeName = flip derDeclrTypeName [] +declSpecTypeName = declSpecTypeName' False +declSpecTypeName' :: Bool -> [CDeclarationSpecifier a] -> Output String +declSpecTypeName' cStyle = flip (derDeclrTypeName' cStyle) [] + declrTypeName :: [CDeclarationSpecifier a] -> CDeclarator a -> Output String -declrTypeName declSpecs (CDeclr _ ddrs _ _ _) = derDeclrTypeName declSpecs ddrs +declrTypeName = declrTypeName' False +declrTypeName' :: Bool -> [CDeclarationSpecifier a] -> CDeclarator a + -> Output String +declrTypeName' cStyle declSpecs (CDeclr _ ddrs _ _ _) = + derDeclrTypeName' cStyle 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 +derDeclrTypeName' cStyle declSpecs ddrs = do + nm <- fullTypeName' None declSpecs + applyDeclrs cStyle nm ddrs + where fullTypeName' :: Signedness -> [CDeclarationSpecifier a] -> Output String - fullTypeName' _ [] = return "" + fullTypeName' _ [] = return "" + + fullTypeName' _ (CTypeSpec (CSignedType _):[]) = + if cStyle then return "signed" else return "CInt" + fullTypeName' _ (CTypeSpec (CUnsigType _):[]) = + if cStyle then return "unsigned" else return "CUInt" + fullTypeName' s (x:xs) = case x of CTypeSpec (CSignedType _) -> fullTypeName' Signed xs @@ -336,28 +404,51 @@ CTypeSpec tspec -> if cStyle then cTypeName tspec s else typeName tspec s - _ -> fullTypeName' s xs + _ -> 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 ++ ")" - _ -> "" +concatM :: (Monad f, Functor f) => [f [a]] -> f [a] +concatM xs = concat <$> sequence xs + +applyDeclrs :: Bool -> String -> [CDerivedDeclarator a] -> Output String + +applyDeclrs cStyle baseType (p@CPtrDeclr {}:f@CFunDeclr {}:ds) + | cStyle = applyDeclrs cStyle (baseType ++ " *") (f:ds) + | otherwise = join $ applyDeclrs cStyle <$> applyDeclrs cStyle baseType [p] + <*> pure (f:ds) + +applyDeclrs cStyle baseType (CFunDeclr (Right (decls, _)) _ _:_) + | cStyle = do + let declNames = sequence $ + map (cdeclTypeName' cStyle) decls ++ [pure baseType] + intercalate ", " <$> (filter (/= "") <$> declNames) + + | otherwise = do + let declNames = sequence $ map cdeclTypeName decls ++ [pure baseType] + argTypes <- intercalate " -> " <$> (filter (/= "") <$> declNames) + return $ "FunPtr (" ++ argTypes ++ ")" + +applyDeclrs cStyle baseType (CPtrDeclr _ _:[]) + | cStyle && baseType == "" = return "void *" + | cStyle = return $ baseType ++ "*" + | baseType == "" = return "Ptr ()" + | baseType == "CChar" = return "CString" + | otherwise = return $ "Ptr " ++ baseType + +applyDeclrs cStyle baseType (CPtrDeclr _ _:xs) + | cStyle = concatM [ applyDeclrs cStyle baseType xs + , pure " *" ] + | otherwise = concatM [ pure "Ptr (" + , applyDeclrs cStyle baseType xs + , pure ")" ] + +applyDeclrs cStyle baseType (CArrDeclr {}:xs) + | cStyle = concatM [ applyDeclrs cStyle baseType xs + , pure "[]" ] + | otherwise = concatM [ pure "Ptr (" + , applyDeclrs cStyle baseType xs + , pure ")" ] + +applyDeclrs _ baseType _ = return baseType -- 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 @@ -365,39 +456,39 @@ typeName :: CTypeSpecifier a -> Signedness -> Output String -typeName (CVoidType _) _ = return $ "" -typeName (CFloatType _) _ = return $ "CFloat" -typeName (CDoubleType _) _ = return $ "CDouble" -typeName (CBoolType _) _ = return $ "CInt" +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" + Signed -> return "CSChar" + Unsigned -> return "CUChar" + _ -> return "CChar" typeName (CShortType _) s = case s of - Signed -> return $ "CShort" - Unsigned -> return $ "CUShort" - _ -> return $ "CShort" + Signed -> return "CShort" + Unsigned -> return "CUShort" + _ -> return "CShort" typeName (CIntType _) s = case s of - Signed -> return $ "CInt" - Unsigned -> return $ "CUInt" - _ -> return $ "CInt" + Signed -> return "CInt" + Unsigned -> return "CUInt" + _ -> return "CInt" typeName (CLongType _) s = case s of - Signed -> return $ "CLong" - Unsigned -> return $ "CULong" - _ -> return $ "CLong" + Signed -> return "CLong" + Unsigned -> return "CULong" + _ -> return "CLong" -typeName (CTypeDef (Ident name _ _) _) _ = do - definition <- lookupType name - return $ fromMaybe ("<" ++ name ++ ">") definition +typeName (CTypeDef (Ident nm _ _) _) _ = do + definition <- lookupType nm + return $ fromMaybe ("<" ++ nm ++ ">") definition -typeName (CComplexType _) _ = return $ "" -typeName (CSUType _ _) _ = return $ "" -typeName (CEnumType _ _) _ = return $ "" -typeName (CTypeOfExpr _ _) _ = return $ "" -typeName (CTypeOfType _ _) _ = return $ "" +typeName (CComplexType _) _ = return "" +typeName (CSUType _ _) _ = return "" +typeName (CEnumType _ _) _ = return "" +typeName (CTypeOfExpr _ _) _ = return "" +typeName (CTypeOfType _ _) _ = return "" -typeName _ _ = 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 @@ -405,40 +496,40 @@ cTypeName :: CTypeSpecifier a -> Signedness -> Output String -cTypeName (CVoidType _) _ = return $ "" -cTypeName (CFloatType _) _ = return $ "float" -cTypeName (CDoubleType _) _ = return $ "double" -cTypeName (CBoolType _) _ = return $ "int" +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" + 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" + 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" + 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" + Signed -> return "signed long" + Unsigned -> return "unsigned long" + _ -> return "long" -cTypeName (CTypeDef (Ident name _ _) _) _ = do - definition <- lookupType name - return $ fromMaybe name definition +cTypeName (CTypeDef (Ident nm _ _) _) _ = do + definition <- lookupType nm + return $ fromMaybe nm definition -cTypeName (CComplexType _) _ = return $ "" -cTypeName (CSUType _ _) _ = return $ "" -cTypeName (CEnumType _ _) _ = return $ "" -cTypeName (CTypeOfExpr _ _) _ = return $ "" -cTypeName (CTypeOfType _ _) _ = return $ "" +cTypeName (CComplexType _) _ = return "" +cTypeName (CSUType _ _) _ = return "" +cTypeName (CEnumType _ _) _ = return "" +cTypeName (CTypeOfExpr _ _) _ = return "" +cTypeName (CTypeOfType _ _) _ = return "" -cTypeName _ _ = return $ "" +cTypeName _ _ = return "" --- parseFile "/usr/bin/gcc" ["-U__BLOCKS__", "/Users/johnw/src/hlibgit2/libgit2/include/git2/types.h"] +-- runArgs ["--prefix=C2Hsc.Smoke", "--cppopts=-U__BLOCKS__", "test/smoke.h"] -- c2hsc.hs diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,3 +8,22 @@ For example, in `hlibgit2` on the Mac I'm using: c2hsc Bindings.Libgit2 -U__BLOCKS__ libgit2/include/git2/tree.h + +Known issues: + + - Varargs functions do not translate + - Arrays are not handled at all (use #array_field $name , $type) + - Handle type synonyms + - Unnamed enums are not being emitted + - Inline helper generator outputs the wrong headers + - Files named foo_bar should become FooBar + - Global variables are not being emitted + +Also, please note that this tool will never be 100% accurate. It cannot +translate macros, or anything related to the preprocessor, for example. It +often misses necessary `#include` files, and will get them wrong in any case +if preprocessor conditionals are involved. + +The goal of `c2hsc` is to solve the hardest 80% of the problem of creating an +FFI library. The remaining 20%, plus validation of the results, is an +exercise necessarily left to the user. diff --git a/c2hsc.cabal b/c2hsc.cabal --- a/c2hsc.cabal +++ b/c2hsc.cabal @@ -1,6 +1,6 @@ Name: c2hsc -Version: 0.2.0 +Version: 0.3.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 @@ -17,19 +17,29 @@ Extra-Source-Files: README.md Executable c2hsc - Main-is: Main.hs - Ghc-options: -Wall + Main-is: Main.hs + Ghc-options: -Wall - Build-depends: base >= 4 && < 5 - , mtl - , containers - , transformers - , directory - , language-c - , HStringTemplate - , pretty - , filepath + Build-depends: base >= 4 && < 5 + , mtl + , containers + , transformers + , directory + , language-c + , HStringTemplate + , pretty + , filepath + , cmdargs +--Test-suite smoke +-- Type: exitcode-stdio-1.0 +-- Main-is: Smoke.hs +-- Hs-source-dirs: test +-- Build-depends: base >= 4 && < 5 +-- , c2hsc + Source-repository head - type: git - location: https://github.com/jwiegley/c2hsc + Type: git + Location: https://github.com/jwiegley/c2hsc + +-- c2hsc.cabal ends here