diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -6,7 +6,7 @@ import Control.Monad hiding (sequence) import Control.Monad.Trans.State import Data.Char -import Data.Foldable hiding (concat, mapM_) +import Data.Foldable hiding (concat, elem, mapM_) import Data.List as L import Data.List.Split import qualified Data.Map as M @@ -40,14 +40,15 @@ c2hscSummary = "c2hsc v" ++ version ++ ", (C) John Wiegley " ++ copyright data C2HscOptions = C2HscOptions - { gcc :: FilePath - , cppopts :: String - , prefix :: String - , useStdout :: Bool - , overrides :: FilePath - , verbose :: Bool - , debug :: Bool - , files :: [FilePath] } + { gcc :: FilePath + , cppopts :: [String] + , prefix :: String + , filePrefix :: Maybe String + , useStdout :: Bool + , overrides :: FilePath + , verbose :: Bool + , debug :: Bool + , files :: [FilePath] } deriving (Data, Typeable, Show, Eq) c2hscOptions :: C2HscOptions @@ -58,6 +59,8 @@ &= help "Pass OPTS to the preprocessor" , prefix = def &= typ "PREFIX" &= help "Use PREFIX when naming modules" + , filePrefix = def &= typ "FILE_PREFIX" + &= help "Process included headers whose paths match this prefix" , useStdout = def &= name "stdout" &= help "Send all output to stdout (for testing)" , overrides = def &= typFile @@ -102,16 +105,18 @@ parseFile gccPath opts = for_ (files opts) $ \fileName -> do result <- runPreprocessor (newGCC gccPath) - (rawCppArgs [cppopts opts] fileName) + (rawCppArgs + (cppopts opts) + fileName) 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 (overrideState >> - parseCFile stream (posFile pos) pos) - newHscState + let fm = maybe (posFile pos ==) isPrefixOf (filePrefix opts) + in execState (overrideState >> parseCFile stream fm pos) + newHscState writeProducts opts fileName hscs helpercs defineTypeOverrides :: FilePath -> IO (Output ()) @@ -161,10 +166,11 @@ -- Sniff through the file again, but looking only for local #include's includes <- filter ("#include \"" `isPrefixOf`) . lines <$> readFile fileName - for_ includes $ \inc -> - hPutStrLn handle $ "import " - ++ prefix opts ++ "." - ++ (capitalize . takeWhile (/= '.') . drop 10 $ inc) + for_ includes $ \inc -> do + let incPath = splitOn "\"" inc !! 1 + incPathParts = map dropTrailingPathSeparator $ splitPath $ dropExtension incPath + modName = intercalate "." $ prefix opts : map capitalize incPathParts + hPutStrLn handle $ "import " ++ modName traverse_ (hPutStrLn handle) hscs @@ -172,7 +178,7 @@ hClose handle putStrLn $ "Wrote " ++ target - when (length helpercs > 0) $ do + unless (null helpercs) $ do let targetc = cap ++ ".hsc.helper.c" handlec <- if useStdout opts then return System.IO.stdout @@ -242,17 +248,17 @@ -- 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 = +parseCFile :: InputStream -> (FilePath -> Bool) -> Position -> Output () +parseCFile stream fm 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) + generateHsc = traverse_ (appendNode fm) -declInFile :: FilePath -> CExtDecl -> Bool -declInFile fileName = (== fileName) . posFile . posOfNode . declInfo +declMatches :: (FilePath -> Bool) -> CExtDecl -> Bool +declMatches fm = fm . posFile . posOfNode . declInfo declInfo :: CExtDecl -> NodeInfo declInfo (CDeclExt (CDecl _ _ info)) = info @@ -271,12 +277,12 @@ -- - Extern Functions -- - Inline Functions -appendNode :: FilePath -> CExtDecl -> Output () +appendNode :: (FilePath -> Bool) -> CExtDecl -> Output () -appendNode fp dx@(CDeclExt (CDecl declSpecs items _)) = +appendNode fm dx@(CDeclExt (CDecl declSpecs items _)) = case items of [] -> - when (declInFile fp dx) $ do + when (declMatches fm dx) $ do appendHsc $ "{- " ++ P.render (pretty dx) ++ " -}" appendType declSpecs "" @@ -284,8 +290,12 @@ for_ xs $ \(declrtr, _, _) -> for_ (splitDecl declrtr) $ \(declrtr', ddrs, nm) -> case ddrs of + CPtrDeclr{}:CFunDeclr (Right _) _ _:_ -> + when (declMatches fm dx) $ + appendFunc "#callback" declSpecs declrtr' + CFunDeclr (Right (_, _)) _ _:_ -> - when (declInFile fp dx) $ + when (declMatches fm dx) $ appendFunc "#ccall" declSpecs declrtr' _ -> @@ -293,19 +303,19 @@ -- look it up later case declSpecs of CStorageSpec (CTypedef _):_ -> do - when (declInFile fp dx) $ do + when (declMatches fm dx) $ do appendHsc $ "{- " ++ P.render (pretty dx) ++ " -}" appendType declSpecs nm dname <- declSpecTypeName declSpecs unless (null dname || dname == "<" ++ nm ++ ">") $ do - when (declInFile fp dx) $ + when (declMatches fm dx) $ appendHsc $ "#synonym_t " ++ nm ++ " , " ++ dname defineType nm Typedef { typedefName = dname , typedefOverride = False } _ -> - when (declInFile fp dx) $ do + when (declMatches fm dx) $ do dname <- declSpecTypeName declSpecs appendHsc $ "#globalvar " ++ nm ++ " , " ++ dname where @@ -313,9 +323,9 @@ d@(CDeclr ident ddrs _ _ _) <- declrtr return (d, ddrs, case ident of Just (Ident nm _ _) -> nm; _ -> "") -appendNode fp dx@(CFDefExt (CFunDef declSpecs declrtr _ _ _)) = +appendNode fm dx@(CFDefExt (CFunDef declSpecs declrtr _ _ _)) = -- Assume functions defined in headers are inline functions - when (declInFile fp dx) $ do + when (declMatches fm dx) $ do appendFunc "#cinline" declSpecs declrtr let CDeclr ident ddrs _ _ _ = declrtr @@ -325,11 +335,10 @@ CFunDeclr (Right (decls, _)) _ _ -> do retType <- derDeclrTypeName' True declSpecs (tail ddrs) funType <- applyDeclrs True retType ddrs - if not (null retType) - then appendHelper $ "BC_INLINE" ++ show (length decls) - ++ "(" ++ nm ++ ", " ++ funType ++ ")" - else appendHelper $ "BC_INLINE" ++ show (length decls) - ++ "VOID(" ++ nm ++ ", " ++ funType ++ ")" + appendHelper $ + "BC_INLINE" ++ show (length decls) + ++ (if not (null retType) then "" else "VOID") + ++ "(" ++ nm ++ ", " ++ funType ++ ")" _ -> return () appendNode _ (CAsmExt _ _) = return () @@ -345,7 +354,7 @@ retType <- derDeclrTypeName declSpecs retDeclr argTypes <- (++) <$> getArgTypes funcDeclr - <*> pure [ "IO (" ++ retType ++ ")" ] + <*> pure [ "IO " ++ tyParens retType ] let name' = nameFromIdent ident code = newSTMP "$marker$ $name$ , $argTypes;separator=' -> '$" @@ -379,7 +388,7 @@ for_ decls $ \xs -> do appendHsc $ "#starttype " ++ name' for_ xs $ \x -> - for_ (cdeclName x) $ \declName -> do + for_ (cdeclNames x) $ \declName -> do let CDecl declSpecs' ((Just y, _, _):_) _ = x case y of CDeclr _ (CArrDeclr {}:zs) _ _ _ -> do @@ -410,11 +419,16 @@ data Signedness = None | Signed | Unsigned deriving (Eq, Show, Enum) -cdeclName :: CDeclaration a -> Maybe String -cdeclName (CDecl _ more _) = - case more of - (Just (CDeclr (Just (Ident nm _ _)) _ _ _ _), _, _) : _ -> Just nm - _ -> Nothing +cdeclNames :: CDeclaration a -> [String] +cdeclNames (CDecl _ more _) = + collect more [] + where + collect [] nms = reverse nms + collect (m:ms) nms = collect ms $ + case m of + (Just (CDeclr (Just (Ident nm _ _)) _ _ _ _), _, _) + -> nm:nms + _ -> nms cdeclTypeName :: CDeclaration a -> Output String cdeclTypeName = cdeclTypeName' False @@ -465,9 +479,9 @@ fullTypeName' s xs fullTypeName' _ (CTypeSpec (CSignedType _):[]) = - if cStyle then return "signed" else return "CInt" + return $ if cStyle then "signed" else "CInt" fullTypeName' _ (CTypeSpec (CUnsigType _):[]) = - if cStyle then return "unsigned" else return "CUInt" + return $ if cStyle then "unsigned" else "CUInt" fullTypeName' s (x:xs) = case x of @@ -493,7 +507,7 @@ argTypes <- renderList " -> " (funTypes decls (if null baseType then "IO ()" else baseType)) - return $ "FunPtr (" ++ argTypes ++ ")" + return $ "FunPtr " ++ tyParens argTypes where renderList str xs = intercalate str <$> filter (not . null) <$> xs funTypes xs bt = (++) <$> mapM (cdeclTypeName' cStyle) xs @@ -511,17 +525,15 @@ | cStyle = concatM [ applyDeclrs cStyle baseType xs , pure "*" , pure (preQualsToString quals) ] - | otherwise = concatM [ pure "Ptr (" - , applyDeclrs cStyle baseType xs - , pure ")" ] + | otherwise = concatM [ pure "Ptr " + , tyParens `fmap` applyDeclrs cStyle baseType xs ] applyDeclrs cStyle baseType (CArrDeclr quals _ _:xs) | cStyle = concatM [ pure (sufQualsToString quals) , applyDeclrs cStyle baseType xs , pure "[]" ] - | otherwise = concatM [ pure "Ptr (" - , applyDeclrs cStyle baseType xs - , pure ")" ] + | otherwise = concatM [ pure "Ptr " + , tyParens `fmap` applyDeclrs cStyle baseType xs ] applyDeclrs _ baseType _ = return baseType @@ -632,5 +644,11 @@ cTypeName (CTypeOfType _ _) _ = return "" cTypeName _ _ = return "" + +tyParens :: String -> String +tyParens ty = + if null ty || ' ' `elem` ty + then concat ["(", ty, ")"] + else ty -- c2hsc.hs diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -12,7 +12,6 @@ Known issues: - - "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 diff --git a/c2hsc.cabal b/c2hsc.cabal --- a/c2hsc.cabal +++ b/c2hsc.cabal @@ -1,6 +1,6 @@ Name: c2hsc -Version: 0.6.2 +Version: 0.6.3 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 @@ -10,7 +10,7 @@ License-file: LICENSE Author: John Wiegley Maintainer: John Wiegley -Category: Utilities +Category: Development Build-type: Simple Cabal-version: >= 1.8