diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -8,9 +8,10 @@ import Data.Char import Data.Foldable hiding (concat) import Data.List +import Data.List.Split import qualified Data.Map as M import Data.Maybe -import Data.Traversable +import Data.Traversable hiding (mapM) import Language.C.Data.Ident import Language.C.Data.InputStream import Language.C.Data.Node @@ -20,7 +21,7 @@ import Language.C.Syntax.AST import Language.C.System.GCC import Language.C.System.Preprocess -import Prelude hiding (concat, sequence) +import Prelude hiding (concat, sequence, mapM) import System.Console.CmdArgs import System.Directory import System.Environment @@ -76,7 +77,7 @@ main = getArgs >>= runArgs smokeTest :: IO () -smokeTest = runArgs ["--prefix=Test", "--stdout", "test/smoke.h"] +smokeTest = runArgs ["--prefix=Test", "--stdout", "test/smoke2.h"] runArgs :: [String] -> IO() runArgs mainArgs = do @@ -112,18 +113,17 @@ 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", prefix opts) - , ("cFileName", cap) ] - code = newSTMP tmpl - base = dropExtension . takeFileName $ fileName - cap = capitalize base + let code = newSTMP $ + unlines [ "#include " + , "#include " + , "module $libName$.$cFileName$ where" + , "#strict_import" + , "" ] + vars = [ ("libName", prefix opts) + , ("cFileName", cap) ] + cap = capitalize . dropExtension . takeFileName $ fileName + target = cap ++ ".hsc" - let target = cap ++ ".hsc" handle <- if useStdout opts then return System.IO.stdout else openFile target WriteMode @@ -131,8 +131,8 @@ 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 + includes <- filter ("#include \"" `isPrefixOf`) . lines + <$> readFile fileName for_ includes $ \inc -> hPutStrLn handle $ "import " ++ prefix opts ++ "." @@ -140,8 +140,9 @@ traverse_ (hPutStrLn handle) hscs - unless (useStdout opts) $ hClose handle - putStrLn $ "Wrote " ++ target + unless (useStdout opts) $ do + hClose handle + putStrLn $ "Wrote " ++ target when (length helpercs > 0) $ do let targetc = cap ++ ".hsc.helper.c" @@ -154,17 +155,18 @@ hPutStrLn handlec "" traverse_ (hPutStrLn handlec) helpercs - unless (useStdout opts) $ hClose handlec - putStrLn $ "Wrote " ++ targetc + unless (useStdout opts) $ do + hClose handlec + putStrLn $ "Wrote " ++ targetc capitalize :: String -> String -capitalize [] = [] +capitalize [] = [] capitalize (x:xs) = toTitle x : camelCase xs camelCase :: String -> String -camelCase [] = [] +camelCase [] = [] camelCase ('_':xs) = capitalize xs -camelCase (x:xs) = x : camelCase xs +camelCase (x:xs) = x : camelCase xs ------------------------------- PURE FUNCTIONS ------------------------------- @@ -245,14 +247,19 @@ appendHsc $ "{- " ++ P.render (pretty dx) ++ " -}" appendType declSpecs "" - _ -> - for_ items $ \(declrtr, _, _) -> - for_ (splitDecl declrtr) $ \(d, ddrs, nm) -> + xs -> + for_ xs $ \(declrtr, _, _) -> + for_ (splitDecl declrtr) $ \(declrtr', ddrs, nm) -> case ddrs of - CFunDeclr (Right (_, _)) _ _ : _ -> + CFunDeclr (Right (_, _)) _ _:_ -> when (declInFile fp dx) $ - appendFunc "#ccall" declSpecs d + appendFunc "#ccall" declSpecs declrtr' + [] -> + when (declInFile fp dx) $ do + dname <- declSpecTypeName declSpecs + appendHsc $ "#globalvar " ++ nm ++ " , " ++ dname + _ -> do when (declInFile fp dx) $ do appendHsc $ "{- " ++ P.render (pretty dx) ++ " -}" @@ -260,15 +267,15 @@ -- 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 + case declSpecs of + CStorageSpec (CTypedef _):_ -> do dname <- declSpecTypeName declSpecs - case dname of - "" -> return () - _ -> defineType nm dname + unless (dname == "" || dname == "<" ++ nm ++ ">") $ do + when (declInFile fp dx) $ + appendHsc $ "#synonym_t " ++ nm ++ " , " ++ dname + + defineType nm dname + _ -> return () where splitDecl declrtr = do -- in the Maybe Monad @@ -280,11 +287,11 @@ when (declInFile fp dx) $ do appendFunc "#cinline" declSpecs declrtr - let (CDeclr ident ddrs _ _ _) = declrtr + let CDeclr ident ddrs _ _ _ = declrtr for_ ident $ \(Ident nm _ _) -> case head ddrs of - (CFunDeclr (Right (decls, _)) _ _) -> do + CFunDeclr (Right (decls, _)) _ _ -> do retType <- derDeclrTypeName' True declSpecs (tail ddrs) funType <- applyDeclrs True retType ddrs if retType /= "" @@ -302,14 +309,16 @@ appendFunc :: String -> [CDeclarationSpecifier a] -> CDeclarator a -> Output () appendFunc marker declSpecs (CDeclr ident ddrs _ _ _) = do - retType <- derDeclrTypeName declSpecs (tail ddrs) - argTypes <- (++) <$> (filter (/= "") <$> sequence (getArgTypes (head ddrs))) + let _:retDeclr:_ = splitWhen isFuncDeclr ddrs + funcDeclr:_ = dropWhile (not . isFuncDeclr) ddrs + + retType <- derDeclrTypeName declSpecs retDeclr + argTypes <- (++) <$> getArgTypes funcDeclr <*> pure [ "IO (" ++ retType ++ ")" ] let name' = nameFromIdent ident - tmpl = "$marker$ $name$ , $argTypes;separator=' -> '$" - code = newSTMP tmpl - -- I have to this separately since argTypes :: [String] + code = newSTMP "$marker$ $name$ , $argTypes;separator=' -> '$" + -- I have to call setAttribute separately since argTypes :: [String] code' = setAttribute "argTypes" argTypes code vars = [ ("marker", marker) , ("name", name') ] @@ -317,15 +326,17 @@ appendHsc $ toString $ setManyAttrib vars code' where - getArgTypes :: CDerivedDeclarator a -> [Output String] - getArgTypes (CFunDeclr (Right (decls, _)) _ _) = map cdeclTypeName decls - getArgTypes _ = [] + getArgTypes x = filter (not . null) <$> sequence (getArgTypes' x) - nameFromIdent :: Maybe Ident -> String - nameFromIdent nm = case nm of - Just (Ident n _ _) -> n - _ -> "" + getArgTypes' (CFunDeclr (Right (decls, _)) _ _) = map cdeclTypeName decls + getArgTypes' _ = [] + nameFromIdent (Just (Ident n _ _)) = n + nameFromIdent _ = "" + + isFuncDeclr (CFunDeclr {}) = True + isFuncDeclr _ = False + appendType :: [CDeclarationSpecifier a] -> String -> Output () appendType declSpecs declrName = traverse_ appendType' declSpecs where @@ -338,9 +349,9 @@ appendHsc $ "#starttype " ++ name' for_ xs $ \x -> for_ (cdeclName x) $ \declName -> do - let (CDecl declSpecs' ((Just y, _, _):_) _) = x + let CDecl declSpecs' ((Just y, _, _):_) _ = x case y of - (CDeclr _ (CArrDeclr {}:zs) _ _ _) -> do + CDeclr _ (CArrDeclr {}:zs) _ _ _ -> do tname <- derDeclrTypeName declSpecs' zs appendHsc $ "#array_field " ++ declName ++ " , " ++ tname _ -> do @@ -438,23 +449,23 @@ 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 (CPtrDeclr {}:f@CFunDeclr {}:ds) = do + baseType' <- applyDeclrs cStyle baseType ds + applyDeclrs cStyle baseType' [f] applyDeclrs cStyle baseType (CFunDeclr (Right (decls, _)) _ _:_) | cStyle = renderList ", " (funTypes decls baseType) - | otherwise = do argTypes <- renderList " -> " (funTypes decls baseType) - return $ "FunPtr (" ++ argTypes ++ ")" + | otherwise = do + argTypes <- renderList " -> " (funTypes decls baseType) + return $ "FunPtr (" ++ argTypes ++ ")" - where renderList str xs = intercalate str . filter (not . null) <$> xs - funTypes xs bt = sequence $ - map (cdeclTypeName' cStyle) xs ++ [pure bt] + where renderList str xs = intercalate str <$> filter (not . null) <$> xs + funTypes xs bt = (++) <$> mapM (cdeclTypeName' cStyle) xs + <*> pure [bt] applyDeclrs cStyle baseType decl@(CPtrDeclr quals _:[]) | cStyle && baseType == "" = applyDeclrs cStyle "void" decl - | cStyle = return $ baseType ++ " *" + | cStyle = return $ baseType ++ "*" ++ preQualsToString quals | baseType == "" = return "Ptr ()" | baseType == "CChar" = return "CString" @@ -462,7 +473,7 @@ applyDeclrs cStyle baseType (CPtrDeclr quals _:xs) | cStyle = concatM [ applyDeclrs cStyle baseType xs - , pure " *" + , pure "*" , pure (preQualsToString quals) ] | otherwise = concatM [ pure "Ptr (" , applyDeclrs cStyle baseType xs @@ -534,9 +545,12 @@ definition <- lookupType nm return $ fromMaybe ("<" ++ nm ++ ">") definition +typeName (CSUType (CStruct _ (Just (Ident nm _ _)) _ _ _) _) _ = + return $ "<" ++ nm ++ ">" +typeName (CEnumType (CEnum (Just (Ident nm _ _)) _ _ _) _) _ = + return $ "<" ++ nm ++ ">" + typeName (CComplexType _) _ = return "" -typeName (CSUType _ _) _ = return "" -typeName (CEnumType _ _) _ = return "" typeName (CTypeOfExpr _ _) _ = return "" typeName (CTypeOfType _ _) _ = return "" diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -12,13 +12,7 @@ Known issues: - - Filename matching is not accurate enough - - Pointers to "struct foo" are being rendered as Ptr () [void *] - - Function pointers of void return type are rendered incorrectly - - Handle type synonyms (output them as type a = b) - - Global variables are not being emitted - Varargs functions do not translate - - Inline helper generator outputs the wrong headers 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.4.0 +Version: 0.5.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 @@ -30,6 +30,7 @@ , pretty >= 1.1 , filepath >= 1.3 , cmdargs >= 0.9 + , split >= 0.2 --Test-suite smoke -- Type: exitcode-stdio-1.0