c2hsc 0.6.2 → 0.6.3
raw patch · 3 files changed
+73/−56 lines, 3 files
Files
- Main.hs +71/−53
- README.md +0/−1
- c2hsc.cabal +2/−2
Main.hs view
@@ -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
README.md view
@@ -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
c2hsc.cabal view
@@ -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 <johnw@newartisans.com>-Category: Utilities+Category: Development Build-type: Simple Cabal-version: >= 1.8