diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -6,12 +6,12 @@ import Control.Monad hiding (sequence) import Control.Monad.Trans.State import Data.Char -import Data.Foldable hiding (concat) -import Data.List +import Data.Foldable hiding (concat, mapM_) +import Data.List as L import Data.List.Split import qualified Data.Map as M import Data.Maybe -import Data.Traversable hiding (mapM) +import Data.Traversable hiding (mapM, forM) import Language.C.Data.Ident import Language.C.Data.InputStream import Language.C.Data.Node @@ -21,7 +21,7 @@ import Language.C.Syntax.AST import Language.C.System.GCC import Language.C.System.Preprocess -import Prelude hiding (concat, sequence, mapM) +import Prelude hiding (concat, sequence, mapM, mapM_, foldr) import System.Console.CmdArgs import System.Directory import System.Environment @@ -31,7 +31,7 @@ import Text.StringTemplate version :: String -version = "0.5.1" +version = "0.6.2" copyright :: String copyright = "2012" @@ -44,6 +44,7 @@ , cppopts :: String , prefix :: String , useStdout :: Bool + , overrides :: FilePath , verbose :: Bool , debug :: Bool , files :: [FilePath] } @@ -59,6 +60,8 @@ &= help "Use PREFIX when naming modules" , useStdout = def &= name "stdout" &= help "Send all output to stdout (for testing)" + , overrides = def &= typFile + &= help "FILE contains \"C type -> FFI type\" translations" , verbose = def &= name "v" &= help "Report progress verbosely" , debug = def &= name "D" @@ -103,24 +106,49 @@ case result of Left err -> error $ "Failed to run cpp: " ++ show err Right stream -> do + overrideState <- defineTypeOverrides (overrides opts) let pos = initPos fileName HscOutput hscs helpercs _ = - execState (parseCFile stream (posFile pos) pos) + execState (overrideState >> + parseCFile stream (posFile pos) pos) newHscState writeProducts opts fileName hscs helpercs +defineTypeOverrides :: FilePath -> IO (Output ()) +defineTypeOverrides [] = return (void defaultOverrides) +defineTypeOverrides overridesFile = do + contents <- readFile overridesFile + return $ mapM_ (\line -> + let (cName:ffiName:[]) = splitOn " -> " line + in overrideType cName ffiName) + (lines contents) + +overrideType :: String -> String -> Output () +overrideType cName ffiName = + defineType cName Typedef { typedefName = ffiName + , typedefOverride = True } + +defaultOverrides :: Output () +defaultOverrides = mapM_ (uncurry overrideType) + [ ("size_t", "CSize") + , ("intptr_t", "IntPtr") + , ("uintptr_t", "WordPtr") ] + -- Write out the gathered data writeProducts :: C2HscOptions -> FilePath -> [String] -> [String] -> IO () writeProducts opts fileName hscs helpercs = do let code = newSTMP $ - unlines [ "#include " - , "#include " + unlines [ "{-# OPTIONS_GHC -fno-warn-unused-imports #-}" + , "#include " + , "#include \"$headerFileName$\"" , "module $libName$.$cFileName$ where" + , "import Foreign.Ptr" , "#strict_import" , "" ] vars = [ ("libName", prefix opts) - , ("cFileName", cap) ] + , ("cFileName", cap) + , ("headerFileName", fileName) ] cap = capitalize . dropExtension . takeFileName $ fileName target = cap ++ ".hsc" @@ -176,7 +204,9 @@ -- pure, and since the data sets involved are relatively small, performance is -- not a critical issue. -type TypeMap = M.Map String String +data Typedef = Typedef { typedefName :: String + , typedefOverride :: Bool } +type TypeMap = M.Map String Typedef data HscOutput = HscOutput [String] [String] TypeMap type Output = State HscOutput @@ -193,12 +223,15 @@ HscOutput xs helpercs types <- get put $ HscOutput xs (helpercs ++ [helperc]) types -defineType :: String -> String -> Output () +defineType :: String -> Typedef -> Output () defineType key value = do HscOutput xs ys types <- get - put $ HscOutput xs ys (M.insert key value types) + hasOverride <- fmap typedefOverride <$> lookupType key + case hasOverride of + Just True -> return () + _ -> put $ HscOutput xs ys (M.insert key value types) -lookupType :: String -> Output (Maybe String) +lookupType :: String -> Output (Maybe Typedef) lookupType key = do HscOutput _ _ types <- get return $ M.lookup key types @@ -240,7 +273,7 @@ appendNode :: FilePath -> CExtDecl -> Output () -appendNode fp dx@(CDeclExt (CDecl declSpecs items _)) = do +appendNode fp dx@(CDeclExt (CDecl declSpecs items _)) = case items of [] -> when (declInFile fp dx) $ do @@ -255,7 +288,7 @@ when (declInFile fp dx) $ appendFunc "#ccall" declSpecs declrtr' - _ -> do + _ -> -- If the type is a typedef, record the equivalence so we can -- look it up later case declSpecs of @@ -269,8 +302,8 @@ when (declInFile fp dx) $ appendHsc $ "#synonym_t " ++ nm ++ " , " ++ dname - defineType nm dname - + defineType nm Typedef { typedefName = dname + , typedefOverride = False } _ -> when (declInFile fp dx) $ do dname <- declSpecTypeName declSpecs @@ -424,7 +457,10 @@ if cStyle then do baseType <- fullTypeName' s xs - return $ qualToStr qual ++ " " ++ baseType + return $ let q = qualToStr qual + in if null q + then baseType + else q ++ " " ++ baseType else fullTypeName' s xs @@ -454,7 +490,9 @@ applyDeclrs cStyle baseType (CFunDeclr (Right (decls, _)) _ _:_) | cStyle = renderList ", " (funTypes decls baseType) | otherwise = do - argTypes <- renderList " -> " (funTypes decls baseType) + argTypes <- renderList " -> " (funTypes decls (if null baseType + then "IO ()" + else baseType)) return $ "FunPtr (" ++ argTypes ++ ")" where renderList str xs = intercalate str <$> filter (not . null) <$> xs @@ -487,22 +525,22 @@ applyDeclrs _ baseType _ = return baseType -prefixWith :: a -> [a] -> [a] -prefixWith _ [] = [] -prefixWith x xs = (x:xs) - preQualsToString :: [CTypeQualifier a] -> String preQualsToString = prefixWith ' ' . qualsToStr +prefixWith :: a -> [a] -> [a] +prefixWith _ [] = [] +prefixWith x xs = x:xs + sufQualsToString :: [CTypeQualifier a] -> String -sufQualsToString = prefixWith ' ' . qualsToStr +sufQualsToString = suffixWith ' ' . qualsToStr suffixWith :: a -> [a] -> [a] suffixWith _ [] = [] suffixWith x xs = xs ++ [x] qualsToStr :: [CTypeQualifier a] -> String -qualsToStr = intercalate " " . map qualToStr +qualsToStr = unwords . map qualToStr qualToStr :: CTypeQualifier t -> String qualToStr (CConstQual _) = "const" @@ -541,7 +579,10 @@ typeName (CTypeDef (Ident nm _ _) _) _ = do definition <- lookupType nm - return $ fromMaybe ("<" ++ nm ++ ">") definition + case definition of + Nothing -> return $ "<" ++ nm ++ ">" + Just (Typedef { typedefName = defNm }) -> + return defNm typeName (CSUType (CStruct _ (Just (Ident nm _ _)) _ _ _) _) _ = return $ "<" ++ nm ++ ">" @@ -582,9 +623,7 @@ Unsigned -> return "unsigned long" _ -> return "long" -cTypeName (CTypeDef (Ident nm _ _) _) _ = do - definition <- lookupType nm - return $ fromMaybe nm definition +cTypeName (CTypeDef (Ident nm _ _) _) _ = return nm cTypeName (CComplexType _) _ = return "" cTypeName (CSUType _ _) _ = return "" diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -12,7 +12,9 @@ Known issues: - - Varargs functions do not translate + - "void (*foo)(int, intptr_t *)" becomes "FunPtr (CInt -> Ptr IntPtr)" + - Need to output vararg functions with a comment mentioning they are not + translatable to the Haskell FFI Also, please note that this tool will never be 100% accurate. It cannot translate macros, or anything related to the preprocessor, for example. It diff --git a/c2hsc.cabal b/c2hsc.cabal --- a/c2hsc.cabal +++ b/c2hsc.cabal @@ -1,6 +1,6 @@ Name: c2hsc -Version: 0.5.1 +Version: 0.6.2 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