diff --git a/Data/C2Hsc.hs b/Data/C2Hsc.hs new file mode 100644 --- /dev/null +++ b/Data/C2Hsc.hs @@ -0,0 +1,697 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.C2Hsc where + +import Control.Applicative +import Control.Logging +import Control.Monad hiding (sequence) +import Control.Monad.Trans.State +import Data.Char +import Data.Data +import Data.Default +import Data.Foldable hiding (concat, elem, mapM_) +import Data.List as L +import Data.List.Split +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid +import Data.Text (pack) +import Data.Traversable hiding (mapM, forM) +import Language.C.Data.Ident +import Language.C.Data.InputStream +import Language.C.Data.Node +import Language.C.Data.Position +import Language.C.Parser +import Language.C.Pretty +import Language.C.Syntax.AST +import Language.C.System.GCC +import Language.C.System.Preprocess +import Prelude hiding (concat, sequence, mapM, mapM_, foldr) +import System.Directory +import System.FilePath.Posix +import System.IO +import System.IO.Temp +import Text.PrettyPrint as P hiding ((<>)) +import Text.StringTemplate + +data C2HscOptions = C2HscOptions + { gcc :: FilePath + , cppopts :: [String] + , prefix :: String + , filePrefix :: [String] + , overrides :: FilePath + , verbose :: Bool + , debug :: Bool + , files :: [FilePath] + } + deriving (Data, Typeable, Show, Eq) + +instance Default C2HscOptions where + def = C2HscOptions "/usr/bin/gcc" [] "" [] "" True False [] + +------------------------------ IMPURE FUNCTIONS ------------------------------ + +-- This function is used for debugging +processString :: String -> IO String +processString str = do + tmpDir <- getTemporaryDirectory + withTempFile tmpDir "c2hsc.src" $ \path h -> do + hPutStr h str + hClose h + withTempFile tmpDir "c2hsc.out" $ \outPath outH -> do + runArgs def { files = [path] + , prefix = "Spec" + } (Just outH) True + hClose outH + readFile outPath + +-- Parsing of C headers begins with finding gcc so we can run the +-- preprocessor. + +runArgs :: C2HscOptions -> Maybe Handle -> Bool -> IO () +runArgs opts output omitHeader = do + gccExe <- findExecutable $ case gcc opts of "" -> "gcc"; x -> x + case gccExe of + Nothing -> error $ "Cannot find executable '" ++ gcc opts ++ "'" + Just gccPath -> for_ (files opts) $ \fileName -> + parseFile gccPath fileName output omitHeader 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 -> FilePath -> Maybe Handle -> Bool -> C2HscOptions -> IO () +parseFile gccPath fileName output omitHeader opts = do + result <- runPreprocessor (newGCC gccPath) + (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 _ = + let ps = filePrefix opts + fm = if null ps + then (posFile pos ==) + else \fn -> any (`isPrefixOf` fn) ps + in execState (overrideState >> parseCFile stream fm pos) + newHscState + writeProducts opts fileName output omitHeader 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 $ Just Typedef { typedefName = ffiName + , typedefOverride = True } + +defaultOverrides :: Output () +defaultOverrides = mapM_ (uncurry overrideType) + [ ("size_t", "CSize") + , ("intptr_t", "IntPtr") + , ("uintptr_t", "WordPtr") ] + +makeModuleName :: String -> String +makeModuleName = Prelude.concatMap capitalize . splitOn "-" + +-- Write out the gathered data + +writeProducts :: C2HscOptions + -> FilePath + -> Maybe Handle + -> Bool + -> [String] + -> [String] + -> IO () +writeProducts opts fileName output omitHeader hscs helpercs = do + let code = newSTMP $ + if omitHeader + then "" + else unlines + [ "{-# OPTIONS_GHC -fno-warn-unused-imports #-}" + , "#include " + , "#include \"$headerFileName$\"" + , "module $libName$$cFileName$ where" + , "import Foreign.Ptr" + , "#strict_import" + , "" + ] + pre = if null (prefix opts) then "" else prefix opts ++ "." + vars = [ ("libName", pre) + , ("cFileName", cap) + , ("headerFileName", fileName) ] + cap = makeModuleName . dropExtension . takeFileName $ fileName + target = cap ++ ".hsc" + + handle <- case output of + Just h -> return h + Nothing -> openFile target WriteMode + + hPutStrLn handle $ toString $ setManyAttrib vars code + + -- Sniff through the file again, but looking only for local #include's + includes <- filter ("#include \"" `isPrefixOf`) . lines + <$> readFile fileName + for_ includes $ \inc -> do + let incPath = splitOn "\"" inc !! 1 + incPathParts = map dropTrailingPathSeparator $ splitPath $ dropExtension incPath + modName = pre ++ intercalate "." (map makeModuleName incPathParts) + hPutStrLn handle $ "import " ++ modName + + traverse_ (hPutStrLn handle) hscs + + when (isNothing output) $ do + hClose handle + log' $ "Wrote " <> pack target + + unless (null helpercs) $ do + let targetc = cap ++ ".hsc.helper.c" + handlec <- case output of + Just h -> return h + Nothing -> openFile targetc WriteMode + + hPutStrLn handlec "#include " + traverse_ (hPutStrLn handlec) includes + hPutStrLn handlec "" + traverse_ (hPutStrLn handlec) helpercs + + when (isNothing output) $ do + hClose handlec + log' $ "Wrote " <> pack targetc + +capitalize :: String -> String +capitalize [] = [] +capitalize (x:xs) = toTitle x : camelCase xs + +camelCase :: String -> String +camelCase [] = [] +camelCase ('_':xs) = capitalize xs +camelCase (x:xs) = x : camelCase xs + +------------------------------- PURE FUNCTIONS ------------------------------- + +-- Rather than writing to the .hsc and .hsc.helper.c files directly from the +-- IO monad, they are collected in an HscOutput value in the State monad. The +-- actual writing is done by writeProducts. This keeps all the code below +-- pure, and since the data sets involved are relatively small, performance is +-- not a critical issue. + +data Typedef = Typedef + { typedefName :: String + , typedefOverride :: Bool + } + deriving Show + +type TypeMap = M.Map String (Maybe Typedef) + +data HscOutput = HscOutput + { hoHsc :: [String] + , hoHelperC :: [String] + , hoTypes :: TypeMap + } + +type Output = State HscOutput + +newHscState :: HscOutput +newHscState = HscOutput [] [] M.empty + +appendHsc :: String -> Output () +appendHsc hsc = do + HscOutput hscs xs types <- get + put $ HscOutput (hscs ++ [hsc]) xs types + +appendHelper :: String -> Output () +appendHelper helperc = do + HscOutput xs helpercs types <- get + put $ HscOutput xs (helpercs ++ [helperc]) types + +defineType :: String -> Maybe Typedef -> Output () +defineType key value = do + HscOutput xs ys types <- get + hasOverride <- fmap typedefOverride <$> lookupType key + case hasOverride of + Just True -> return () + _ -> put $ HscOutput xs ys (M.insert key value types) + +lookupType :: String -> Output (Maybe Typedef) +lookupType key = do + HscOutput _ _ types <- get + return . join $ M.lookup key types + +-- Now we are ready to parse the C code from the preprocessed input stream, +-- located in the given file and starting at the specified position. The +-- result of a parse is a list of global declarations, so filter the list down +-- to those occurring in the target file, and then print the declarations in +-- Bindings-DSL format. + +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 fm) + +declMatches :: (FilePath -> Bool) -> CExtDecl -> Bool +declMatches fm = fm . posFile . posOfNode . declInfo + +declInfo :: CExtDecl -> NodeInfo +declInfo (CDeclExt (CDecl _ _ info)) = info +declInfo (CDeclExt (CStaticAssert _ _ info)) = info +declInfo (CFDefExt (CFunDef _ _ _ _ info)) = info +declInfo (CAsmExt _ info) = info + +-- These are the top-level printing routines. We are only interested in +-- declarations and function defitions (which almost always means inline +-- functions if the target file is a header file). +-- +-- We will end up printing the following constructs: +-- +-- - Structure definitions +-- - Opaque types (i.e., forward declarations of pointer type) +-- - Enums +-- - Extern Functions +-- - Inline Functions + +appendNode :: (FilePath -> Bool) -> CExtDecl -> Output () + +appendNode _ (CDeclExt (CStaticAssert _ _ _)) = return () + +appendNode fm dx@(CDeclExt (CDecl declSpecs items _)) = + case items of + [] -> + when (declMatches fm dx) $ do + appendHsc $ "{- " ++ P.render (pretty dx) ++ " -}" + appendType declSpecs "" + + xs -> + 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 (declMatches fm dx) $ + appendFunc "#ccall" declSpecs declrtr' + + CArrDeclr{}:CPtrDeclr{}:_ -> + when (declMatches fm dx) $ do + dname <- declSpecTypeName True declSpecs + appendHsc $ "#globalarray " ++ nm ++ " , Ptr " ++ tyParens dname + + CArrDeclr{}:_ -> + when (declMatches fm dx) $ do + dname <- declSpecTypeName True declSpecs + appendHsc $ "#globalarray " ++ nm ++ " , " ++ tyParens dname + + CPtrDeclr{}:_ -> + when (declMatches fm dx) $ do + dname <- declSpecTypeName True declSpecs + appendHsc $ "#globalvar " ++ nm ++ " , Ptr " ++ tyParens dname + + _ -> + -- If the type is a typedef, record the equivalence so we can + -- look it up later + case declSpecs of + CStorageSpec (CTypedef _):_ -> do + when (declMatches fm dx) $ do + appendHsc $ "{- " ++ P.render (pretty dx) ++ " -}" + appendType declSpecs nm + + dname <- declSpecTypeName True declSpecs + unless (null dname || dname == "<" ++ nm ++ ">") $ do + when (declMatches fm dx) $ + appendHsc $ "#synonym_t " ++ nm ++ " , " ++ dname + -- We saw the synonym, override the defineType just above + defineType nm $ Just Typedef + { typedefName = dname + , typedefOverride = False + } + + _ -> + when (declMatches fm dx) $ do + dname <- declSpecTypeName True declSpecs + appendHsc $ "#globalvar " ++ nm ++ " , " ++ tyParens dname + where + splitDecl declrtr = do -- in the Maybe Monad + d@(CDeclr ident ddrs _ _ _) <- declrtr + return (d, ddrs, case ident of Just (Ident nm _ _) -> nm; _ -> "") + +appendNode fm dx@(CFDefExt (CFunDef declSpecs declrtr _ _ _)) = + -- Assume functions defined in headers are inline functions + when (declMatches fm dx) $ do + appendFunc "#cinline" declSpecs declrtr + + let CDeclr ident ddrs _ _ _ = declrtr + + for_ ident $ \(Ident nm _ _) -> + case head ddrs of + CFunDeclr (Right (decls, _)) _ _ -> do + retType <- derDeclrTypeName' True False declSpecs (tail ddrs) + funType <- applyDeclrs True False retType ddrs + appendHelper $ + "BC_INLINE" ++ show (length decls) + ++ (if not (null retType) then "" else "VOID") + ++ "(" ++ nm ++ ", " ++ funType ++ ")" + _ -> return () + +appendNode _ (CAsmExt _ _) = return () + +-- Print out a function as #ccall or #cinline. The syntax is the same for +-- both externs and inlines, except that we want to do extra work for inline +-- and create a helper file with some additional macros. + +appendFunc :: String -> [CDeclarationSpecifier a] -> CDeclarator a -> Output () +appendFunc marker declSpecs (CDeclr ident ddrs _ _ _) = do + let _:retDeclr:_ = splitWhen isFuncDeclr ddrs + funcDeclr:_ = dropWhile (not . isFuncDeclr) ddrs + + retType <- derDeclrTypeName False declSpecs retDeclr + argTypes <- (++) <$> getArgTypes funcDeclr + <*> pure [ "IO " ++ tyParens retType ] + + let name' = nameFromIdent ident + 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') ] + + appendHsc $ toString $ setManyAttrib vars code' + + where + getArgTypes x = filter (not . null) <$> sequence (getArgTypes' x) + + getArgTypes' (CFunDeclr (Right (decls, _)) _ _) = + map (cdeclTypeName False) decls + getArgTypes' _ = [] + + nameFromIdent (Just (Ident n _ _)) = n + nameFromIdent _ = "" + + isFuncDeclr (CFunDeclr {}) = True + isFuncDeclr _ = False + +structTagPrefix :: CStructTag -> String +structTagPrefix CStructTag = "struct " +structTagPrefix CUnionTag = "union " + +appendType :: [CDeclarationSpecifier a] -> String -> Output () +appendType declSpecs declrName = traverse_ appendType' declSpecs + where + appendType' (CTypeSpec (CSUType (CStruct tag ident decls _ _) _)) = do + let name' = identName (structTagPrefix tag) ident + seen <- M.member name' . hoTypes <$> get + when (isNothing decls && not seen) $ do + appendHsc $ "#opaque_t " ++ name' + defineType name' Nothing + + for_ decls $ \xs -> do + appendHsc $ "#starttype " ++ name' + for_ xs $ \x -> + for_ (cdeclNames x) $ \declName -> do + let CDecl declSpecs' ((Just y, _, _):_) _ = x + case y of + CDeclr _ (CArrDeclr {}:zs) _ _ _ -> do + tname <- derDeclrTypeName True declSpecs' zs + appendHsc $ "#array_field " ++ declName ++ " , " ++ tname + _ -> do + tname <- cdeclTypeName True x + appendHsc $ "#field " ++ declName ++ " , " ++ tname + appendHsc "#stoptype" + + appendType' (CTypeSpec (CEnumType (CEnum ident defs _ _) _)) = do + let name' = identName "enum " ident + unless (null name') $ appendHsc $ "#integral_t " ++ name' + + for_ defs $ \ds -> + for_ ds $ \(Ident nm _ _, _) -> + appendHsc $ "#num " ++ nm + + appendType' _ = return () + + identName pref ident = case ident of + Nothing -> declrName + Just (Ident nm _ _) -> pref ++ 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 +-- the type name "Ptr (Ptr CInt)". + +data Signedness = None | Signed | Unsigned deriving (Eq, Show, Enum) + +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 +cdeclNames (CStaticAssert _ _ _) = [] + +cdeclTypeName :: Bool -> CDeclaration a -> Output String +cdeclTypeName = cdeclTypeName' False + +cdeclTypeName' :: Bool -> Bool -> CDeclaration a -> Output String +cdeclTypeName' cStyle isDirect (CDecl declSpecs more _) = + case more of + (Just x, _, _) : _ -> declrTypeName' cStyle isDirect declSpecs x + _ -> declSpecTypeName' cStyle isDirect declSpecs +cdeclTypeName' _ _ (CStaticAssert _ _ _) = error "Unhandled static assertion" + +declSpecTypeName :: Bool -> [CDeclarationSpecifier a] -> Output String +declSpecTypeName = declSpecTypeName' False + +declSpecTypeName' :: Bool -> Bool -> [CDeclarationSpecifier a] -> Output String +declSpecTypeName' cStyle isDirect = flip (derDeclrTypeName' cStyle isDirect) [] + +declrTypeName :: Bool -> [CDeclarationSpecifier a] -> CDeclarator a + -> Output String +declrTypeName = declrTypeName' False + +declrTypeName' :: Bool -> Bool -> [CDeclarationSpecifier a] -> CDeclarator a + -> Output String +declrTypeName' cStyle isDirect declSpecs (CDeclr _ ddrs _ _ _) = + derDeclrTypeName' cStyle isDirect declSpecs ddrs + +derDeclrTypeName :: Bool -> [CDeclarationSpecifier a] -> [CDerivedDeclarator a] + -> Output String +derDeclrTypeName = derDeclrTypeName' False + +derDeclrTypeName' :: Bool + -> Bool + -> [CDeclarationSpecifier a] + -> [CDerivedDeclarator a] + -> Output String +derDeclrTypeName' cStyle isDirect declSpecs ddrs = do + nm <- fullTypeName' None declSpecs + applyDeclrs cStyle isDirect nm ddrs + + where + fullTypeName' :: Signedness -> [CDeclarationSpecifier a] -> Output String + fullTypeName' _ [] = return "" + + fullTypeName' s (CTypeQual qual:xs) = + if cStyle + then do + baseType <- fullTypeName' s xs + return $ let q = qualToStr qual + in if null q + then baseType + else q ++ " " ++ baseType + else + fullTypeName' s xs + + fullTypeName' _ (CTypeSpec (CSignedType _):[]) = + return $ if cStyle then "signed" else "CInt" + fullTypeName' _ (CTypeSpec (CUnsigType _):[]) = + return $ if cStyle then "unsigned" else "CUInt" + + fullTypeName' s (x:xs) = + case x of + CTypeSpec (CSignedType _) -> fullTypeName' Signed xs + CTypeSpec (CUnsigType _) -> fullTypeName' Unsigned xs + CTypeSpec tspec -> if cStyle + then cTypeName tspec s + else typeName tspec s + _ -> fullTypeName' s xs + +concatM :: (Monad f, Functor f) => [f [a]] -> f [a] +concatM xs = concat <$> sequence xs + +applyDeclrs :: Bool -> Bool -> String -> [CDerivedDeclarator a] -> Output String + +applyDeclrs cStyle _isDirect baseType (CPtrDeclr {}:f@CFunDeclr {}:ds) = do + baseType' <- applyDeclrs cStyle False baseType ds + applyDeclrs cStyle False baseType' [f] + +applyDeclrs cStyle isDirect baseType (CFunDeclr (Right (decls, _)) _ _:_) + | cStyle = renderList ", " (funTypes decls baseType) + | otherwise = do + argTypes <- renderList " -> " (funTypes decls (if null baseType + then "IO ()" + else baseType)) + return $ "FunPtr " ++ tyParens argTypes + + where renderList str xs = intercalate str <$> filter (not . null) <$> xs + funTypes xs bt = (++) <$> mapM (cdeclTypeName' cStyle isDirect) xs + <*> pure [bt] + +applyDeclrs cStyle isDirect baseType decl@(CPtrDeclr quals _:[]) + | cStyle && baseType == "" = applyDeclrs cStyle isDirect "void" decl + | cStyle = return $ baseType ++ "*" + ++ preQualsToString quals + | baseType == "" = return "Ptr ()" + | baseType == "CChar" = return "CString" + | otherwise = return $ "Ptr " ++ baseType + +applyDeclrs cStyle isDirect baseType (CPtrDeclr quals _:xs) + | cStyle = concatM [ applyDeclrs cStyle isDirect baseType xs + , pure "*" + , pure (preQualsToString quals) ] + | otherwise = concatM [ pure "Ptr " + , tyParens `fmap` + applyDeclrs cStyle isDirect baseType xs ] + +applyDeclrs cStyle isDirect baseType (CArrDeclr quals _ _:xs) + | cStyle = concatM [ pure (sufQualsToString quals) + , applyDeclrs cStyle isDirect baseType xs + , pure "[]" ] + | otherwise = concatM [ pure $ if isDirect then "" else "Ptr " + , tyParens `fmap` + applyDeclrs cStyle isDirect baseType xs ] + +applyDeclrs _ _ baseType _ = return baseType + +preQualsToString :: [CTypeQualifier a] -> String +preQualsToString = prefixWith ' ' . qualsToStr + +prefixWith :: a -> [a] -> [a] +prefixWith _ [] = [] +prefixWith x xs = x:xs + +sufQualsToString :: [CTypeQualifier a] -> String +sufQualsToString = suffixWith ' ' . qualsToStr + +suffixWith :: a -> [a] -> [a] +suffixWith _ [] = [] +suffixWith x xs = xs ++ [x] + +qualsToStr :: [CTypeQualifier a] -> String +qualsToStr = unwords . map qualToStr + +qualToStr :: CTypeQualifier t -> String +qualToStr (CConstQual _) = "const" +qualToStr (CVolatQual _) = "volatile" +qualToStr (CRestrQual _) = "restricted" +qualToStr (CAtomicQual _) = "atomic" +qualToStr (CAttrQual _) = "" +qualToStr (CNullableQual _) = "" +qualToStr (CNonnullQual _) = "" + +-- 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 +-- a void star becomes Ptr (). + +typeName :: CTypeSpecifier a -> Signedness -> Output String + +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" +typeName (CShortType _) s = case s of + Signed -> return "CShort" + Unsigned -> return "CUShort" + _ -> return "CShort" +typeName (CIntType _) s = case s of + Signed -> return "CInt" + Unsigned -> return "CUInt" + _ -> return "CInt" +typeName (CLongType _) s = case s of + Signed -> return "CLong" + Unsigned -> return "CULong" + _ -> return "CLong" + +typeName (CTypeDef (Ident nm _ _) _) _ = do + definition <- lookupType nm + case definition of + Nothing -> return $ "<" ++ nm ++ ">" + Just (Typedef { typedefName = defNm }) -> + return defNm + +typeName (CSUType (CStruct tag (Just (Ident nm _ _)) _ _ _) _) _ = + return $ "<" ++ structTagPrefix tag ++ nm ++ ">" +typeName (CEnumType (CEnum (Just (Ident nm _ _)) _ _ _) _) _ = + return $ "" + +typeName (CComplexType _) _ = return "" +typeName (CTypeOfExpr _ _) _ = return "" +typeName (CTypeOfType _ _) _ = 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 +-- language-c. + +cTypeName :: CTypeSpecifier a -> Signedness -> Output String + +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" +cTypeName (CShortType _) s = case s of + 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" +cTypeName (CLongType _) s = case s of + Signed -> return "signed long" + Unsigned -> return "unsigned long" + _ -> return "long" + +cTypeName (CTypeDef (Ident nm _ _) _) _ = return nm + +cTypeName (CComplexType _) _ = return "" +cTypeName (CSUType _ _) _ = return "" +cTypeName (CEnumType _ _) _ = return "" +cTypeName (CTypeOfExpr _ _) _ = return "" +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/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,56 +1,22 @@ -{-# LANGUAGE DeriveDataTypeable #-} - module Main where -import Control.Applicative -import Control.Monad hiding (sequence) -import Control.Monad.Trans.State -import Data.Char -import Data.Foldable hiding (concat, elem, mapM_) -import Data.List as L -import Data.List.Split -import qualified Data.Map as M -import Data.Maybe -import Data.Traversable hiding (mapM, forM) -import Language.C.Data.Ident -import Language.C.Data.InputStream -import Language.C.Data.Node -import Language.C.Data.Position -import Language.C.Parser -import Language.C.Pretty -import Language.C.Syntax.AST -import Language.C.System.GCC -import Language.C.System.Preprocess -import Prelude hiding (concat, sequence, mapM, mapM_, foldr) -import System.Console.CmdArgs -import System.Directory -import System.Environment -import System.FilePath -import System.IO -import Text.PrettyPrint as P -import Text.StringTemplate - +import Control.Logging hiding (debug) +import Control.Monad hiding (sequence) +import Data.C2Hsc (C2HscOptions(..), runArgs) +import Data.List as L +import Prelude hiding (concat, sequence, mapM, mapM_, foldr) +import System.Console.CmdArgs +import System.Environment + version :: String -version = "0.6.4" +version = "0.7.0" copyright :: String -copyright = "2012" +copyright = "2012-2014" c2hscSummary :: String c2hscSummary = "c2hsc v" ++ version ++ ", (C) John Wiegley " ++ copyright -data C2HscOptions = C2HscOptions - { 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 c2hscOptions = C2HscOptions { gcc = def &= typFile @@ -61,8 +27,6 @@ &= 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 &= help "FILE contains \"C type -> FFI type\" translations" , verbose = def &= name "v" @@ -73,589 +37,14 @@ 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 = getArgs >>= runArgs - -smokeTest :: IO () -smokeTest = runArgs ["--prefix=Test", "--stdout", "test/smoke2.h"] - -runArgs :: [String] -> IO() -runArgs mainArgs = do +main = getArgs >>= \mainArgs -> do opts <- withArgs (if null mainArgs then ["--help"] else mainArgs) (cmdArgs c2hscOptions) - when (null (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 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 -> 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 - overrideState <- defineTypeOverrides (overrides opts) - let pos = initPos fileName - HscOutput hscs helpercs _ = - 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 ()) -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") ] - -makeModuleName :: String -> String -makeModuleName = Prelude.concatMap capitalize . splitOn "-" - --- Write out the gathered data - -writeProducts :: C2HscOptions -> FilePath -> [String] -> [String] -> IO () -writeProducts opts fileName hscs helpercs = do - let code = newSTMP $ - 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) - , ("headerFileName", fileName) ] - cap = makeModuleName . dropExtension . takeFileName $ fileName - target = cap ++ ".hsc" - - 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 - includes <- filter ("#include \"" `isPrefixOf`) . lines - <$> readFile fileName - for_ includes $ \inc -> do - let incPath = splitOn "\"" inc !! 1 - incPathParts = map dropTrailingPathSeparator $ splitPath $ dropExtension incPath - modName = intercalate "." $ prefix opts : map makeModuleName incPathParts - hPutStrLn handle $ "import " ++ modName - - traverse_ (hPutStrLn handle) hscs - - unless (useStdout opts) $ do - hClose handle - putStrLn $ "Wrote " ++ target - - unless (null helpercs) $ do - let targetc = cap ++ ".hsc.helper.c" - 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 - - unless (useStdout opts) $ do - hClose handlec - putStrLn $ "Wrote " ++ targetc - -capitalize :: String -> String -capitalize [] = [] -capitalize (x:xs) = toTitle x : camelCase xs - -camelCase :: String -> String -camelCase [] = [] -camelCase ('_':xs) = capitalize xs -camelCase (x:xs) = x : camelCase xs - -------------------------------- PURE FUNCTIONS ------------------------------- - --- Rather than writing to the .hsc and .hsc.helper.c files directly from the --- IO monad, they are collected in an HscOutput value in the State monad. The --- actual writing is done by writeProducts. This keeps all the code below --- pure, and since the data sets involved are relatively small, performance is --- not a critical issue. - -data Typedef = Typedef { typedefName :: String - , typedefOverride :: Bool } -type TypeMap = M.Map String Typedef -data HscOutput = HscOutput [String] [String] TypeMap -type Output = State HscOutput - -newHscState :: HscOutput -newHscState = HscOutput [] [] M.empty - -appendHsc :: String -> Output () -appendHsc hsc = do - HscOutput hscs xs types <- get - put $ HscOutput (hscs ++ [hsc]) xs types - -appendHelper :: String -> Output () -appendHelper helperc = do - HscOutput xs helpercs types <- get - put $ HscOutput xs (helpercs ++ [helperc]) types - -defineType :: String -> Typedef -> Output () -defineType key value = do - HscOutput xs ys types <- get - hasOverride <- fmap typedefOverride <$> lookupType key - case hasOverride of - Just True -> return () - _ -> put $ HscOutput xs ys (M.insert key value types) - -lookupType :: String -> Output (Maybe Typedef) -lookupType key = do - HscOutput _ _ types <- get - return $ M.lookup key types - --- Now we are ready to parse the C code from the preprocessed input stream, --- located in the given file and starting at the specified position. The --- result of a parse is a list of global declarations, so filter the list down --- to those occurring in the target file, and then print the declarations in --- Bindings-DSL format. - -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 fm) - -declMatches :: (FilePath -> Bool) -> CExtDecl -> Bool -declMatches fm = fm . posFile . posOfNode . declInfo - -declInfo :: CExtDecl -> NodeInfo -declInfo (CDeclExt (CDecl _ _ info)) = info -declInfo (CFDefExt (CFunDef _ _ _ _ info)) = info -declInfo (CAsmExt _ info) = info - --- These are the top-level printing routines. We are only interested in --- declarations and function defitions (which almost always means inline --- functions if the target file is a header file). --- --- We will end up printing the following constructs: --- --- - Structure definitions --- - Opaque types (i.e., forward declarations of pointer type) --- - Enums --- - Extern Functions --- - Inline Functions - -appendNode :: (FilePath -> Bool) -> CExtDecl -> Output () - -appendNode fm dx@(CDeclExt (CDecl declSpecs items _)) = - case items of - [] -> - when (declMatches fm dx) $ do - appendHsc $ "{- " ++ P.render (pretty dx) ++ " -}" - appendType declSpecs "" - - xs -> - 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 (declMatches fm dx) $ - appendFunc "#ccall" declSpecs declrtr' - - _ -> - -- If the type is a typedef, record the equivalence so we can - -- look it up later - case declSpecs of - CStorageSpec (CTypedef _):_ -> do - when (declMatches fm dx) $ do - appendHsc $ "{- " ++ P.render (pretty dx) ++ " -}" - appendType declSpecs nm - - dname <- declSpecTypeName declSpecs - unless (null dname || dname == "<" ++ nm ++ ">") $ do - when (declMatches fm dx) $ - appendHsc $ "#synonym_t " ++ nm ++ " , " ++ dname - - defineType nm Typedef { typedefName = dname - , typedefOverride = False } - _ -> - when (declMatches fm dx) $ do - dname <- declSpecTypeName declSpecs - appendHsc $ "#globalvar " ++ nm ++ " , " ++ dname - where - splitDecl declrtr = do -- in the Maybe Monad - d@(CDeclr ident ddrs _ _ _) <- declrtr - return (d, ddrs, case ident of Just (Ident nm _ _) -> nm; _ -> "") - -appendNode fm dx@(CFDefExt (CFunDef declSpecs declrtr _ _ _)) = - -- Assume functions defined in headers are inline functions - when (declMatches fm dx) $ do - appendFunc "#cinline" declSpecs declrtr - - 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 - appendHelper $ - "BC_INLINE" ++ show (length decls) - ++ (if not (null retType) then "" else "VOID") - ++ "(" ++ nm ++ ", " ++ funType ++ ")" - _ -> return () - -appendNode _ (CAsmExt _ _) = return () - --- Print out a function as #ccall or #cinline. The syntax is the same for --- both externs and inlines, except that we want to do extra work for inline --- and create a helper file with some additional macros. - -appendFunc :: String -> [CDeclarationSpecifier a] -> CDeclarator a -> Output () -appendFunc marker declSpecs (CDeclr ident ddrs _ _ _) = do - let _:retDeclr:_ = splitWhen isFuncDeclr ddrs - funcDeclr:_ = dropWhile (not . isFuncDeclr) ddrs - - retType <- derDeclrTypeName declSpecs retDeclr - argTypes <- (++) <$> getArgTypes funcDeclr - <*> pure [ "IO " ++ tyParens retType ] - - let name' = nameFromIdent ident - 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') ] - - appendHsc $ toString $ setManyAttrib vars code' - - where - getArgTypes x = filter (not . null) <$> sequence (getArgTypes' x) - - getArgTypes' (CFunDeclr (Right (decls, _)) _ _) = map cdeclTypeName decls - getArgTypes' _ = [] - - nameFromIdent (Just (Ident n _ _)) = n - nameFromIdent _ = "" - - isFuncDeclr (CFunDeclr {}) = True - isFuncDeclr _ = False - -structTagPrefix :: CStructTag -> String -structTagPrefix CStructTag = "struct " -structTagPrefix CUnionTag = "union " - -appendType :: [CDeclarationSpecifier a] -> String -> Output () -appendType declSpecs declrName = traverse_ appendType' declSpecs - where - appendType' (CTypeSpec (CSUType (CStruct tag ident decls _ _) _)) = do - let name' = identName (structTagPrefix tag) ident - when (isNothing decls) $ - appendHsc $ "#opaque_t " ++ name' - - for_ decls $ \xs -> do - appendHsc $ "#starttype " ++ name' - for_ xs $ \x -> - for_ (cdeclNames x) $ \declName -> do - let CDecl declSpecs' ((Just y, _, _):_) _ = x - case y of - CDeclr _ (CArrDeclr {}:zs) _ _ _ -> do - tname <- derDeclrTypeName declSpecs' zs - appendHsc $ "#array_field " ++ declName ++ " , " ++ tname - _ -> do - tname <- cdeclTypeName x - appendHsc $ "#field " ++ declName ++ " , " ++ tname - appendHsc "#stoptype" - - appendType' (CTypeSpec (CEnumType (CEnum ident defs _ _) _)) = do - let name' = identName "enum " ident - when (length name' > 0) $ appendHsc $ "#integral_t " ++ name' - - for_ defs $ \ds -> - for_ ds $ \(Ident nm _ _, _) -> - appendHsc $ "#num " ++ nm - - appendType' _ = return () - - identName pref ident = case ident of - Nothing -> declrName - Just (Ident nm _ _) -> pref ++ 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 --- the type name "Ptr (Ptr CInt)". - -data Signedness = None | Signed | Unsigned deriving (Eq, Show, Enum) - -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 - -cdeclTypeName' :: Bool -> CDeclaration a -> Output String -cdeclTypeName' cStyle (CDecl declSpecs more _) = - case more of - (Just x, _, _) : _ -> declrTypeName' cStyle declSpecs x - _ -> declSpecTypeName' cStyle declSpecs - -declSpecTypeName :: [CDeclarationSpecifier a] -> Output String -declSpecTypeName = declSpecTypeName' False - -declSpecTypeName' :: Bool -> [CDeclarationSpecifier a] -> Output String -declSpecTypeName' cStyle = flip (derDeclrTypeName' cStyle) [] - -declrTypeName :: [CDeclarationSpecifier a] -> CDeclarator a -> Output String -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 = do - nm <- fullTypeName' None declSpecs - applyDeclrs cStyle nm ddrs - - where - fullTypeName' :: Signedness -> [CDeclarationSpecifier a] -> Output String - fullTypeName' _ [] = return "" - - fullTypeName' s (CTypeQual qual:xs) = - if cStyle - then do - baseType <- fullTypeName' s xs - return $ let q = qualToStr qual - in if null q - then baseType - else q ++ " " ++ baseType - else - fullTypeName' s xs - - fullTypeName' _ (CTypeSpec (CSignedType _):[]) = - return $ if cStyle then "signed" else "CInt" - fullTypeName' _ (CTypeSpec (CUnsigType _):[]) = - return $ if cStyle then "unsigned" else "CUInt" - - fullTypeName' s (x:xs) = - case x of - CTypeSpec (CSignedType _) -> fullTypeName' Signed xs - CTypeSpec (CUnsigType _) -> fullTypeName' Unsigned xs - CTypeSpec tspec -> if cStyle - then cTypeName tspec s - else typeName tspec s - _ -> fullTypeName' s 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 (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 (if null baseType - then "IO ()" - else baseType)) - return $ "FunPtr " ++ tyParens argTypes - - 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 ++ "*" - ++ preQualsToString quals - | baseType == "" = return "Ptr ()" - | baseType == "CChar" = return "CString" - | otherwise = return $ "Ptr " ++ baseType - -applyDeclrs cStyle baseType (CPtrDeclr quals _:xs) - | cStyle = concatM [ applyDeclrs cStyle baseType xs - , pure "*" - , pure (preQualsToString quals) ] - | 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 " - , tyParens `fmap` applyDeclrs cStyle baseType xs ] - -applyDeclrs _ baseType _ = return baseType - -preQualsToString :: [CTypeQualifier a] -> String -preQualsToString = prefixWith ' ' . qualsToStr - -prefixWith :: a -> [a] -> [a] -prefixWith _ [] = [] -prefixWith x xs = x:xs - -sufQualsToString :: [CTypeQualifier a] -> String -sufQualsToString = suffixWith ' ' . qualsToStr - -suffixWith :: a -> [a] -> [a] -suffixWith _ [] = [] -suffixWith x xs = xs ++ [x] - -qualsToStr :: [CTypeQualifier a] -> String -qualsToStr = unwords . map qualToStr - -qualToStr :: CTypeQualifier t -> String -qualToStr (CConstQual _) = "const" -qualToStr (CVolatQual _) = "volatile" -qualToStr (CRestrQual _) = "restricted" -qualToStr (CInlineQual _) = "" -qualToStr (CAttrQual _) = error "Unimplemented: attribute qualifiers" - --- 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 --- a void star becomes Ptr (). - -typeName :: CTypeSpecifier a -> Signedness -> Output String - -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" -typeName (CShortType _) s = case s of - Signed -> return "CShort" - Unsigned -> return "CUShort" - _ -> return "CShort" -typeName (CIntType _) s = case s of - Signed -> return "CInt" - Unsigned -> return "CUInt" - _ -> return "CInt" -typeName (CLongType _) s = case s of - Signed -> return "CLong" - Unsigned -> return "CULong" - _ -> return "CLong" - -typeName (CTypeDef (Ident nm _ _) _) _ = do - definition <- lookupType nm - case definition of - Nothing -> return $ "<" ++ nm ++ ">" - Just (Typedef { typedefName = defNm }) -> - return defNm - -typeName (CSUType (CStruct tag (Just (Ident nm _ _)) _ _ _) _) _ = - return $ "<" ++ (structTagPrefix tag) ++ nm ++ ">" -typeName (CEnumType (CEnum (Just (Ident nm _ _)) _ _ _) _) _ = - return $ "" - -typeName (CComplexType _) _ = return "" -typeName (CTypeOfExpr _ _) _ = return "" -typeName (CTypeOfType _ _) _ = 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 --- language-c. - -cTypeName :: CTypeSpecifier a -> Signedness -> Output String - -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" -cTypeName (CShortType _) s = case s of - 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" -cTypeName (CLongType _) s = case s of - Signed -> return "signed long" - Unsigned -> return "unsigned long" - _ -> return "long" - -cTypeName (CTypeDef (Ident nm _ _) _) _ = return nm - -cTypeName (CComplexType _) _ = return "" -cTypeName (CSUType _ _) _ = return "" -cTypeName (CEnumType _ _) _ = return "" -cTypeName (CTypeOfExpr _ _) _ = return "" -cTypeName (CTypeOfType _ _) _ = return "" - -cTypeName _ _ = return "" - -tyParens :: String -> String -tyParens ty = - if null ty || ' ' `elem` ty - then concat ["(", ty, ")"] - else ty - --- c2hsc.hs + withStderrLogging $ runArgs opts Nothing False diff --git a/c2hsc.cabal b/c2hsc.cabal --- a/c2hsc.cabal +++ b/c2hsc.cabal @@ -1,43 +1,78 @@ -Name: c2hsc - -Version: 0.6.5 -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 - -Homepage: https://github.com/jwiegley/c2hsc -License: BSD3 -License-file: LICENSE -Author: John Wiegley -Maintainer: John Wiegley -Category: Development -Build-type: Simple -Cabal-version: >= 1.8 +Name: c2hsc +Version: 0.7.1 +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 +Homepage: https://github.com/jwiegley/c2hsc +License: BSD3 +License-file: LICENSE +Author: John Wiegley +Maintainer: John Wiegley +Category: Development +Build-type: Simple +Cabal-version: >= 1.10 Extra-Source-Files: README.md +Library + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >= 3 && < 5 + , mtl >= 2.0 + , containers >= 0.4 + , transformers >= 0.2 + , directory >= 1.1 + , language-c >= 0.4 + , logging >= 1.3.0 + , HStringTemplate >= 0.7.1 + , pretty >= 1.1 + , filepath >= 1.3 + , split >= 0.2 + , temporary >= 1.1.2.5 + , data-default >= 0.5.3 + , text >= 0.11.3.1 + exposed-modules: + Data.C2Hsc + default-extensions: + BangPatterns + FlexibleContexts + OverloadedStrings + Executable c2hsc - Main-is: Main.hs - Ghc-options: -Wall + default-language: Haskell2010 + main-is: Main.hs + ghc-options: -Wall - Build-depends: base >= 4 && < 5 - , mtl >= 2.0 - , containers >= 0.4 - , transformers >= 0.2 - , directory >= 1.1 - , language-c >= 0.4 - , HStringTemplate >= 0.6 - , pretty >= 1.1 - , filepath >= 1.3 - , cmdargs >= 0.9 - , split >= 0.2 + build-depends: + base >= 4 && < 5 + , c2hsc + , cmdargs >= 0.9 + , HStringTemplate >= 0.7.1 + , pretty >= 1.1 + , filepath >= 1.3 + , directory >= 1.1 + , language-c >= 0.4 + , logging >= 1.3.0 + , containers >= 0.4 + , split >= 0.2 + , transformers >= 0.2 + , temporary >= 1.1.2.5 + , data-default >= 0.5.3 + , text >= 0.11.3.1 ---Test-suite smoke --- Type: exitcode-stdio-1.0 --- Main-is: Smoke.hs --- Hs-source-dirs: test --- Build-depends: base >= 4 && < 5 --- , c2hsc +Test-suite test + default-language: Haskell2010 + Type: exitcode-stdio-1.0 + Main-is: main.hs + Hs-source-dirs: test + Build-depends: + base >= 4 && < 5 + , c2hsc + , hspec >= 1.8.3 + , here >= 1.2.3 + , monad-logger >= 0.3.4.1 + , logging >= 1.3.0 + , text >= 0.11.3.1 Source-repository head Type: git diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -0,0 +1,1688 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Main where + +import Control.Exception +import Control.Logging +import Data.C2Hsc +import Data.Char +import Data.String.Here +import Data.Text (Text, pack) +import Prelude hiding (log) +import Test.Hspec + +tryAny :: IO a -> IO (Either SomeException a) +tryAny = try + +main :: IO () +main = withStdoutLogging $ hspec $ do + describe "issues" $ do + it "#25" $ do + matches [here| +typedef struct { + char listOfNames[8][255]; +} MyCoolStruct; +|] [here| +{- typedef struct { + char listOfNames[8][255]; + } MyCoolStruct; -} +#starttype MyCoolStruct +#array_field listOfNames , CChar +#stoptype +|] + + describe "#17" $ do + it "function pointer types" $ + matches [here| +typedef int (*foo)(int); +|] [here| +#callback foo , CInt -> IO CInt +|] + +-- it "function pointer arrays" $ +-- matches [here| +-- int (*my_array[])(int); +-- |] [here| +-- #callback my_array_callback , CInt -> IO CInt +-- #globalvar my_array , +-- |] + +-- it "function pointer structure members" $ +-- matches [here| +-- struct foo_t { +-- int (*foo_member)(int); +-- }; +-- |] [here| +-- {- struct foo_t { +-- int (* foo_member)(int); +-- }; -} +-- #callback foo_member_callback , CInt -> IO CInt +-- #starttype struct foo_t +-- #field foo_member , +-- #stoptype +-- |] + +-- it "function pointer function arguments" $ +-- matches [here| +-- void foo_function(int (*foo)(int)) {} +-- |] [here| +-- #callback foo_function_foo_callback , CInt -> IO CInt +-- #cinline foo_function , -> IO () +-- #include + +-- BC_INLINE1VOID(foo_function, int, int) +-- |] + + it "#15" $ + matches [here| +typedef struct Foo_ Foo; +typedef enum Bar_ { BAR } Bar; +|] [here| +{- typedef struct Foo_ Foo; -} +#opaque_t struct Foo_ +#synonym_t Foo , +{- typedef enum Bar_ { + BAR + } Bar; -} +#integral_t enum Bar_ +#num BAR +#synonym_t Bar , +|] + + it "#12" $ + matches [here| +struct st { + int i; +}; + +enum e { + CONST +}; + +union u { + char c; +}; +|] [here| +{- struct st { + int i; +}; -} +#starttype struct st +#field i , CInt +#stoptype +{- enum e { + CONST +}; -} +#integral_t enum e +#num CONST +{- union u { + char c; +}; -} +#starttype union u +#field c , CChar +#stoptype +|] +-- it "#15" $ +-- matches [here| +-- struct MyTypeImpl; +-- typedef struct MyTypeImpl* MyType; +-- +-- typedef struct MyStruct { +-- int x; +-- } MyStructType; +-- +-- typedef struct MyStructEmpty MyStructEmptyType; +-- |] [here| +-- {- struct MyTypeImpl; -} +-- #opaque_t struct MyTypeImpl +-- {- typedef struct MyTypeImpl * MyType; -} +-- #synonym_t MyType , +-- {- typedef struct MyStruct { +-- int x; +-- } MyStructType; -} +-- #starttype struct MyStruct +-- #field x , CInt +-- #stoptype +-- #synonym_t MyStructType , +-- {- typedef struct MyStructEmpty MyStructEmptyType; -} +-- #opaque_t struct MyStructEmpty +-- #synonym_t MyStructEmptyType , +-- |] + + describe "primitive types" $ do + it "float" $ + matches [here| +float ordinary_float; +|] [here| +#globalvar ordinary_float , CFloat +|] + it "double" $ + matches [here| +double ordinary_double; +|] [here| +#globalvar ordinary_double , CDouble +|] + -- test disabled until https://ghc.haskell.org/trac/ghc/ticket/3353 is + -- resolved. + -- + -- it "long double" $ + -- matches [here| + -- long double ordinary_long_double; + -- |] [here| + -- #globalvar ordinary_long_double , CLongDouble + -- |] + + it "char" $ + matches [here| +char ordinary_char; +|] [here| +#globalvar ordinary_char , CChar +|] + it "signed char" $ + matches [here| +signed char signed_char; +|] [here| +#globalvar signed_char , CSChar +|] + it "unsigned char" $ + matches [here| +unsigned char unsigned_char; +|] [here| +#globalvar unsigned_char , CUChar +|] + it "short" $ + matches [here| +short ordinary_signed_short; +|] [here| +#globalvar ordinary_signed_short , CShort +|] + it "signed short" $ + matches [here| +signed short explicit_signed_short; +|] [here| +#globalvar explicit_signed_short , CShort +|] + it "unsigned short" $ + matches [here| +unsigned short unsigned_short; +|] [here| +#globalvar unsigned_short , CUShort +|] + it "int" $ + matches [here| +int ordinary_signed_int; +|] [here| +#globalvar ordinary_signed_int , CInt +|] + it "signed int" $ + matches [here| +signed int explicit_signed_int; +|] [here| +#globalvar explicit_signed_int , CInt +|] + it "unsigned int" $ + matches [here| +unsigned int unsigned_int; +|] [here| +#globalvar unsigned_int , CUInt +|] + it "long" $ + matches [here| +long ordinary_signed_long; +|] [here| +#globalvar ordinary_signed_long , CLong +|] + it "signed long" $ + matches [here| +signed long explicit_signed_long; +|] [here| +#globalvar explicit_signed_long , CLong +|] + it "unsigned long" $ + matches [here| +unsigned long unsigned_long; +|] [here| +#globalvar unsigned_long , CULong +|] + +-- jww (2014-04-05): language-c does not yet support "long long" types, +-- although GHC's FFI does. +-- it "long long" $ do +-- matches [here| +-- long long ordinary_signed_long_long; +-- |] [here| +-- #globalvar ordinary_signed_long_long , CLLong +-- |] +-- it "signed long long" $ do +-- matches [here| +-- signed long long explicit_signed_long_long; +-- |] [here| +-- #globalvar explicit_signed_long_long , CLLong +-- |] +-- it "unsigned long long" $ do +-- matches [here| +-- unsigned long long unsigned_long_long; +-- |] [here| +-- #globalvar unsigned_long_long , CULLong +-- |] + + describe "pointers" $ do + describe "primitive types which cannot be signed" $ do + it "ordinary_void_pointer" $ + -- jww (2014-04-05): This is wrong! + matches [here| + void* ordinary_void_pointer; +|] [here| +#globalvar ordinary_void_pointer , Ptr () +|] + it "ordinary_float_pointer" $ + matches [here| + float* ordinary_float_pointer; +|] [here| +#globalvar ordinary_float_pointer , Ptr CFloat +|] + it "ordinary_double_pointer" $ + matches [here| + double* ordinary_double_pointer; +|] [here| +#globalvar ordinary_double_pointer , Ptr CDouble +|] +-- it "ordinary_long_double_pointer" $ +-- matches [here| +-- long double* ordinary_long_double_pointer; +-- |] [here| +-- |] + describe "types which can be signed" $ do + describe "char" $ do + it "ordinary_char_pointer" $ + matches [here| + char *ordinary_char_pointer; +|] [here| +#globalvar ordinary_char_pointer , Ptr CChar +|] + it "signed_char_pointer" $ + matches [here| + signed char *signed_char_pointer; +|] [here| +#globalvar signed_char_pointer , Ptr CSChar +|] + it "unsigned_char_pointer" $ + matches [here| + unsigned char *unsigned_char_pointer; +|] [here| +#globalvar unsigned_char_pointer , Ptr CUChar +|] + describe "short" $ do + it "ordinary_signed_short_pointer" $ + matches [here| + short *ordinary_signed_short_pointer; +|] [here| +#globalvar ordinary_signed_short_pointer , Ptr CShort +|] + it "explicit_signed_short_pointer" $ + matches [here| + signed short *explicit_signed_short_pointer; +|] [here| +#globalvar explicit_signed_short_pointer , Ptr CShort +|] + it "unsigned_short_pointer" $ + matches [here| + unsigned short *unsigned_short_pointer; +|] [here| +#globalvar unsigned_short_pointer , Ptr CUShort +|] + describe "int" $ do + it "ordinary_signed_int_pointer" $ + matches [here| + int* ordinary_signed_int_pointer; +|] [here| +#globalvar ordinary_signed_int_pointer , Ptr CInt +|] + it "explicit_signed_int_pointer" $ + matches [here| + signed int* explicit_signed_int_pointer; +|] [here| +#globalvar explicit_signed_int_pointer , Ptr CInt +|] + it "unsigned_int_pointer" $ + matches [here| + unsigned int* unsigned_int_pointer; +|] [here| +#globalvar unsigned_int_pointer , Ptr CUInt +|] + describe "long" $ do + it "ordinary_signed_long_pointer" $ + matches [here| + long *ordinary_signed_long_pointer; +|] [here| +#globalvar ordinary_signed_long_pointer , Ptr CLong +|] + it "explicit_signed_long_pointer" $ + matches [here| + signed long *explicit_signed_long_pointer; +|] [here| +#globalvar explicit_signed_long_pointer , Ptr CLong +|] + it "unsigned_long_pointer" $ + matches [here| + unsigned long *unsigned_long_pointer; +|] [here| +#globalvar unsigned_long_pointer , Ptr CULong +|] +-- language-c does not yet support "long long" types +-- describe "long long" $ do +-- it "ordinary_signed_long_long_pointer" $ +-- matches [here| +-- long long* ordinary_signed_long_long_pointer; +-- |] [here| +-- #globalvar ordinary_signed_long_long_pointer , Ptr CLLong +-- |] +-- it "explicit_signed_long_long_pointer" $ +-- matches [here| +-- signed long long* explicit_signed_long_long_pointer; +-- |] [here| +-- #globalvar explicit_signed_long_long_pointer , Ptr CLLong +-- |] +-- it "unsigned_long_long_pointer" $ +-- matches [here| +-- unsigned long long* unsigned_long_long_pointer; +-- |] [here| +-- #globalvar unsigned_long_long_pointer , Ptr CULLong +-- |] + + describe "arrays" $ do + describe "primitive types which cannot be signed" $ do + it "ordinary_float_array" $ + matches [here| + float ordinary_float_array[10]; +|] [here| +#globalarray ordinary_float_array , CFloat +|] + it "ordinary_double_array" $ + matches [here| + double ordinary_double_array[10]; +|] [here| +#globalarray ordinary_double_array , CDouble +|] + it "ordinary_long_double_array" $ + matches [here| + long double ordinary_long_double_array[10]; +|] [here| +#globalarray ordinary_long_double_array , CLong +|] + describe "types which can be signed" $ do + describe "char" $ do + it "ordinary_signed_char_array" $ + matches [here| + char ordinary_signed_char_array[10]; +|] [here| +#globalarray ordinary_signed_char_array , CChar +|] + it "explicit_signed_char_array" $ + matches [here| + signed char explicit_signed_char_array[10]; +|] [here| +#globalarray explicit_signed_char_array , CSChar +|] + it "unsigned_char_array" $ + matches [here| + unsigned char unsigned_char_array[10]; +|] [here| +#globalarray unsigned_char_array , CUChar +|] + describe "short" $ do + it "ordinary_signed_short_array" $ + matches [here| + short ordinary_signed_short_array[10]; +|] [here| +#globalarray ordinary_signed_short_array , CShort +|] + it "explicit_signed_short_array" $ + matches [here| + signed short explicit_signed_short_array[10]; +|] [here| +#globalarray explicit_signed_short_array , CShort +|] + it "unsigned_short_array" $ + matches [here| + unsigned short unsigned_short_array[10]; +|] [here| +#globalarray unsigned_short_array , CUShort +|] + describe "int" $ do + it "ordinary_signed_int_array" $ + matches [here| + int ordinary_signed_int_array[10]; +|] [here| +#globalarray ordinary_signed_int_array , CInt +|] + it "explicit_signed_int_array" $ + matches [here| + signed int explicit_signed_int_array[10]; +|] [here| +#globalarray explicit_signed_int_array , CInt +|] + it "unsigned_int_array" $ + matches [here| + unsigned int unsigned_int_array[10]; +|] [here| +#globalarray unsigned_int_array , CUInt +|] + describe "long" $ do + it "ordinary_signed_long_array" $ + matches [here| + long ordinary_signed_long_array[10]; +|] [here| +#globalarray ordinary_signed_long_array , CLong +|] + it "explicit_signed_long_array" $ + matches [here| + signed long explicit_signed_long_array[10]; +|] [here| +#globalarray explicit_signed_long_array , CLong +|] + it "unsigned_long_array" $ + matches [here| + unsigned long unsigned_long_array[10]; +|] [here| +#globalarray unsigned_long_array , CULong +|] +-- language-c does not yet support "long long" types +-- describe "long long" $ do +-- it "ordinary_signed_long_long_array" $ +-- matches [here| +-- long long ordinary_signed_long_long_array[10]; +-- |] [here| +-- #globalarray ordinary_signed_long_long_array , CLLong +-- |] +-- it "explicit_signed_long_long_array" $ +-- matches [here| +-- signed long long explicit_signed_long_long_array[10]; +-- |] [here| +-- #globalarray explicit_signed_long_long_array , CLLong +-- |] +-- it "unsigned_long_long_array" $ +-- matches [here| +-- unsigned long long unsigned_long_long_array[10]; +-- |] [here| +-- #globalarray unsigned_long_long_array , CULLong +-- |] + describe "pointers" $ do + describe "primitive types which cannot be signed" $ do + it "ordinary_void_pointer_array" $ + matches [here| + void* ordinary_void_pointer_array[10]; +|] [here| +#globalarray ordinary_void_pointer_array , Ptr () +|] + it "ordinary_float_pointer_array" $ + matches [here| + float* ordinary_float_pointer_array[10]; +|] [here| +#globalarray ordinary_float_pointer_array , Ptr CFloat +|] + it "ordinary_double_pointer_array" $ + matches [here| + double* ordinary_double_pointer_array[10]; +|] [here| +#globalarray ordinary_double_pointer_array , Ptr CDouble +|] + it "ordinary_long_double_pointer_array" $ + matches [here| + long double* ordinary_long_double_pointer_array[10]; +|] [here| +#globalarray ordinary_long_double_pointer_array , Ptr CLong +|] + describe "types which can be signed" $ do + describe "char" $ do + it "ordinary_signed_char_pointer_array" $ + matches [here| + char *ordinary_signed_char_pointer_array[10]; +|] [here| +#globalarray ordinary_signed_char_pointer_array , Ptr CChar +|] + it "explicit_signed_char_pointer_array" $ + matches [here| + signed char *explicit_signed_char_pointer_array[10]; +|] [here| +#globalarray explicit_signed_char_pointer_array , Ptr CSChar +|] + it "unsigned_char_pointer_array" $ + matches [here| + unsigned char *unsigned_char_pointer_array[10]; +|] [here| +#globalarray unsigned_char_pointer_array , Ptr CUChar +|] + describe "short" $ do + it "ordinary_signed_short_pointer_array" $ + matches [here| + short *ordinary_signed_short_pointer_array[10]; +|] [here| +#globalarray ordinary_signed_short_pointer_array , Ptr CShort +|] + it "explicit_signed_short_pointer_array" $ + matches [here| + signed short *explicit_signed_short_pointer_array[10]; +|] [here| +#globalarray explicit_signed_short_pointer_array , Ptr CShort +|] + it "unsigned_short_pointer_array" $ + matches [here| + unsigned short *unsigned_short_pointer_array[10]; +|] [here| +#globalarray unsigned_short_pointer_array , Ptr CUShort +|] + describe "int" $ do + it "ordinary_signed_int_pointer_array" $ + matches [here| + int* ordinary_signed_int_pointer_array[10]; +|] [here| +#globalarray ordinary_signed_int_pointer_array , Ptr CInt +|] + it "explicit_signed_int_pointer_array" $ + matches [here| + signed int* explicit_signed_int_pointer_array[10]; +|] [here| +#globalarray explicit_signed_int_pointer_array , Ptr CInt +|] + it "unsigned_int_pointer_array" $ + matches [here| + unsigned int* unsigned_int_pointer_array[10]; +|] [here| +#globalarray unsigned_int_pointer_array , Ptr CUInt +|] + describe "long" $ do + it "ordinary_signed_long_pointer_array" $ + matches [here| + long *ordinary_signed_long_pointer_array[10]; +|] [here| +#globalarray ordinary_signed_long_pointer_array , Ptr CLong +|] + it "explicit_signed_long_pointer_array" $ + matches [here| + signed long *explicit_signed_long_pointer_array[10]; +|] [here| +#globalarray explicit_signed_long_pointer_array , Ptr CLong +|] + it "unsigned_long_pointer_array" $ + matches [here| + unsigned long *unsigned_long_pointer_array[10]; +|] [here| +#globalarray unsigned_long_pointer_array , Ptr CULong +|] +-- language-c does not yet support "long long" types +-- describe "long long" $ do +-- it "ordinary_signed_long_long_pointer_array" $ +-- matches [here| +-- long long* ordinary_signed_long_long_pointer_array[10]; +-- |] [here| +-- #globalarray ordinary_signed_long_long_pointer_array , Ptr CLLong +-- |] +-- it "explicit_signed_long_long_pointer_array" $ +-- matches [here| +-- signed long long* explicit_signed_long_long_pointer_array[10]; +-- |] [here| +-- #globalarray explicit_signed_long_long_pointer_array , Ptr CLLong +-- |] +-- it "unsigned_long_long_pointer_array" $ +-- matches [here| +-- unsigned long long* unsigned_long_long_pointer_array[10]; +-- |] [here| +-- #globalarray unsigned_long_long_pointer_array , Ptr CULLong +-- |] + + describe "structs" $ do + describe "primitive types which cannot be signed" $ do + it "ordinary_float_struct" $ + matches [here| + struct ordinary_float_struct {float ordinary_float_member;}; +|] [here| +{- struct ordinary_float_struct { + float ordinary_float_member; +}; -} +#starttype struct ordinary_float_struct +#field ordinary_float_member , CFloat +#stoptype +|] + it "ordinary_double_struct" $ + matches [here| + struct ordinary_double_struct {double ordinary_double_member;}; +|] [here| +{- struct ordinary_double_struct { + double ordinary_double_member; +}; -} +#starttype struct ordinary_double_struct +#field ordinary_double_member , CDouble +#stoptype +|] + it "ordinary_long_double_struct" $ + matches [here| + struct ordinary_long_double_struct {long double ordinary_long_double_member;}; +|] [here| +{- struct ordinary_long_double_struct { + long double ordinary_long_double_member; +}; -} +#starttype struct ordinary_long_double_struct +#field ordinary_long_double_member , CLong +#stoptype +|] + describe "types which can be signed" $ do + describe "char" $ do + it "ordinary_signed_char_struct" $ + matches [here| + struct ordinary_signed_char_struct {char ordinary_signed_char_member;}; +|] [here| +{- struct ordinary_signed_char_struct { + char ordinary_signed_char_member; +}; -} +#starttype struct ordinary_signed_char_struct +#field ordinary_signed_char_member , CChar +#stoptype +|] + it "explicit_signed_char_struct" $ + matches [here| + struct explicit_signed_char_struct {signed char explicit_signed_char_member;}; +|] [here| +{- struct explicit_signed_char_struct { + signed char explicit_signed_char_member; +}; -} +#starttype struct explicit_signed_char_struct +#field explicit_signed_char_member , CSChar +#stoptype +|] + it "unsigned_char_struct" $ + matches [here| + struct unsigned_char_struct {unsigned char unsigned_char_member;}; +|] [here| +{- struct unsigned_char_struct { + unsigned char unsigned_char_member; +}; -} +#starttype struct unsigned_char_struct +#field unsigned_char_member , CUChar +#stoptype +|] + describe "short" $ do + it "ordinary_signed_short_struct" $ + matches [here| + struct ordinary_signed_short_struct {short ordinary_signed_short_member;}; +|] [here| +{- struct ordinary_signed_short_struct { + short ordinary_signed_short_member; +}; -} +#starttype struct ordinary_signed_short_struct +#field ordinary_signed_short_member , CShort +#stoptype +|] + it "explicit_signed_short_struct" $ + matches [here| + struct explicit_signed_short_struct {signed short explicit_signed_short_member;}; +|] [here| +{- struct explicit_signed_short_struct { + signed short explicit_signed_short_member; +}; -} +#starttype struct explicit_signed_short_struct +#field explicit_signed_short_member , CShort +#stoptype +|] + it "unsigned_short_struct" $ + matches [here| + struct unsigned_short_struct {unsigned short unsigned_short_member;}; +|] [here| +{- struct unsigned_short_struct { + unsigned short unsigned_short_member; +}; -} +#starttype struct unsigned_short_struct +#field unsigned_short_member , CUShort +#stoptype +|] + describe "int" $ do + it "ordinary_signed_int_struct" $ + matches [here| + struct ordinary_signed_int_struct {int ordinary_signed_int_member;}; +|] [here| +{- struct ordinary_signed_int_struct { + int ordinary_signed_int_member; +}; -} +#starttype struct ordinary_signed_int_struct +#field ordinary_signed_int_member , CInt +#stoptype +|] + it "explicit_signed_int_struct" $ + matches [here| + struct explicit_signed_int_struct {signed int explicit_signed_int_member;}; +|] [here| +{- struct explicit_signed_int_struct { + signed int explicit_signed_int_member; +}; -} +#starttype struct explicit_signed_int_struct +#field explicit_signed_int_member , CInt +#stoptype +|] + it "unsigned_int_struct" $ + matches [here| + struct unsigned_int_struct {unsigned int unsigned_int_member;}; +|] [here| +{- struct unsigned_int_struct { + unsigned int unsigned_int_member; +}; -} +#starttype struct unsigned_int_struct +#field unsigned_int_member , CUInt +#stoptype +|] + describe "long" $ do + it "ordinary_signed_long_struct" $ + matches [here| + struct ordinary_signed_long_struct {long ordinary_signed_long_member;}; +|] [here| +{- struct ordinary_signed_long_struct { + long ordinary_signed_long_member; +}; -} +#starttype struct ordinary_signed_long_struct +#field ordinary_signed_long_member , CLong +#stoptype +|] + it "explicit_signed_long_struct" $ + matches [here| + struct explicit_signed_long_struct {signed long explicit_signed_long_member;}; +|] [here| +{- struct explicit_signed_long_struct { + signed long explicit_signed_long_member; +}; -} +#starttype struct explicit_signed_long_struct +#field explicit_signed_long_member , CLong +#stoptype +|] + it "unsigned_long_struct" $ + matches [here| + struct unsigned_long_struct {unsigned long unsigned_long_member;}; +|] [here| +{- struct unsigned_long_struct { + unsigned long unsigned_long_member; +}; -} +#starttype struct unsigned_long_struct +#field unsigned_long_member , CULong +#stoptype +|] +-- language-c does not yet support "long long" types +-- describe "long long" $ do +-- it "ordinary_signed_long_long_struct" $ +-- matches [here| +-- struct ordinary_signed_long_long_struct {long long ordinary_signed_long_long_member;}; +-- |] [here| +-- {- struct ordinary_signed_long_long_struct { +-- long long ordinary_signed_long_long_member; +-- }; -} +-- #starttype struct ordinary_signed_long_long_struct +-- #field ordinary_signed_long_long_member , CLLong +-- #stoptype +-- |] +-- it "explicit_signed_long_long_struct" $ +-- matches [here| +-- struct explicit_signed_long_long_struct {signed long long explicit_signed_long_long_member;}; +-- |] [here| +-- {- struct explicit_signed_long_long_struct { +-- signed long long explicit_signed_long_long_member; +-- }; -} +-- -- #starttype struct explicit_signed_long_long_struct +-- -- #field explicit_signed_long_long_member , CLLLong +-- -- #stoptype +-- -- |] +-- -- it "unsigned_long_long_struct" $ +-- -- matches [here| +-- -- struct unsigned_long_long_struct {unsigned long long unsigned_long_long_member;}; +-- -- |] [here| +-- {- struct unsigned_long_long_struct { +-- unsigned long long unsigned_long_long_member; +-- }; -} +-- #starttype struct unsigned_long_long_struct +-- #field unsigned_long_long_member , CULLong +-- #stoptype +-- |] + describe "pointers" $ do + describe "primitive types which cannot be signed" $ do + it "ordinary_void_pointer_struct" $ + matches [here| + struct ordinary_void_pointer_struct {void* ordinary_void_pointer_member;}; +|] [here| +{- struct ordinary_void_pointer_struct { + void * ordinary_void_pointer_member; +}; -} +#starttype struct ordinary_void_pointer_struct +#field ordinary_void_pointer_member , Ptr () +#stoptype +|] + it "ordinary_float_pointer_struct" $ + matches [here| + struct ordinary_float_pointer_struct {float* ordinary_float_pointer_member;}; +|] [here| +{- struct ordinary_float_pointer_struct { + float * ordinary_float_pointer_member; +}; -} +#starttype struct ordinary_float_pointer_struct +#field ordinary_float_pointer_member , Ptr CFloat +#stoptype +|] + it "ordinary_double_pointer_struct" $ + matches [here| + struct ordinary_double_pointer_struct {double* ordinary_double_pointer_member;}; +|] [here| +{- struct ordinary_double_pointer_struct { + double * ordinary_double_pointer_member; +}; -} +#starttype struct ordinary_double_pointer_struct +#field ordinary_double_pointer_member , Ptr CDouble +#stoptype +|] + it "ordinary_long_double_pointer_struct" $ + matches [here| + struct ordinary_long_double_pointer_struct {long double* ordinary_long_double_pointer_member;}; +|] [here| +{- struct ordinary_long_double_pointer_struct { + long double * ordinary_long_double_pointer_member; +}; -} +#starttype struct ordinary_long_double_pointer_struct +#field ordinary_long_double_pointer_member , Ptr CLong +#stoptype +|] + describe "types which can be signed" $ do + describe "char" $ do +-- it "ordinary_signed_char_pointer_struct" $ +-- matches [here| +-- struct ordinary_signed_char_pointer_struct {char *ordinary_signed_char_pointer_member;}; +-- |] [here| +-- {- struct ordinary_signed_char_pointer_struct { +-- char * ordinary_signed_char_pointer_member; +-- }; -} +-- #starttype struct ordinary_signed_char_pointer_struct +-- #field ordinary_signed_char_pointer_member , Ptr CString +-- #stoptype +-- |] + it "explicit_signed_char_pointer_struct" $ + matches [here| + struct explicit_signed_char_pointer_struct {signed char *explicit_signed_char_pointer_member;}; +|] [here| +{- struct explicit_signed_char_pointer_struct { + signed char * explicit_signed_char_pointer_member; +}; -} +#starttype struct explicit_signed_char_pointer_struct +#field explicit_signed_char_pointer_member , Ptr CSChar +#stoptype +|] + it "unsigned_char_pointer_struct" $ + matches [here| + struct unsigned_char_pointer_struct {unsigned char *unsigned_char_pointer_member;}; +|] [here| +{- struct unsigned_char_pointer_struct { + unsigned char * unsigned_char_pointer_member; +}; -} +#starttype struct unsigned_char_pointer_struct +#field unsigned_char_pointer_member , Ptr CUChar +#stoptype +|] + describe "short" $ do + it "ordinary_signed_short_pointer_struct" $ + matches [here| + struct ordinary_signed_short_pointer_struct {short *ordinary_signed_short_pointer_member;}; +|] [here| +{- struct ordinary_signed_short_pointer_struct { + short * ordinary_signed_short_pointer_member; +}; -} +#starttype struct ordinary_signed_short_pointer_struct +#field ordinary_signed_short_pointer_member , Ptr CShort +#stoptype +|] + it "explicit_signed_short_pointer_struct" $ + matches [here| + struct explicit_signed_short_pointer_struct {signed short *explicit_signed_short_pointer_member;}; +|] [here| +{- struct explicit_signed_short_pointer_struct { + signed short * explicit_signed_short_pointer_member; +}; -} +#starttype struct explicit_signed_short_pointer_struct +#field explicit_signed_short_pointer_member , Ptr CShort +#stoptype +|] + it "unsigned_short_pointer_struct" $ + matches [here| + struct unsigned_short_pointer_struct {unsigned short *unsigned_short_pointer_member;}; +|] [here| +{- struct unsigned_short_pointer_struct { + unsigned short * unsigned_short_pointer_member; +}; -} +#starttype struct unsigned_short_pointer_struct +#field unsigned_short_pointer_member , Ptr CUShort +#stoptype +|] + describe "int" $ do + it "ordinary_signed_int_pointer_struct" $ + matches [here| + struct ordinary_signed_int_pointer_struct {int* ordinary_signed_int_pointer_member;}; +|] [here| +{- struct ordinary_signed_int_pointer_struct { + int * ordinary_signed_int_pointer_member; +}; -} +#starttype struct ordinary_signed_int_pointer_struct +#field ordinary_signed_int_pointer_member , Ptr CInt +#stoptype +|] + it "explicit_signed_int_pointer_struct" $ + matches [here| + struct explicit_signed_int_pointer_struct {signed int* explicit_signed_int_pointer_member;}; +|] [here| +{- struct explicit_signed_int_pointer_struct { + signed int * explicit_signed_int_pointer_member; +}; -} +#starttype struct explicit_signed_int_pointer_struct +#field explicit_signed_int_pointer_member , Ptr CInt +#stoptype +|] + it "unsigned_int_pointer_struct" $ + matches [here| + struct unsigned_int_pointer_struct {unsigned int* unsigned_int_pointer_member;}; +|] [here| +{- struct unsigned_int_pointer_struct { + unsigned int * unsigned_int_pointer_member; +}; -} +#starttype struct unsigned_int_pointer_struct +#field unsigned_int_pointer_member , Ptr CUInt +#stoptype +|] + describe "long" $ do + it "ordinary_signed_long_pointer_struct" $ + matches [here| + struct ordinary_signed_long_pointer_struct {long *ordinary_signed_long_pointer_member;}; +|] [here| +{- struct ordinary_signed_long_pointer_struct { + long * ordinary_signed_long_pointer_member; +}; -} +#starttype struct ordinary_signed_long_pointer_struct +#field ordinary_signed_long_pointer_member , Ptr CLong +#stoptype +|] + it "explicit_signed_long_pointer_struct" $ + matches [here| + struct explicit_signed_long_pointer_struct {signed long *explicit_signed_long_pointer_member;}; +|] [here| +{- struct explicit_signed_long_pointer_struct { + signed long * explicit_signed_long_pointer_member; +}; -} +#starttype struct explicit_signed_long_pointer_struct +#field explicit_signed_long_pointer_member , Ptr CLong +#stoptype +|] + it "unsigned_long_pointer_struct" $ + matches [here| + struct unsigned_long_pointer_struct {unsigned long *unsigned_long_pointer_member;}; +|] [here| +{- struct unsigned_long_pointer_struct { + unsigned long * unsigned_long_pointer_member; +}; -} +#starttype struct unsigned_long_pointer_struct +#field unsigned_long_pointer_member , Ptr CULong +#stoptype +|] +-- language-c does not yet support "long long" types +-- describe "long long" $ do +-- it "ordinary_signed_long_long_pointer_struct" $ +-- matches [here| +-- struct ordinary_signed_long_long_pointer_struct {long long* ordinary_signed_long_long_pointer_member;}; +-- |] [here| +-- {- struct ordinary_signed_long_long_pointer_struct { +-- long long * ordinary_signed_long_long_pointer_member; +-- }; -} +-- #starttype struct ordinary_signed_long_long_pointer_struct +-- #field ordinary_signed_long_long_pointer_member , Ptr CLLong +-- #stoptype +-- |] +-- it "explicit_signed_long_long_pointer_struct" $ +-- matches [here| +-- struct explicit_signed_long_long_pointer_struct {signed long long* explicit_signed_long_long_pointer_member;}; +-- |] [here| +-- {- struct explicit_signed_long_long_pointer_struct { +-- signed long long * explicit_signed_long_long_pointer_member; +-- }; -} +-- #starttype struct explicit_signed_long_long_pointer_struct +-- #field explicit_signed_long_long_pointer_member , Ptr CLLong +-- #stoptype +-- |] +-- it "unsigned_long_long_pointer_struct" $ +-- matches [here| +-- struct unsigned_long_long_pointer_struct {unsigned long long* unsigned_long_long_pointer_member;}; +-- |] [here| +-- {- struct unsigned_long_long_pointer_struct { +-- unsigned long long * unsigned_long_long_pointer_member; +-- }; -} +-- #starttype struct unsigned_long_long_pointer_struct +-- #field unsigned_long_long_pointer_member , Ptr CULLong +-- #stoptype +-- |] + describe "arrays" $ do + describe "primitive types which cannot be signed" $ do + it "ordinary_float_array_struct" $ + matches [here| + struct ordinary_float_array_struct {float ordinary_float_array_member[10];}; +|] [here| +{- struct ordinary_float_array_struct { + float ordinary_float_array_member[10]; +}; -} +#starttype struct ordinary_float_array_struct +#array_field ordinary_float_array_member , CFloat +#stoptype +|] + it "ordinary_double_array_struct" $ + matches [here| + struct ordinary_double_array_struct {double ordinary_double_array_member[10];}; +|] [here| +{- struct ordinary_double_array_struct { + double ordinary_double_array_member[10]; +}; -} +#starttype struct ordinary_double_array_struct +#array_field ordinary_double_array_member , CDouble +#stoptype +|] + it "ordinary_long_double_array_struct" $ + matches [here| + struct ordinary_long_double_array_struct {long double ordinary_long_double_array_member[10];}; +|] [here| +{- struct ordinary_long_double_array_struct { + long double ordinary_long_double_array_member[10]; +}; -} +#starttype struct ordinary_long_double_array_struct +#array_field ordinary_long_double_array_member , CLong +#stoptype +|] + describe "types which can be signed" $ do + describe "char" $ do + it "ordinary_signed_char_array_struct" $ + matches [here| + struct ordinary_signed_char_array_struct {char ordinary_signed_char_array_member[10];}; +|] [here| +{- struct ordinary_signed_char_array_struct { + char ordinary_signed_char_array_member[10]; +}; -} +#starttype struct ordinary_signed_char_array_struct +#array_field ordinary_signed_char_array_member , CChar +#stoptype +|] + it "explicit_signed_char_array_struct" $ + matches [here| + struct explicit_signed_char_array_struct {signed char explicit_signed_char_array_member[10];}; +|] [here| +{- struct explicit_signed_char_array_struct { + signed char explicit_signed_char_array_member[10]; +}; -} +#starttype struct explicit_signed_char_array_struct +#array_field explicit_signed_char_array_member , CSChar +#stoptype +|] + it "unsigned_char_array_struct" $ + matches [here| + struct unsigned_char_array_struct {unsigned char unsigned_char_array_member[10];}; +|] [here| +{- struct unsigned_char_array_struct { + unsigned char unsigned_char_array_member[10]; +}; -} +#starttype struct unsigned_char_array_struct +#array_field unsigned_char_array_member , CUChar +#stoptype +|] + describe "short" $ do + it "ordinary_signed_short_array_struct" $ + matches [here| + struct ordinary_signed_short_array_struct {short ordinary_signed_short_array_member[10];}; +|] [here| +{- struct ordinary_signed_short_array_struct { + short ordinary_signed_short_array_member[10]; +}; -} +#starttype struct ordinary_signed_short_array_struct +#array_field ordinary_signed_short_array_member , CShort +#stoptype +|] + it "explicit_signed_short_array_struct" $ + matches [here| + struct explicit_signed_short_array_struct {signed short explicit_signed_short_array_member[10];}; +|] [here| +{- struct explicit_signed_short_array_struct { + signed short explicit_signed_short_array_member[10]; +}; -} +#starttype struct explicit_signed_short_array_struct +#array_field explicit_signed_short_array_member , CShort +#stoptype +|] + it "unsigned_short_array_struct" $ + matches [here| + struct unsigned_short_array_struct {unsigned short unsigned_short_array_member[10];}; +|] [here| +{- struct unsigned_short_array_struct { + unsigned short unsigned_short_array_member[10]; +}; -} +#starttype struct unsigned_short_array_struct +#array_field unsigned_short_array_member , CUShort +#stoptype +|] + describe "int" $ do + it "ordinary_signed_int_array_struct" $ + matches [here| + struct ordinary_signed_int_array_struct {int ordinary_signed_int_array_member[10];}; +|] [here| +{- struct ordinary_signed_int_array_struct { + int ordinary_signed_int_array_member[10]; +}; -} +#starttype struct ordinary_signed_int_array_struct +#array_field ordinary_signed_int_array_member , CInt +#stoptype +|] + it "explicit_signed_int_array_struct" $ + matches [here| + struct explicit_signed_int_array_struct {signed int explicit_signed_int_array_member[10];}; +|] [here| +{- struct explicit_signed_int_array_struct { + signed int explicit_signed_int_array_member[10]; +}; -} +#starttype struct explicit_signed_int_array_struct +#array_field explicit_signed_int_array_member , CInt +#stoptype +|] + it "unsigned_int_array_struct" $ + matches [here| + struct unsigned_int_array_struct {unsigned int unsigned_int_array_member[10];}; +|] [here| +{- struct unsigned_int_array_struct { + unsigned int unsigned_int_array_member[10]; +}; -} +#starttype struct unsigned_int_array_struct +#array_field unsigned_int_array_member , CUInt +#stoptype +|] + describe "long" $ do + it "ordinary_signed_long_array_struct" $ + matches [here| + struct ordinary_signed_long_array_struct {long ordinary_signed_long_array_member[10];}; +|] [here| +{- struct ordinary_signed_long_array_struct { + long ordinary_signed_long_array_member[10]; +}; -} +#starttype struct ordinary_signed_long_array_struct +#array_field ordinary_signed_long_array_member , CLong +#stoptype +|] + it "explicit_signed_long_array_struct" $ + matches [here| + struct explicit_signed_long_array_struct {signed long explicit_signed_long_array_member[10];}; +|] [here| +{- struct explicit_signed_long_array_struct { + signed long explicit_signed_long_array_member[10]; +}; -} +#starttype struct explicit_signed_long_array_struct +#array_field explicit_signed_long_array_member , CLong +#stoptype +|] + it "unsigned_long_array_struct" $ + matches [here| + struct unsigned_long_array_struct {unsigned long unsigned_long_array_member[10];}; +|] [here| +{- struct unsigned_long_array_struct { + unsigned long unsigned_long_array_member[10]; +}; -} +#starttype struct unsigned_long_array_struct +#array_field unsigned_long_array_member , CULong +#stoptype +|] +-- language-c does not yet support "long long" types +-- describe "long long" $ do +-- it "ordinary_signed_long_long_array_struct" $ +-- matches [here| +-- struct ordinary_signed_long_long_array_struct {long long ordinary_signed_long_long_array_member[10];}; +-- |] [here| +-- {- struct ordinary_signed_long_long_array_struct { +-- long long ordinary_signed_long_long_array_member[10]; +-- }; -} +-- #starttype struct ordinary_signed_long_long_array_struct +-- #array_field ordinary_signed_long_long_array_member , CLLong +-- #stoptype +-- |] +-- it "explicit_signed_long_long_array_struct" $ +-- matches [here| +-- struct explicit_signed_long_long_array_struct {signed long long explicit_signed_long_long_array_member[10];}; +-- |] [here| +-- {- struct explicit_signed_long_long_array_struct { +-- signed long long explicit_signed_long_long_array_member[10]; +-- }; -} +-- #starttype struct explicit_signed_long_long_array_struct +-- #array_field explicit_signed_long_long_array_member , CLLong +-- #stoptype +-- |] +-- it "unsigned_long_long_array_struct" $ +-- matches [here| +-- struct unsigned_long_long_array_struct {unsigned long long unsigned_long_long_array_member[10];}; +-- |] [here| +-- {- struct unsigned_long_long_array_struct { +-- unsigned long long unsigned_long_long_array_member[10]; +-- }; -} +-- #starttype struct unsigned_long_long_array_struct +-- #array_field unsigned_long_long_array_member , CULLong +-- #stoptype +-- |] + describe "pointers" $ do + describe "primitive types which cannot be signed" $ do + it "ordinary_void_pointer_array_struct" $ + matches [here| + struct ordinary_void_pointer_array_struct {void* ordinary_void_pointer_array_member[10];}; +|] [here| +{- struct ordinary_void_pointer_array_struct { + void * ordinary_void_pointer_array_member[10]; +}; -} +#starttype struct ordinary_void_pointer_array_struct +#array_field ordinary_void_pointer_array_member , Ptr () +#stoptype +|] + it "ordinary_float_pointer_array_struct" $ + matches [here| + struct ordinary_float_pointer_array_struct {float* ordinary_float_pointer_array_member[10];}; +|] [here| +{- struct ordinary_float_pointer_array_struct { + float * ordinary_float_pointer_array_member[10]; +}; -} +#starttype struct ordinary_float_pointer_array_struct +#array_field ordinary_float_pointer_array_member , Ptr CFloat +#stoptype +|] + it "ordinary_double_pointer_array_struct" $ + matches [here| + struct ordinary_double_pointer_array_struct {double* ordinary_double_pointer_array_member[10];}; +|] [here| +{- struct ordinary_double_pointer_array_struct { + double * ordinary_double_pointer_array_member[10]; +}; -} +#starttype struct ordinary_double_pointer_array_struct +#array_field ordinary_double_pointer_array_member , Ptr CDouble +#stoptype +|] + it "ordinary_long_double_pointer_array_struct" $ + matches [here| + struct ordinary_long_double_pointer_array_struct {long double* ordinary_long_double_pointer_array_member[10];}; +|] [here| +{- struct ordinary_long_double_pointer_array_struct { + long double * ordinary_long_double_pointer_array_member[10]; +}; -} +#starttype struct ordinary_long_double_pointer_array_struct +#array_field ordinary_long_double_pointer_array_member , Ptr CLong +#stoptype +|] + describe "types which can be signed" $ do + describe "char" $ do +-- it "ordinary_signed_char_pointer_array_struct" $ +-- matches [here| +-- struct ordinary_signed_char_pointer_array_struct {char *ordinary_signed_char_pointer_array_member[10];}; +-- |] [here| +-- {- struct ordinary_signed_char_pointer_array_struct { +-- char * ordinary_signed_char_pointer_array_member[10]; +-- }; -} +-- #starttype struct ordinary_signed_char_pointer_array_struct +-- #array_field ordinary_signed_char_pointer_array_member , Ptr CString +-- #stoptype +-- |] + it "explicit_signed_char_pointer_array_struct" $ + matches [here| + struct explicit_signed_char_pointer_array_struct {signed char *explicit_signed_char_pointer_array_member[10];}; +|] [here| +{- struct explicit_signed_char_pointer_array_struct { + signed char * explicit_signed_char_pointer_array_member[10]; +}; -} +#starttype struct explicit_signed_char_pointer_array_struct +#array_field explicit_signed_char_pointer_array_member , Ptr CSChar +#stoptype +|] + it "unsigned_char_pointer_array_struct" $ + matches [here| + struct unsigned_char_pointer_array_struct {unsigned char *unsigned_char_pointer_array_member[10];}; +|] [here| +{- struct unsigned_char_pointer_array_struct { + unsigned char * unsigned_char_pointer_array_member[10]; +}; -} +#starttype struct unsigned_char_pointer_array_struct +#array_field unsigned_char_pointer_array_member , Ptr CUChar +#stoptype +|] + describe "short" $ do + it "ordinary_signed_short_pointer_array_struct" $ + matches [here| + struct ordinary_signed_short_pointer_array_struct {short *ordinary_signed_short_pointer_array_member[10];}; +|] [here| +{- struct ordinary_signed_short_pointer_array_struct { + short * ordinary_signed_short_pointer_array_member[10]; +}; -} +#starttype struct ordinary_signed_short_pointer_array_struct +#array_field ordinary_signed_short_pointer_array_member , Ptr CShort +#stoptype +|] + it "explicit_signed_short_pointer_array_struct" $ + matches [here| + struct explicit_signed_short_pointer_array_struct {signed short *explicit_signed_short_pointer_array_member[10];}; +|] [here| +{- struct explicit_signed_short_pointer_array_struct { + signed short * explicit_signed_short_pointer_array_member[10]; +}; -} +#starttype struct explicit_signed_short_pointer_array_struct +#array_field explicit_signed_short_pointer_array_member , Ptr CShort +#stoptype +|] + it "unsigned_short_pointer_array_struct" $ + matches [here| + struct unsigned_short_pointer_array_struct {unsigned short *unsigned_short_pointer_array_member[10];}; +|] [here| +{- struct unsigned_short_pointer_array_struct { + unsigned short * unsigned_short_pointer_array_member[10]; +}; -} +#starttype struct unsigned_short_pointer_array_struct +#array_field unsigned_short_pointer_array_member , Ptr CUShort +#stoptype +|] + describe "int" $ do + it "ordinary_signed_int_pointer_array_struct" $ + matches [here| + struct ordinary_signed_int_pointer_array_struct {int* ordinary_signed_int_pointer_array_member[10];}; +|] [here| +{- struct ordinary_signed_int_pointer_array_struct { + int * ordinary_signed_int_pointer_array_member[10]; +}; -} +#starttype struct ordinary_signed_int_pointer_array_struct +#array_field ordinary_signed_int_pointer_array_member , Ptr CInt +#stoptype +|] + it "explicit_signed_int_pointer_array_struct" $ + matches [here| + struct explicit_signed_int_pointer_array_struct {signed int* explicit_signed_int_pointer_array_member[10];}; +|] [here| +{- struct explicit_signed_int_pointer_array_struct { + signed int * explicit_signed_int_pointer_array_member[10]; +}; -} +#starttype struct explicit_signed_int_pointer_array_struct +#array_field explicit_signed_int_pointer_array_member , Ptr CInt +#stoptype +|] + it "unsigned_int_pointer_array_struct" $ + matches [here| + struct unsigned_int_pointer_array_struct {unsigned int* unsigned_int_pointer_array_member[10];}; +|] [here| +{- struct unsigned_int_pointer_array_struct { + unsigned int * unsigned_int_pointer_array_member[10]; +}; -} +#starttype struct unsigned_int_pointer_array_struct +#array_field unsigned_int_pointer_array_member , Ptr CUInt +#stoptype +|] + describe "long" $ do + it "ordinary_signed_long_pointer_array_struct" $ + matches [here| + struct ordinary_signed_long_pointer_array_struct {long *ordinary_signed_long_pointer_array_member[10];}; +|] [here| +{- struct ordinary_signed_long_pointer_array_struct { + long * ordinary_signed_long_pointer_array_member[10]; +}; -} +#starttype struct ordinary_signed_long_pointer_array_struct +#array_field ordinary_signed_long_pointer_array_member , Ptr CLong +#stoptype +|] + it "explicit_signed_long_pointer_array_struct" $ + matches [here| + struct explicit_signed_long_pointer_array_struct {signed long *explicit_signed_long_pointer_array_member[10];}; +|] [here| +{- struct explicit_signed_long_pointer_array_struct { + signed long * explicit_signed_long_pointer_array_member[10]; +}; -} +#starttype struct explicit_signed_long_pointer_array_struct +#array_field explicit_signed_long_pointer_array_member , Ptr CLong +#stoptype +|] + it "unsigned_long_pointer_array_struct" $ + matches [here| + struct unsigned_long_pointer_array_struct {unsigned long *unsigned_long_pointer_array_member[10];}; +|] [here| +{- struct unsigned_long_pointer_array_struct { + unsigned long * unsigned_long_pointer_array_member[10]; +}; -} +#starttype struct unsigned_long_pointer_array_struct +#array_field unsigned_long_pointer_array_member , Ptr CULong +#stoptype +|] +-- language-c does not yet support "long long" types +-- describe "long long" $ do +-- it "ordinary_signed_long_long_pointer_array_struct" $ +-- matches [here| +-- struct ordinary_signed_long_long_pointer_array_struct {long long* ordinary_signed_long_long_pointer_array_member[10];}; +-- |] [here| +-- {- struct ordinary_signed_long_long_pointer_array_struct { +-- long long * ordinary_signed_long_long_pointer_array_member[10]; +-- }; -} +-- #starttype struct ordinary_signed_long_long_pointer_array_struct +-- #array_field ordinary_signed_long_long_pointer_array_member , Ptr CLLong +-- #stoptype +-- |] +-- it "explicit_signed_long_long_pointer_array_struct" $ +-- matches [here| +-- struct explicit_signed_long_long_pointer_array_struct {signed long long* explicit_signed_long_long_pointer_array_member[10];}; +-- |] [here| +-- {- struct explicit_signed_long_long_pointer_array_struct { +-- signed long long * explicit_signed_long_long_pointer_array_member[10]; +-- }; -} +-- #starttype struct explicit_signed_long_long_pointer_array_struct +-- #array_field explicit_signed_long_long_pointer_array_member , Ptr CLLong +-- #stoptype +-- |] +-- it "unsigned_long_long_pointer_array_struct" $ +-- matches [here| +-- struct unsigned_long_long_pointer_array_struct {unsigned long long* unsigned_long_long_pointer_array_member[10];}; +-- |] [here| +-- {- struct unsigned_long_long_pointer_array_struct { +-- unsigned long long * unsigned_long_long_pointer_array_member[10]; +-- }; -} +-- #starttype struct unsigned_long_long_pointer_array_struct +-- #array_field unsigned_long_long_pointer_array_member , Ptr CULLong +-- #stoptype +-- |] + + describe "sanity check" $ do + it "maps a typedef" $ + matches [here| +typedef int an_int; +|] [here| +{- typedef int an_int; -} +#synonym_t an_int , CInt +|] + + it "processes smoke.h" $ + matches [here| +typedef unsigned int uint; +typedef unsigned long size_t; + +void foo1(void); +void foo2(int); +void foo3(int, int); +int foo4(void); +char foo5(int); +char * foo6(int, int); +char * foo7(char *); +char * foo8(char * b); +char * foo9(char * (*b)(void)); +char * foo10(char * (*b)(int)); +void * foo11(void * (*b)(void)); +void * foo12(void * (*b)(int)); +char * foo13(char []); +char * foo14(char b[]); +char * foo15(char b[5]); +char * foo16(int); +int foo17(char ***); +int foo18(unsigned); +int foo19(unsigned int); +int foo20(uint); +int foo21(int (*)(int)); +int foo22(int *(*)(int)); +int foo23(int **(*)(int)); +int foo24(int ***(*)(int)); +int * foo25(int); +int ** foo26(int); +int *** foo27(int); +int *** foo28(size_t); + +struct bar1_t { + void * a; + int b; + char c; + char * d; + char * (*e)(void); + void (*f)(void *); + int * (*g)(void *); + int ** (*h)(void *); + int *** (*i)(void *); + char j[2]; + + struct bar1_t * k; +}; + +typedef struct bar2_t { + int a; +} bar2_t; + +typedef struct { + int a; +} bar3_t; + +enum { + BAZ1 = 1 +}; + +typedef enum { + BAZ2 = 1 +} baz2_t; + +enum baz3_t { + BAZ3 = 1 +}; + +typedef enum baz4_t { + BAZ4 = 1 +} baz4_t; + +extern int global; + +inline int inline_foo(int a, int * b, const int c, const int * d, + const int ** e, const int * const * f, size_t g) { + return 10; +} +|] [here| +{- typedef unsigned int uint; -} +#synonym_t uint , CUInt +{- typedef unsigned long size_t; -} +#synonym_t size_t , CULong +#ccall foo1 , IO () +#ccall foo2 , CInt -> IO () +#ccall foo3 , CInt -> CInt -> IO () +#ccall foo4 , IO CInt +#ccall foo5 , CInt -> IO CChar +#ccall foo6 , CInt -> CInt -> IO CString +#ccall foo7 , CString -> IO CString +#ccall foo8 , CString -> IO CString +#ccall foo9 , FunPtr CString -> IO CString +#ccall foo10 , FunPtr (CInt -> CString) -> IO CString +#ccall foo11 , FunPtr (Ptr ()) -> IO (Ptr ()) +#ccall foo12 , FunPtr (CInt -> Ptr ()) -> IO (Ptr ()) +#ccall foo13 , Ptr CChar -> IO CString +#ccall foo14 , Ptr CChar -> IO CString +#ccall foo15 , Ptr CChar -> IO CString +#ccall foo16 , CInt -> IO CString +#ccall foo17 , Ptr (Ptr CString) -> IO CInt +#ccall foo18 , CUInt -> IO CInt +#ccall foo19 , CUInt -> IO CInt +#ccall foo20 , CUInt -> IO CInt +#ccall foo21 , FunPtr (CInt -> CInt) -> IO CInt +#ccall foo22 , FunPtr (CInt -> Ptr CInt) -> IO CInt +#ccall foo23 , FunPtr (CInt -> Ptr (Ptr CInt)) -> IO CInt +#ccall foo24 , FunPtr (CInt -> Ptr (Ptr (Ptr CInt))) -> IO CInt +#ccall foo25 , CInt -> IO (Ptr CInt) +#ccall foo26 , CInt -> IO (Ptr (Ptr CInt)) +#ccall foo27 , CInt -> IO (Ptr (Ptr (Ptr CInt))) +#ccall foo28 , CSize -> IO (Ptr (Ptr (Ptr CInt))) +{- struct bar1_t { + void * a; + int b; + char c; + char * d; + char * (* e)(void); + void (* f)(void *); + int * (* g)(void *); + int * * (* h)(void *); + int * * * (* i)(void *); + char j[2]; + struct bar1_t * k; +}; -} +#starttype struct bar1_t +#field a , Ptr () +#field b , CInt +#field c , CChar +#field d , CString +#field e , FunPtr CString +#field f , FunPtr (Ptr () -> IO ()) +#field g , FunPtr (Ptr () -> Ptr CInt) +#field h , FunPtr (Ptr () -> Ptr (Ptr CInt)) +#field i , FunPtr (Ptr () -> Ptr (Ptr (Ptr CInt))) +#array_field j , CChar +#field k , Ptr +#stoptype +{- typedef struct bar2_t { + int a; + } bar2_t; -} +#starttype struct bar2_t +#field a , CInt +#stoptype +#synonym_t bar2_t , +{- typedef struct { + int a; + } bar3_t; -} +#starttype bar3_t +#field a , CInt +#stoptype +{- enum { + BAZ1 = 1 +}; -} +#num BAZ1 +{- typedef enum { + BAZ2 = 1 + } baz2_t; -} +#integral_t baz2_t +#num BAZ2 +{- enum baz3_t { + BAZ3 = 1 +}; -} +#integral_t enum baz3_t +#num BAZ3 +{- typedef enum baz4_t { + BAZ4 = 1 + } baz4_t; -} +#integral_t enum baz4_t +#num BAZ4 +#synonym_t baz4_t , +#globalvar global , CInt +#cinline inline_foo , CInt -> Ptr CInt -> CInt -> Ptr CInt -> Ptr (Ptr CInt) -> Ptr (Ptr CInt) -> CSize -> IO CInt +#include + +BC_INLINE7(inline_foo, int, int*, const int, const int*, const int**, const int* const*, size_t, int) +|] + +matches :: String -> String -> IO () +matches input output = do + res <- processString input + trim res `shouldBe` output + +tshow :: String -> Text +tshow = pack . show + +trim :: String -> String +trim = trimTail . dropWhile isSpace + +trimTail :: String -> String +trimTail "" = "" +trimTail s = take (lastNonBlank s) s + where lastNonBlank = (+1) . fst . foldl acc (0, 0) + acc (l, n) c | isSpace c = (l, n + 1) + | otherwise = (n, n + 1)