c2hsc 0.6.5 → 0.7.1
raw patch · 4 files changed
+2467/−658 lines, 4 filesdep +c2hscdep +data-defaultdep +heredep ~HStringTemplatedep ~base
Dependencies added: c2hsc, data-default, here, hspec, logging, monad-logger, temporary, text
Dependency ranges changed: HStringTemplate, base
Files
- Data/C2Hsc.hs +697/−0
- Main.hs +13/−624
- c2hsc.cabal +69/−34
- test/main.hs +1688/−0
+ Data/C2Hsc.hs view
@@ -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 <bindings.dsl.h>"+ , "#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 <bindings.cmacros.h>"+ 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 _ = "<no name>"++ 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 $ "<enum " ++ nm ++ ">"++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
Main.hs view
@@ -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 <bindings.dsl.h>"- , "#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 <bindings.cmacros.h>"- 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 _ = "<no name>"-- 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 $ "<enum " ++ nm ++ ">"--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
c2hsc.cabal view
@@ -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 <johnw@newartisans.com>-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 <johnw@newartisans.com>+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
+ test/main.hs view
@@ -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 , <my_array_callback>+-- |]++-- 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 , <foo_member_callback>+-- #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 , <foo_function_foo_callback> -> IO ()+-- #include <bindings.cmacros.h>++-- 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 , <struct Foo_>+{- typedef enum Bar_ {+ BAR+ } Bar; -}+#integral_t enum Bar_+#num BAR+#synonym_t Bar , <enum 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 , <struct MyTypeImpl>+-- {- typedef struct MyStruct {+-- int x;+-- } MyStructType; -}+-- #starttype struct MyStruct+-- #field x , CInt+-- #stoptype+-- #synonym_t MyStructType , <struct MyStruct>+-- {- typedef struct MyStructEmpty MyStructEmptyType; -}+-- #opaque_t struct MyStructEmpty+-- #synonym_t MyStructEmptyType , <struct MyStructEmpty>+-- |]++ 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 <struct bar1_t>+#stoptype+{- typedef struct bar2_t {+ int a;+ } bar2_t; -}+#starttype struct bar2_t+#field a , CInt+#stoptype+#synonym_t bar2_t , <struct 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 , <enum baz4_t>+#globalvar global , CInt+#cinline inline_foo , CInt -> Ptr CInt -> CInt -> Ptr CInt -> Ptr (Ptr CInt) -> Ptr (Ptr CInt) -> CSize -> IO CInt+#include <bindings.cmacros.h>++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)