├── Setup.hs ├── .gitignore ├── .travis.yml ├── Sample └── sample.h ├── default.nix ├── README.md ├── LICENSE ├── Main.hs ├── c2hsc.cabal ├── stack.yaml ├── Data └── C2Hsc.hs └── test └── main.hs /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /dist/ 2 | /shell.nix 3 | .stack-work/ 4 | stack.yaml.lock -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: nix 2 | 3 | sudo: true 4 | 5 | git: 6 | depth: 1 7 | 8 | env: 9 | global: 10 | matrix: 11 | - GHCVERSION=ghc802 12 | - GHCVERSION=ghc822 13 | - GHCVERSION=ghc843 14 | 15 | matrix: 16 | allow_failures: 17 | exclude: 18 | 19 | script: 20 | - nix-build --argstr compiler $GHCVERSION 21 | 22 | branches: 23 | only: 24 | - master 25 | -------------------------------------------------------------------------------- /Sample/sample.h: -------------------------------------------------------------------------------- 1 | #ifndef C2HSC_SAMPLE_H 2 | #define C2HSC_SAMPLE_H 3 | 4 | #include 5 | #include 6 | #include 7 | 8 | struct test_info; 9 | typedef struct test_info* test_info_ptr; 10 | typedef const char* an_pchar; 11 | 12 | int32_t test_init(int32_t flag, test_info_ptr p_test_info); 13 | int32_t test_process(test_info_ptr p_test_info, an_pchar buf); 14 | void test_uninit(test_info_ptr p_test_info); 15 | 16 | #endif 17 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { compiler ? "ghc822" 2 | , doBenchmark ? false 3 | , doTracing ? false 4 | , doStrict ? false 5 | , rev ? "d1ae60cbad7a49874310de91cd17708b042400c8" 6 | , sha256 ? "0a1w4702jlycg2ab87m7n8frjjngf0cis40lyxm3vdwn7p4fxikz" 7 | , pkgs ? import (builtins.fetchTarball { 8 | url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz"; 9 | inherit sha256; }) { 10 | config.allowUnfree = true; 11 | config.allowBroken = false; 12 | } 13 | , returnShellEnv ? pkgs.lib.inNixShell 14 | , mkDerivation ? null 15 | }: 16 | 17 | let haskellPackages = pkgs.haskell.packages.${compiler}; 18 | 19 | in haskellPackages.developPackage { 20 | root = ./.; 21 | 22 | source-overrides = { 23 | }; 24 | 25 | modifier = drv: pkgs.haskell.lib.overrideCabal drv (attrs: { 26 | inherit doBenchmark; 27 | }); 28 | 29 | inherit returnShellEnv; 30 | } 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Converts C API header files to `.hsc` and `.hsc.helper.c` files 2 | 3 | Usage: c2hsc --prefix= .h 4 | 5 | This will create `.hsc`, and `.hsc.helper.c` if the header file 6 | contains inline functions. 7 | 8 | For example, in `hlibgit2` on the Mac I'm using: 9 | 10 | c2hsc --prefix=Bindings.Libgit2 --cppopts=-U__BLOCKS__ \ 11 | libgit2/include/git2/tree.h 12 | 13 | Known issues: 14 | 15 | - Need to output vararg functions with a comment mentioning they are not 16 | translatable to the Haskell FFI 17 | 18 | Also, please note that this tool will never be 100% accurate. It cannot 19 | translate macros, or anything related to the preprocessor, for example. It 20 | often misses necessary `#include` files, and will get them wrong in any case 21 | if preprocessor conditionals are involved. 22 | 23 | The goal of `c2hsc` is to solve the hardest 80% of the problem of creating an 24 | FFI library. The remaining 20%, plus validation of the results, is an 25 | exercise necessarily left to the user. 26 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, John Wiegley. All rights reserved. 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are 5 | met: 6 | 7 | - Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | - Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 14 | - Neither the name of New Artisans LLC nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Logging hiding (debug) 4 | import Control.Monad hiding (sequence) 5 | import Data.C2Hsc (C2HscOptions(..), runArgs) 6 | import Data.List as L 7 | import Data.Time.Clock 8 | import Data.Time.Calendar 9 | import Prelude hiding (concat, sequence, mapM, mapM_, foldr) 10 | import System.Console.CmdArgs 11 | import System.Environment 12 | 13 | version :: String 14 | version = "0.7.0" 15 | 16 | copyright :: Integer -> String 17 | copyright year = "2012-" ++ (show year) 18 | 19 | c2hscSummary :: Integer -> String 20 | c2hscSummary year = "c2hsc v" ++ version ++ ", (C) John Wiegley " ++ (copyright year) 21 | 22 | c2hscOptions :: Integer -> C2HscOptions 23 | c2hscOptions year = C2HscOptions 24 | { gcc = def &= typFile 25 | &= help "Specify explicit path to gcc or cpp" 26 | , cppopts = def &= typ "OPTS" 27 | &= help "Pass OPTS to the preprocessor" 28 | , prefix = def &= typ "PREFIX" 29 | &= help "Use PREFIX when naming modules" 30 | , filePrefix = def &= typ "FILE_PREFIX" 31 | &= help "Process included headers whose paths match this prefix" 32 | , overrides = def &= typFile 33 | &= help "FILE contains \"C type -> FFI type\" translations" 34 | , verbose = def &= name "v" 35 | &= help "Report progress verbosely" 36 | , debug = def &= name "D" 37 | &= help "Report debug information" 38 | , files = def &= args &= typFile } &= 39 | summary (c2hscSummary year) &= 40 | program "c2hsc" &= 41 | help "Create an .hsc Bindings-DSL file from a C API header file" 42 | 43 | ------------------------------ IMPURE FUNCTIONS ------------------------------ 44 | 45 | -- Parsing of C headers begins with finding gcc so we can run the 46 | -- preprocessor. 47 | 48 | main :: IO () 49 | main = getArgs >>= \mainArgs -> do 50 | (year, _, _) <- getCurrentTime >>= return . toGregorian . utctDay 51 | opts <- withArgs (if null mainArgs then ["--help"] else mainArgs) 52 | (cmdArgs $ c2hscOptions year) 53 | withStderrLogging $ runArgs opts Nothing False 54 | -------------------------------------------------------------------------------- /c2hsc.cabal: -------------------------------------------------------------------------------- 1 | Name: c2hsc 2 | Version: 0.7.1 3 | Synopsis: Convert C API header files to .hsc and .hsc.helper.c files 4 | Description: Convert C API header files to .hsc and .hsc.helper.c files 5 | Homepage: https://github.com/jwiegley/c2hsc 6 | License: BSD3 7 | License-file: LICENSE 8 | Author: John Wiegley 9 | Maintainer: John Wiegley 10 | Category: Development 11 | Build-type: Simple 12 | Cabal-version: >= 1.10 13 | 14 | Extra-Source-Files: README.md 15 | 16 | Library 17 | default-language: Haskell2010 18 | ghc-options: -Wall 19 | build-depends: 20 | base >= 3 && < 5 21 | , mtl >= 2.0 22 | , containers >= 0.4 23 | , transformers >= 0.2 24 | , directory >= 1.1 25 | , language-c >= 0.4 26 | , logging >= 1.3.0 27 | , HStringTemplate >= 0.7.1 28 | , pretty >= 1.1 29 | , filepath >= 1.3 30 | , split >= 0.2 31 | , temporary >= 1.1.2.5 32 | , data-default >= 0.5.3 33 | , text >= 0.11.3.1 34 | exposed-modules: 35 | Data.C2Hsc 36 | default-extensions: 37 | BangPatterns 38 | FlexibleContexts 39 | OverloadedStrings 40 | 41 | Executable c2hsc 42 | default-language: Haskell2010 43 | main-is: Main.hs 44 | ghc-options: -Wall 45 | 46 | build-depends: 47 | base >= 4 && < 5 48 | , c2hsc 49 | , cmdargs >= 0.9 50 | , HStringTemplate >= 0.7.1 51 | , pretty >= 1.1 52 | , filepath >= 1.3 53 | , directory >= 1.1 54 | , language-c >= 0.4 55 | , logging >= 1.3.0 56 | , containers >= 0.4 57 | , split >= 0.2 58 | , transformers >= 0.2 59 | , temporary >= 1.1.2.5 60 | , data-default >= 0.5.3 61 | , text >= 0.11.3.1 62 | , time >= 1.8.0.2 63 | 64 | Test-suite test 65 | default-language: Haskell2010 66 | Type: exitcode-stdio-1.0 67 | Main-is: main.hs 68 | Hs-source-dirs: test 69 | Build-depends: 70 | base >= 4 && < 5 71 | , c2hsc 72 | , hspec >= 1.8.3 73 | , here >= 1.2.3 74 | , monad-logger >= 0.3.4.1 75 | , logging >= 1.3.0 76 | , text >= 0.11.3.1 77 | 78 | Source-repository head 79 | Type: git 80 | Location: https://github.com/jwiegley/c2hsc 81 | 82 | -- c2hsc.cabal ends here 83 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-14.16 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # The following packages have been ignored due to incompatibility with the 34 | # resolver compiler, dependency conflicts with other packages 35 | # or unsatisfied dependencies. 36 | #- . 37 | 38 | # Dependency packages to be pulled from upstream that are not in the resolver. 39 | # These entries can reference officially published versions as well as 40 | # forks / in-progress versions pinned to a git hash. For example: 41 | # 42 | # extra-deps: 43 | # - acme-missiles-0.3 44 | # - git: https://github.com/commercialhaskell/stack.git 45 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 46 | # 47 | extra-deps: 48 | - logging-3.0.5@sha256:88096d3124fce9a19af3720f751e1a354d866ed5030d2e5197238d2277cdb2f2,2374 49 | 50 | # Override default flag values for local packages and extra-deps 51 | # flags: {} 52 | 53 | # Extra package databases containing global packages 54 | # extra-package-dbs: [] 55 | 56 | # Control whether we use the GHC we find on the path 57 | # system-ghc: true 58 | # 59 | # Require a specific version of stack, using version ranges 60 | # require-stack-version: -any # Default 61 | # require-stack-version: ">=2.1" 62 | # 63 | # Override the architecture used by stack, especially useful on Windows 64 | # arch: i386 65 | # arch: x86_64 66 | # 67 | # Extra directories used by stack for building 68 | # extra-include-dirs: [/path/to/dir] 69 | # extra-lib-dirs: [/path/to/dir] 70 | # 71 | # Allow a newer minor version of GHC than the snapshot specifies 72 | # compiler-check: newer-minor 73 | -------------------------------------------------------------------------------- /Data/C2Hsc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Data.C2Hsc where 5 | 6 | import Control.Applicative 7 | import Control.Logging 8 | import Control.Monad hiding (sequence) 9 | import Control.Monad.Trans.Maybe 10 | import Control.Monad.Trans.State 11 | import Data.Char 12 | import Data.Data 13 | import Data.Default 14 | import Data.Foldable hiding (concat, elem, mapM_) 15 | import Data.List as L 16 | import Data.List.Split 17 | import qualified Data.Map as M 18 | import Data.Maybe 19 | import Data.Monoid 20 | import Data.Text (pack) 21 | import Data.Traversable hiding (mapM, forM) 22 | import Language.C.Data.Ident 23 | import Language.C.Data.InputStream 24 | import Language.C.Data.Node 25 | import Language.C.Data.Position 26 | import Language.C.Parser 27 | import Language.C.Pretty 28 | import Language.C.Syntax.AST 29 | import Language.C.System.GCC 30 | import Language.C.System.Preprocess 31 | import Prelude hiding (concat, sequence, mapM, mapM_, foldr) 32 | import System.Directory 33 | import System.FilePath.Posix 34 | import System.IO 35 | import System.IO.Temp 36 | import Text.PrettyPrint as P hiding ((<>)) 37 | import Text.StringTemplate 38 | 39 | data C2HscOptions = C2HscOptions 40 | { gcc :: FilePath 41 | , cppopts :: [String] 42 | , prefix :: String 43 | , filePrefix :: [String] 44 | , overrides :: FilePath 45 | , verbose :: Bool 46 | , debug :: Bool 47 | , files :: [FilePath] 48 | } 49 | deriving (Data, Typeable, Show, Eq) 50 | 51 | instance Default C2HscOptions where 52 | def = C2HscOptions "" [] "" [] "" True False [] 53 | 54 | ------------------------------ IMPURE FUNCTIONS ------------------------------ 55 | 56 | -- This function is used for debugging 57 | processString :: String -> IO String 58 | processString str = do 59 | tmpDir <- getTemporaryDirectory 60 | withTempFile tmpDir "c2hsc.src" $ \path h -> do 61 | hPutStr h str 62 | hClose h 63 | withTempFile tmpDir "c2hsc.out" $ \outPath outH -> do 64 | runArgs def { files = [path] 65 | , prefix = "Spec" 66 | } (Just outH) True 67 | hClose outH 68 | readFile outPath 69 | 70 | -- Parsing of C headers begins with finding gcc so we can run the 71 | -- preprocessor. 72 | 73 | runArgs :: C2HscOptions -> Maybe Handle -> Bool -> IO () 74 | runArgs opts output omitHeader = do 75 | let gccArg = not . null $ gcc opts 76 | gccExe <- runMaybeT . asum . map (MaybeT . findExecutable) $ 77 | if gccArg 78 | then [gcc opts] 79 | else ["gcc", "/usr/bin/gcc"] 80 | case gccExe of 81 | Nothing -> error $ "Cannot find gcc executable" 82 | ++ if gccArg then " '" ++ gcc opts ++ "'" else "" 83 | Just gccPath -> for_ (files opts) $ \fileName -> 84 | parseFile gccPath fileName output omitHeader opts 85 | 86 | -- Once gcc is found, setup to parse the C file by running the preprocessor. 87 | -- Then, identify the input file absolutely so we know which declarations to 88 | -- print out at the end. 89 | 90 | parseFile :: FilePath -> FilePath -> Maybe Handle -> Bool -> C2HscOptions -> IO () 91 | parseFile gccPath fileName output omitHeader opts = do 92 | result <- runPreprocessor (newGCC gccPath) 93 | (rawCppArgs 94 | (cppopts opts) 95 | fileName) 96 | case result of 97 | Left err -> error $ "Failed to run cpp: " ++ show err 98 | Right stream -> do 99 | overrideState <- defineTypeOverrides (overrides opts) 100 | let pos = initPos fileName 101 | HscOutput hscs helpercs _ = 102 | let ps = filePrefix opts 103 | fm = if null ps 104 | then (posFile pos ==) 105 | else \fn -> any (`isPrefixOf` fn) ps 106 | in execState (overrideState >> parseCFile stream fm pos) 107 | newHscState 108 | writeProducts opts fileName output omitHeader hscs helpercs 109 | 110 | defineTypeOverrides :: FilePath -> IO (Output ()) 111 | defineTypeOverrides [] = return (void defaultOverrides) 112 | defineTypeOverrides overridesFile = do 113 | contents <- readFile overridesFile 114 | return $ mapM_ (\line -> 115 | let [cName, ffiName] = splitOn " -> " line 116 | in overrideType cName ffiName) 117 | (lines contents) 118 | 119 | overrideType :: String -> String -> Output () 120 | overrideType cName ffiName = 121 | defineType cName $ Just Typedef { typedefName = ffiName 122 | , typedefOverride = True } 123 | 124 | defaultOverrides :: Output () 125 | defaultOverrides = mapM_ (uncurry overrideType) 126 | [ ("size_t", "CSize") 127 | , ("intptr_t", "IntPtr") 128 | , ("uintptr_t", "WordPtr") ] 129 | 130 | makeModuleName :: String -> String 131 | makeModuleName = Prelude.concatMap capitalize . splitOn "-" 132 | 133 | -- Write out the gathered data 134 | 135 | writeProducts :: C2HscOptions 136 | -> FilePath 137 | -> Maybe Handle 138 | -> Bool 139 | -> [String] 140 | -> [String] 141 | -> IO () 142 | writeProducts opts fileName output omitHeader hscs helpercs = do 143 | let code = newSTMP $ 144 | if omitHeader 145 | then "" 146 | else unlines 147 | [ "{-# OPTIONS_GHC -fno-warn-unused-imports #-}" 148 | , "#include " 149 | , "#include \"$headerFileName$\"" 150 | , "module $libName$$cFileName$ where" 151 | , "import Foreign.Ptr" 152 | , "#strict_import" 153 | , "" 154 | ] 155 | pre = if null (prefix opts) then "" else prefix opts ++ "." 156 | vars = [ ("libName", pre) 157 | , ("cFileName", cap) 158 | , ("headerFileName", fileName) ] 159 | cap = makeModuleName . dropExtension . takeFileName $ fileName 160 | target = cap ++ ".hsc" 161 | 162 | handle <- case output of 163 | Just h -> return h 164 | Nothing -> openFile target WriteMode 165 | 166 | hPutStrLn handle $ toString $ setManyAttrib vars code 167 | 168 | -- Sniff through the file again, but looking only for local #include's 169 | includes <- filter ("#include \"" `isPrefixOf`) . lines 170 | <$> readFile fileName 171 | for_ includes $ \inc -> do 172 | let incPath = splitOn "\"" inc !! 1 173 | incPathParts = map dropTrailingPathSeparator $ splitPath $ dropExtension incPath 174 | modName = pre ++ intercalate "." (map makeModuleName incPathParts) 175 | hPutStrLn handle $ "import " ++ modName 176 | 177 | traverse_ (hPutStrLn handle) hscs 178 | 179 | when (isNothing output) $ do 180 | hClose handle 181 | log' $ "Wrote " <> pack target 182 | 183 | unless (null helpercs) $ do 184 | let targetc = cap ++ ".hsc.helper.c" 185 | handlec <- case output of 186 | Just h -> return h 187 | Nothing -> openFile targetc WriteMode 188 | 189 | hPutStrLn handlec "#include " 190 | traverse_ (hPutStrLn handlec) includes 191 | hPutStrLn handlec "" 192 | traverse_ (hPutStrLn handlec) helpercs 193 | 194 | when (isNothing output) $ do 195 | hClose handlec 196 | log' $ "Wrote " <> pack targetc 197 | 198 | capitalize :: String -> String 199 | capitalize [] = [] 200 | capitalize (x:xs) = toTitle x : camelCase xs 201 | 202 | camelCase :: String -> String 203 | camelCase [] = [] 204 | camelCase ('_':xs) = capitalize xs 205 | camelCase (x:xs) = x : camelCase xs 206 | 207 | ------------------------------- PURE FUNCTIONS ------------------------------- 208 | 209 | -- Rather than writing to the .hsc and .hsc.helper.c files directly from the 210 | -- IO monad, they are collected in an HscOutput value in the State monad. The 211 | -- actual writing is done by writeProducts. This keeps all the code below 212 | -- pure, and since the data sets involved are relatively small, performance is 213 | -- not a critical issue. 214 | 215 | data Typedef = Typedef 216 | { typedefName :: String 217 | , typedefOverride :: Bool 218 | } 219 | deriving Show 220 | 221 | type TypeMap = M.Map String (Maybe Typedef) 222 | 223 | data HscOutput = HscOutput 224 | { hoHsc :: [String] 225 | , hoHelperC :: [String] 226 | , hoTypes :: TypeMap 227 | } 228 | 229 | type Output = State HscOutput 230 | 231 | newHscState :: HscOutput 232 | newHscState = HscOutput [] [] M.empty 233 | 234 | appendHsc :: String -> Output () 235 | appendHsc hsc = do 236 | HscOutput hscs xs types <- get 237 | put $ HscOutput (hscs ++ [hsc]) xs types 238 | 239 | appendHelper :: String -> Output () 240 | appendHelper helperc = do 241 | HscOutput xs helpercs types <- get 242 | put $ HscOutput xs (helpercs ++ [helperc]) types 243 | 244 | defineType :: String -> Maybe Typedef -> Output () 245 | defineType key value = do 246 | HscOutput xs ys types <- get 247 | hasOverride <- fmap typedefOverride <$> lookupType key 248 | case hasOverride of 249 | Just True -> return () 250 | _ -> put $ HscOutput xs ys (M.insert key value types) 251 | 252 | lookupType :: String -> Output (Maybe Typedef) 253 | lookupType key = do 254 | HscOutput _ _ types <- get 255 | return . join $ M.lookup key types 256 | 257 | -- Now we are ready to parse the C code from the preprocessed input stream, 258 | -- located in the given file and starting at the specified position. The 259 | -- result of a parse is a list of global declarations, so filter the list down 260 | -- to those occurring in the target file, and then print the declarations in 261 | -- Bindings-DSL format. 262 | 263 | parseCFile :: InputStream -> (FilePath -> Bool) -> Position -> Output () 264 | parseCFile stream fm pos = 265 | case parseC stream pos of 266 | Left err -> error $ "Failed to compile: " ++ show err 267 | Right (CTranslUnit decls _) -> generateHsc decls 268 | where 269 | generateHsc :: [CExtDecl] -> Output () 270 | generateHsc = traverse_ (appendNode fm) 271 | 272 | declMatches :: (FilePath -> Bool) -> CExtDecl -> Bool 273 | declMatches fm = fm . posFile . posOfNode . declInfo 274 | 275 | declInfo :: CExtDecl -> NodeInfo 276 | declInfo (CDeclExt (CDecl _ _ info)) = info 277 | declInfo (CDeclExt (CStaticAssert _ _ info)) = info 278 | declInfo (CFDefExt (CFunDef _ _ _ _ info)) = info 279 | declInfo (CAsmExt _ info) = info 280 | 281 | -- These are the top-level printing routines. We are only interested in 282 | -- declarations and function defitions (which almost always means inline 283 | -- functions if the target file is a header file). 284 | -- 285 | -- We will end up printing the following constructs: 286 | -- 287 | -- - Structure definitions 288 | -- - Opaque types (i.e., forward declarations of pointer type) 289 | -- - Enums 290 | -- - Extern Functions 291 | -- - Inline Functions 292 | 293 | appendNode :: (FilePath -> Bool) -> CExtDecl -> Output () 294 | 295 | appendNode _ (CDeclExt (CStaticAssert _ _ _)) = return () 296 | 297 | appendNode fm dx@(CDeclExt (CDecl declSpecs items _)) = 298 | case items of 299 | [] -> 300 | when (declMatches fm dx) $ do 301 | appendHsc $ "{- " ++ P.render (pretty dx) ++ " -}" 302 | appendType declSpecs "" 303 | 304 | xs -> 305 | for_ xs $ \(declrtr, _, _) -> 306 | for_ (splitDecl declrtr) $ \(declrtr', ddrs, nm) -> 307 | case ddrs of 308 | CPtrDeclr{}:CFunDeclr (Right _) _ _:_ -> 309 | when (declMatches fm dx) $ 310 | appendFunc "#callback" declSpecs declrtr' 311 | 312 | CFunDeclr (Right (_, _)) _ _:_ -> 313 | when (declMatches fm dx) $ 314 | appendFunc "#ccall" declSpecs declrtr' 315 | 316 | CArrDeclr{}:CPtrDeclr{}:_ -> 317 | when (declMatches fm dx) $ do 318 | dname <- declSpecTypeName True declSpecs 319 | appendHsc $ "#globalarray " ++ nm ++ " , Ptr " ++ tyParens dname 320 | 321 | CArrDeclr{}:_ -> 322 | when (declMatches fm dx) $ do 323 | dname <- declSpecTypeName True declSpecs 324 | appendHsc $ "#globalarray " ++ nm ++ " , " ++ tyParens dname 325 | 326 | CPtrDeclr{}:_ -> 327 | case declSpecs of 328 | CStorageSpec (CTypedef _):_ -> do 329 | when (declMatches fm dx) $ do 330 | appendHsc $ "{- " ++ P.render (pretty dx) ++ " -}" 331 | appendType declSpecs nm 332 | 333 | org_dname <- declSpecTypeName True declSpecs 334 | unless (null org_dname || org_dname == "<" ++ nm ++ ">") $ do 335 | let dname = "Ptr " ++ org_dname 336 | when (declMatches fm dx) $ 337 | appendHsc $ "#synonym_t " ++ nm ++ " , " ++ dname 338 | -- We saw the synonym, override the defineType just above 339 | defineType nm $ Just Typedef 340 | { typedefName = dname 341 | , typedefOverride = False 342 | } 343 | 344 | _ -> 345 | when (declMatches fm dx) $ do 346 | dname <- declSpecTypeName True declSpecs 347 | appendHsc $ "#globalvar " ++ nm ++ " , Ptr " ++ tyParens dname 348 | 349 | _ -> 350 | -- If the type is a typedef, record the equivalence so we can 351 | -- look it up later 352 | case declSpecs of 353 | CStorageSpec (CTypedef _):_ -> do 354 | when (declMatches fm dx) $ do 355 | appendHsc $ "{- " ++ P.render (pretty dx) ++ " -}" 356 | appendType declSpecs nm 357 | 358 | dname <- declSpecTypeName True declSpecs 359 | unless (null dname || dname == "<" ++ nm ++ ">") $ do 360 | when (declMatches fm dx) $ 361 | appendHsc $ "#synonym_t " ++ nm ++ " , " ++ dname 362 | -- We saw the synonym, override the defineType just above 363 | defineType nm $ Just Typedef 364 | { typedefName = dname 365 | , typedefOverride = False 366 | } 367 | 368 | _ -> 369 | when (declMatches fm dx) $ do 370 | dname <- declSpecTypeName True declSpecs 371 | appendHsc $ "#globalvar " ++ nm ++ " , " ++ tyParens dname 372 | where 373 | splitDecl declrtr = do -- in the Maybe Monad 374 | d@(CDeclr ident ddrs _ _ _) <- declrtr 375 | return (d, ddrs, case ident of Just (Ident nm _ _) -> nm; _ -> "") 376 | 377 | appendNode fm dx@(CFDefExt (CFunDef declSpecs declrtr _ _ _)) = 378 | -- Assume functions defined in headers are inline functions 379 | when (declMatches fm dx) $ do 380 | appendFunc "#cinline" declSpecs declrtr 381 | 382 | let CDeclr ident ddrs _ _ _ = declrtr 383 | 384 | for_ ident $ \(Ident nm _ _) -> 385 | case head ddrs of 386 | CFunDeclr (Right (decls, _)) _ _ -> do 387 | retType <- derDeclrTypeName' True False declSpecs (tail ddrs) 388 | funType <- applyDeclrs True False retType ddrs 389 | appendHelper $ 390 | "BC_INLINE" ++ show (length decls) 391 | ++ (if not (null retType) then "" else "VOID") 392 | ++ "(" ++ nm ++ ", " ++ funType ++ ")" 393 | _ -> return () 394 | 395 | appendNode _ (CAsmExt _ _) = return () 396 | 397 | -- Print out a function as #ccall or #cinline. The syntax is the same for 398 | -- both externs and inlines, except that we want to do extra work for inline 399 | -- and create a helper file with some additional macros. 400 | 401 | appendFunc :: String -> [CDeclarationSpecifier a] -> CDeclarator a -> Output () 402 | appendFunc marker declSpecs (CDeclr ident ddrs _ _ _) = do 403 | let _:retDeclr:_ = splitWhen isFuncDeclr ddrs 404 | funcDeclr:_ = dropWhile (not . isFuncDeclr) ddrs 405 | 406 | retType <- derDeclrTypeName False declSpecs retDeclr 407 | argTypes <- (++) <$> getArgTypes funcDeclr 408 | <*> pure [ "IO " ++ tyParens retType ] 409 | 410 | let name' = nameFromIdent ident 411 | code = newSTMP "$marker$ $name$ , $argTypes;separator=' -> '$" 412 | -- I have to call setAttribute separately since argTypes :: [String] 413 | code' = setAttribute "argTypes" argTypes code 414 | vars = [ ("marker", marker) 415 | , ("name", name') ] 416 | 417 | appendHsc $ toString $ setManyAttrib vars code' 418 | 419 | where 420 | getArgTypes x = filter (not . null) <$> sequence (getArgTypes' x) 421 | 422 | getArgTypes' (CFunDeclr (Right (decls, _)) _ _) = 423 | map (cdeclTypeName False) decls 424 | getArgTypes' _ = [] 425 | 426 | nameFromIdent (Just (Ident n _ _)) = n 427 | nameFromIdent _ = "" 428 | 429 | isFuncDeclr (CFunDeclr {}) = True 430 | isFuncDeclr _ = False 431 | 432 | structTagPrefix :: CStructTag -> String 433 | structTagPrefix CStructTag = "struct " 434 | structTagPrefix CUnionTag = "union " 435 | 436 | appendType :: [CDeclarationSpecifier a] -> String -> Output () 437 | appendType declSpecs declrName = traverse_ appendType' declSpecs 438 | where 439 | appendType' (CTypeSpec (CSUType (CStruct tag ident decls _ _) _)) = do 440 | let name' = identName (structTagPrefix tag) ident 441 | seen <- M.member name' . hoTypes <$> get 442 | when (isNothing decls && not seen) $ do 443 | appendHsc $ "#opaque_t " ++ name' 444 | defineType name' Nothing 445 | 446 | for_ decls $ \xs -> do 447 | appendHsc $ "#starttype " ++ name' 448 | for_ xs $ \x -> 449 | for_ (cdeclNames x) $ \declName -> do 450 | let CDecl declSpecs' ((Just y, _, _):_) _ = x 451 | case y of 452 | CDeclr _ (CArrDeclr {}:zs) _ _ _ -> do 453 | tname <- derDeclrTypeName True declSpecs' zs 454 | appendHsc $ "#array_field " ++ declName ++ " , " ++ tname 455 | _ -> do 456 | tname <- cdeclTypeName True x 457 | appendHsc $ "#field " ++ declName ++ " , " ++ tname 458 | appendHsc "#stoptype" 459 | 460 | appendType' (CTypeSpec (CEnumType (CEnum ident defs _ _) _)) = do 461 | let name' = identName "enum " ident 462 | unless (null name') $ appendHsc $ "#integral_t " ++ name' 463 | 464 | for_ defs $ \ds -> 465 | for_ ds $ \(Ident nm _ _, _) -> 466 | appendHsc $ "#num " ++ nm 467 | 468 | appendType' _ = return () 469 | 470 | identName pref ident = case ident of 471 | Nothing -> declrName 472 | Just (Ident nm _ _) -> pref ++ nm 473 | 474 | -- The remainder of this file is some hairy code for turning various 475 | -- constructs into Bindings-DSL type names, such as turning "int ** foo" into 476 | -- the type name "Ptr (Ptr CInt)". 477 | 478 | data Signedness = None | Signed | Unsigned deriving (Eq, Show, Enum) 479 | data Lengthiness = Unspecified | Long deriving (Eq, Show, Enum) 480 | 481 | cdeclNames :: CDeclaration a -> [String] 482 | cdeclNames (CDecl _ more _) = 483 | collect more [] 484 | where 485 | collect [] nms = reverse nms 486 | collect (m:ms) nms = collect ms $ case m of 487 | (Just (CDeclr (Just (Ident nm _ _)) _ _ _ _), _, _) 488 | -> nm:nms 489 | _ -> nms 490 | cdeclNames (CStaticAssert _ _ _) = [] 491 | 492 | cdeclTypeName :: Bool -> CDeclaration a -> Output String 493 | cdeclTypeName = cdeclTypeName' False 494 | 495 | cdeclTypeName' :: Bool -> Bool -> CDeclaration a -> Output String 496 | cdeclTypeName' cStyle isDirect (CDecl declSpecs more _) = 497 | case more of 498 | (Just x, _, _) : _ -> declrTypeName' cStyle isDirect declSpecs x 499 | _ -> declSpecTypeName' cStyle isDirect declSpecs 500 | cdeclTypeName' _ _ (CStaticAssert _ _ _) = error "Unhandled static assertion" 501 | 502 | declSpecTypeName :: Bool -> [CDeclarationSpecifier a] -> Output String 503 | declSpecTypeName = declSpecTypeName' False 504 | 505 | declSpecTypeName' :: Bool -> Bool -> [CDeclarationSpecifier a] -> Output String 506 | declSpecTypeName' cStyle isDirect = flip (derDeclrTypeName' cStyle isDirect) [] 507 | 508 | declrTypeName :: Bool -> [CDeclarationSpecifier a] -> CDeclarator a 509 | -> Output String 510 | declrTypeName = declrTypeName' False 511 | 512 | declrTypeName' :: Bool -> Bool -> [CDeclarationSpecifier a] -> CDeclarator a 513 | -> Output String 514 | declrTypeName' cStyle isDirect declSpecs (CDeclr _ ddrs _ _ _) = 515 | derDeclrTypeName' cStyle isDirect declSpecs ddrs 516 | 517 | derDeclrTypeName :: Bool -> [CDeclarationSpecifier a] -> [CDerivedDeclarator a] 518 | -> Output String 519 | derDeclrTypeName = derDeclrTypeName' False 520 | 521 | derDeclrTypeName' :: Bool 522 | -> Bool 523 | -> [CDeclarationSpecifier a] 524 | -> [CDerivedDeclarator a] 525 | -> Output String 526 | derDeclrTypeName' cStyle isDirect declSpecs ddrs = do 527 | nm <- fullTypeName' (if cStyle then "int" else "") Unspecified None declSpecs 528 | applyDeclrs cStyle isDirect nm ddrs 529 | 530 | where 531 | fullTypeName' :: String -> Lengthiness -> Signedness -> [CDeclarationSpecifier a] -> Output String 532 | fullTypeName' "" _ None [] 533 | | cStyle = return "void" 534 | | otherwise = return "" 535 | fullTypeName' "" _ Unsigned [] 536 | | cStyle = return "int" 537 | | otherwise = return "CUInt" 538 | fullTypeName' "" _ Signed [] 539 | | cStyle = return "int" 540 | | otherwise = return "CInt" 541 | 542 | fullTypeName' ty _ _ [] = return ty 543 | 544 | fullTypeName' ty l s (x:xs) = case x of 545 | CTypeSpec (CSignedType _) 546 | | cStyle -> ("signed " ++) <$> fullTypeName' ty l Signed xs 547 | | otherwise -> fullTypeName' ty l Signed xs 548 | 549 | CTypeSpec (CUnsigType _) 550 | | cStyle -> ("unsigned " ++) <$> fullTypeName' ty l Unsigned xs 551 | | otherwise -> fullTypeName' ty l Unsigned xs 552 | 553 | CTypeSpec tspec@(CLongType _) 554 | | cStyle -> fullTypeName' ((case l of 555 | Long -> "long " 556 | Unspecified -> "") ++ cTypeName tspec) Long s xs 557 | | otherwise -> typeName tspec l s >>= \ty' -> fullTypeName' ty' Long s xs 558 | 559 | CTypeSpec tspec 560 | | cStyle -> fullTypeName' ((case l of 561 | Long -> "long " 562 | Unspecified -> "") ++ cTypeName tspec) Unspecified s xs 563 | | otherwise -> typeName tspec l s >>= \ty' -> fullTypeName' ty' Unspecified s xs 564 | 565 | CTypeQual qual 566 | | cStyle -> do 567 | baseType <- fullTypeName' ty l s xs 568 | return $ let q = qualToStr qual 569 | in if null q 570 | then baseType 571 | else q ++ " " ++ baseType 572 | 573 | _ -> fullTypeName' ty l s xs 574 | 575 | concatM :: (Monad f, Functor f) => [f [a]] -> f [a] 576 | concatM xs = concat <$> sequence xs 577 | 578 | applyDeclrs :: Bool -> Bool -> String -> [CDerivedDeclarator a] -> Output String 579 | 580 | applyDeclrs cStyle _isDirect baseType (CPtrDeclr {}:f@CFunDeclr {}:ds) = do 581 | baseType' <- applyDeclrs cStyle False baseType ds 582 | applyDeclrs cStyle False baseType' [f] 583 | 584 | applyDeclrs cStyle isDirect baseType (CFunDeclr (Right (decls, _)) _ _:_) 585 | | cStyle = renderList ", " (funTypes decls baseType) 586 | | otherwise = do 587 | argTypes <- renderList " -> " (funTypes decls (if null baseType 588 | then "IO ()" 589 | else baseType)) 590 | return $ "FunPtr " ++ tyParens argTypes 591 | 592 | where renderList str xs = intercalate str <$> filter (not . null) <$> xs 593 | funTypes xs bt = (++) <$> mapM (cdeclTypeName' cStyle isDirect) xs 594 | <*> pure [bt] 595 | 596 | applyDeclrs cStyle isDirect baseType decl@(CPtrDeclr quals _:[]) 597 | | cStyle && baseType == "" = applyDeclrs cStyle isDirect "void" decl 598 | | cStyle = return $ baseType ++ "*" 599 | ++ preQualsToString quals 600 | | baseType == "" = return "Ptr ()" 601 | | baseType == "CChar" = return "CString" 602 | | otherwise = return $ "Ptr " ++ baseType 603 | 604 | applyDeclrs cStyle isDirect baseType (CPtrDeclr quals _:xs) 605 | | cStyle = concatM [ applyDeclrs cStyle isDirect baseType xs 606 | , pure "*" 607 | , pure (preQualsToString quals) ] 608 | | otherwise = concatM [ pure "Ptr " 609 | , tyParens `fmap` 610 | applyDeclrs cStyle isDirect baseType xs ] 611 | 612 | applyDeclrs cStyle isDirect baseType (CArrDeclr quals _ _:xs) 613 | | cStyle = concatM [ pure (sufQualsToString quals) 614 | , applyDeclrs cStyle isDirect baseType xs 615 | , pure "[]" ] 616 | | otherwise = concatM [ pure $ if isDirect then "" else "Ptr " 617 | , tyParens `fmap` 618 | applyDeclrs cStyle isDirect baseType xs ] 619 | 620 | applyDeclrs _ _ baseType _ = return baseType 621 | 622 | preQualsToString :: [CTypeQualifier a] -> String 623 | preQualsToString = prefixWith ' ' . qualsToStr 624 | 625 | prefixWith :: a -> [a] -> [a] 626 | prefixWith _ [] = [] 627 | prefixWith x xs = x:xs 628 | 629 | sufQualsToString :: [CTypeQualifier a] -> String 630 | sufQualsToString = suffixWith ' ' . qualsToStr 631 | 632 | suffixWith :: a -> [a] -> [a] 633 | suffixWith _ [] = [] 634 | suffixWith x xs = xs ++ [x] 635 | 636 | qualsToStr :: [CTypeQualifier a] -> String 637 | qualsToStr = unwords . map qualToStr 638 | 639 | qualToStr :: CTypeQualifier t -> String 640 | qualToStr (CConstQual _) = "const" 641 | qualToStr (CVolatQual _) = "volatile" 642 | qualToStr (CRestrQual _) = "restricted" 643 | qualToStr (CAtomicQual _) = "atomic" 644 | qualToStr (CAttrQual _) = "" 645 | qualToStr (CNullableQual _) = "" 646 | qualToStr (CNonnullQual _) = "" 647 | qualToStr (CClRdOnlyQual _) = "__read_only" 648 | qualToStr (CClWrOnlyQual _) = "__write_only" 649 | 650 | -- Simple translation from C types to Foreign.C.Types types. We represent 651 | -- Void as the empty string so that returning void becomes IO (), and passing 652 | -- a void star becomes Ptr (). 653 | 654 | typeName :: CTypeSpecifier a -> Lengthiness -> Signedness -> Output String 655 | 656 | typeName (CVoidType _) _ _ = return "" 657 | typeName (CFloatType _) _ _ = return "CFloat" 658 | typeName (CDoubleType _) _ _ = return "CDouble" 659 | typeName (CBoolType _) _ _ = return "CInt" 660 | 661 | typeName (CCharType _) _ Signed = return "CSChar" 662 | typeName (CCharType _) _ Unsigned = return "CUChar" 663 | typeName (CCharType _) _ _ = return "CChar" 664 | 665 | typeName (CShortType _) _ Signed = return "CShort" 666 | typeName (CShortType _) _ Unsigned = return "CUShort" 667 | typeName (CShortType _) _ _ = return "CShort" 668 | 669 | typeName (CIntType _) Long Signed = return "CLong" 670 | typeName (CIntType _) Long Unsigned = return "CULong" 671 | typeName (CIntType _) Long _ = return "CLong" 672 | 673 | typeName (CIntType _) _ Signed = return "CInt" 674 | typeName (CIntType _) _ Unsigned = return "CUInt" 675 | typeName (CIntType _) _ _ = return "CInt" 676 | 677 | typeName (CLongType _) Long Signed = return "CLLong" 678 | typeName (CLongType _) Long Unsigned = return "CULLong" 679 | typeName (CLongType _) Long _ = return "CLLong" 680 | 681 | typeName (CLongType _) _ Signed = return "CLong" 682 | typeName (CLongType _) _ Unsigned = return "CULong" 683 | typeName (CLongType _) _ _ = return "CLong" 684 | 685 | typeName (CTypeDef (Ident nm _ _) _) _ _ = do 686 | definition <- lookupType nm 687 | case definition of 688 | Nothing -> return $ "<" ++ nm ++ ">" 689 | Just Typedef { typedefName = defNm } -> 690 | return defNm 691 | 692 | typeName (CSUType (CStruct tag (Just (Ident nm _ _)) _ _ _) _) _ _ = 693 | return $ "<" ++ structTagPrefix tag ++ nm ++ ">" 694 | typeName (CEnumType (CEnum (Just (Ident nm _ _)) _ _ _) _) _ _ = 695 | return $ "" 696 | 697 | typeName (CComplexType _) _ _ = return "" 698 | typeName (CTypeOfExpr _ _) _ _ = return "" 699 | typeName (CTypeOfType _ _) _ _ = return "" 700 | 701 | typeName _ _ _ = return "" 702 | 703 | cTypeName :: CTypeSpecifier a -> String 704 | cTypeName (CVoidType _) = "" 705 | cTypeName (CFloatType _) = "float" 706 | cTypeName (CDoubleType _) = "double" 707 | cTypeName (CBoolType _) = "int" 708 | cTypeName (CCharType _) = "char" 709 | cTypeName (CShortType _) = "short" 710 | cTypeName (CIntType _) = "int" 711 | cTypeName (CLongType _) = "long" 712 | cTypeName (CTypeDef (Ident nm _ _) _) = nm 713 | cTypeName (CComplexType _) = "" 714 | cTypeName (CSUType _ _) = "" 715 | cTypeName (CEnumType _ _) = "" 716 | cTypeName (CTypeOfExpr _ _) = "" 717 | cTypeName (CTypeOfType _ _) = "" 718 | 719 | cTypeName _ = "" 720 | 721 | tyParens :: String -> String 722 | tyParens ty = 723 | if null ty || ' ' `elem` ty 724 | then concat ["(", ty, ")"] 725 | else ty 726 | 727 | -- c2hsc.hs 728 | -------------------------------------------------------------------------------- /test/main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | 4 | module Main where 5 | 6 | import Control.Exception 7 | import Control.Logging 8 | import Data.C2Hsc 9 | import Data.Char 10 | import Data.String.Here 11 | import Data.Text (Text, pack) 12 | import Prelude hiding (log) 13 | import Test.Hspec 14 | 15 | tryAny :: IO a -> IO (Either SomeException a) 16 | tryAny = try 17 | 18 | main :: IO () 19 | main = withStdoutLogging $ hspec $ do 20 | describe "issues" $ do 21 | it "#38" $ do 22 | matches [here| 23 | typedef const char* an_pchar; 24 | |] [here| 25 | {- typedef const char * an_pchar; -} 26 | #synonym_t an_pchar , Ptr CChar 27 | |] 28 | 29 | it "#25" $ do 30 | matches [here| 31 | typedef struct { 32 | char listOfNames[8][255]; 33 | } MyCoolStruct; 34 | |] [here| 35 | {- typedef struct { 36 | char listOfNames[8][255]; 37 | } MyCoolStruct; -} 38 | #starttype MyCoolStruct 39 | #array_field listOfNames , CChar 40 | #stoptype 41 | |] 42 | 43 | describe "#17" $ do 44 | it "function pointer types" $ 45 | matches [here| 46 | typedef int (*foo)(int); 47 | |] [here| 48 | #callback foo , CInt -> IO CInt 49 | |] 50 | 51 | -- it "function pointer arrays" $ 52 | -- matches [here| 53 | -- int (*my_array[])(int); 54 | -- |] [here| 55 | -- #callback my_array_callback , CInt -> IO CInt 56 | -- #globalvar my_array , 57 | -- |] 58 | 59 | -- it "function pointer structure members" $ 60 | -- matches [here| 61 | -- struct foo_t { 62 | -- int (*foo_member)(int); 63 | -- }; 64 | -- |] [here| 65 | -- {- struct foo_t { 66 | -- int (* foo_member)(int); 67 | -- }; -} 68 | -- #callback foo_member_callback , CInt -> IO CInt 69 | -- #starttype struct foo_t 70 | -- #field foo_member , 71 | -- #stoptype 72 | -- |] 73 | 74 | -- it "function pointer function arguments" $ 75 | -- matches [here| 76 | -- void foo_function(int (*foo)(int)) {} 77 | -- |] [here| 78 | -- #callback foo_function_foo_callback , CInt -> IO CInt 79 | -- #cinline foo_function , -> IO () 80 | -- #include 81 | 82 | -- BC_INLINE1VOID(foo_function, int, int) 83 | -- |] 84 | 85 | it "#15" $ 86 | matches [here| 87 | typedef struct Foo_ Foo; 88 | typedef enum Bar_ { BAR } Bar; 89 | |] [here| 90 | {- typedef struct Foo_ Foo; -} 91 | #opaque_t struct Foo_ 92 | #synonym_t Foo , 93 | {- typedef enum Bar_ { 94 | BAR 95 | } Bar; -} 96 | #integral_t enum Bar_ 97 | #num BAR 98 | #synonym_t Bar , 99 | |] 100 | 101 | it "#12" $ 102 | matches [here| 103 | struct st { 104 | int i; 105 | }; 106 | 107 | enum e { 108 | CONST 109 | }; 110 | 111 | union u { 112 | char c; 113 | }; 114 | |] [here| 115 | {- struct st { 116 | int i; 117 | }; -} 118 | #starttype struct st 119 | #field i , CInt 120 | #stoptype 121 | {- enum e { 122 | CONST 123 | }; -} 124 | #integral_t enum e 125 | #num CONST 126 | {- union u { 127 | char c; 128 | }; -} 129 | #starttype union u 130 | #field c , CChar 131 | #stoptype 132 | |] 133 | it "#15" $ 134 | matches [here| 135 | struct MyTypeImpl; 136 | typedef struct MyTypeImpl* MyType; 137 | 138 | typedef struct MyStruct { 139 | int x; 140 | } MyStructType; 141 | 142 | typedef struct MyStructEmpty MyStructEmptyType; 143 | |] [here| 144 | {- struct MyTypeImpl; -} 145 | #opaque_t struct MyTypeImpl 146 | {- typedef struct MyTypeImpl * MyType; -} 147 | #synonym_t MyType , Ptr 148 | {- typedef struct MyStruct { 149 | int x; 150 | } MyStructType; -} 151 | #starttype struct MyStruct 152 | #field x , CInt 153 | #stoptype 154 | #synonym_t MyStructType , 155 | {- typedef struct MyStructEmpty MyStructEmptyType; -} 156 | #opaque_t struct MyStructEmpty 157 | #synonym_t MyStructEmptyType , 158 | |] 159 | 160 | it "#33" $ do 161 | matches [here| 162 | unsigned foo(unsigned); 163 | |] [here| 164 | #ccall foo , CUInt -> IO CUInt 165 | |] 166 | matches [here| 167 | unsigned __attribute__ ((visibility ("default"))) foo(unsigned); 168 | |] [here| 169 | #ccall foo , CUInt -> IO CUInt 170 | |] 171 | matches [here| 172 | long long __attribute__ ((visibility ("default"))) foo(long long); 173 | |] [here| 174 | #ccall foo , CLLong -> IO CLLong 175 | |] 176 | 177 | describe "primitive types" $ do 178 | it "float" $ 179 | matches [here| 180 | float ordinary_float; 181 | |] [here| 182 | #globalvar ordinary_float , CFloat 183 | |] 184 | it "double" $ 185 | matches [here| 186 | double ordinary_double; 187 | |] [here| 188 | #globalvar ordinary_double , CDouble 189 | |] 190 | -- test disabled until https://ghc.haskell.org/trac/ghc/ticket/3353 is 191 | -- resolved. 192 | -- 193 | -- it "long double" $ 194 | -- matches [here| 195 | -- long double ordinary_long_double; 196 | -- |] [here| 197 | -- #globalvar ordinary_long_double , CLongDouble 198 | -- |] 199 | 200 | it "char" $ 201 | matches [here| 202 | char ordinary_char; 203 | |] [here| 204 | #globalvar ordinary_char , CChar 205 | |] 206 | it "signed char" $ 207 | matches [here| 208 | signed char signed_char; 209 | |] [here| 210 | #globalvar signed_char , CSChar 211 | |] 212 | it "unsigned char" $ 213 | matches [here| 214 | unsigned char unsigned_char; 215 | |] [here| 216 | #globalvar unsigned_char , CUChar 217 | |] 218 | it "short" $ 219 | matches [here| 220 | short ordinary_signed_short; 221 | |] [here| 222 | #globalvar ordinary_signed_short , CShort 223 | |] 224 | it "signed short" $ 225 | matches [here| 226 | signed short explicit_signed_short; 227 | |] [here| 228 | #globalvar explicit_signed_short , CShort 229 | |] 230 | it "unsigned short" $ 231 | matches [here| 232 | unsigned short unsigned_short; 233 | |] [here| 234 | #globalvar unsigned_short , CUShort 235 | |] 236 | it "int" $ 237 | matches [here| 238 | int ordinary_signed_int; 239 | |] [here| 240 | #globalvar ordinary_signed_int , CInt 241 | |] 242 | it "signed int" $ 243 | matches [here| 244 | signed int explicit_signed_int; 245 | |] [here| 246 | #globalvar explicit_signed_int , CInt 247 | |] 248 | it "unsigned int" $ 249 | matches [here| 250 | unsigned int unsigned_int; 251 | |] [here| 252 | #globalvar unsigned_int , CUInt 253 | |] 254 | it "long" $ 255 | matches [here| 256 | long ordinary_signed_long; 257 | |] [here| 258 | #globalvar ordinary_signed_long , CLong 259 | |] 260 | it "signed long" $ 261 | matches [here| 262 | signed long explicit_signed_long; 263 | |] [here| 264 | #globalvar explicit_signed_long , CLong 265 | |] 266 | it "unsigned long" $ 267 | matches [here| 268 | unsigned long unsigned_long; 269 | |] [here| 270 | #globalvar unsigned_long , CULong 271 | |] 272 | 273 | it "long long" $ do 274 | matches [here| 275 | long long ordinary_signed_long_long; 276 | |] [here| 277 | #globalvar ordinary_signed_long_long , CLLong 278 | |] 279 | it "signed long long" $ do 280 | matches [here| 281 | signed long long explicit_signed_long_long; 282 | |] [here| 283 | #globalvar explicit_signed_long_long , CLLong 284 | |] 285 | it "unsigned long long" $ 286 | matches [here| 287 | unsigned long long unsigned_long_long; 288 | |] [here| 289 | #globalvar unsigned_long_long , CULLong 290 | |] 291 | 292 | describe "pointers" $ do 293 | describe "primitive types which cannot be signed" $ do 294 | it "ordinary_void_pointer" $ 295 | -- jww (2014-04-05): This is wrong! 296 | matches [here| 297 | void* ordinary_void_pointer; 298 | |] [here| 299 | #globalvar ordinary_void_pointer , Ptr () 300 | |] 301 | it "ordinary_float_pointer" $ 302 | matches [here| 303 | float* ordinary_float_pointer; 304 | |] [here| 305 | #globalvar ordinary_float_pointer , Ptr CFloat 306 | |] 307 | it "ordinary_double_pointer" $ 308 | matches [here| 309 | double* ordinary_double_pointer; 310 | |] [here| 311 | #globalvar ordinary_double_pointer , Ptr CDouble 312 | |] 313 | -- it "ordinary_long_double_pointer" $ 314 | -- matches [here| 315 | -- long double* ordinary_long_double_pointer; 316 | -- |] [here| 317 | -- |] 318 | describe "types which can be signed" $ do 319 | describe "char" $ do 320 | it "ordinary_char_pointer" $ 321 | matches [here| 322 | char *ordinary_char_pointer; 323 | |] [here| 324 | #globalvar ordinary_char_pointer , Ptr CChar 325 | |] 326 | it "signed_char_pointer" $ 327 | matches [here| 328 | signed char *signed_char_pointer; 329 | |] [here| 330 | #globalvar signed_char_pointer , Ptr CSChar 331 | |] 332 | it "unsigned_char_pointer" $ 333 | matches [here| 334 | unsigned char *unsigned_char_pointer; 335 | |] [here| 336 | #globalvar unsigned_char_pointer , Ptr CUChar 337 | |] 338 | describe "short" $ do 339 | it "ordinary_signed_short_pointer" $ 340 | matches [here| 341 | short *ordinary_signed_short_pointer; 342 | |] [here| 343 | #globalvar ordinary_signed_short_pointer , Ptr CShort 344 | |] 345 | it "explicit_signed_short_pointer" $ 346 | matches [here| 347 | signed short *explicit_signed_short_pointer; 348 | |] [here| 349 | #globalvar explicit_signed_short_pointer , Ptr CShort 350 | |] 351 | it "unsigned_short_pointer" $ 352 | matches [here| 353 | unsigned short *unsigned_short_pointer; 354 | |] [here| 355 | #globalvar unsigned_short_pointer , Ptr CUShort 356 | |] 357 | describe "int" $ do 358 | it "ordinary_signed_int_pointer" $ 359 | matches [here| 360 | int* ordinary_signed_int_pointer; 361 | |] [here| 362 | #globalvar ordinary_signed_int_pointer , Ptr CInt 363 | |] 364 | it "explicit_signed_int_pointer" $ 365 | matches [here| 366 | signed int* explicit_signed_int_pointer; 367 | |] [here| 368 | #globalvar explicit_signed_int_pointer , Ptr CInt 369 | |] 370 | it "unsigned_int_pointer" $ 371 | matches [here| 372 | unsigned int* unsigned_int_pointer; 373 | |] [here| 374 | #globalvar unsigned_int_pointer , Ptr CUInt 375 | |] 376 | describe "long" $ do 377 | it "ordinary_signed_long_pointer" $ 378 | matches [here| 379 | long *ordinary_signed_long_pointer; 380 | |] [here| 381 | #globalvar ordinary_signed_long_pointer , Ptr CLong 382 | |] 383 | it "explicit_signed_long_pointer" $ 384 | matches [here| 385 | signed long *explicit_signed_long_pointer; 386 | |] [here| 387 | #globalvar explicit_signed_long_pointer , Ptr CLong 388 | |] 389 | it "unsigned_long_pointer" $ 390 | matches [here| 391 | unsigned long *unsigned_long_pointer; 392 | |] [here| 393 | #globalvar unsigned_long_pointer , Ptr CULong 394 | |] 395 | describe "long long" $ do 396 | it "ordinary_signed_long_long_pointer" $ 397 | matches [here| 398 | long long* ordinary_signed_long_long_pointer; 399 | |] [here| 400 | #globalvar ordinary_signed_long_long_pointer , Ptr CLLong 401 | |] 402 | it "explicit_signed_long_long_pointer" $ 403 | matches [here| 404 | signed long long* explicit_signed_long_long_pointer; 405 | |] [here| 406 | #globalvar explicit_signed_long_long_pointer , Ptr CLLong 407 | |] 408 | it "unsigned_long_long_pointer" $ 409 | matches [here| 410 | unsigned long long* unsigned_long_long_pointer; 411 | |] [here| 412 | #globalvar unsigned_long_long_pointer , Ptr CULLong 413 | |] 414 | 415 | describe "arrays" $ do 416 | describe "primitive types which cannot be signed" $ do 417 | it "ordinary_float_array" $ 418 | matches [here| 419 | float ordinary_float_array[10]; 420 | |] [here| 421 | #globalarray ordinary_float_array , CFloat 422 | |] 423 | it "ordinary_double_array" $ 424 | matches [here| 425 | double ordinary_double_array[10]; 426 | |] [here| 427 | #globalarray ordinary_double_array , CDouble 428 | |] 429 | it "ordinary_long_double_array" $ 430 | matches [here| 431 | long double ordinary_long_double_array[10]; 432 | |] [here| 433 | #globalarray ordinary_long_double_array , CDouble 434 | |] 435 | describe "types which can be signed" $ do 436 | describe "char" $ do 437 | it "ordinary_signed_char_array" $ 438 | matches [here| 439 | char ordinary_signed_char_array[10]; 440 | |] [here| 441 | #globalarray ordinary_signed_char_array , CChar 442 | |] 443 | it "explicit_signed_char_array" $ 444 | matches [here| 445 | signed char explicit_signed_char_array[10]; 446 | |] [here| 447 | #globalarray explicit_signed_char_array , CSChar 448 | |] 449 | it "unsigned_char_array" $ 450 | matches [here| 451 | unsigned char unsigned_char_array[10]; 452 | |] [here| 453 | #globalarray unsigned_char_array , CUChar 454 | |] 455 | describe "short" $ do 456 | it "ordinary_signed_short_array" $ 457 | matches [here| 458 | short ordinary_signed_short_array[10]; 459 | |] [here| 460 | #globalarray ordinary_signed_short_array , CShort 461 | |] 462 | it "explicit_signed_short_array" $ 463 | matches [here| 464 | signed short explicit_signed_short_array[10]; 465 | |] [here| 466 | #globalarray explicit_signed_short_array , CShort 467 | |] 468 | it "unsigned_short_array" $ 469 | matches [here| 470 | unsigned short unsigned_short_array[10]; 471 | |] [here| 472 | #globalarray unsigned_short_array , CUShort 473 | |] 474 | describe "int" $ do 475 | it "ordinary_signed_int_array" $ 476 | matches [here| 477 | int ordinary_signed_int_array[10]; 478 | |] [here| 479 | #globalarray ordinary_signed_int_array , CInt 480 | |] 481 | it "explicit_signed_int_array" $ 482 | matches [here| 483 | signed int explicit_signed_int_array[10]; 484 | |] [here| 485 | #globalarray explicit_signed_int_array , CInt 486 | |] 487 | it "unsigned_int_array" $ 488 | matches [here| 489 | unsigned int unsigned_int_array[10]; 490 | |] [here| 491 | #globalarray unsigned_int_array , CUInt 492 | |] 493 | describe "long" $ do 494 | it "ordinary_signed_long_array" $ 495 | matches [here| 496 | long ordinary_signed_long_array[10]; 497 | |] [here| 498 | #globalarray ordinary_signed_long_array , CLong 499 | |] 500 | it "explicit_signed_long_array" $ 501 | matches [here| 502 | signed long explicit_signed_long_array[10]; 503 | |] [here| 504 | #globalarray explicit_signed_long_array , CLong 505 | |] 506 | it "unsigned_long_array" $ 507 | matches [here| 508 | unsigned long unsigned_long_array[10]; 509 | |] [here| 510 | #globalarray unsigned_long_array , CULong 511 | |] 512 | describe "long long" $ do 513 | it "ordinary_signed_long_long_array" $ 514 | matches [here| 515 | long long ordinary_signed_long_long_array[10]; 516 | |] [here| 517 | #globalarray ordinary_signed_long_long_array , CLLong 518 | |] 519 | it "explicit_signed_long_long_array" $ 520 | matches [here| 521 | signed long long explicit_signed_long_long_array[10]; 522 | |] [here| 523 | #globalarray explicit_signed_long_long_array , CLLong 524 | |] 525 | it "unsigned_long_long_array" $ 526 | matches [here| 527 | unsigned long long unsigned_long_long_array[10]; 528 | |] [here| 529 | #globalarray unsigned_long_long_array , CULLong 530 | |] 531 | describe "pointers" $ do 532 | describe "primitive types which cannot be signed" $ do 533 | it "ordinary_void_pointer_array" $ 534 | matches [here| 535 | void* ordinary_void_pointer_array[10]; 536 | |] [here| 537 | #globalarray ordinary_void_pointer_array , Ptr () 538 | |] 539 | it "ordinary_float_pointer_array" $ 540 | matches [here| 541 | float* ordinary_float_pointer_array[10]; 542 | |] [here| 543 | #globalarray ordinary_float_pointer_array , Ptr CFloat 544 | |] 545 | it "ordinary_double_pointer_array" $ 546 | matches [here| 547 | double* ordinary_double_pointer_array[10]; 548 | |] [here| 549 | #globalarray ordinary_double_pointer_array , Ptr CDouble 550 | |] 551 | it "ordinary_long_double_pointer_array" $ 552 | matches [here| 553 | long double* ordinary_long_double_pointer_array[10]; 554 | |] [here| 555 | #globalarray ordinary_long_double_pointer_array , Ptr CDouble 556 | |] 557 | describe "types which can be signed" $ do 558 | describe "char" $ do 559 | it "ordinary_signed_char_pointer_array" $ 560 | matches [here| 561 | char *ordinary_signed_char_pointer_array[10]; 562 | |] [here| 563 | #globalarray ordinary_signed_char_pointer_array , Ptr CChar 564 | |] 565 | it "explicit_signed_char_pointer_array" $ 566 | matches [here| 567 | signed char *explicit_signed_char_pointer_array[10]; 568 | |] [here| 569 | #globalarray explicit_signed_char_pointer_array , Ptr CSChar 570 | |] 571 | it "unsigned_char_pointer_array" $ 572 | matches [here| 573 | unsigned char *unsigned_char_pointer_array[10]; 574 | |] [here| 575 | #globalarray unsigned_char_pointer_array , Ptr CUChar 576 | |] 577 | describe "short" $ do 578 | it "ordinary_signed_short_pointer_array" $ 579 | matches [here| 580 | short *ordinary_signed_short_pointer_array[10]; 581 | |] [here| 582 | #globalarray ordinary_signed_short_pointer_array , Ptr CShort 583 | |] 584 | it "explicit_signed_short_pointer_array" $ 585 | matches [here| 586 | signed short *explicit_signed_short_pointer_array[10]; 587 | |] [here| 588 | #globalarray explicit_signed_short_pointer_array , Ptr CShort 589 | |] 590 | it "unsigned_short_pointer_array" $ 591 | matches [here| 592 | unsigned short *unsigned_short_pointer_array[10]; 593 | |] [here| 594 | #globalarray unsigned_short_pointer_array , Ptr CUShort 595 | |] 596 | describe "int" $ do 597 | it "ordinary_signed_int_pointer_array" $ 598 | matches [here| 599 | int* ordinary_signed_int_pointer_array[10]; 600 | |] [here| 601 | #globalarray ordinary_signed_int_pointer_array , Ptr CInt 602 | |] 603 | it "explicit_signed_int_pointer_array" $ 604 | matches [here| 605 | signed int* explicit_signed_int_pointer_array[10]; 606 | |] [here| 607 | #globalarray explicit_signed_int_pointer_array , Ptr CInt 608 | |] 609 | it "unsigned_int_pointer_array" $ 610 | matches [here| 611 | unsigned int* unsigned_int_pointer_array[10]; 612 | |] [here| 613 | #globalarray unsigned_int_pointer_array , Ptr CUInt 614 | |] 615 | describe "long" $ do 616 | it "ordinary_signed_long_pointer_array" $ 617 | matches [here| 618 | long *ordinary_signed_long_pointer_array[10]; 619 | |] [here| 620 | #globalarray ordinary_signed_long_pointer_array , Ptr CLong 621 | |] 622 | it "explicit_signed_long_pointer_array" $ 623 | matches [here| 624 | signed long *explicit_signed_long_pointer_array[10]; 625 | |] [here| 626 | #globalarray explicit_signed_long_pointer_array , Ptr CLong 627 | |] 628 | it "unsigned_long_pointer_array" $ 629 | matches [here| 630 | unsigned long *unsigned_long_pointer_array[10]; 631 | |] [here| 632 | #globalarray unsigned_long_pointer_array , Ptr CULong 633 | |] 634 | describe "long long" $ do 635 | it "ordinary_signed_long_long_pointer_array" $ 636 | matches [here| 637 | long long* ordinary_signed_long_long_pointer_array[10]; 638 | |] [here| 639 | #globalarray ordinary_signed_long_long_pointer_array , Ptr CLLong 640 | |] 641 | it "explicit_signed_long_long_pointer_array" $ 642 | matches [here| 643 | signed long long* explicit_signed_long_long_pointer_array[10]; 644 | |] [here| 645 | #globalarray explicit_signed_long_long_pointer_array , Ptr CLLong 646 | |] 647 | it "unsigned_long_long_pointer_array" $ 648 | matches [here| 649 | unsigned long long* unsigned_long_long_pointer_array[10]; 650 | |] [here| 651 | #globalarray unsigned_long_long_pointer_array , Ptr CULLong 652 | |] 653 | 654 | describe "structs" $ do 655 | describe "primitive types which cannot be signed" $ do 656 | it "ordinary_float_struct" $ 657 | matches [here| 658 | struct ordinary_float_struct {float ordinary_float_member;}; 659 | |] [here| 660 | {- struct ordinary_float_struct { 661 | float ordinary_float_member; 662 | }; -} 663 | #starttype struct ordinary_float_struct 664 | #field ordinary_float_member , CFloat 665 | #stoptype 666 | |] 667 | it "ordinary_double_struct" $ 668 | matches [here| 669 | struct ordinary_double_struct {double ordinary_double_member;}; 670 | |] [here| 671 | {- struct ordinary_double_struct { 672 | double ordinary_double_member; 673 | }; -} 674 | #starttype struct ordinary_double_struct 675 | #field ordinary_double_member , CDouble 676 | #stoptype 677 | |] 678 | it "ordinary_long_double_struct" $ 679 | matches [here| 680 | struct ordinary_long_double_struct {long double ordinary_long_double_member;}; 681 | |] [here| 682 | {- struct ordinary_long_double_struct { 683 | long double ordinary_long_double_member; 684 | }; -} 685 | #starttype struct ordinary_long_double_struct 686 | #field ordinary_long_double_member , CDouble 687 | #stoptype 688 | |] 689 | describe "types which can be signed" $ do 690 | describe "char" $ do 691 | it "ordinary_signed_char_struct" $ 692 | matches [here| 693 | struct ordinary_signed_char_struct {char ordinary_signed_char_member;}; 694 | |] [here| 695 | {- struct ordinary_signed_char_struct { 696 | char ordinary_signed_char_member; 697 | }; -} 698 | #starttype struct ordinary_signed_char_struct 699 | #field ordinary_signed_char_member , CChar 700 | #stoptype 701 | |] 702 | it "explicit_signed_char_struct" $ 703 | matches [here| 704 | struct explicit_signed_char_struct {signed char explicit_signed_char_member;}; 705 | |] [here| 706 | {- struct explicit_signed_char_struct { 707 | signed char explicit_signed_char_member; 708 | }; -} 709 | #starttype struct explicit_signed_char_struct 710 | #field explicit_signed_char_member , CSChar 711 | #stoptype 712 | |] 713 | it "unsigned_char_struct" $ 714 | matches [here| 715 | struct unsigned_char_struct {unsigned char unsigned_char_member;}; 716 | |] [here| 717 | {- struct unsigned_char_struct { 718 | unsigned char unsigned_char_member; 719 | }; -} 720 | #starttype struct unsigned_char_struct 721 | #field unsigned_char_member , CUChar 722 | #stoptype 723 | |] 724 | describe "short" $ do 725 | it "ordinary_signed_short_struct" $ 726 | matches [here| 727 | struct ordinary_signed_short_struct {short ordinary_signed_short_member;}; 728 | |] [here| 729 | {- struct ordinary_signed_short_struct { 730 | short ordinary_signed_short_member; 731 | }; -} 732 | #starttype struct ordinary_signed_short_struct 733 | #field ordinary_signed_short_member , CShort 734 | #stoptype 735 | |] 736 | it "explicit_signed_short_struct" $ 737 | matches [here| 738 | struct explicit_signed_short_struct {signed short explicit_signed_short_member;}; 739 | |] [here| 740 | {- struct explicit_signed_short_struct { 741 | signed short explicit_signed_short_member; 742 | }; -} 743 | #starttype struct explicit_signed_short_struct 744 | #field explicit_signed_short_member , CShort 745 | #stoptype 746 | |] 747 | it "unsigned_short_struct" $ 748 | matches [here| 749 | struct unsigned_short_struct {unsigned short unsigned_short_member;}; 750 | |] [here| 751 | {- struct unsigned_short_struct { 752 | unsigned short unsigned_short_member; 753 | }; -} 754 | #starttype struct unsigned_short_struct 755 | #field unsigned_short_member , CUShort 756 | #stoptype 757 | |] 758 | describe "int" $ do 759 | it "ordinary_signed_int_struct" $ 760 | matches [here| 761 | struct ordinary_signed_int_struct {int ordinary_signed_int_member;}; 762 | |] [here| 763 | {- struct ordinary_signed_int_struct { 764 | int ordinary_signed_int_member; 765 | }; -} 766 | #starttype struct ordinary_signed_int_struct 767 | #field ordinary_signed_int_member , CInt 768 | #stoptype 769 | |] 770 | it "explicit_signed_int_struct" $ 771 | matches [here| 772 | struct explicit_signed_int_struct {signed int explicit_signed_int_member;}; 773 | |] [here| 774 | {- struct explicit_signed_int_struct { 775 | signed int explicit_signed_int_member; 776 | }; -} 777 | #starttype struct explicit_signed_int_struct 778 | #field explicit_signed_int_member , CInt 779 | #stoptype 780 | |] 781 | it "unsigned_int_struct" $ 782 | matches [here| 783 | struct unsigned_int_struct {unsigned int unsigned_int_member;}; 784 | |] [here| 785 | {- struct unsigned_int_struct { 786 | unsigned int unsigned_int_member; 787 | }; -} 788 | #starttype struct unsigned_int_struct 789 | #field unsigned_int_member , CUInt 790 | #stoptype 791 | |] 792 | describe "long" $ do 793 | it "ordinary_signed_long_struct" $ 794 | matches [here| 795 | struct ordinary_signed_long_struct {long ordinary_signed_long_member;}; 796 | |] [here| 797 | {- struct ordinary_signed_long_struct { 798 | long ordinary_signed_long_member; 799 | }; -} 800 | #starttype struct ordinary_signed_long_struct 801 | #field ordinary_signed_long_member , CLong 802 | #stoptype 803 | |] 804 | it "explicit_signed_long_struct" $ 805 | matches [here| 806 | struct explicit_signed_long_struct {signed long explicit_signed_long_member;}; 807 | |] [here| 808 | {- struct explicit_signed_long_struct { 809 | signed long explicit_signed_long_member; 810 | }; -} 811 | #starttype struct explicit_signed_long_struct 812 | #field explicit_signed_long_member , CLong 813 | #stoptype 814 | |] 815 | it "unsigned_long_struct" $ 816 | matches [here| 817 | struct unsigned_long_struct {unsigned long unsigned_long_member;}; 818 | |] [here| 819 | {- struct unsigned_long_struct { 820 | unsigned long unsigned_long_member; 821 | }; -} 822 | #starttype struct unsigned_long_struct 823 | #field unsigned_long_member , CULong 824 | #stoptype 825 | |] 826 | describe "long long" $ do 827 | it "ordinary_signed_long_long_struct" $ 828 | matches [here| 829 | struct ordinary_signed_long_long_struct {long long ordinary_signed_long_long_member;}; 830 | |] [here| 831 | {- struct ordinary_signed_long_long_struct { 832 | long long ordinary_signed_long_long_member; 833 | }; -} 834 | #starttype struct ordinary_signed_long_long_struct 835 | #field ordinary_signed_long_long_member , CLLong 836 | #stoptype 837 | |] 838 | it "explicit_signed_long_long_struct" $ 839 | matches [here| 840 | struct explicit_signed_long_long_struct {signed long long explicit_signed_long_long_member;}; 841 | |] [here| 842 | {- struct explicit_signed_long_long_struct { 843 | signed long long explicit_signed_long_long_member; 844 | }; -} 845 | #starttype struct explicit_signed_long_long_struct 846 | #field explicit_signed_long_long_member , CLLong 847 | #stoptype 848 | |] 849 | it "unsigned_long_long_struct" $ 850 | matches [here| 851 | struct unsigned_long_long_struct {unsigned long long unsigned_long_long_member;}; 852 | |] [here| 853 | {- struct unsigned_long_long_struct { 854 | unsigned long long unsigned_long_long_member; 855 | }; -} 856 | #starttype struct unsigned_long_long_struct 857 | #field unsigned_long_long_member , CULLong 858 | #stoptype 859 | |] 860 | describe "pointers" $ do 861 | describe "primitive types which cannot be signed" $ do 862 | it "ordinary_void_pointer_struct" $ 863 | matches [here| 864 | struct ordinary_void_pointer_struct {void* ordinary_void_pointer_member;}; 865 | |] [here| 866 | {- struct ordinary_void_pointer_struct { 867 | void * ordinary_void_pointer_member; 868 | }; -} 869 | #starttype struct ordinary_void_pointer_struct 870 | #field ordinary_void_pointer_member , Ptr () 871 | #stoptype 872 | |] 873 | it "ordinary_float_pointer_struct" $ 874 | matches [here| 875 | struct ordinary_float_pointer_struct {float* ordinary_float_pointer_member;}; 876 | |] [here| 877 | {- struct ordinary_float_pointer_struct { 878 | float * ordinary_float_pointer_member; 879 | }; -} 880 | #starttype struct ordinary_float_pointer_struct 881 | #field ordinary_float_pointer_member , Ptr CFloat 882 | #stoptype 883 | |] 884 | it "ordinary_double_pointer_struct" $ 885 | matches [here| 886 | struct ordinary_double_pointer_struct {double* ordinary_double_pointer_member;}; 887 | |] [here| 888 | {- struct ordinary_double_pointer_struct { 889 | double * ordinary_double_pointer_member; 890 | }; -} 891 | #starttype struct ordinary_double_pointer_struct 892 | #field ordinary_double_pointer_member , Ptr CDouble 893 | #stoptype 894 | |] 895 | it "ordinary_long_double_pointer_struct" $ 896 | matches [here| 897 | struct ordinary_long_double_pointer_struct {long double* ordinary_long_double_pointer_member;}; 898 | |] [here| 899 | {- struct ordinary_long_double_pointer_struct { 900 | long double * ordinary_long_double_pointer_member; 901 | }; -} 902 | #starttype struct ordinary_long_double_pointer_struct 903 | #field ordinary_long_double_pointer_member , Ptr CDouble 904 | #stoptype 905 | |] 906 | describe "types which can be signed" $ do 907 | describe "char" $ do 908 | -- it "ordinary_signed_char_pointer_struct" $ 909 | -- matches [here| 910 | -- struct ordinary_signed_char_pointer_struct {char *ordinary_signed_char_pointer_member;}; 911 | -- |] [here| 912 | -- {- struct ordinary_signed_char_pointer_struct { 913 | -- char * ordinary_signed_char_pointer_member; 914 | -- }; -} 915 | -- #starttype struct ordinary_signed_char_pointer_struct 916 | -- #field ordinary_signed_char_pointer_member , Ptr CString 917 | -- #stoptype 918 | -- |] 919 | it "explicit_signed_char_pointer_struct" $ 920 | matches [here| 921 | struct explicit_signed_char_pointer_struct {signed char *explicit_signed_char_pointer_member;}; 922 | |] [here| 923 | {- struct explicit_signed_char_pointer_struct { 924 | signed char * explicit_signed_char_pointer_member; 925 | }; -} 926 | #starttype struct explicit_signed_char_pointer_struct 927 | #field explicit_signed_char_pointer_member , Ptr CSChar 928 | #stoptype 929 | |] 930 | it "unsigned_char_pointer_struct" $ 931 | matches [here| 932 | struct unsigned_char_pointer_struct {unsigned char *unsigned_char_pointer_member;}; 933 | |] [here| 934 | {- struct unsigned_char_pointer_struct { 935 | unsigned char * unsigned_char_pointer_member; 936 | }; -} 937 | #starttype struct unsigned_char_pointer_struct 938 | #field unsigned_char_pointer_member , Ptr CUChar 939 | #stoptype 940 | |] 941 | describe "short" $ do 942 | it "ordinary_signed_short_pointer_struct" $ 943 | matches [here| 944 | struct ordinary_signed_short_pointer_struct {short *ordinary_signed_short_pointer_member;}; 945 | |] [here| 946 | {- struct ordinary_signed_short_pointer_struct { 947 | short * ordinary_signed_short_pointer_member; 948 | }; -} 949 | #starttype struct ordinary_signed_short_pointer_struct 950 | #field ordinary_signed_short_pointer_member , Ptr CShort 951 | #stoptype 952 | |] 953 | it "explicit_signed_short_pointer_struct" $ 954 | matches [here| 955 | struct explicit_signed_short_pointer_struct {signed short *explicit_signed_short_pointer_member;}; 956 | |] [here| 957 | {- struct explicit_signed_short_pointer_struct { 958 | signed short * explicit_signed_short_pointer_member; 959 | }; -} 960 | #starttype struct explicit_signed_short_pointer_struct 961 | #field explicit_signed_short_pointer_member , Ptr CShort 962 | #stoptype 963 | |] 964 | it "unsigned_short_pointer_struct" $ 965 | matches [here| 966 | struct unsigned_short_pointer_struct {unsigned short *unsigned_short_pointer_member;}; 967 | |] [here| 968 | {- struct unsigned_short_pointer_struct { 969 | unsigned short * unsigned_short_pointer_member; 970 | }; -} 971 | #starttype struct unsigned_short_pointer_struct 972 | #field unsigned_short_pointer_member , Ptr CUShort 973 | #stoptype 974 | |] 975 | describe "int" $ do 976 | it "ordinary_signed_int_pointer_struct" $ 977 | matches [here| 978 | struct ordinary_signed_int_pointer_struct {int* ordinary_signed_int_pointer_member;}; 979 | |] [here| 980 | {- struct ordinary_signed_int_pointer_struct { 981 | int * ordinary_signed_int_pointer_member; 982 | }; -} 983 | #starttype struct ordinary_signed_int_pointer_struct 984 | #field ordinary_signed_int_pointer_member , Ptr CInt 985 | #stoptype 986 | |] 987 | it "explicit_signed_int_pointer_struct" $ 988 | matches [here| 989 | struct explicit_signed_int_pointer_struct {signed int* explicit_signed_int_pointer_member;}; 990 | |] [here| 991 | {- struct explicit_signed_int_pointer_struct { 992 | signed int * explicit_signed_int_pointer_member; 993 | }; -} 994 | #starttype struct explicit_signed_int_pointer_struct 995 | #field explicit_signed_int_pointer_member , Ptr CInt 996 | #stoptype 997 | |] 998 | it "unsigned_int_pointer_struct" $ 999 | matches [here| 1000 | struct unsigned_int_pointer_struct {unsigned int* unsigned_int_pointer_member;}; 1001 | |] [here| 1002 | {- struct unsigned_int_pointer_struct { 1003 | unsigned int * unsigned_int_pointer_member; 1004 | }; -} 1005 | #starttype struct unsigned_int_pointer_struct 1006 | #field unsigned_int_pointer_member , Ptr CUInt 1007 | #stoptype 1008 | |] 1009 | describe "long" $ do 1010 | it "ordinary_signed_long_pointer_struct" $ 1011 | matches [here| 1012 | struct ordinary_signed_long_pointer_struct {long *ordinary_signed_long_pointer_member;}; 1013 | |] [here| 1014 | {- struct ordinary_signed_long_pointer_struct { 1015 | long * ordinary_signed_long_pointer_member; 1016 | }; -} 1017 | #starttype struct ordinary_signed_long_pointer_struct 1018 | #field ordinary_signed_long_pointer_member , Ptr CLong 1019 | #stoptype 1020 | |] 1021 | it "explicit_signed_long_pointer_struct" $ 1022 | matches [here| 1023 | struct explicit_signed_long_pointer_struct {signed long *explicit_signed_long_pointer_member;}; 1024 | |] [here| 1025 | {- struct explicit_signed_long_pointer_struct { 1026 | signed long * explicit_signed_long_pointer_member; 1027 | }; -} 1028 | #starttype struct explicit_signed_long_pointer_struct 1029 | #field explicit_signed_long_pointer_member , Ptr CLong 1030 | #stoptype 1031 | |] 1032 | it "unsigned_long_pointer_struct" $ 1033 | matches [here| 1034 | struct unsigned_long_pointer_struct {unsigned long *unsigned_long_pointer_member;}; 1035 | |] [here| 1036 | {- struct unsigned_long_pointer_struct { 1037 | unsigned long * unsigned_long_pointer_member; 1038 | }; -} 1039 | #starttype struct unsigned_long_pointer_struct 1040 | #field unsigned_long_pointer_member , Ptr CULong 1041 | #stoptype 1042 | |] 1043 | describe "long long" $ do 1044 | it "ordinary_signed_long_long_pointer_struct" $ 1045 | matches [here| 1046 | struct ordinary_signed_long_long_pointer_struct {long long* ordinary_signed_long_long_pointer_member;}; 1047 | |] [here| 1048 | {- struct ordinary_signed_long_long_pointer_struct { 1049 | long long * ordinary_signed_long_long_pointer_member; 1050 | }; -} 1051 | #starttype struct ordinary_signed_long_long_pointer_struct 1052 | #field ordinary_signed_long_long_pointer_member , Ptr CLLong 1053 | #stoptype 1054 | |] 1055 | it "explicit_signed_long_long_pointer_struct" $ 1056 | matches [here| 1057 | struct explicit_signed_long_long_pointer_struct {signed long long* explicit_signed_long_long_pointer_member;}; 1058 | |] [here| 1059 | {- struct explicit_signed_long_long_pointer_struct { 1060 | signed long long * explicit_signed_long_long_pointer_member; 1061 | }; -} 1062 | #starttype struct explicit_signed_long_long_pointer_struct 1063 | #field explicit_signed_long_long_pointer_member , Ptr CLLong 1064 | #stoptype 1065 | |] 1066 | it "unsigned_long_long_pointer_struct" $ 1067 | matches [here| 1068 | struct unsigned_long_long_pointer_struct {unsigned long long* unsigned_long_long_pointer_member;}; 1069 | |] [here| 1070 | {- struct unsigned_long_long_pointer_struct { 1071 | unsigned long long * unsigned_long_long_pointer_member; 1072 | }; -} 1073 | #starttype struct unsigned_long_long_pointer_struct 1074 | #field unsigned_long_long_pointer_member , Ptr CULLong 1075 | #stoptype 1076 | |] 1077 | describe "arrays" $ do 1078 | describe "primitive types which cannot be signed" $ do 1079 | it "ordinary_float_array_struct" $ 1080 | matches [here| 1081 | struct ordinary_float_array_struct {float ordinary_float_array_member[10];}; 1082 | |] [here| 1083 | {- struct ordinary_float_array_struct { 1084 | float ordinary_float_array_member[10]; 1085 | }; -} 1086 | #starttype struct ordinary_float_array_struct 1087 | #array_field ordinary_float_array_member , CFloat 1088 | #stoptype 1089 | |] 1090 | it "ordinary_double_array_struct" $ 1091 | matches [here| 1092 | struct ordinary_double_array_struct {double ordinary_double_array_member[10];}; 1093 | |] [here| 1094 | {- struct ordinary_double_array_struct { 1095 | double ordinary_double_array_member[10]; 1096 | }; -} 1097 | #starttype struct ordinary_double_array_struct 1098 | #array_field ordinary_double_array_member , CDouble 1099 | #stoptype 1100 | |] 1101 | it "ordinary_long_double_array_struct" $ 1102 | matches [here| 1103 | struct ordinary_long_double_array_struct {long double ordinary_long_double_array_member[10];}; 1104 | |] [here| 1105 | {- struct ordinary_long_double_array_struct { 1106 | long double ordinary_long_double_array_member[10]; 1107 | }; -} 1108 | #starttype struct ordinary_long_double_array_struct 1109 | #array_field ordinary_long_double_array_member , CDouble 1110 | #stoptype 1111 | |] 1112 | describe "types which can be signed" $ do 1113 | describe "char" $ do 1114 | it "ordinary_signed_char_array_struct" $ 1115 | matches [here| 1116 | struct ordinary_signed_char_array_struct {char ordinary_signed_char_array_member[10];}; 1117 | |] [here| 1118 | {- struct ordinary_signed_char_array_struct { 1119 | char ordinary_signed_char_array_member[10]; 1120 | }; -} 1121 | #starttype struct ordinary_signed_char_array_struct 1122 | #array_field ordinary_signed_char_array_member , CChar 1123 | #stoptype 1124 | |] 1125 | it "explicit_signed_char_array_struct" $ 1126 | matches [here| 1127 | struct explicit_signed_char_array_struct {signed char explicit_signed_char_array_member[10];}; 1128 | |] [here| 1129 | {- struct explicit_signed_char_array_struct { 1130 | signed char explicit_signed_char_array_member[10]; 1131 | }; -} 1132 | #starttype struct explicit_signed_char_array_struct 1133 | #array_field explicit_signed_char_array_member , CSChar 1134 | #stoptype 1135 | |] 1136 | it "unsigned_char_array_struct" $ 1137 | matches [here| 1138 | struct unsigned_char_array_struct {unsigned char unsigned_char_array_member[10];}; 1139 | |] [here| 1140 | {- struct unsigned_char_array_struct { 1141 | unsigned char unsigned_char_array_member[10]; 1142 | }; -} 1143 | #starttype struct unsigned_char_array_struct 1144 | #array_field unsigned_char_array_member , CUChar 1145 | #stoptype 1146 | |] 1147 | describe "short" $ do 1148 | it "ordinary_signed_short_array_struct" $ 1149 | matches [here| 1150 | struct ordinary_signed_short_array_struct {short ordinary_signed_short_array_member[10];}; 1151 | |] [here| 1152 | {- struct ordinary_signed_short_array_struct { 1153 | short ordinary_signed_short_array_member[10]; 1154 | }; -} 1155 | #starttype struct ordinary_signed_short_array_struct 1156 | #array_field ordinary_signed_short_array_member , CShort 1157 | #stoptype 1158 | |] 1159 | it "explicit_signed_short_array_struct" $ 1160 | matches [here| 1161 | struct explicit_signed_short_array_struct {signed short explicit_signed_short_array_member[10];}; 1162 | |] [here| 1163 | {- struct explicit_signed_short_array_struct { 1164 | signed short explicit_signed_short_array_member[10]; 1165 | }; -} 1166 | #starttype struct explicit_signed_short_array_struct 1167 | #array_field explicit_signed_short_array_member , CShort 1168 | #stoptype 1169 | |] 1170 | it "unsigned_short_array_struct" $ 1171 | matches [here| 1172 | struct unsigned_short_array_struct {unsigned short unsigned_short_array_member[10];}; 1173 | |] [here| 1174 | {- struct unsigned_short_array_struct { 1175 | unsigned short unsigned_short_array_member[10]; 1176 | }; -} 1177 | #starttype struct unsigned_short_array_struct 1178 | #array_field unsigned_short_array_member , CUShort 1179 | #stoptype 1180 | |] 1181 | describe "int" $ do 1182 | it "ordinary_signed_int_array_struct" $ 1183 | matches [here| 1184 | struct ordinary_signed_int_array_struct {int ordinary_signed_int_array_member[10];}; 1185 | |] [here| 1186 | {- struct ordinary_signed_int_array_struct { 1187 | int ordinary_signed_int_array_member[10]; 1188 | }; -} 1189 | #starttype struct ordinary_signed_int_array_struct 1190 | #array_field ordinary_signed_int_array_member , CInt 1191 | #stoptype 1192 | |] 1193 | it "explicit_signed_int_array_struct" $ 1194 | matches [here| 1195 | struct explicit_signed_int_array_struct {signed int explicit_signed_int_array_member[10];}; 1196 | |] [here| 1197 | {- struct explicit_signed_int_array_struct { 1198 | signed int explicit_signed_int_array_member[10]; 1199 | }; -} 1200 | #starttype struct explicit_signed_int_array_struct 1201 | #array_field explicit_signed_int_array_member , CInt 1202 | #stoptype 1203 | |] 1204 | it "unsigned_int_array_struct" $ 1205 | matches [here| 1206 | struct unsigned_int_array_struct {unsigned int unsigned_int_array_member[10];}; 1207 | |] [here| 1208 | {- struct unsigned_int_array_struct { 1209 | unsigned int unsigned_int_array_member[10]; 1210 | }; -} 1211 | #starttype struct unsigned_int_array_struct 1212 | #array_field unsigned_int_array_member , CUInt 1213 | #stoptype 1214 | |] 1215 | describe "long" $ do 1216 | it "ordinary_signed_long_array_struct" $ 1217 | matches [here| 1218 | struct ordinary_signed_long_array_struct {long ordinary_signed_long_array_member[10];}; 1219 | |] [here| 1220 | {- struct ordinary_signed_long_array_struct { 1221 | long ordinary_signed_long_array_member[10]; 1222 | }; -} 1223 | #starttype struct ordinary_signed_long_array_struct 1224 | #array_field ordinary_signed_long_array_member , CLong 1225 | #stoptype 1226 | |] 1227 | it "explicit_signed_long_array_struct" $ 1228 | matches [here| 1229 | struct explicit_signed_long_array_struct {signed long explicit_signed_long_array_member[10];}; 1230 | |] [here| 1231 | {- struct explicit_signed_long_array_struct { 1232 | signed long explicit_signed_long_array_member[10]; 1233 | }; -} 1234 | #starttype struct explicit_signed_long_array_struct 1235 | #array_field explicit_signed_long_array_member , CLong 1236 | #stoptype 1237 | |] 1238 | it "unsigned_long_array_struct" $ 1239 | matches [here| 1240 | struct unsigned_long_array_struct {unsigned long unsigned_long_array_member[10];}; 1241 | |] [here| 1242 | {- struct unsigned_long_array_struct { 1243 | unsigned long unsigned_long_array_member[10]; 1244 | }; -} 1245 | #starttype struct unsigned_long_array_struct 1246 | #array_field unsigned_long_array_member , CULong 1247 | #stoptype 1248 | |] 1249 | describe "long long" $ do 1250 | it "ordinary_signed_long_long_array_struct" $ 1251 | matches [here| 1252 | struct ordinary_signed_long_long_array_struct {long long ordinary_signed_long_long_array_member[10];}; 1253 | |] [here| 1254 | {- struct ordinary_signed_long_long_array_struct { 1255 | long long ordinary_signed_long_long_array_member[10]; 1256 | }; -} 1257 | #starttype struct ordinary_signed_long_long_array_struct 1258 | #array_field ordinary_signed_long_long_array_member , CLLong 1259 | #stoptype 1260 | |] 1261 | it "explicit_signed_long_long_array_struct" $ 1262 | matches [here| 1263 | struct explicit_signed_long_long_array_struct {signed long long explicit_signed_long_long_array_member[10];}; 1264 | |] [here| 1265 | {- struct explicit_signed_long_long_array_struct { 1266 | signed long long explicit_signed_long_long_array_member[10]; 1267 | }; -} 1268 | #starttype struct explicit_signed_long_long_array_struct 1269 | #array_field explicit_signed_long_long_array_member , CLLong 1270 | #stoptype 1271 | |] 1272 | it "unsigned_long_long_array_struct" $ 1273 | matches [here| 1274 | struct unsigned_long_long_array_struct {unsigned long long unsigned_long_long_array_member[10];}; 1275 | |] [here| 1276 | {- struct unsigned_long_long_array_struct { 1277 | unsigned long long unsigned_long_long_array_member[10]; 1278 | }; -} 1279 | #starttype struct unsigned_long_long_array_struct 1280 | #array_field unsigned_long_long_array_member , CULLong 1281 | #stoptype 1282 | |] 1283 | describe "pointers" $ do 1284 | describe "primitive types which cannot be signed" $ do 1285 | it "ordinary_void_pointer_array_struct" $ 1286 | matches [here| 1287 | struct ordinary_void_pointer_array_struct {void* ordinary_void_pointer_array_member[10];}; 1288 | |] [here| 1289 | {- struct ordinary_void_pointer_array_struct { 1290 | void * ordinary_void_pointer_array_member[10]; 1291 | }; -} 1292 | #starttype struct ordinary_void_pointer_array_struct 1293 | #array_field ordinary_void_pointer_array_member , Ptr () 1294 | #stoptype 1295 | |] 1296 | it "ordinary_float_pointer_array_struct" $ 1297 | matches [here| 1298 | struct ordinary_float_pointer_array_struct {float* ordinary_float_pointer_array_member[10];}; 1299 | |] [here| 1300 | {- struct ordinary_float_pointer_array_struct { 1301 | float * ordinary_float_pointer_array_member[10]; 1302 | }; -} 1303 | #starttype struct ordinary_float_pointer_array_struct 1304 | #array_field ordinary_float_pointer_array_member , Ptr CFloat 1305 | #stoptype 1306 | |] 1307 | it "ordinary_double_pointer_array_struct" $ 1308 | matches [here| 1309 | struct ordinary_double_pointer_array_struct {double* ordinary_double_pointer_array_member[10];}; 1310 | |] [here| 1311 | {- struct ordinary_double_pointer_array_struct { 1312 | double * ordinary_double_pointer_array_member[10]; 1313 | }; -} 1314 | #starttype struct ordinary_double_pointer_array_struct 1315 | #array_field ordinary_double_pointer_array_member , Ptr CDouble 1316 | #stoptype 1317 | |] 1318 | it "ordinary_long_double_pointer_array_struct" $ 1319 | matches [here| 1320 | struct ordinary_long_double_pointer_array_struct {long double* ordinary_long_double_pointer_array_member[10];}; 1321 | |] [here| 1322 | {- struct ordinary_long_double_pointer_array_struct { 1323 | long double * ordinary_long_double_pointer_array_member[10]; 1324 | }; -} 1325 | #starttype struct ordinary_long_double_pointer_array_struct 1326 | #array_field ordinary_long_double_pointer_array_member , Ptr CDouble 1327 | #stoptype 1328 | |] 1329 | describe "types which can be signed" $ do 1330 | describe "char" $ do 1331 | -- it "ordinary_signed_char_pointer_array_struct" $ 1332 | -- matches [here| 1333 | -- struct ordinary_signed_char_pointer_array_struct {char *ordinary_signed_char_pointer_array_member[10];}; 1334 | -- |] [here| 1335 | -- {- struct ordinary_signed_char_pointer_array_struct { 1336 | -- char * ordinary_signed_char_pointer_array_member[10]; 1337 | -- }; -} 1338 | -- #starttype struct ordinary_signed_char_pointer_array_struct 1339 | -- #array_field ordinary_signed_char_pointer_array_member , Ptr CString 1340 | -- #stoptype 1341 | -- |] 1342 | it "explicit_signed_char_pointer_array_struct" $ 1343 | matches [here| 1344 | struct explicit_signed_char_pointer_array_struct {signed char *explicit_signed_char_pointer_array_member[10];}; 1345 | |] [here| 1346 | {- struct explicit_signed_char_pointer_array_struct { 1347 | signed char * explicit_signed_char_pointer_array_member[10]; 1348 | }; -} 1349 | #starttype struct explicit_signed_char_pointer_array_struct 1350 | #array_field explicit_signed_char_pointer_array_member , Ptr CSChar 1351 | #stoptype 1352 | |] 1353 | it "unsigned_char_pointer_array_struct" $ 1354 | matches [here| 1355 | struct unsigned_char_pointer_array_struct {unsigned char *unsigned_char_pointer_array_member[10];}; 1356 | |] [here| 1357 | {- struct unsigned_char_pointer_array_struct { 1358 | unsigned char * unsigned_char_pointer_array_member[10]; 1359 | }; -} 1360 | #starttype struct unsigned_char_pointer_array_struct 1361 | #array_field unsigned_char_pointer_array_member , Ptr CUChar 1362 | #stoptype 1363 | |] 1364 | describe "short" $ do 1365 | it "ordinary_signed_short_pointer_array_struct" $ 1366 | matches [here| 1367 | struct ordinary_signed_short_pointer_array_struct {short *ordinary_signed_short_pointer_array_member[10];}; 1368 | |] [here| 1369 | {- struct ordinary_signed_short_pointer_array_struct { 1370 | short * ordinary_signed_short_pointer_array_member[10]; 1371 | }; -} 1372 | #starttype struct ordinary_signed_short_pointer_array_struct 1373 | #array_field ordinary_signed_short_pointer_array_member , Ptr CShort 1374 | #stoptype 1375 | |] 1376 | it "explicit_signed_short_pointer_array_struct" $ 1377 | matches [here| 1378 | struct explicit_signed_short_pointer_array_struct {signed short *explicit_signed_short_pointer_array_member[10];}; 1379 | |] [here| 1380 | {- struct explicit_signed_short_pointer_array_struct { 1381 | signed short * explicit_signed_short_pointer_array_member[10]; 1382 | }; -} 1383 | #starttype struct explicit_signed_short_pointer_array_struct 1384 | #array_field explicit_signed_short_pointer_array_member , Ptr CShort 1385 | #stoptype 1386 | |] 1387 | it "unsigned_short_pointer_array_struct" $ 1388 | matches [here| 1389 | struct unsigned_short_pointer_array_struct {unsigned short *unsigned_short_pointer_array_member[10];}; 1390 | |] [here| 1391 | {- struct unsigned_short_pointer_array_struct { 1392 | unsigned short * unsigned_short_pointer_array_member[10]; 1393 | }; -} 1394 | #starttype struct unsigned_short_pointer_array_struct 1395 | #array_field unsigned_short_pointer_array_member , Ptr CUShort 1396 | #stoptype 1397 | |] 1398 | describe "int" $ do 1399 | it "ordinary_signed_int_pointer_array_struct" $ 1400 | matches [here| 1401 | struct ordinary_signed_int_pointer_array_struct {int* ordinary_signed_int_pointer_array_member[10];}; 1402 | |] [here| 1403 | {- struct ordinary_signed_int_pointer_array_struct { 1404 | int * ordinary_signed_int_pointer_array_member[10]; 1405 | }; -} 1406 | #starttype struct ordinary_signed_int_pointer_array_struct 1407 | #array_field ordinary_signed_int_pointer_array_member , Ptr CInt 1408 | #stoptype 1409 | |] 1410 | it "explicit_signed_int_pointer_array_struct" $ 1411 | matches [here| 1412 | struct explicit_signed_int_pointer_array_struct {signed int* explicit_signed_int_pointer_array_member[10];}; 1413 | |] [here| 1414 | {- struct explicit_signed_int_pointer_array_struct { 1415 | signed int * explicit_signed_int_pointer_array_member[10]; 1416 | }; -} 1417 | #starttype struct explicit_signed_int_pointer_array_struct 1418 | #array_field explicit_signed_int_pointer_array_member , Ptr CInt 1419 | #stoptype 1420 | |] 1421 | it "unsigned_int_pointer_array_struct" $ 1422 | matches [here| 1423 | struct unsigned_int_pointer_array_struct {unsigned int* unsigned_int_pointer_array_member[10];}; 1424 | |] [here| 1425 | {- struct unsigned_int_pointer_array_struct { 1426 | unsigned int * unsigned_int_pointer_array_member[10]; 1427 | }; -} 1428 | #starttype struct unsigned_int_pointer_array_struct 1429 | #array_field unsigned_int_pointer_array_member , Ptr CUInt 1430 | #stoptype 1431 | |] 1432 | describe "long" $ do 1433 | it "ordinary_signed_long_pointer_array_struct" $ 1434 | matches [here| 1435 | struct ordinary_signed_long_pointer_array_struct {long *ordinary_signed_long_pointer_array_member[10];}; 1436 | |] [here| 1437 | {- struct ordinary_signed_long_pointer_array_struct { 1438 | long * ordinary_signed_long_pointer_array_member[10]; 1439 | }; -} 1440 | #starttype struct ordinary_signed_long_pointer_array_struct 1441 | #array_field ordinary_signed_long_pointer_array_member , Ptr CLong 1442 | #stoptype 1443 | |] 1444 | it "explicit_signed_long_pointer_array_struct" $ 1445 | matches [here| 1446 | struct explicit_signed_long_pointer_array_struct {signed long *explicit_signed_long_pointer_array_member[10];}; 1447 | |] [here| 1448 | {- struct explicit_signed_long_pointer_array_struct { 1449 | signed long * explicit_signed_long_pointer_array_member[10]; 1450 | }; -} 1451 | #starttype struct explicit_signed_long_pointer_array_struct 1452 | #array_field explicit_signed_long_pointer_array_member , Ptr CLong 1453 | #stoptype 1454 | |] 1455 | it "unsigned_long_pointer_array_struct" $ 1456 | matches [here| 1457 | struct unsigned_long_pointer_array_struct {unsigned long *unsigned_long_pointer_array_member[10];}; 1458 | |] [here| 1459 | {- struct unsigned_long_pointer_array_struct { 1460 | unsigned long * unsigned_long_pointer_array_member[10]; 1461 | }; -} 1462 | #starttype struct unsigned_long_pointer_array_struct 1463 | #array_field unsigned_long_pointer_array_member , Ptr CULong 1464 | #stoptype 1465 | |] 1466 | describe "long long" $ do 1467 | it "ordinary_signed_long_long_pointer_array_struct" $ 1468 | matches [here| 1469 | struct ordinary_signed_long_long_pointer_array_struct {long long* ordinary_signed_long_long_pointer_array_member[10];}; 1470 | |] [here| 1471 | {- struct ordinary_signed_long_long_pointer_array_struct { 1472 | long long * ordinary_signed_long_long_pointer_array_member[10]; 1473 | }; -} 1474 | #starttype struct ordinary_signed_long_long_pointer_array_struct 1475 | #array_field ordinary_signed_long_long_pointer_array_member , Ptr CLLong 1476 | #stoptype 1477 | |] 1478 | it "explicit_signed_long_long_pointer_array_struct" $ 1479 | matches [here| 1480 | struct explicit_signed_long_long_pointer_array_struct {signed long long* explicit_signed_long_long_pointer_array_member[10];}; 1481 | |] [here| 1482 | {- struct explicit_signed_long_long_pointer_array_struct { 1483 | signed long long * explicit_signed_long_long_pointer_array_member[10]; 1484 | }; -} 1485 | #starttype struct explicit_signed_long_long_pointer_array_struct 1486 | #array_field explicit_signed_long_long_pointer_array_member , Ptr CLLong 1487 | #stoptype 1488 | |] 1489 | it "unsigned_long_long_pointer_array_struct" $ 1490 | matches [here| 1491 | struct unsigned_long_long_pointer_array_struct {unsigned long long* unsigned_long_long_pointer_array_member[10];}; 1492 | |] [here| 1493 | {- struct unsigned_long_long_pointer_array_struct { 1494 | unsigned long long * unsigned_long_long_pointer_array_member[10]; 1495 | }; -} 1496 | #starttype struct unsigned_long_long_pointer_array_struct 1497 | #array_field unsigned_long_long_pointer_array_member , Ptr CULLong 1498 | #stoptype 1499 | |] 1500 | 1501 | describe "sanity check" $ do 1502 | it "maps a typedef" $ 1503 | matches [here| 1504 | typedef int an_int; 1505 | |] [here| 1506 | {- typedef int an_int; -} 1507 | #synonym_t an_int , CInt 1508 | |] 1509 | 1510 | it "processes smoke.h" $ 1511 | matches [here| 1512 | typedef unsigned int uint; 1513 | typedef unsigned long size_t; 1514 | 1515 | void foo1(void); 1516 | void foo2(int); 1517 | void foo3(int, int); 1518 | int foo4(void); 1519 | char foo5(int); 1520 | char * foo6(int, int); 1521 | char * foo7(char *); 1522 | char * foo8(char * b); 1523 | char * foo9(char * (*b)(void)); 1524 | char * foo10(char * (*b)(int)); 1525 | void * foo11(void * (*b)(void)); 1526 | void * foo12(void * (*b)(int)); 1527 | char * foo13(char []); 1528 | char * foo14(char b[]); 1529 | char * foo15(char b[5]); 1530 | char * foo16(int); 1531 | int foo17(char ***); 1532 | int foo18(unsigned); 1533 | int foo19(unsigned int); 1534 | int foo20(uint); 1535 | int foo21(int (*)(int)); 1536 | int foo22(int *(*)(int)); 1537 | int foo23(int **(*)(int)); 1538 | int foo24(int ***(*)(int)); 1539 | int * foo25(int); 1540 | int ** foo26(int); 1541 | int *** foo27(int); 1542 | int *** foo28(size_t); 1543 | 1544 | struct bar1_t { 1545 | void * a; 1546 | int b; 1547 | char c; 1548 | char * d; 1549 | char * (*e)(void); 1550 | void (*f)(void *); 1551 | int * (*g)(void *); 1552 | int ** (*h)(void *); 1553 | int *** (*i)(void *); 1554 | char j[2]; 1555 | 1556 | struct bar1_t * k; 1557 | }; 1558 | 1559 | typedef struct bar2_t { 1560 | int a; 1561 | } bar2_t; 1562 | 1563 | typedef struct { 1564 | int a; 1565 | } bar3_t; 1566 | 1567 | enum { 1568 | BAZ1 = 1 1569 | }; 1570 | 1571 | typedef enum { 1572 | BAZ2 = 1 1573 | } baz2_t; 1574 | 1575 | enum baz3_t { 1576 | BAZ3 = 1 1577 | }; 1578 | 1579 | typedef enum baz4_t { 1580 | BAZ4 = 1 1581 | } baz4_t; 1582 | 1583 | extern int global; 1584 | 1585 | inline int inline_foo(int a, int * b, const int c, const int * d, 1586 | const int ** e, const int * const * f, size_t g) { 1587 | return 10; 1588 | } 1589 | |] [here| 1590 | {- typedef unsigned int uint; -} 1591 | #synonym_t uint , CUInt 1592 | {- typedef unsigned long size_t; -} 1593 | #synonym_t size_t , CULong 1594 | #ccall foo1 , IO () 1595 | #ccall foo2 , CInt -> IO () 1596 | #ccall foo3 , CInt -> CInt -> IO () 1597 | #ccall foo4 , IO CInt 1598 | #ccall foo5 , CInt -> IO CChar 1599 | #ccall foo6 , CInt -> CInt -> IO CString 1600 | #ccall foo7 , CString -> IO CString 1601 | #ccall foo8 , CString -> IO CString 1602 | #ccall foo9 , FunPtr CString -> IO CString 1603 | #ccall foo10 , FunPtr (CInt -> CString) -> IO CString 1604 | #ccall foo11 , FunPtr (Ptr ()) -> IO (Ptr ()) 1605 | #ccall foo12 , FunPtr (CInt -> Ptr ()) -> IO (Ptr ()) 1606 | #ccall foo13 , Ptr CChar -> IO CString 1607 | #ccall foo14 , Ptr CChar -> IO CString 1608 | #ccall foo15 , Ptr CChar -> IO CString 1609 | #ccall foo16 , CInt -> IO CString 1610 | #ccall foo17 , Ptr (Ptr CString) -> IO CInt 1611 | #ccall foo18 , CUInt -> IO CInt 1612 | #ccall foo19 , CUInt -> IO CInt 1613 | #ccall foo20 , CUInt -> IO CInt 1614 | #ccall foo21 , FunPtr (CInt -> CInt) -> IO CInt 1615 | #ccall foo22 , FunPtr (CInt -> Ptr CInt) -> IO CInt 1616 | #ccall foo23 , FunPtr (CInt -> Ptr (Ptr CInt)) -> IO CInt 1617 | #ccall foo24 , FunPtr (CInt -> Ptr (Ptr (Ptr CInt))) -> IO CInt 1618 | #ccall foo25 , CInt -> IO (Ptr CInt) 1619 | #ccall foo26 , CInt -> IO (Ptr (Ptr CInt)) 1620 | #ccall foo27 , CInt -> IO (Ptr (Ptr (Ptr CInt))) 1621 | #ccall foo28 , CSize -> IO (Ptr (Ptr (Ptr CInt))) 1622 | {- struct bar1_t { 1623 | void * a; 1624 | int b; 1625 | char c; 1626 | char * d; 1627 | char * (* e)(void); 1628 | void (* f)(void *); 1629 | int * (* g)(void *); 1630 | int * * (* h)(void *); 1631 | int * * * (* i)(void *); 1632 | char j[2]; 1633 | struct bar1_t * k; 1634 | }; -} 1635 | #starttype struct bar1_t 1636 | #field a , Ptr () 1637 | #field b , CInt 1638 | #field c , CChar 1639 | #field d , CString 1640 | #field e , FunPtr CString 1641 | #field f , FunPtr (Ptr () -> IO ()) 1642 | #field g , FunPtr (Ptr () -> Ptr CInt) 1643 | #field h , FunPtr (Ptr () -> Ptr (Ptr CInt)) 1644 | #field i , FunPtr (Ptr () -> Ptr (Ptr (Ptr CInt))) 1645 | #array_field j , CChar 1646 | #field k , Ptr 1647 | #stoptype 1648 | {- typedef struct bar2_t { 1649 | int a; 1650 | } bar2_t; -} 1651 | #starttype struct bar2_t 1652 | #field a , CInt 1653 | #stoptype 1654 | #synonym_t bar2_t , 1655 | {- typedef struct { 1656 | int a; 1657 | } bar3_t; -} 1658 | #starttype bar3_t 1659 | #field a , CInt 1660 | #stoptype 1661 | {- enum { 1662 | BAZ1 = 1 1663 | }; -} 1664 | #num BAZ1 1665 | {- typedef enum { 1666 | BAZ2 = 1 1667 | } baz2_t; -} 1668 | #integral_t baz2_t 1669 | #num BAZ2 1670 | {- enum baz3_t { 1671 | BAZ3 = 1 1672 | }; -} 1673 | #integral_t enum baz3_t 1674 | #num BAZ3 1675 | {- typedef enum baz4_t { 1676 | BAZ4 = 1 1677 | } baz4_t; -} 1678 | #integral_t enum baz4_t 1679 | #num BAZ4 1680 | #synonym_t baz4_t , 1681 | #globalvar global , CInt 1682 | #cinline inline_foo , CInt -> Ptr CInt -> CInt -> Ptr CInt -> Ptr (Ptr CInt) -> Ptr (Ptr CInt) -> CSize -> IO CInt 1683 | #include 1684 | 1685 | BC_INLINE7(inline_foo, int, int*, const int, const int*, const int**, const int* const*, size_t, int) 1686 | |] 1687 | 1688 | matches :: String -> String -> IO () 1689 | matches input output = do 1690 | res <- processString input 1691 | trim res `shouldBe` output 1692 | 1693 | tshow :: String -> Text 1694 | tshow = pack . show 1695 | 1696 | trim :: String -> String 1697 | trim = trimTail . dropWhile isSpace 1698 | 1699 | trimTail :: String -> String 1700 | trimTail "" = "" 1701 | trimTail s = take (lastNonBlank s) s 1702 | where lastNonBlank = (+1) . fst . foldl acc (0, 0) 1703 | acc (l, n) c | isSpace c = (l, n + 1) 1704 | | otherwise = (n, n + 1) 1705 | --------------------------------------------------------------------------------