inline-c-0.9.1.10/examples/0000755000000000000000000000000014504254724013451 5ustar0000000000000000inline-c-0.9.1.10/src/0000755000000000000000000000000014503767417012431 5ustar0000000000000000inline-c-0.9.1.10/src/Language/0000755000000000000000000000000014503767417014154 5ustar0000000000000000inline-c-0.9.1.10/src/Language/C/0000755000000000000000000000000014505621771014330 5ustar0000000000000000inline-c-0.9.1.10/src/Language/C/Inline/0000755000000000000000000000000014505625044015543 5ustar0000000000000000inline-c-0.9.1.10/src/Language/C/Types/0000755000000000000000000000000014503767417015442 5ustar0000000000000000inline-c-0.9.1.10/test/0000755000000000000000000000000014503767417012621 5ustar0000000000000000inline-c-0.9.1.10/test/Language/0000755000000000000000000000000014503767417014344 5ustar0000000000000000inline-c-0.9.1.10/test/Language/C/0000755000000000000000000000000014503767417014526 5ustar0000000000000000inline-c-0.9.1.10/test/Language/C/Inline/0000755000000000000000000000000014503767417015744 5ustar0000000000000000inline-c-0.9.1.10/test/Language/C/Types/0000755000000000000000000000000014503767417015632 5ustar0000000000000000inline-c-0.9.1.10/src/Language/C/Inline.hs0000644000000000000000000003203614505621771016106 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- | Enable painless embedding of C code in Haskell code. If you're interested -- in how to use the library, skip to the "Inline C" section. To build, read the -- first two sections. -- -- This module is intended to be imported qualified: -- -- @ -- import qualified "Language.C.Inline" as C -- @ module Language.C.Inline ( -- * GHCi -- $building -- * Contexts Context , baseCtx , fptrCtx , funCtx , vecCtx , bsCtx , context -- * Substitution , substitute , getHaskellType -- * Inline C -- $quoting , exp , pure , block , include , verbatim , emitBlock -- * 'Ptr' utils , withPtr , withPtr_ , WithPtrs(..) -- * 'FunPtr' utils , funPtr -- ** 'FunPtr' conversion -- -- Functions to quickly convert from/to 'FunPtr's. They're provided here -- since they can be useful to work with Haskell functions in C, and -- vice-versa. However, consider using 'funCtx' if you're doing this -- a lot. , mkFunPtr , mkFunPtrFromName , peekFunPtr -- * C types re-exports -- -- Re-export these to avoid errors when `inline-c` generates FFI calls GHC -- needs the constructors for those types. , module Foreign.C.Types ) where #if __GLASGOW_HASKELL__ < 710 import Prelude hiding (exp) #else import Prelude hiding (exp, pure) #endif import Control.Monad (void) import Foreign.C.Types import Foreign.Marshal.Alloc (alloca) import Foreign.Ptr (Ptr) import Foreign.Storable (peek, Storable) import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as TH import Language.C.Inline.Context import Language.C.Inline.Internal import Language.C.Inline.FunPtr -- $building -- -- Currently @inline-c@ does not work in interpreted mode. However, GHCi -- can still be used using the @-fobject-code@ flag. For speed, we -- reccomend passing @-fobject-code -O0@, for example -- -- @ -- stack ghci --ghci-options='-fobject-code -O0' -- @ -- -- or -- -- @ -- cabal repl --ghc-options='-fobject-code -O0' -- @ ------------------------------------------------------------------------ -- Quoting sugar -- $quoting -- -- The quasiquoters below are the main interface to this library, for inlining -- C code into Haskell source files. -- -- In general, quasiquoters are used like so: -- -- @ -- [C.XXX| int { \ } |] -- @ -- -- Where @C.XXX@ is one of the quasi-quoters defined in this section. -- -- This syntax stands for a piece of typed C, decorated with a type: -- -- * The first type to appear (@int@ in the example) is the type of said C code. -- -- * The syntax of the @\@ depends on on the quasi-quoter used, and the -- anti-quoters available. The @exp@ quasi-quoter expects a C expression. The -- @block@ quasi-quoter expects a list of statements, like the body of -- a function. Just like a C function, a block has a return type, matching the -- type of any values in any @return@ statements appearing in the block. -- -- See also the @README.md@ file for more documentation. -- -- === Anti-quoters -- -- Haskell variables can be captured using anti-quoters. @inline-c@ -- provides a basic anti-quoting mechanism extensible with user-defined -- anti-quoters (see "Language.C.Inline.Context"). The basic -- anti-quoter lets you capture Haskell variables, for -- example we might say -- -- @ -- let x = pi / 3 in ['C.exp'| double { cos($(double x)) } |] -- @ -- -- Which would capture the Haskell variable @x@ of type @'CDouble'@. -- -- In C expressions the @$@ character is denoted using @$$@. -- -- === Variable capture and the typing relation -- -- The Haskell type of the inlined expression is determined by the specified -- C return type. The relation between the C type and the Haskell type is -- defined in the current 'Context' -- see 'convertCType'. C pointers and -- arrays are both converted to Haskell @'Ptr'@s, and function pointers are -- converted to @'FunPtr'@s. Sized arrays are not supported. -- -- Similarly, when capturing Haskell variables using anti-quoting, their -- type is assumed to be of the Haskell type corresponding to the C type -- provided. For example, if we capture variable @x@ using @double x@ -- in the parameter list, the code will expect a variable @x@ of type -- 'CDouble' in Haskell (when using 'baseCtx'). -- -- === Purity -- -- The 'exp' and 'block' quasi-quotes denote computations in the 'IO' monad. -- 'pure' denotes a pure value, expressed as a C expression. -- -- === Safe and @unsafe@ calls -- -- @unsafe@ variants of the quasi-quoters are provided in -- "Language.C.Inline.Unsafe" to call the C code unsafely, in the sense that the -- C code will block the RTS, but with the advantage of a faster call to the -- foreign code. See -- . -- -- == Examples -- -- === Inline C expression -- -- @ -- {-\# LANGUAGE QuasiQuotes \#-} -- import qualified "Language.C.Inline" as C -- import qualified "Language.C.Inline.Unsafe" as CU -- import "Foreign.C.Types" -- -- C.'include' "\" -- -- c_cos :: 'CDouble' -> IO 'CDouble' -- c_cos x = [C.exp| double { cos($(double x)) } |] -- -- faster_c_cos :: 'CDouble' -> IO 'CDouble' -- faster_c_cos x = [CU.exp| double { cos($(double x)) } |] -- @ -- -- === Inline C statements -- -- @ -- {-\# LANGUAGE QuasiQuotes \#-} -- {-\# LANGUAGE TemplateHaskell \#-} -- import qualified Data.Vector.Storable.Mutable as V -- import qualified "Language.C.Inline" as C -- import "Foreign.C.Types" -- -- C.'include' "\" -- -- parseVector :: 'CInt' -> 'IO' (V.IOVector 'CDouble') -- parseVector len = do -- vec <- V.new $ 'fromIntegral' len0 -- V.unsafeWith vec $ \\ptr -> [C.'block'| void { -- int i; -- for (i = 0; i < $(int len); i++) { -- scanf("%lf ", &$(double *ptr)[i]); -- } -- } |] -- 'return' vec -- @ -- -- == How it works -- -- For each quasi-quotation of C code, a C function is generated in a C file -- corresponding to the current Haskell file. Every inline C expression will result -- in a corresponding C function. -- For example, if we define @c_cos@ -- as in the example above in @CCos.hs@, we will get a file containing -- -- @ -- #include -- -- double inline_c_Main_0_a03fba228a6d8e36ea7d69381f87bade594c949d(double x_inline_c_0) { -- return cos(x_inline_c_0); -- } -- @ -- -- Every anti-quotation will correspond to an argument in the C function. If the same -- Haskell variable is anti-quoted twice, this will result in two arguments. -- -- The C function is then automatically compiled and invoked from Haskell with the correct arguments passed in. -- | C expressions. exp :: TH.QuasiQuoter exp = genericQuote IO $ inlineExp TH.Safe -- | Variant of 'exp', for use with expressions known to have no side effects. -- -- __BEWARE__: Use this function with caution, only when you know what you are -- doing. If an expression does in fact have side-effects, then indiscriminate -- use of 'pure' may endanger referential transparency, and in principle even -- type safety. Also note that the function might be called multiple times, -- given that 'System.IO.Unsafe.unsafeDupablePerformIO' is used to call the -- provided C code. Please refer to the documentation for -- 'System.IO.Unsafe.unsafePerformIO' for more details. -- [unsafeDupablePerformIO is used to ensure good performance using the -- threaded runtime](https://github.com/fpco/inline-c/issues/115). pure :: TH.QuasiQuoter pure = genericQuote Pure $ inlineExp TH.Safe -- | C code blocks (i.e. statements). block :: TH.QuasiQuoter block = genericQuote IO $ inlineItems TH.Safe False Nothing -- | Easily get a 'FunPtr': -- -- @ -- let fp :: FunPtr (Ptr CInt -> IO ()) = [C.funPtr| void poke42(int *ptr) { *ptr = 42; } |] -- @ -- -- Especially useful to generate finalizers that require C code. -- -- Most importantly, this allows you to write `Foreign.ForeignPtr.newForeignPtr` invocations conveniently: -- -- @ -- do -- let c_finalizer_funPtr = -- [C.funPtr| void myfree(char * ptr) { free(ptr); } |] -- fp <- newForeignPtr c_finalizer_funPtr objPtr -- @ -- -- Using where possible `Foreign.ForeignPtr.newForeignPtr` is superior to -- resorting to its delayed-by-a-thread alternative `Foreign.Concurrent.newForeignPtr` -- from "Foreign.Concurrent" which takes an @IO ()@ Haskell finaliser action: -- With the non-concurrent `newForeignPtr` you can guarantee that the finaliser -- will actually be run -- -- * when a GC is executed under memory pressure, because it can point directly -- to a C function that doesn't have to run any Haskell code (which is -- problematic when you're out of memory) -- * when the program terminates (`Foreign.Concurrent.newForeignPtr`'s finaliser -- will likely NOT be called if your main thread exits, making your program -- e.g. not Valgrind-clean if your finaliser is @free@ or C++'s @delete@). -- -- `funPtr` makes the normal `newForeignPtr` as convenient as its concurrent -- counterpart. funPtr :: TH.QuasiQuoter funPtr = funPtrQuote TH.Unsafe -- doesn't make much sense for this to be "safe", but it'd be good to verify what this means -- | Emits a CPP include directive for C code associated with the current -- module. To avoid having to escape quotes, the function itself adds them when -- appropriate, so that -- -- @ -- include "foo.h" ==> #include "foo.h" -- @ -- -- but -- -- @ -- include "\" ==> #include \ -- @ include :: String -> TH.DecsQ include s | null s = fail "inline-c: empty string (include)" | head s == '<' = verbatim $ "#include " ++ s | otherwise = verbatim $ "#include \"" ++ s ++ "\"" -- | Emits an arbitrary C string to the C code associated with the -- current module. Use with care. verbatim :: String -> TH.DecsQ verbatim s = do void $ emitVerbatim s return [] ------------------------------------------------------------------------ -- 'Ptr' utils -- | Like 'alloca', but also peeks the contents of the 'Ptr' and returns -- them once the provided action has finished. withPtr :: (Storable a) => (Ptr a -> IO b) -> IO (a, b) withPtr f = do alloca $ \ptr -> do x <- f ptr y <- peek ptr return (y, x) withPtr_ :: (Storable a) => (Ptr a -> IO ()) -> IO a withPtr_ f = do (x, ()) <- withPtr f return x -- | Type class with methods useful to allocate and peek multiple -- pointers at once: -- -- @ -- withPtrs_ :: (Storable a, Storable b) => ((Ptr a, Ptr b) -> IO ()) -> IO (a, b) -- withPtrs_ :: (Storable a, Storable b, Storable c) => ((Ptr a, Ptr b, Ptr c) -> IO ()) -> IO (a, b, c) -- ... -- @ class WithPtrs a where type WithPtrsPtrs a :: * withPtrs :: (WithPtrsPtrs a -> IO b) -> IO (a, b) withPtrs_ :: (WithPtrsPtrs a -> IO ()) -> IO a withPtrs_ f = do (x, _) <- withPtrs f return x instance (Storable a, Storable b) => WithPtrs (a, b) where type WithPtrsPtrs (a, b) = (Ptr a, Ptr b) withPtrs f = do (a, (b, x)) <- withPtr $ \a -> withPtr $ \b -> f (a, b) return ((a, b), x) instance (Storable a, Storable b, Storable c) => WithPtrs (a, b, c) where type WithPtrsPtrs (a, b, c) = (Ptr a, Ptr b, Ptr c) withPtrs f = do (a, ((b, c), x)) <- withPtr $ \a -> withPtrs $ \(b, c) -> f (a, b, c) return ((a, b, c), x) instance (Storable a, Storable b, Storable c, Storable d) => WithPtrs (a, b, c, d) where type WithPtrsPtrs (a, b, c, d) = (Ptr a, Ptr b, Ptr c, Ptr d) withPtrs f = do (a, ((b, c, d), x)) <- withPtr $ \a -> withPtrs $ \(b, c, d) -> f (a, b, c, d) return ((a, b, c, d), x) instance (Storable a, Storable b, Storable c, Storable d, Storable e) => WithPtrs (a, b, c, d, e) where type WithPtrsPtrs (a, b, c, d, e) = (Ptr a, Ptr b, Ptr c, Ptr d, Ptr e) withPtrs f = do (a, ((b, c, d, e), x)) <- withPtr $ \a -> withPtrs $ \(b, c, d, e) -> f (a, b, c, d, e) return ((a, b, c, d, e), x) instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f) => WithPtrs (a, b, c, d, e, f) where type WithPtrsPtrs (a, b, c, d, e, f) = (Ptr a, Ptr b, Ptr c, Ptr d, Ptr e, Ptr f) withPtrs fun = do (a, ((b, c, d, e, f), x)) <- withPtr $ \a -> withPtrs $ \(b, c, d, e, f) -> fun (a, b, c, d, e, f) return ((a, b, c, d, e, f), x) instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g) => WithPtrs (a, b, c, d, e, f, g) where type WithPtrsPtrs (a, b, c, d, e, f, g) = (Ptr a, Ptr b, Ptr c, Ptr d, Ptr e, Ptr f, Ptr g) withPtrs fun = do (a, ((b, c, d, e, f, g), x)) <- withPtr $ \a -> withPtrs $ \(b, c, d, e, f, g) -> fun (a, b, c, d, e, f, g) return ((a, b, c, d, e, f, g), x) ------------------------------------------------------------------------ -- setContext alias -- | Sets the 'Context' for the current module. This function, if -- called, must be called before any of the other TH functions in this -- module. Fails if that's not the case. context :: Context -> TH.DecsQ context ctx = do setContext ctx return [] inline-c-0.9.1.10/src/Language/C/Inline/Context.hs0000644000000000000000000005321214505621771017531 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | A 'Context' is used to define the capabilities of the Template Haskell code -- that handles the inline C code. See the documentation of the data type for -- more details. -- -- In practice, a 'Context' will have to be defined for each library that -- defines new C types, to allow the TemplateHaskell code to interpret said -- types correctly. module Language.C.Inline.Context ( -- * 'TypesTable' TypesTable , Purity(..) , convertType , CArray , typeNamesFromTypesTable -- * 'AntiQuoter' , AntiQuoter(..) , AntiQuoterId , SomeAntiQuoter(..) , AntiQuoters -- * 'Context' , Context(..) , baseCtx , fptrCtx , funCtx , vecCtx , VecCtx(..) , bsCtx ) where import Control.Applicative ((<|>)) import Control.Monad (mzero, forM) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS import Data.Coerce import Data.Int (Int8, Int16, Int32, Int64) import qualified Data.Map as Map import Data.Typeable (Typeable) import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as VM import Data.Word (Word8, Word16, Word32, Word64) import Foreign.C.Types import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr, FunPtr, freeHaskellFunPtr) import Foreign.Storable (Storable) import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH import qualified Text.Parser.Token as Parser import qualified Data.HashSet as HashSet #if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup, (<>)) #else import Data.Monoid ((<>)) #endif #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid(..)) import Data.Traversable (traverse) #endif import Language.C.Inline.FunPtr import qualified Language.C.Types as C import Language.C.Inline.HaskellIdentifier -- | A mapping from 'C.TypeSpecifier's to Haskell types. Needed both to -- parse C types, and to convert them to Haskell types. type TypesTable = Map.Map C.TypeSpecifier TH.TypeQ -- | A data type to indicate whether the user requested pure or IO -- function from Haskell data Purity = Pure | IO deriving (Eq, Show) -- | Specifies how to parse and process an antiquotation in the C code. -- -- All antiquotations (apart from plain variable capture) have syntax -- -- @ -- $XXX:YYY -- @ -- -- Where @XXX@ is the name of the antiquoter and @YYY@ is something -- parseable by the respective 'aqParser'. data AntiQuoter a = AntiQuoter { aqParser :: forall m. C.CParser HaskellIdentifier m => m (C.CIdentifier, C.Type C.CIdentifier, a) -- ^ Parses the body of the antiquotation, returning a hint for the name to -- assign to the variable that will replace the anti-quotation, the type of -- said variable, and some arbitrary data which will then be fed to -- 'aqMarshaller'. -- -- The 'C.Type' has 'Void' as an identifier type to make sure that -- no names appear in it. , aqMarshaller :: Purity -> TypesTable -> C.Type C.CIdentifier -> a -> TH.Q (TH.Type, TH.Exp) -- ^ Takes the requested purity, the current 'TypesTable', and the -- type and the body returned by 'aqParser'. -- -- Returns the Haskell type for the parameter, and the Haskell expression -- that will be passed in as the parameter. -- -- If the the type returned is @ty@, the 'TH.Exp' __must__ have type @forall -- a. (ty -> IO a) -> IO a@. This allows to do resource handling when -- preparing C values. -- -- Care must be taken regarding 'Purity'. Specifically, the generated IO -- computation must be idempotent to guarantee its safety when used in pure -- code. We cannot prevent the IO computation from being inlined, hence -- potentially duplicated. If non-idempotent marshallers are required (e.g. -- if an update to some global state is needed), it is best to throw an -- error when 'Purity' is 'Pure' (for example "you cannot use context X with -- @pure@"), which will show up at compile time. } -- | An identifier for a 'AntiQuoter'. type AntiQuoterId = String -- | Existential wrapper around 'AntiQuoter'. data SomeAntiQuoter = forall a. (Eq a, Typeable a) => SomeAntiQuoter (AntiQuoter a) type AntiQuoters = Map.Map AntiQuoterId SomeAntiQuoter -- | A 'Context' stores various information needed to produce the files with -- the C code derived from the inline C snippets. -- -- 'Context's can be composed with their 'Monoid' instance, where 'mappend' is -- right-biased -- in @'mappend' x y@ @y@ will take precedence over @x@. data Context = Context { ctxTypesTable :: TypesTable -- ^ Needed to convert C types to Haskell types. , ctxAntiQuoters :: AntiQuoters -- ^ Needed to parse and process antiquotations. , ctxOutput :: Maybe (String -> String) -- ^ This function is used to post-process the functions generated -- from the C snippets. Currently just used to specify C linkage -- when generating C++ code. , ctxForeignSrcLang :: Maybe TH.ForeignSrcLang -- ^ TH.LangC by default , ctxEnableCpp :: Bool -- ^ Compile source code to raw object. , ctxRawObjectCompile :: Maybe (String -> TH.Q FilePath) } #if MIN_VERSION_base(4,9,0) instance Semigroup Context where ctx2 <> ctx1 = Context { ctxTypesTable = ctxTypesTable ctx1 <> ctxTypesTable ctx2 , ctxAntiQuoters = ctxAntiQuoters ctx1 <> ctxAntiQuoters ctx2 , ctxOutput = ctxOutput ctx1 <|> ctxOutput ctx2 , ctxForeignSrcLang = ctxForeignSrcLang ctx1 <|> ctxForeignSrcLang ctx2 , ctxEnableCpp = ctxEnableCpp ctx1 || ctxEnableCpp ctx2 , ctxRawObjectCompile = ctxRawObjectCompile ctx1 <|> ctxRawObjectCompile ctx2 } #endif instance Monoid Context where mempty = Context { ctxTypesTable = mempty , ctxAntiQuoters = mempty , ctxOutput = Nothing , ctxForeignSrcLang = Nothing , ctxEnableCpp = False , ctxRawObjectCompile = Nothing } #if !MIN_VERSION_base(4,11,0) mappend ctx2 ctx1 = Context { ctxTypesTable = ctxTypesTable ctx1 <> ctxTypesTable ctx2 , ctxAntiQuoters = ctxAntiQuoters ctx1 <> ctxAntiQuoters ctx2 , ctxOutput = ctxOutput ctx1 <|> ctxOutput ctx2 , ctxForeignSrcLang = ctxForeignSrcLang ctx1 <|> ctxForeignSrcLang ctx2 , ctxEnableCpp = ctxEnableCpp ctx1 || ctxEnableCpp ctx2 , ctxRawObjectCompile = ctxRawObjectCompile ctx1 <|> ctxRawObjectCompile ctx2 } #endif -- | Context useful to work with vanilla C. Used by default. -- -- 'ctxTypesTable': converts C basic types to their counterparts in -- "Foreign.C.Types". -- -- No 'ctxAntiQuoters'. baseCtx :: Context baseCtx = mempty { ctxTypesTable = baseTypesTable } baseTypesTable :: Map.Map C.TypeSpecifier TH.TypeQ baseTypesTable = Map.fromList [ (C.Void, [t| () |]) -- Types from Foreign.C.Types in the order in which they are presented there, -- along with its documentation's section headers. -- -- Integral types , (C.Bool, [t| CBool |]) , (C.Char Nothing, [t| CChar |]) , (C.Char (Just C.Signed), [t| CSChar |]) , (C.Char (Just C.Unsigned), [t| CUChar |]) , (C.Short C.Signed, [t| CShort |]) , (C.Short C.Unsigned, [t| CUShort |]) , (C.Int C.Signed, [t| CInt |]) , (C.Int C.Unsigned, [t| CUInt |]) , (C.Long C.Signed, [t| CLong |]) , (C.Long C.Unsigned, [t| CULong |]) , (C.TypeName "ptrdiff_t", [t| CPtrdiff |]) , (C.TypeName "size_t", [t| CSize |]) , (C.TypeName "wchar_t", [t| CWchar |]) , (C.TypeName "sig_atomic_t", [t| CSigAtomic |]) , (C.LLong C.Signed, [t| CLLong |]) , (C.LLong C.Unsigned, [t| CULLong |]) , (C.TypeName "intptr_t", [t| CIntPtr |]) , (C.TypeName "uintptr_t", [t| CUIntPtr |]) , (C.TypeName "intmax_t", [t| CIntMax |]) , (C.TypeName "uintmax_t", [t| CUIntMax |]) -- Numeric types , (C.TypeName "clock_t", [t| CClock |]) , (C.TypeName "time_t", [t| CTime |]) , (C.TypeName "useconds_t", [t| CUSeconds |]) , (C.TypeName "suseconds_t", [t| CSUSeconds |]) -- Floating types , (C.Float, [t| CFloat |]) , (C.Double, [t| CDouble |]) -- Other types , (C.TypeName "FILE", [t| CFile |]) , (C.TypeName "fpos_t", [t| CFpos |]) , (C.TypeName "jmp_buf", [t| CJmpBuf |]) -- Types from stdint.h that can be statically mapped to their Haskell -- equivalents. Excludes int_fast*_t and int_least*_t and the corresponding -- unsigned types, since their sizes are platform-specific. , (C.TypeName "int8_t", [t| Int8 |]) , (C.TypeName "int16_t", [t| Int16 |]) , (C.TypeName "int32_t", [t| Int32 |]) , (C.TypeName "int64_t", [t| Int64 |]) , (C.TypeName "uint8_t", [t| Word8 |]) , (C.TypeName "uint16_t", [t| Word16 |]) , (C.TypeName "uint32_t", [t| Word32 |]) , (C.TypeName "uint64_t", [t| Word64 |]) ] -- | An alias for 'Ptr'. type CArray = Ptr ------------------------------------------------------------------------ -- Type conversion -- | Given a 'Context', it uses its 'ctxTypesTable' to convert -- arbitrary C types. convertType :: Purity -> TypesTable -> C.Type C.CIdentifier -> TH.Q (Maybe TH.Type) convertType purity cTypes = runMaybeT . go where goDecl = go . C.parameterDeclarationType go :: C.Type C.CIdentifier -> MaybeT TH.Q TH.Type go cTy = do case cTy of C.TypeSpecifier _specs (C.Template ident' cTys) -> do -- let symbol = TH.LitT (TH.StrTyLit (C.unCIdentifier ident')) symbol <- case Map.lookup (C.TypeName ident') cTypes of Nothing -> mzero Just ty -> return ty hsTy <- forM cTys $ \cTys' -> go (C.TypeSpecifier undefined cTys') case hsTy of [] -> fail $ "Can not find template parameters." (a:[]) -> lift $ TH.AppT <$> symbol <*> return a other -> let tuple = foldl (\tuple arg -> TH.AppT tuple arg) (TH.PromotedTupleT (length other)) other in lift $ TH.AppT <$> symbol <*> return tuple C.TypeSpecifier _specs (C.TemplateConst num) -> do let n = (TH.LitT (TH.NumTyLit (read num))) lift [t| $(return n) |] C.TypeSpecifier _specs (C.TemplatePointer cSpec) -> do case Map.lookup cSpec cTypes of Nothing -> mzero Just ty -> lift [t| Ptr $(ty) |] C.TypeSpecifier _specs cSpec -> case Map.lookup cSpec cTypes of Nothing -> mzero Just ty -> lift ty C.Ptr _quals (C.Proto retType pars) -> do hsRetType <- go retType hsPars <- mapM goDecl pars lift [t| FunPtr $(buildArr hsPars hsRetType) |] C.Ptr _quals cTy' -> do hsTy <- go cTy' lift [t| Ptr $(return hsTy) |] C.Array _mbSize cTy' -> do hsTy <- go cTy' lift [t| CArray $(return hsTy) |] C.Proto _retType _pars -> do -- We cannot convert standalone prototypes mzero buildArr [] hsRetType = case purity of Pure -> [t| $(return hsRetType) |] IO -> [t| IO $(return hsRetType) |] buildArr (hsPar : hsPars) hsRetType = [t| $(return hsPar) -> $(buildArr hsPars hsRetType) |] typeNamesFromTypesTable :: TypesTable -> C.TypeNames typeNamesFromTypesTable cTypes = HashSet.fromList [ id' | C.TypeName id' <- Map.keys cTypes ] ------------------------------------------------------------------------ -- Useful contexts getHsVariable :: String -> HaskellIdentifier -> TH.ExpQ getHsVariable err s = do mbHsName <- TH.lookupValueName $ unHaskellIdentifier s case mbHsName of Nothing -> fail $ "Cannot capture Haskell variable " ++ unHaskellIdentifier s ++ ", because it's not in scope. (" ++ err ++ ")" Just hsName -> TH.varE hsName convertType_ :: String -> Purity -> TypesTable -> C.Type C.CIdentifier -> TH.Q TH.Type convertType_ err purity cTypes cTy = do mbHsType <- convertType purity cTypes cTy case mbHsType of Nothing -> fail $ "Cannot convert C type (" ++ err ++ ")" Just hsType -> return hsType -- | This 'Context' adds support for 'ForeignPtr' arguments. It adds a unique -- marshaller called @fptr-ptr@. For example, @$fptr-ptr:(int *x)@ extracts the -- bare C pointer out of foreign pointer @x@. fptrCtx :: Context fptrCtx = mempty { ctxAntiQuoters = Map.fromList [("fptr-ptr", SomeAntiQuoter fptrAntiQuoter)] } fptrAntiQuoter :: AntiQuoter HaskellIdentifier fptrAntiQuoter = AntiQuoter { aqParser = cDeclAqParser , aqMarshaller = \purity cTypes cTy cId -> do hsTy <- convertType_ "fptrCtx" purity cTypes cTy hsExp <- getHsVariable "fptrCtx" cId hsExp' <- [| withForeignPtr (coerce $(return hsExp)) |] return (hsTy, hsExp') } -- | This 'Context' includes a 'AntiQuoter' that removes the need for -- explicitely creating 'FunPtr's, named @"fun"@ along with one which -- allocates new memory which must be manually freed named @"fun-alloc"@. -- -- For example, we can capture function @f@ of type @CInt -> CInt -> IO -- CInt@ in C code using @$fun:(int (*f)(int, int))@. -- -- When used in a @pure@ embedding, the Haskell function will have to be -- pure too. Continuing the example above we'll have @CInt -> CInt -> -- IO CInt@. -- -- Does not include the 'baseCtx', since most of the time it's going to -- be included as part of larger contexts. -- -- IMPORTANT: When using the @fun@ anti quoter, one must be aware that -- the function pointer which is automatically generated is freed when -- the code contained in the block containing the anti quoter exits. -- Thus, if you need the function pointer to be longer-lived, you must -- allocate it and free it manually using 'freeHaskellFunPtr'. -- We provide utilities to easily -- allocate them (see 'Language.C.Inline.mkFunPtr'). -- -- IMPORTANT: When using the @fun-alloc@ anti quoter, one must free the allocated -- function pointer. The GHC runtime provides a function to do this, -- 'hs_free_fun_ptr' available in the 'HsFFI.h' header. funCtx :: Context funCtx = mempty { ctxAntiQuoters = Map.fromList [("fun", SomeAntiQuoter funPtrAntiQuoter) ,("fun-alloc", SomeAntiQuoter funAllocPtrAntiQuoter)] } funPtrAntiQuoter :: AntiQuoter HaskellIdentifier funPtrAntiQuoter = AntiQuoter { aqParser = cDeclAqParser , aqMarshaller = \purity cTypes cTy cId -> do hsTy <- convertType_ "funCtx" purity cTypes cTy hsExp <- getHsVariable "funCtx" cId case hsTy of TH.AppT (TH.ConT n) hsTy' | n == ''FunPtr -> do hsExp' <- [| \cont -> do funPtr <- $(mkFunPtr (return hsTy')) $(return hsExp) x <- cont funPtr freeHaskellFunPtr funPtr return x |] return (hsTy, hsExp') _ -> fail "The `fun' marshaller captures function pointers only" } funAllocPtrAntiQuoter :: AntiQuoter HaskellIdentifier funAllocPtrAntiQuoter = AntiQuoter { aqParser = cDeclAqParser , aqMarshaller = \purity cTypes cTy cId -> do hsTy <- convertType_ "funCtx" purity cTypes cTy hsExp <- getHsVariable "funCtx" cId case hsTy of TH.AppT (TH.ConT n) hsTy' | n == ''FunPtr -> do hsExp' <- [| \cont -> do funPtr <- $(mkFunPtr (return hsTy')) $(return hsExp) cont funPtr |] return (hsTy, hsExp') _ -> fail "The `fun-alloc' marshaller captures function pointers only" } -- | This 'Context' includes two 'AntiQuoter's that allow to easily use -- Haskell vectors in C. -- -- Specifically, the @vec-len@ and @vec-ptr@ will get the length and the -- pointer underlying mutable ('V.IOVector') and immutable ('V.Vector') -- storable vectors. -- -- Note that if you use 'vecCtx' to manipulate immutable vectors you -- must make sure that the vector is not modified in the C code. -- -- To use @vec-len@, simply write @$vec-len:x@, where @x@ is something -- of type @'V.IOVector' a@ or @'V.Vector' a@, for some @a@. To use -- @vec-ptr@ you need to specify the type of the pointer, -- e.g. @$vec-len:(int *x)@ will work if @x@ has type @'V.IOVector' -- 'CInt'@. vecCtx :: Context vecCtx = mempty { ctxAntiQuoters = Map.fromList [ ("vec-ptr", SomeAntiQuoter vecPtrAntiQuoter) , ("vec-len", SomeAntiQuoter vecLenAntiQuoter) ] } -- | Type class used to implement the anti-quoters in 'vecCtx'. class VecCtx a where type VecCtxScalar a :: * vecCtxLength :: a -> Int vecCtxUnsafeWith :: a -> (Ptr (VecCtxScalar a) -> IO b) -> IO b instance Storable a => VecCtx (V.Vector a) where type VecCtxScalar (V.Vector a) = a vecCtxLength = V.length vecCtxUnsafeWith = V.unsafeWith instance Storable a => VecCtx (VM.IOVector a) where type VecCtxScalar (VM.IOVector a) = a vecCtxLength = VM.length vecCtxUnsafeWith = VM.unsafeWith vecPtrAntiQuoter :: AntiQuoter HaskellIdentifier vecPtrAntiQuoter = AntiQuoter { aqParser = cDeclAqParser , aqMarshaller = \purity cTypes cTy cId -> do hsTy <- convertType_ "vecCtx" purity cTypes cTy hsExp <- getHsVariable "vecCtx" cId hsExp' <- [| vecCtxUnsafeWith $(return hsExp) |] return (hsTy, hsExp') } vecLenAntiQuoter :: AntiQuoter HaskellIdentifier vecLenAntiQuoter = AntiQuoter { aqParser = do hId <- C.parseIdentifier useCpp <- C.parseEnableCpp let cId = mangleHaskellIdentifier useCpp hId return (cId, C.TypeSpecifier mempty (C.Long C.Signed), hId) , aqMarshaller = \_purity _cTypes cTy cId -> do case cTy of C.TypeSpecifier _ (C.Long C.Signed) -> do hsExp <- getHsVariable "vecCtx" cId hsExp' <- [| fromIntegral (vecCtxLength $(return hsExp)) |] hsTy <- [t| CLong |] hsExp'' <- [| \cont -> cont $(return hsExp') |] return (hsTy, hsExp'') _ -> do fail "impossible: got type different from `long' (vecCtx)" } -- | 'bsCtx' serves exactly the same purpose as 'vecCtx', but only for -- 'BS.ByteString'. @vec-ptr@ becomes @bs-ptr@, and @vec-len@ becomes -- @bs-len@. You don't need to specify the type of the pointer in -- @bs-ptr@, it will always be @char*@. -- -- Moreover, @bs-cstr@ works as @bs-ptr@ but it provides a null-terminated -- copy of the given 'BS.ByteString'. bsCtx :: Context bsCtx = mempty { ctxAntiQuoters = Map.fromList [ ("bs-ptr", SomeAntiQuoter bsPtrAntiQuoter) , ("bs-len", SomeAntiQuoter bsLenAntiQuoter) , ("bs-cstr", SomeAntiQuoter bsCStrAntiQuoter) ] } bsPtrAntiQuoter :: AntiQuoter HaskellIdentifier bsPtrAntiQuoter = AntiQuoter { aqParser = do hId <- C.parseIdentifier useCpp <- C.parseEnableCpp let cId = mangleHaskellIdentifier useCpp hId return (cId, C.Ptr [] (C.TypeSpecifier mempty (C.Char Nothing)), hId) , aqMarshaller = \_purity _cTypes cTy cId -> do case cTy of C.Ptr _ (C.TypeSpecifier _ (C.Char Nothing)) -> do hsTy <- [t| Ptr CChar |] hsExp <- getHsVariable "bsCtx" cId hsExp' <- [| \cont -> BS.unsafeUseAsCString $(return hsExp) $ \ptr -> cont ptr |] return (hsTy, hsExp') _ -> fail "impossible: got type different from `char *' (bsCtx)" } bsLenAntiQuoter :: AntiQuoter HaskellIdentifier bsLenAntiQuoter = AntiQuoter { aqParser = do hId <- C.parseIdentifier useCpp <- C.parseEnableCpp let cId = mangleHaskellIdentifier useCpp hId return (cId, C.TypeSpecifier mempty (C.Long C.Signed), hId) , aqMarshaller = \_purity _cTypes cTy cId -> do case cTy of C.TypeSpecifier _ (C.Long C.Signed) -> do hsExp <- getHsVariable "bsCtx" cId hsExp' <- [| fromIntegral (BS.length $(return hsExp)) |] hsTy <- [t| CLong |] hsExp'' <- [| \cont -> cont $(return hsExp') |] return (hsTy, hsExp'') _ -> do fail "impossible: got type different from `long' (bsCtx)" } bsCStrAntiQuoter :: AntiQuoter HaskellIdentifier bsCStrAntiQuoter = AntiQuoter { aqParser = do hId <- C.parseIdentifier useCpp <- C.parseEnableCpp let cId = mangleHaskellIdentifier useCpp hId return (cId, C.Ptr [] (C.TypeSpecifier mempty (C.Char Nothing)), hId) , aqMarshaller = \_purity _cTypes cTy cId -> do case cTy of C.Ptr _ (C.TypeSpecifier _ (C.Char Nothing)) -> do hsTy <- [t| Ptr CChar |] hsExp <- getHsVariable "bsCtx" cId hsExp' <- [| \cont -> BS.useAsCString $(return hsExp) $ \ptr -> cont ptr |] return (hsTy, hsExp') _ -> fail "impossible: got type different from `char *' (bsCtx)" } -- Utils ------------------------------------------------------------------------ cDeclAqParser :: C.CParser HaskellIdentifier m => m (C.CIdentifier, C.Type C.CIdentifier, HaskellIdentifier) cDeclAqParser = do cTy <- Parser.parens C.parseParameterDeclaration useCpp <- C.parseEnableCpp case C.parameterDeclarationId cTy of Nothing -> fail "Every captured function must be named (funCtx)" Just hId -> do let cId = mangleHaskellIdentifier useCpp hId cTy' <- deHaskellifyCType $ C.parameterDeclarationType cTy return (cId, cTy', hId) deHaskellifyCType :: C.CParser HaskellIdentifier m => C.Type HaskellIdentifier -> m (C.Type C.CIdentifier) deHaskellifyCType = traverse $ \hId -> do useCpp <- C.parseEnableCpp case C.cIdentifierFromString useCpp (unHaskellIdentifier hId) of Left err -> fail $ "Illegal Haskell identifier " ++ unHaskellIdentifier hId ++ " in C type:\n" ++ err Right x -> return x inline-c-0.9.1.10/src/Language/C/Inline/HaskellIdentifier.hs0000644000000000000000000001251614503767417021503 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} module Language.C.Inline.HaskellIdentifier ( HaskellIdentifier , unHaskellIdentifier , haskellIdentifierFromString , haskellCParserContext , parseHaskellIdentifier , mangleHaskellIdentifier -- * for testing , haskellReservedWords ) where import Control.Applicative ((<|>)) import Control.Monad (when, msum, void) import Data.Char (ord) import qualified Data.HashSet as HashSet import Data.Hashable (Hashable) import Data.List (intercalate, partition, intersperse) import Data.Monoid ((<>)) import Data.String (IsString(..)) import Data.Typeable (Typeable) import Numeric (showHex) import Text.Parser.Char (upper, lower, digit, char) import Text.Parser.Combinators (many, eof, try, unexpected, ()) import Text.Parser.Token (IdentifierStyle(..), highlight, TokenParsing) import qualified Text.Parser.Token.Highlight as Highlight import qualified Prettyprinter as PP import qualified Language.C.Types.Parse as C #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<*), (<$>), (<*>)) #endif -- | A possibly qualified Haskell identifier. newtype HaskellIdentifier = HaskellIdentifier {unHaskellIdentifier :: String} deriving (Typeable, Eq, Ord, Show, Hashable) instance IsString HaskellIdentifier where fromString s = case haskellIdentifierFromString True s of Left err -> error $ "HaskellIdentifier fromString: invalid string " ++ s ++ ":\n" ++ err Right x -> x instance PP.Pretty HaskellIdentifier where pretty = fromString . unHaskellIdentifier haskellIdentifierFromString :: Bool -> String -> Either String HaskellIdentifier haskellIdentifierFromString useCpp s = case C.runCParser cpc "haskellIdentifierFromString" s (parseHaskellIdentifier <* eof) of Left err -> Left $ show err Right x -> Right x where cpc = haskellCParserContext useCpp HashSet.empty haskellCParserContext :: Bool -> C.TypeNames -> C.CParserContext HaskellIdentifier haskellCParserContext useCpp typeNames = C.CParserContext { C.cpcTypeNames = typeNames , C.cpcParseIdent = parseHaskellIdentifier , C.cpcIdentName = "Haskell identifier" , C.cpcIdentToString = unHaskellIdentifier , C.cpcEnableCpp = useCpp } -- | See -- . haskellIdentStyle :: C.CParser i m => IdentifierStyle m haskellIdentStyle = IdentifierStyle { _styleName = "Haskell identifier" , _styleStart = small , _styleLetter = small <|> large <|> digit <|> char '\'' , _styleReserved = haskellReservedWords , _styleHighlight = Highlight.Identifier , _styleReservedHighlight = Highlight.ReservedIdentifier } where small = lower <|> char '_' large = upper -- We disallow both Haskell reserved words and C reserved words. haskellReservedWords :: HashSet.HashSet String haskellReservedWords = C.cReservedWords <> HashSet.fromList [ "case", "class", "data", "default", "deriving", "do", "else" , "foreign", "if", "import", "in", "infix", "infixl" , "infixr", "instance", "let", "module", "newtype", "of" , "then", "type", "where" ] -- | See -- . parseHaskellIdentifier :: forall i m. C.CParser i m => m HaskellIdentifier parseHaskellIdentifier = do segments <- go return $ HaskellIdentifier $ intercalate "." segments where small = lower <|> char '_' large = upper conid :: m String conid = try $ highlight Highlight.Identifier $ ((:) <$> large <*> many (small <|> large <|> digit <|> char '\'')) "Haskell constructor" varid :: m String varid = identNoLex haskellIdentStyle go = msum [ do con <- conid msum [ do void $ char '.' (con :) <$> go , return [con] ] , do var <- varid return [var] ] -- | Mangles an 'HaskellIdentifier' to produce a valid 'C.CIdentifier' -- which still sort of resembles the 'HaskellIdentifier'. mangleHaskellIdentifier :: Bool -> HaskellIdentifier -> C.CIdentifier mangleHaskellIdentifier useCpp (HaskellIdentifier hs) = -- The leading underscore if we have no valid chars is because then -- we'd have an identifier starting with numbers. let cs = (if null valid then "_" else "") ++ valid ++ (if null mangled || null valid then "" else "_") ++ mangled in case C.cIdentifierFromString useCpp cs of Left err -> error $ "mangleHaskellIdentifier: produced bad C identifier\n" ++ err Right x -> x where (valid, invalid) = partition (`elem` C.cIdentLetter) hs mangled = concat $ intersperse "_" $ map (`showHex` "") $ map ord invalid -- Utils ------------------------------------------------------------------------ identNoLex :: (TokenParsing m, Monad m, IsString s) => IdentifierStyle m -> m s identNoLex s = fmap fromString $ try $ do name <- highlight (_styleHighlight s) ((:) <$> _styleStart s <*> many (_styleLetter s) _styleName s) when (HashSet.member name (_styleReserved s)) $ unexpected $ "reserved " ++ _styleName s ++ " " ++ show name return name inline-c-0.9.1.10/src/Language/C/Inline/Internal.hs0000644000000000000000000007544714505621771017677 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MonoLocalBinds #-} module Language.C.Inline.Internal ( -- * Context handling setContext , getContext -- * Substitution , Substitutions(..) , substitute , getHaskellType -- * Emitting and invoking C code -- -- | The functions in this section let us access more the C file -- associated with the current module. They can be used to build -- additional features on top of the basic machinery. All of -- @inline-c@ is based upon the functions defined here. -- ** Emitting C code , emitVerbatim , emitBlock -- ** Inlining C code -- $embedding , Code(..) , inlineCode , inlineExp , inlineItems -- * Parsing -- -- | These functions are used to parse the anti-quotations. They're -- exposed for testing purposes, you really should not use them. , SomeEq , toSomeEq , fromSomeEq , ParameterType(..) , ParseTypedC(..) , parseTypedC , runParserInQ , splitTypedC -- * Line directives , lineDirective , here , shiftLines -- * Utility functions for writing quasiquoters , genericQuote , funPtrQuote ) where import Control.Applicative import Control.Monad (forM, void, msum) import Control.Monad.State (evalStateT, StateT, get, put) import Control.Monad.Trans.Class (lift) import Data.Foldable (forM_) import qualified Data.Map as Map import Data.Maybe (fromMaybe, isJust) import Data.Traversable (for) import Data.Typeable (Typeable, cast) import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as TH import qualified Language.Haskell.TH.Syntax as TH import System.Environment (lookupEnv) import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO) import qualified Text.Parsec as Parsec import qualified Text.Parsec.Pos as Parsec import qualified Text.Parser.Char as Parser import qualified Text.Parser.Combinators as Parser import qualified Text.Parser.LookAhead as Parser import qualified Text.Parser.Token as Parser import Prettyprinter ((<+>)) import qualified Prettyprinter as PP import qualified Prettyprinter.Render.String as PP import qualified Data.List as L import qualified Data.Char as C import Data.Hashable (Hashable) import Foreign.Ptr (FunPtr) import qualified Data.Map as M -- We cannot use getQ/putQ before 7.10.3 because of #define USE_GETQ (__GLASGOW_HASKELL__ > 710 || (__GLASGOW_HASKELL__ == 710 && __GLASGOW_HASKELL_PATCHLEVEL1__ >= 3)) #if !USE_GETQ import Control.Concurrent.MVar (MVar, newMVar, modifyMVar_, readMVar) #endif import Language.C.Inline.Context import Language.C.Inline.FunPtr import Language.C.Inline.HaskellIdentifier import qualified Language.C.Types as C data ModuleState = ModuleState { msContext :: Context , msGeneratedNames :: Int , msFileChunks :: [String] } deriving (Typeable) getModuleState :: TH.Q (Maybe ModuleState) putModuleState :: ModuleState -> TH.Q () #if USE_GETQ getModuleState = TH.getQ putModuleState = TH.putQ #else -- | Identifier for the current module. Currently we use the file name. -- Since we're pairing Haskell files with C files, it makes more sense -- to use the file name. I'm not sure if it's possible to compile two -- modules with the same name in one run of GHC, but in this way we make -- sure that we don't run into trouble even it is. type ModuleId = String getModuleId :: TH.Q ModuleId getModuleId = TH.loc_filename <$> TH.location -- | 'MVar' storing the state for all the modules we visited. Note that -- currently we do not bother with cleaning up the state after we're -- done compiling a module. TODO if there is an easy way, clean up the -- state. {-# NOINLINE moduleStatesVar #-} moduleStatesVar :: MVar (Map.Map ModuleId ModuleState) moduleStatesVar = unsafePerformIO $ newMVar Map.empty getModuleState = do moduleStates <- TH.runIO (readMVar moduleStatesVar) moduleId <- getModuleId return (Map.lookup moduleId moduleStates) putModuleState ms = do moduleId <- getModuleId TH.runIO (modifyMVar_ moduleStatesVar (return . Map.insert moduleId ms)) #endif -- | Make sure that 'moduleStatesVar' and the respective C file are up -- to date. initialiseModuleState :: Maybe Context -- ^ The 'Context' to use if we initialise the module. If 'Nothing', -- 'baseCtx' will be used. -> TH.Q Context initialiseModuleState mbContext = do mbModuleState <- getModuleState case mbModuleState of Just moduleState -> return (msContext moduleState) Nothing -> do -- Add hook to add the file TH.addModFinalizer $ do mbMs <- getModuleState ms <- case mbMs of Nothing -> fail "inline-c: ModuleState not present (initialiseModuleState)" Just ms -> return ms let lang = fromMaybe TH.LangC (ctxForeignSrcLang context) addForeignSource = #if MIN_VERSION_base(4,12,0) TH.addForeignSource #else TH.addForeignFile #endif src = (concat (reverse (msFileChunks ms))) case (lang, ctxRawObjectCompile context) of (TH.RawObject, Just compile) -> compile src >>= TH.addForeignFilePath lang (_, _) -> addForeignSource lang src let moduleState = ModuleState { msContext = context , msGeneratedNames = 0 , msFileChunks = mempty } putModuleState moduleState return context where context = fromMaybe baseCtx mbContext -- | Gets the current 'Context'. Also makes sure that the current -- module is initialised. getContext :: TH.Q Context getContext = initialiseModuleState Nothing modifyModuleState :: (ModuleState -> (ModuleState, a)) -> TH.Q a modifyModuleState f = do mbModuleState <- getModuleState case mbModuleState of Nothing -> fail "inline-c: ModuleState not present (modifyModuleState)" Just ms -> do let (ms', x) = f ms putModuleState ms' return x -- $context -- -- The inline C functions ('cexp', 'c', etc.) need a 'Context' to -- operate. Said context can be explicitely set with 'setContext'. -- Otherwise, at the first usage of one of the TH functions in this -- module the 'Context' is implicitely set to 'baseCtx'. -- | Sets the 'Context' for the current module. This function, if -- called, must be called before any of the other TH functions in this -- module. Fails if that's not the case. setContext :: Context -> TH.Q () setContext ctx = do mbModuleState <- getModuleState forM_ mbModuleState $ \_ms -> fail "inline-c: The module has already been initialised (setContext)." void $ initialiseModuleState $ Just ctx bumpGeneratedNames :: TH.Q Int bumpGeneratedNames = do modifyModuleState $ \ms -> let c' = msGeneratedNames ms in (ms{msGeneratedNames = c' + 1}, c') ------------------------------------------------------------------------ -- Emitting -- | Simply appends some string to the module's C file. Use with care. emitVerbatim :: String -> TH.DecsQ emitVerbatim s = do -- Make sure that the 'ModuleState' is initialized void (initialiseModuleState Nothing) let chunk = "\n" ++ s ++ "\n" modifyModuleState $ \ms -> (ms{msFileChunks = chunk : msFileChunks ms}, ()) return [] -- | Simply appends some string of block to the module's C file. Use with care. emitBlock :: TH.QuasiQuoter emitBlock = TH.QuasiQuoter { TH.quoteExp = const $ fail "inline-c: quoteExp not implemented (quoteCode)" , TH.quotePat = const $ fail "inline-c: quotePat not implemented (quoteCode)" , TH.quoteType = const $ fail "inline-c: quoteType not implemented (quoteCode)" , TH.quoteDec = emitVerbatim } ------------------------------------------------------------------------ -- Inlining -- $embedding -- -- We use the 'Code' data structure to represent some C code that we -- want to emit to the module's C file and immediately generate a -- foreign call to. For this reason, 'Code' includes both some C -- definition, and enough information to be able to generate a foreign -- call -- specifically the name of the function to call and the Haskell -- type. -- -- All the quasi-quoters work by constructing a 'Code' and calling -- 'inlineCode'. -- | Data type representing a list of C definitions with a typed and named entry -- function. -- -- We use it as a basis to inline and call C code. data Code = Code { codeCallSafety :: TH.Safety -- ^ Safety of the foreign call. , codeLoc :: Maybe TH.Loc -- ^ The haskell source location used for the #line directive , codeType :: TH.TypeQ -- ^ Type of the foreign call. , codeFunName :: String -- ^ Name of the function to call in the code below. , codeDefs :: String -- ^ The C code. , codeFunPtr :: Bool -- ^ If 'True', the type will be wrapped in 'FunPtr', and -- the call will be static (e.g. prefixed by &). } -- TODO use the #line CPP macro to have the functions in the C file -- refer to the source location in the Haskell file they come from. -- -- See . -- | Inlines a piece of code inline. The resulting 'TH.Exp' will have -- the type specified in the 'codeType'. -- -- In practice, this function outputs the C code to the module's C file, -- and then inserts a foreign call of type 'codeType' calling the -- provided 'codeFunName'. -- -- Example: -- -- @ -- c_add :: Int -> Int -> Int -- c_add = $(do -- here <- TH.location -- inlineCode $ Code -- TH.Unsafe -- Call safety -- (Just here) -- [t| Int -> Int -> Int |] -- Call type -- "francescos_add" -- Call name -- -- C Code -- \"int francescos_add(int x, int y) { int z = x + y; return z; }\") -- @ inlineCode :: Code -> TH.ExpQ inlineCode Code{..} = do -- Write out definitions ctx <- getContext let out = fromMaybe id $ ctxOutput ctx let directive = maybe "" lineDirective codeLoc void $ emitVerbatim $ out $ directive ++ codeDefs -- Create and add the FFI declaration. ffiImportName <- uniqueFfiImportName -- Note [ghcide-support] -- haskell-language-server / ghcide cannot handle code that use -- `addForeignFile`/`addForeignSource` as we do here; it will result -- in linker errors during TH evaluations, see: -- -- Thus for GHCIDE, simply generate a call to `error` instead of a call to a foreign import. usingGhcide <- TH.runIO $ isJust <$> lookupEnv "__GHCIDE__" if usingGhcide then do [e|error "inline-c: A 'usingGhcide' inlineCode stub was evaluated -- this should not happen" :: $(if codeFunPtr then [t| FunPtr $(codeType) |] else codeType) |] else do -- Actual foreign function call generation. dec <- if codeFunPtr then TH.forImpD TH.CCall codeCallSafety ("&" ++ codeFunName) ffiImportName [t| FunPtr $(codeType) |] else TH.forImpD TH.CCall codeCallSafety codeFunName ffiImportName codeType TH.addTopDecls [dec] TH.varE ffiImportName uniqueCName :: Maybe String -> TH.Q String uniqueCName mbPostfix = do -- The name looks like this: -- inline_c_MODULE_INDEX_POSTFIX -- -- Where: -- * MODULE is the module name but with _s instead of .s; -- * INDEX is a counter that keeps track of how many names we're generating -- for each module. -- * POSTFIX is an optional postfix to ease debuggability -- -- we previously also generated a hash from the contents of the -- C code because of problems when cabal recompiled but now this -- is not needed anymore since we use 'addDependentFile' to compile -- the C code. c' <- bumpGeneratedNames module_ <- TH.loc_module <$> TH.location let replaceDot '.' = '_' replaceDot c = c let postfix = case mbPostfix of Nothing -> "" Just s -> "_" ++ s ++ "_" return $ "inline_c_" ++ map replaceDot module_ ++ "_" ++ show c' ++ postfix -- | Same as 'inlineCItems', but with a single expression. -- -- @ -- c_cos :: Double -> Double -- c_cos = $(do -- here <- TH.location -- inlineExp -- TH.Unsafe -- here -- [t| Double -> Double |] -- (quickCParser_ \"double\" parseType) -- [("x", quickCParser_ \"double\" parseType)] -- "cos(x)") -- @ inlineExp :: TH.Safety -- ^ Safety of the foreign call -> TH.Loc -- ^ The location to report -> TH.TypeQ -- ^ Type of the foreign call -> C.Type C.CIdentifier -- ^ Return type of the C expr -> [(C.CIdentifier, C.Type C.CIdentifier)] -- ^ Parameters of the C expr -> String -- ^ The C expression -> TH.ExpQ inlineExp callSafety loc type_ cRetType cParams cExp = inlineItems callSafety False Nothing loc type_ cRetType cParams cItems where cItems = case cRetType of C.TypeSpecifier _quals C.Void -> cExp ++ ";" _ -> "return (" ++ cExp ++ ");" -- | Same as 'inlineCode', but accepts a string containing a list of C -- statements instead instead than a full-blown 'Code'. A function -- containing the provided statement will be automatically generated. -- -- @ -- c_cos :: Double -> Double -- c_cos = $(do -- here <- TH.location -- inlineItems -- TH.Unsafe -- False -- Nothing -- here -- [t| Double -> Double |] -- (quickCParser_ \"double\" parseType) -- [("x", quickCParser_ \"double\" parseType)] -- "return cos(x);") -- @ inlineItems :: TH.Safety -- ^ Safety of the foreign call -> Bool -- ^ Whether to return as a FunPtr or not -> Maybe String -- ^ Optional postfix for the generated name -> TH.Loc -- ^ The location to report -> TH.TypeQ -- ^ Type of the foreign call -> C.Type C.CIdentifier -- ^ Return type of the C expr -> [(C.CIdentifier, C.Type C.CIdentifier)] -- ^ Parameters of the C expr -> String -- ^ The C items -> TH.ExpQ inlineItems callSafety funPtr mbPostfix loc type_ cRetType cParams cItems = do let mkParam (id', paramTy) = C.ParameterDeclaration (Just id') paramTy let proto = C.Proto cRetType (map mkParam cParams) ctx <- getContext funName <- uniqueCName mbPostfix cFunName <- case C.cIdentifierFromString (ctxEnableCpp ctx) funName of Left err -> fail $ "inlineItems: impossible, generated bad C identifier " ++ "funName:\n" ++ err Right x -> return x let decl = C.ParameterDeclaration (Just cFunName) proto let defs = prettyOneLine (PP.pretty decl) ++ " { " ++ cItems ++ " }\n" inlineCode $ Code { codeCallSafety = callSafety , codeLoc = Just loc , codeType = type_ , codeFunName = funName , codeDefs = defs , codeFunPtr = funPtr } ------------------------------------------------------------------------ -- Parsing runParserInQ :: (Hashable ident) => String -> C.CParserContext ident -> (forall m. C.CParser ident m => m a) -> TH.Q a runParserInQ s ctx p = do loc <- TH.location let (line, col) = TH.loc_start loc let parsecLoc = Parsec.newPos (TH.loc_filename loc) line col let p' = lift (Parsec.setPosition parsecLoc) *> p <* lift Parser.eof case C.runCParser ctx (TH.loc_filename loc) s p' of Left err -> do -- TODO consider prefixing with "error while parsing C" or similar fail $ show err Right res -> do return res data SomeEq = forall a. (Typeable a, Eq a) => SomeEq a instance Eq SomeEq where SomeEq x == SomeEq y = case cast x of Nothing -> False Just x' -> x' == y instance Show SomeEq where show _ = "<>" toSomeEq :: (Eq a, Typeable a) => a -> SomeEq toSomeEq x = SomeEq x fromSomeEq :: (Eq a, Typeable a) => SomeEq -> Maybe a fromSomeEq (SomeEq x) = cast x data ParameterType = Plain HaskellIdentifier -- The name of the captured variable | AntiQuote AntiQuoterId SomeEq deriving (Show, Eq) data ParseTypedC = ParseTypedC { ptcReturnType :: C.Type C.CIdentifier , ptcParameters :: [(C.CIdentifier, C.Type C.CIdentifier, ParameterType)] , ptcBody :: String } newtype Substitutions = Substitutions { unSubstitutions :: M.Map String (String -> String) } applySubstitutions :: String -> TH.Q String applySubstitutions str = do subs <- maybe mempty unSubstitutions <$> TH.getQ let substitution = msum $ flip map (M.toList subs) $ \( subName, subFunc ) -> Parsec.try $ do _ <- Parsec.string ('@' : subName ++ "(") subArg <- Parsec.manyTill Parsec.anyChar (Parsec.char ')') return (subFunc subArg) let someChar = (:[]) <$> Parsec.anyChar case Parsec.parse (many (substitution <|> someChar)) "" str of Left _ -> fail "Substitution failed (should be impossible)" Right chunks -> return (concat chunks) -- | Define macros that can be used in the nested Template Haskell expression. -- Macros can be used as @\@MACRO_NAME(input)@ in inline-c quotes, and will transform their input with the given function. -- They can be useful for passing in types when defining Haskell instances for C++ template types. substitute :: [ ( String, String -> String ) ] -> TH.Q a -> TH.Q a substitute subsList cont = do oldSubs <- maybe mempty unSubstitutions <$> TH.getQ let subs = M.fromList subsList let conflicting = M.intersection subs oldSubs newSubs <- if M.null conflicting then return (Substitutions (M.union oldSubs subs)) else fail ("Conflicting substitutions `" ++ show (M.keys conflicting) ++ "`") TH.putQ newSubs *> cont <* TH.putQ (Substitutions oldSubs) -- | Given a C type name, return the Haskell type in Template Haskell. The first parameter controls whether function pointers -- should be mapped as pure or IO functions. getHaskellType :: Bool -> String -> TH.TypeQ getHaskellType pureFunctions cTypeStr = do ctx <- getContext let cParseCtx = C.cCParserContext (ctxEnableCpp ctx) (typeNamesFromTypesTable (ctxTypesTable ctx)) cType <- runParserInQ cTypeStr cParseCtx C.parseType cToHs ctx (if pureFunctions then Pure else IO) cType -- To parse C declarations, we're faced with a bit of a problem: we want -- to parse the anti-quotations so that Haskell identifiers are -- accepted, but we want them to appear only as the root of -- declarations. For this reason, we parse allowing Haskell identifiers -- everywhere, and then we "purge" Haskell identifiers everywhere but at -- the root. parseTypedC :: forall m. C.CParser HaskellIdentifier m => Bool -> AntiQuoters -> m ParseTypedC -- ^ Returns the return type, the captured variables, and the body. parseTypedC useCpp antiQs = do -- Parse return type (consume spaces first) Parser.spaces cRetType <- purgeHaskellIdentifiers =<< C.parseType -- Parse the body void $ Parser.char '{' (cParams, cBody) <- evalStateT parseBody 0 return $ ParseTypedC cRetType cParams cBody where parseBody :: StateT Int m ([(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String) parseBody = do -- Note that this code does not use "lexing" combinators (apart -- when appropriate) because we want to make sure to preserve -- whitespace after we substitute things. s <- Parser.manyTill Parser.anyChar $ Parser.lookAhead (Parser.char '}' <|> Parser.char '$') (decls, s') <- msum [ do Parser.try $ do -- Try because we might fail to parse the 'eof' -- 'symbolic' because we want to consume whitespace void $ Parser.symbolic '}' Parser.eof return ([], "") , do void $ Parser.char '}' (decls, s') <- parseBody return (decls, "}" ++ s') , do void $ Parser.char '$' (decls1, s1) <- parseEscapedDollar <|> parseAntiQuote <|> parseTypedCapture (decls2, s2) <- parseBody return (decls1 ++ decls2, s1 ++ s2) ] return (decls, s ++ s') where parseAntiQuote :: StateT Int m ([(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String) parseAntiQuote = msum [ do void $ Parser.try (Parser.string $ antiQId ++ ":") Parser. "anti quoter id" (s, cTy, x) <- aqParser antiQ id' <- freshId s return ([(id', cTy, AntiQuote antiQId (toSomeEq x))], C.unCIdentifier id') | (antiQId, SomeAntiQuoter antiQ) <- Map.toList antiQs ] parseEscapedDollar :: StateT Int m ([a], String) parseEscapedDollar = do void $ Parser.char '$' return ([], "$") parseTypedCapture :: StateT Int m ([(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String) parseTypedCapture = do void $ Parser.symbolic '(' decl <- C.parseParameterDeclaration declType <- purgeHaskellIdentifiers $ C.parameterDeclarationType decl -- Purge the declaration type of all the Haskell identifiers. hId <- case C.parameterDeclarationId decl of Nothing -> fail $ pretty80 $ "Un-named captured variable in decl" <+> PP.pretty decl Just hId -> return hId id' <- freshId $ mangleHaskellIdentifier useCpp hId void $ Parser.char ')' return ([(id', declType, Plain hId)], C.unCIdentifier id') freshId s = do c <- get put $ c + 1 case C.cIdentifierFromString useCpp (C.unCIdentifier s ++ "_inline_c_" ++ show c) of Left _err -> error "freshId: The impossible happened" Right x -> return x -- The @m@ is polymorphic because we use this both for the plain -- parser and the StateT parser we use above. We only need 'fail'. purgeHaskellIdentifiers #if MIN_VERSION_base(4,13,0) :: forall n. MonadFail n #else :: forall n. (Applicative n, Monad n) #endif => C.Type HaskellIdentifier -> n (C.Type C.CIdentifier) purgeHaskellIdentifiers cTy = for cTy $ \hsIdent -> do let hsIdentS = unHaskellIdentifier hsIdent case C.cIdentifierFromString useCpp hsIdentS of Left err -> fail $ "Haskell identifier " ++ hsIdentS ++ " in illegal position" ++ "in C type\n" ++ pretty80 (PP.pretty cTy) ++ "\n" ++ "A C identifier was expected, but:\n" ++ err Right cIdent -> return cIdent quoteCode :: (String -> TH.ExpQ) -- ^ The parser -> TH.QuasiQuoter quoteCode p = TH.QuasiQuoter { TH.quoteExp = p , TH.quotePat = const $ fail "inline-c: quotePat not implemented (quoteCode)" , TH.quoteType = const $ fail "inline-c: quoteType not implemented (quoteCode)" , TH.quoteDec = const $ fail "inline-c: quoteDec not implemented (quoteCode)" } cToHs :: Context -> Purity -> C.Type C.CIdentifier -> TH.TypeQ cToHs ctx purity cTy = do mbHsTy <- convertType purity (ctxTypesTable ctx) cTy case mbHsTy of Nothing -> fail $ "Could not resolve Haskell type for C type " ++ pretty80 (PP.pretty cTy) Just hsTy -> return hsTy genericQuote :: Purity -> (TH.Loc -> TH.TypeQ -> C.Type C.CIdentifier -> [(C.CIdentifier, C.Type C.CIdentifier)] -> String -> TH.ExpQ) -- ^ Function building an Haskell expression, see 'inlineExp' for -- guidance on the other args. -> TH.QuasiQuoter genericQuote purity build = quoteCode $ \rawStr -> do ctx <- getContext here <- TH.location s <- applySubstitutions rawStr ParseTypedC cType cParams cExp <- runParserInQ s (haskellCParserContext (ctxEnableCpp ctx) (typeNamesFromTypesTable (ctxTypesTable ctx))) (parseTypedC (ctxEnableCpp ctx) (ctxAntiQuoters ctx)) hsType <- cToHs ctx purity cType hsParams <- forM cParams $ \(_cId, cTy, parTy) -> do case parTy of Plain s' -> do hsTy <- cToHs ctx purity cTy let hsName = TH.mkName (unHaskellIdentifier s') hsExp <- [| \cont -> cont ($(TH.varE hsName) :: $(return hsTy)) |] return (hsTy, hsExp) AntiQuote antiId dyn -> do case Map.lookup antiId (ctxAntiQuoters ctx) of Nothing -> fail $ "IMPOSSIBLE: could not find anti-quoter " ++ show antiId ++ ". (genericQuote)" Just (SomeAntiQuoter antiQ) -> case fromSomeEq dyn of Nothing -> fail $ "IMPOSSIBLE: could not cast value for anti-quoter " ++ show antiId ++ ". (genericQuote)" Just x -> aqMarshaller antiQ purity (ctxTypesTable ctx) cTy x let hsFunType = convertCFunSig hsType $ map fst hsParams let cParams' = [(cId, cTy) | (cId, cTy, _) <- cParams] ioCall <- buildFunCall ctx (build here hsFunType cType cParams' cExp) (map snd hsParams) [] -- If the user requested a pure function, make it so. case purity of -- Using unsafeDupablePerformIO to increase performance of pure calls, see Pure -> [| unsafeDupablePerformIO $(return ioCall) |] IO -> return ioCall where buildFunCall :: Context -> TH.ExpQ -> [TH.Exp] -> [TH.Name] -> TH.ExpQ buildFunCall _ctx f [] args = foldl (\f' arg -> [| $f' $(TH.varE arg) |]) f args buildFunCall ctx f (hsExp : params) args = [| $(return hsExp) $ \arg -> $(buildFunCall ctx f params (args ++ ['arg])) |] convertCFunSig :: TH.Type -> [TH.Type] -> TH.TypeQ convertCFunSig retType params0 = do go params0 where go [] = [t| IO $(return retType) |] go (paramType : params) = do [t| $(return paramType) -> $(go params) |] -- NOTE: splitTypedC wouldn't be necessary if inline-c-cpp could reuse C.block -- internals with a clean interface. -- This would be a significant refactoring but presumably it would lead to an -- api that could let users write their own quasiquoters a bit more conveniently. -- | Returns the type and the body separately. splitTypedC :: String -> (String, String, Int) splitTypedC s = (trim ty, bodyIndent <> body, bodyLineShift) where (ty, body) = span (/= '{') s trim x = L.dropWhileEnd C.isSpace (dropWhile C.isSpace x) -- We may need to correct the line number of the body bodyLineShift = length (filter (== '\n') ty) -- Indentation is relevant for error messages when the syntax is: -- [C.foo| type -- { foo(); } -- |] bodyIndent = let precedingSpaceReversed = takeWhile (\c -> C.isSpace c) $ reverse $ ty (precedingSpacesTabsReversed, precedingLine) = span (`notElem` ("\n\r" :: [Char])) precedingSpaceReversed in case precedingLine of ('\n':_) -> reverse precedingSpacesTabsReversed ('\r':_) -> reverse precedingSpacesTabsReversed _ -> "" -- it wasn't indentation after all; just spaces after the type -- | Data to parse for the 'funPtr' quasi-quoter. data FunPtrDecl = FunPtrDecl { funPtrReturnType :: C.Type C.CIdentifier , funPtrParameters :: [(C.CIdentifier, C.Type C.CIdentifier)] , funPtrBody :: String , funPtrName :: Maybe String } deriving (Eq, Show) funPtrQuote :: TH.Safety -> TH.QuasiQuoter funPtrQuote callSafety = quoteCode $ \rawCode -> do loc <- TH.location ctx <- getContext code <- applySubstitutions rawCode FunPtrDecl{..} <- runParserInQ code (C.cCParserContext (ctxEnableCpp ctx) (typeNamesFromTypesTable (ctxTypesTable ctx))) parse hsRetType <- cToHs ctx IO funPtrReturnType hsParams <- forM funPtrParameters (\(_ident, typ_) -> cToHs ctx IO typ_) let hsFunType = convertCFunSig hsRetType hsParams inlineItems callSafety True funPtrName loc hsFunType funPtrReturnType funPtrParameters funPtrBody where convertCFunSig :: TH.Type -> [TH.Type] -> TH.TypeQ convertCFunSig retType params0 = do go params0 where go [] = [t| IO $(return retType) |] go (paramType : params) = do [t| $(return paramType) -> $(go params) |] parse :: C.CParser C.CIdentifier m => m FunPtrDecl parse = do -- skip spaces Parser.spaces -- parse a proto C.ParameterDeclaration mbName protoTyp <- C.parseParameterDeclaration case protoTyp of C.Proto retType paramList -> do args <- forM paramList $ \decl -> case C.parameterDeclarationId decl of Nothing -> fail $ pretty80 $ "Un-named captured variable in decl" <+> PP.pretty decl Just declId -> return (declId, C.parameterDeclarationType decl) -- get the rest of the body void (Parser.symbolic '{') body <- parseBody return FunPtrDecl { funPtrReturnType = retType , funPtrParameters = args , funPtrBody = body , funPtrName = fmap C.unCIdentifier mbName } _ -> fail $ "Expecting function declaration" parseBody :: C.CParser C.CIdentifier m => m String parseBody = do s <- Parser.manyTill Parser.anyChar $ Parser.lookAhead (Parser.char '}') s' <- msum [ do Parser.try $ do -- Try because we might fail to parse the 'eof' -- 'symbolic' because we want to consume whitespace void $ Parser.symbolic '}' Parser.eof return "" , do void $ Parser.char '}' s' <- parseBody return ("}" ++ s') ] return (s ++ s') ------------------------------------------------------------------------ -- Line directives -- | Tell the C compiler where the next line came from. -- -- Example: -- -- @@@ -- there <- location -- f (unlines -- [ lineDirective $(here) -- , "generated_code_user_did_not_write()" -- , lineDirective there -- ] ++ userCode -- ]) -- @@@ -- -- Use @lineDirective $(C.here)@ when generating code, so that any errors or -- warnings report the location of the generating haskell module, rather than -- tangentially related user code that doesn't contain the actual problem. lineDirective :: TH.Loc -> String lineDirective l = "#line " ++ show (fst $ TH.loc_start l) ++ " " ++ show (TH.loc_filename l ) ++ "\n" -- | Get the location of the code you're looking at, for use with -- 'lineDirective'; place before generated code that user did not write. here :: TH.ExpQ here = [| $(TH.location >>= \(TH.Loc a b c (d1, d2) (e1, e2)) -> [|Loc $(TH.lift a) $(TH.lift b) $(TH.lift c) ($(TH.lift d1), $(TH.lift d2)) ($(TH.lift e1), $(TH.lift e2)) |]) |] shiftLines :: Int -> TH.Loc -> TH.Loc shiftLines n l = l { TH.loc_start = let (startLn, startCol) = TH.loc_start l in (startLn + n, startCol) , TH.loc_end = let (endLn, endCol) = TH.loc_end l in (endLn + n, endCol) } ------------------------------------------------------------------------ -- Utils pretty80 :: PP.Doc ann -> String pretty80 x = PP.renderString $ PP.layoutSmart (PP.LayoutOptions { PP.layoutPageWidth = PP.AvailablePerLine 80 0.8 }) x prettyOneLine :: PP.Doc ann -> String prettyOneLine x = PP.renderString $ PP.layoutCompact x inline-c-0.9.1.10/src/Language/C/Inline/Unsafe.hs0000644000000000000000000000364014503767417017334 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | @unsafe@ variants of the "Language.C.Inline" quasi-quoters, to call the C code -- unsafely in the sense of -- . -- In GHC, unsafe foreign calls are faster than safe foreign calls, but the user -- must guarantee the control flow will never enter Haskell code (via a callback -- or otherwise) before the call is done. -- -- This module is intended to be imported qualified: -- -- @ -- import qualified "Language.C.Inline.Unsafe" as CU -- @ module Language.C.Inline.Unsafe ( exp , pure , block ) where #if __GLASGOW_HASKELL__ < 710 import Prelude hiding (exp) #else import Prelude hiding (exp, pure) #endif import qualified Language.Haskell.TH.Quote as TH import qualified Language.Haskell.TH.Syntax as TH import Language.C.Inline.Context import Language.C.Inline.Internal -- | C expressions. exp :: TH.QuasiQuoter exp = genericQuote IO $ inlineExp TH.Unsafe -- | Variant of 'exp', for use with expressions known to have no side effects. -- -- __BEWARE__: Use this function with caution, only when you know what you are -- doing. If an expression does in fact have side-effects, then indiscriminate -- use of 'pure' may endanger referential transparency, and in principle even -- type safety. Also note that the function may run more than once and that it -- may run in parallel with itself, given that -- 'System.IO.Unsafe.unsafeDupablePerformIO' is used to call the provided C -- code [to ensure good performance using the threaded -- runtime](https://github.com/fpco/inline-c/issues/115). Please refer to the -- documentation for 'System.IO.Unsafe.unsafeDupablePerformIO' for more -- details. pure :: TH.QuasiQuoter pure = genericQuote Pure $ inlineExp TH.Unsafe -- | C code blocks (i.e. statements). block :: TH.QuasiQuoter block = genericQuote IO $ inlineItems TH.Unsafe False Nothing inline-c-0.9.1.10/src/Language/C/Inline/Interruptible.hs0000644000000000000000000000344214503767417020743 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | @interruptible@ variants of the "Language.C.Inline" quasi-quoters, to call -- interruptible C code. See -- for more information. -- -- This module is intended to be imported qualified: -- -- @ -- import qualified "Language.C.Inline.Interruptible" as CI -- @ module Language.C.Inline.Interruptible ( exp , pure , block ) where #if __GLASGOW_HASKELL__ < 710 import Prelude hiding (exp) #else import Prelude hiding (exp, pure) #endif import qualified Language.Haskell.TH.Quote as TH import qualified Language.Haskell.TH.Syntax as TH import Language.C.Inline.Context import Language.C.Inline.Internal -- | C expressions. exp :: TH.QuasiQuoter exp = genericQuote IO $ inlineExp TH.Interruptible -- | Variant of 'exp', for use with expressions known to have no side effects. -- -- __BEWARE__: Use this function with caution, only when you know what you are -- doing. If an expression does in fact have side-effects, then indiscriminate -- use of 'pure' may endanger referential transparency, and in principle even -- type safety. Also note that the function may run more than once and that it -- may run in parallel with itself, given that -- 'System.IO.Unsafe.unsafeDupablePerformIO' is used to call the provided C -- code [to ensure good performance using the threaded -- runtime](https://github.com/fpco/inline-c/issues/115). Please refer to the -- documentation for 'System.IO.Unsafe.unsafeDupablePerformIO' for more -- details. pure :: TH.QuasiQuoter pure = genericQuote Pure $ inlineExp TH.Interruptible -- | C code blocks (i.e. statements). block :: TH.QuasiQuoter block = genericQuote IO $ inlineItems TH.Interruptible False Nothing inline-c-0.9.1.10/src/Language/C/Types.hs0000644000000000000000000004714114503767417016005 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -- | Views of C datatypes. While "Language.C.Types.Parse" defines datatypes for -- representing the concrete syntax tree of C types, this module provides -- friendlier views of C types, by turning them into a data type matching more -- closely how we read and think about types, both in Haskell and in C. To -- appreciate the difference, look at the difference between -- 'P.ParameterDeclaration' and 'ParameterDeclaration'. -- -- As a bonus, routines are provided for describing types in natural language -- (English) -- see 'describeParameterDeclaration' and 'describeType'. module Language.C.Types ( -- * Types P.CIdentifier , P.unCIdentifier , P.cIdentifierFromString , P.StorageClassSpecifier(..) , P.TypeQualifier(..) , P.FunctionSpecifier(..) , P.ArrayType(..) , Specifiers(..) , Type(..) , TypeSpecifier(..) , Sign(..) , ParameterDeclaration(..) -- * Parsing , P.TypeNames , P.CParser , P.CParserContext , P.cCParserContext , P.runCParser , P.quickCParser , P.quickCParser_ , parseParameterDeclaration , parseParameterList , parseIdentifier , parseEnableCpp , parseType -- * Convert to and from high-level views , UntangleErr(..) , untangleParameterDeclaration , tangleParameterDeclaration -- * To english , describeParameterDeclaration , describeType ) where import Control.Arrow (second) import Control.Monad (when, unless, forM_, forM) import Control.Monad.State (execState, modify) import Control.Monad.Reader (ask) import Data.List (partition, intersperse) import Data.Maybe (fromMaybe) import Data.String (fromString) import Data.Typeable (Typeable) import Prettyprinter ((<+>)) import qualified Prettyprinter as PP import qualified Prettyprinter.Render.String as PP #if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup, (<>)) #else import Data.Monoid ((<>)) #endif #if __GLASGOW_HASKELL__ < 710 import Data.Foldable (Foldable) import Data.Functor ((<$>)) import Data.Monoid (Monoid(..)) import Data.Traversable (Traversable) #endif import qualified Language.C.Types.Parse as P ------------------------------------------------------------------------ -- Proper types data TypeSpecifier = Void | Bool | Char (Maybe Sign) | Short Sign | Int Sign | Long Sign | LLong Sign | Float | Double | LDouble | TypeName P.CIdentifier | Struct P.CIdentifier | Enum P.CIdentifier | Template P.CIdentifier [TypeSpecifier] | TemplateConst String | TemplatePointer TypeSpecifier deriving (Typeable, Show, Eq, Ord) data Specifiers = Specifiers { storageClassSpecifiers :: [P.StorageClassSpecifier] , typeQualifiers :: [P.TypeQualifier] , functionSpecifiers :: [P.FunctionSpecifier] } deriving (Typeable, Show, Eq) #if MIN_VERSION_base(4,9,0) instance Semigroup Specifiers where Specifiers x1 y1 z1 <> Specifiers x2 y2 z2 = Specifiers (x1 ++ x2) (y1 ++ y2) (z1 ++ z2) #endif instance Monoid Specifiers where mempty = Specifiers [] [] [] #if !MIN_VERSION_base(4,11,0) mappend (Specifiers x1 y1 z1) (Specifiers x2 y2 z2) = Specifiers (x1 ++ x2) (y1 ++ y2) (z1 ++ z2) #endif data Type i = TypeSpecifier Specifiers TypeSpecifier | Ptr [P.TypeQualifier] (Type i) | Array (P.ArrayType i) (Type i) | Proto (Type i) [ParameterDeclaration i] deriving (Typeable, Show, Eq, Functor, Foldable, Traversable) data Sign = Signed | Unsigned deriving (Typeable, Show, Eq, Ord) data ParameterDeclaration i = ParameterDeclaration { parameterDeclarationId :: Maybe i , parameterDeclarationType :: (Type i) } deriving (Typeable, Show, Eq, Functor, Foldable, Traversable) ------------------------------------------------------------------------ -- Conversion data UntangleErr = MultipleDataTypes [P.DeclarationSpecifier] | NoDataTypes [P.DeclarationSpecifier] | IllegalSpecifiers String [P.TypeSpecifier] deriving (Typeable, Show, Eq) failConversion :: UntangleErr -> Either UntangleErr a failConversion = Left untangleParameterDeclaration :: P.ParameterDeclaration i -> Either UntangleErr (ParameterDeclaration i) untangleParameterDeclaration P.ParameterDeclaration{..} = do (specs, tySpec) <- untangleDeclarationSpecifiers parameterDeclarationSpecifiers let baseTy = TypeSpecifier specs tySpec (mbS, ty) <- case parameterDeclarationDeclarator of P.IsDeclarator decltor -> do (s, ty) <- untangleDeclarator baseTy decltor return (Just s, ty) P.IsAbstractDeclarator decltor -> (Nothing, ) <$> untangleAbstractDeclarator baseTy decltor return $ ParameterDeclaration mbS ty untangleDeclarationSpecifiers :: [P.DeclarationSpecifier] -> Either UntangleErr (Specifiers, TypeSpecifier) untangleDeclarationSpecifiers declSpecs = do let (pStorage, pTySpecs, pTyQuals, pFunSpecs) = flip execState ([], [], [], []) $ do forM_ (reverse declSpecs) $ \declSpec -> case declSpec of P.StorageClassSpecifier x -> modify $ \(a, b, c, d) -> (x:a, b, c, d) P.TypeSpecifier x -> modify $ \(a, b, c, d) -> (a, x:b, c, d) P.TypeQualifier x -> modify $ \(a, b, c, d) -> (a, b, x:c, d) P.FunctionSpecifier x -> modify $ \(a, b, c, d) -> (a, b, c, x:d) tySpec <- type2type pTySpecs return (Specifiers pStorage pTyQuals pFunSpecs, tySpec) where type2type pTySpecs = do -- Split data type and specifiers let (dataTypes, specs) = partition (\x -> not (x `elem` [P.SIGNED, P.UNSIGNED, P.LONG, P.SHORT])) pTySpecs let illegalSpecifiers s = failConversion $ IllegalSpecifiers s specs -- Find out sign, if present mbSign0 <- case filter (== P.SIGNED) specs of [] -> return Nothing [_] -> return $ Just Signed _:_ -> illegalSpecifiers "conflicting/duplicate sign information" mbSign <- case (mbSign0, filter (== P.UNSIGNED) specs) of (Nothing, []) -> return Nothing (Nothing, [_]) -> return $ Just Unsigned (Just b, []) -> return $ Just b _ -> illegalSpecifiers "conflicting/duplicate sign information" let sign = fromMaybe Signed mbSign -- Find out length let longs = length $ filter (== P.LONG) specs let shorts = length $ filter (== P.SHORT) specs when (longs > 0 && shorts > 0) $ illegalSpecifiers "both long and short" -- Find out data type dataType <- case dataTypes of [x] -> return x [] | mbSign0 == Just Signed -> return P.INT -- "The Case of 'signed' not including 'signed int'" [] | mbSign == Just Unsigned -> return P.INT -- "The Case of 'unsigned' not including 'unsigned int'" [] | longs > 0 || shorts > 0 -> return P.INT [] -> failConversion $ NoDataTypes declSpecs _:_ -> failConversion $ MultipleDataTypes declSpecs -- Check if things are compatible with one another let checkNoSpecs = unless (null specs) $ illegalSpecifiers "expecting no specifiers" let checkNoLength = when (longs > 0 || shorts > 0) $ illegalSpecifiers "unexpected long/short" case dataType of P.Template s args -> do checkNoSpecs args' <- forM args type2type return $ Template s args' P.TemplateConst s -> do checkNoSpecs return $ TemplateConst s P.TemplatePointer s -> do checkNoSpecs s' <- type2type [s] return $ TemplatePointer s' P.TypeName s -> do checkNoSpecs return $ TypeName s P.Struct s -> do checkNoSpecs return $ Struct s P.Enum s -> do checkNoSpecs return $ Enum s P.VOID -> do checkNoSpecs return Void P.BOOL -> do checkNoLength return $ Bool P.CHAR -> do checkNoLength return $ Char mbSign P.INT | longs == 0 && shorts == 0 -> do return $ Int sign P.INT | longs == 1 -> do return $ Long sign P.INT | longs == 2 -> do return $ LLong sign P.INT | shorts == 1 -> do return $ Short sign P.INT -> do illegalSpecifiers "too many long/short" P.FLOAT -> do checkNoLength return Float P.DOUBLE -> do if longs == 1 then return LDouble else do checkNoLength return Double _ -> do error $ "untangleDeclarationSpecifiers impossible: " ++ show dataType untangleDeclarator :: forall i. Type i -> P.Declarator i -> Either UntangleErr (i, Type i) untangleDeclarator ty0 (P.Declarator ptrs0 directDecltor) = go ty0 ptrs0 where go :: Type i -> [P.Pointer] -> Either UntangleErr (i, Type i) go ty [] = goDirect ty directDecltor go ty (P.Pointer quals : ptrs) = go (Ptr quals ty) ptrs goDirect :: Type i -> P.DirectDeclarator i -> Either UntangleErr (i, Type i) goDirect ty direct0 = case direct0 of P.DeclaratorRoot s -> return (s, ty) P.ArrayOrProto direct (P.Array arrayType) -> goDirect (Array arrayType ty) direct P.ArrayOrProto direct (P.Proto params) -> do params' <- mapM untangleParameterDeclaration params goDirect (Proto ty params') direct P.DeclaratorParens decltor -> untangleDeclarator ty decltor untangleAbstractDeclarator :: forall i. Type i -> P.AbstractDeclarator i -> Either UntangleErr (Type i) untangleAbstractDeclarator ty0 (P.AbstractDeclarator ptrs0 mbDirectDecltor) = go ty0 ptrs0 where go :: Type i -> [P.Pointer] -> Either UntangleErr (Type i) go ty [] = case mbDirectDecltor of Nothing -> return ty Just directDecltor -> goDirect ty directDecltor go ty (P.Pointer quals : ptrs) = go (Ptr quals ty) ptrs goDirect :: Type i -> P.DirectAbstractDeclarator i -> Either UntangleErr (Type i) goDirect ty direct0 = case direct0 of P.ArrayOrProtoThere direct (P.Array arrayType) -> goDirect (Array arrayType ty) direct P.ArrayOrProtoThere direct (P.Proto params) -> do params' <- mapM untangleParameterDeclaration params goDirect (Proto ty params') direct P.ArrayOrProtoHere (P.Array arrayType) -> return $ Array arrayType ty P.ArrayOrProtoHere (P.Proto params) -> do params' <- mapM untangleParameterDeclaration params return $ Proto ty params' P.AbstractDeclaratorParens decltor -> untangleAbstractDeclarator ty decltor ------------------------------------------------------------------------ -- Tangling tangleParameterDeclaration :: forall i. ParameterDeclaration i -> P.ParameterDeclaration i tangleParameterDeclaration (ParameterDeclaration mbId ty00) = uncurry P.ParameterDeclaration $ case mbId of Nothing -> second P.IsAbstractDeclarator $ goAbstractDirect ty00 Nothing Just id' -> second P.IsDeclarator $ goConcreteDirect ty00 $ P.DeclaratorRoot id' where goAbstractDirect :: Type i -> Maybe (P.DirectAbstractDeclarator i) -> ([P.DeclarationSpecifier], P.AbstractDeclarator i) goAbstractDirect ty0 mbDirect = case ty0 of TypeSpecifier specifiers tySpec -> let declSpecs = tangleTypeSpecifier specifiers tySpec in (declSpecs, P.AbstractDeclarator [] mbDirect) Ptr tyQuals ty -> goAbstract ty [P.Pointer tyQuals] mbDirect Array arrType ty -> let arr = P.Array arrType in case mbDirect of Nothing -> goAbstractDirect ty $ Just $ P.ArrayOrProtoHere arr Just decltor -> goAbstractDirect ty $ Just $ P.ArrayOrProtoThere decltor arr Proto ty params -> let proto = P.Proto $ map tangleParameterDeclaration params in case mbDirect of Nothing -> goAbstractDirect ty $ Just $ P.ArrayOrProtoHere proto Just decltor -> goAbstractDirect ty $ Just $ P.ArrayOrProtoThere decltor proto goAbstract :: Type i -> [P.Pointer] -> Maybe (P.DirectAbstractDeclarator i) -> ([P.DeclarationSpecifier], P.AbstractDeclarator i) goAbstract ty0 ptrs mbDirect = case ty0 of TypeSpecifier specifiers tySpec -> let declSpecs = tangleTypeSpecifier specifiers tySpec in (declSpecs, P.AbstractDeclarator ptrs mbDirect) Ptr tyQuals ty -> goAbstract ty (P.Pointer tyQuals : ptrs) mbDirect Array{} -> goAbstractDirect ty0 $ Just $ P.AbstractDeclaratorParens $ P.AbstractDeclarator ptrs mbDirect Proto{} -> goAbstractDirect ty0 $ Just $ P.AbstractDeclaratorParens $ P.AbstractDeclarator ptrs mbDirect goConcreteDirect :: Type i -> P.DirectDeclarator i -> ([P.DeclarationSpecifier], P.Declarator i) goConcreteDirect ty0 direct = case ty0 of TypeSpecifier specifiers tySpec -> let declSpecs = tangleTypeSpecifier specifiers tySpec in (declSpecs, P.Declarator [] direct) Ptr tyQuals ty -> goConcrete ty [P.Pointer tyQuals] direct Array arrType ty -> goConcreteDirect ty $ P.ArrayOrProto direct $ P.Array arrType Proto ty params -> goConcreteDirect ty $ P.ArrayOrProto direct $ P.Proto $ map tangleParameterDeclaration params goConcrete :: Type i -> [P.Pointer] -> P.DirectDeclarator i -> ([P.DeclarationSpecifier], P.Declarator i) goConcrete ty0 ptrs direct = case ty0 of TypeSpecifier specifiers tySpec -> let declSpecs = tangleTypeSpecifier specifiers tySpec in (declSpecs, P.Declarator ptrs direct) Ptr tyQuals ty -> goConcrete ty (P.Pointer tyQuals : ptrs) direct Array{} -> goConcreteDirect ty0 $ P.DeclaratorParens $ P.Declarator ptrs direct Proto{} -> goConcreteDirect ty0 $ P.DeclaratorParens $ P.Declarator ptrs direct tangleTypeSpecifier :: Specifiers -> TypeSpecifier -> [P.DeclarationSpecifier] tangleTypeSpecifier (Specifiers storages tyQuals funSpecs) tySpec = let pTySpecs ty = case ty of Void -> [P.VOID] Bool -> [P.BOOL] Char Nothing -> [P.CHAR] Char (Just Signed) -> [P.SIGNED, P.CHAR] Char (Just Unsigned) -> [P.UNSIGNED, P.CHAR] Short Signed -> [P.SHORT] Short Unsigned -> [P.UNSIGNED, P.SHORT] Int Signed -> [P.INT] Int Unsigned -> [P.UNSIGNED] Long Signed -> [P.LONG] Long Unsigned -> [P.UNSIGNED, P.LONG] LLong Signed -> [P.LONG, P.LONG] LLong Unsigned -> [P.UNSIGNED, P.LONG, P.LONG] Float -> [P.FLOAT] Double -> [P.DOUBLE] LDouble -> [P.LONG, P.DOUBLE] TypeName s -> [P.TypeName s] Struct s -> [P.Struct s] Enum s -> [P.Enum s] Template s types -> [P.Template s (map pTySpecs types)] TemplateConst s -> [P.TemplateConst s] TemplatePointer type' -> [P.TemplatePointer (head (pTySpecs type'))] in map P.StorageClassSpecifier storages ++ map P.TypeQualifier tyQuals ++ map P.FunctionSpecifier funSpecs ++ map P.TypeSpecifier (pTySpecs tySpec) ------------------------------------------------------------------------ -- To english describeParameterDeclaration :: PP.Pretty i => ParameterDeclaration i -> PP.Doc ann describeParameterDeclaration (ParameterDeclaration mbId ty) = let idDoc = case mbId of Nothing -> "" Just id' -> PP.pretty id' <+> "is a " in idDoc <> describeType ty describeType :: PP.Pretty i => Type i -> PP.Doc ann describeType ty0 = case ty0 of TypeSpecifier specs tySpec -> engSpecs specs <> PP.pretty tySpec Ptr quals ty -> engQuals quals <> "ptr to" <+> describeType ty Array arrTy ty -> engArrTy arrTy <> "of" <+> describeType ty Proto retTy params -> "function from" <+> engParams params <> "returning" <+> describeType retTy where engSpecs (Specifiers [] [] []) = "" engSpecs (Specifiers x y z) = let xs = map P.StorageClassSpecifier x ++ map P.TypeQualifier y ++ map P.FunctionSpecifier z in PP.hsep (map PP.pretty xs) <> " " engQuals = PP.hsep . map PP.pretty engArrTy arrTy = case arrTy of P.VariablySized -> "variably sized array " P.SizedByInteger n -> "array of size" <+> fromString (show n) <> " " P.SizedByIdentifier s -> "array of size" <+> PP.pretty s <> " " P.Unsized -> "array " engParams [] = "" engParams params0 = "(" <> go params0 <> ") " where go xs = case xs of [] -> "" [x] -> describeParameterDeclaration x (x:xs') -> describeParameterDeclaration x <> "," <+> go xs' ------------------------------------------------------------------------ -- Convenient parsing untangleParameterDeclaration' :: (P.CParser i m, PP.Pretty i) => P.ParameterDeclaration i -> m (ParameterDeclaration i) untangleParameterDeclaration' pDecl = case untangleParameterDeclaration pDecl of Left err -> fail $ pretty80 $ PP.vsep ["Error while parsing declaration:", PP.pretty err, PP.pretty pDecl] Right x -> return x parseParameterDeclaration :: (P.CParser i m, PP.Pretty i) => m (ParameterDeclaration i) parseParameterDeclaration = untangleParameterDeclaration' =<< P.parameter_declaration parseParameterList :: (P.CParser i m, PP.Pretty i) => m [ParameterDeclaration i] parseParameterList = mapM untangleParameterDeclaration' =<< P.parameter_list parseIdentifier :: P.CParser i m => m i parseIdentifier = P.identifier_no_lex parseEnableCpp :: P.CParser i m => m Bool parseEnableCpp = do ctx <- ask return (P.cpcEnableCpp ctx) parseType :: (P.CParser i m, PP.Pretty i) => m (Type i) parseType = parameterDeclarationType <$> parseParameterDeclaration ------------------------------------------------------------------------ -- Pretty instance PP.Pretty TypeSpecifier where pretty tySpec = case tySpec of Void -> "void" Bool -> "bool" Char Nothing -> "char" Char (Just Signed) -> "signed char" Char (Just Unsigned) -> "unsigned char" Short Signed -> "short" Short Unsigned -> "unsigned short" Int Signed -> "int" Int Unsigned -> "unsigned" Long Signed -> "long" Long Unsigned -> "unsigned long" LLong Signed -> "long long" LLong Unsigned -> "unsigned long long" Float -> "float" Double -> "double" LDouble -> "long double" TypeName s -> PP.pretty s Struct s -> "struct" <+> PP.pretty s Enum s -> "enum" <+> PP.pretty s Template s args -> PP.pretty s <+> "<" <+> mconcat (intersperse "," (map PP.pretty args)) <+> ">" TemplateConst s -> PP.pretty s TemplatePointer s -> PP.pretty s <+> "*" instance PP.Pretty UntangleErr where pretty err = case err of MultipleDataTypes specs -> PP.vsep ["Multiple data types in", PP.prettyList specs] IllegalSpecifiers s specs -> PP.vsep ["Illegal specifiers," <+> fromString s <> ", in", PP.prettyList specs] NoDataTypes specs -> PP.vsep ["No data types in", PP.prettyList specs] instance PP.Pretty i => PP.Pretty (ParameterDeclaration i) where pretty = PP.pretty . tangleParameterDeclaration instance PP.Pretty i => PP.Pretty (Type i) where pretty ty = PP.pretty $ tangleParameterDeclaration $ ParameterDeclaration Nothing ty ------------------------------------------------------------------------ -- Utils pretty80 :: PP.Doc ann -> String pretty80 x = PP.renderString $ PP.layoutSmart (PP.LayoutOptions { PP.layoutPageWidth = PP.AvailablePerLine 80 0.8 }) x inline-c-0.9.1.10/src/Language/C/Types/Parse.hs0000644000000000000000000006032114503767417017052 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -- | A parser for C99 declarations. Currently, the parser has the following limitations: -- -- * Array sizes can only be @*@, @n@ (where n is a positive integer), @x@ -- (where @x@ is a C identifier). In C99 they can be arbitrary expressions. See -- the @'ArrayType'@ data type. -- -- * @_Bool@, @_Complex@, and @_Imaginary@ are not present. -- -- * Untyped parameter lists (pre-K&R C) are not allowed. -- -- The parser is incremental and generic (see 'CParser'). 'PP.Pretty' -- and 'QC.Arbitrary' instances are provided for all the data types. -- -- The entry point if you want to parse C declarations is -- @'parameter_declaration'@. module Language.C.Types.Parse ( -- * Parser configuration TypeNames , CParserContext(..) -- ** Default configuration , CIdentifier , unCIdentifier , cIdentifierFromString , cCParserContext -- * Parser type , CParser , runCParser , quickCParser , quickCParser_ -- * Types and parsing -- , identifier , identifier_no_lex , DeclarationSpecifier(..) , declaration_specifiers , StorageClassSpecifier(..) , storage_class_specifier , TypeSpecifier(..) , type_specifier , TypeQualifier(..) , type_qualifier , FunctionSpecifier(..) , function_specifier , Declarator(..) , declarator , DirectDeclarator(..) , direct_declarator , ArrayOrProto(..) , array_or_proto , ArrayType(..) , array_type , Pointer(..) , pointer , ParameterDeclaration(..) , DeclaratorOrAbstractDeclarator(..) , parameter_declaration , parameter_list , AbstractDeclarator(..) , abstract_declarator , DirectAbstractDeclarator(..) , direct_abstract_declarator -- * YACC grammar -- $yacc -- * Testing utilities , cIdentStart , cIdentLetter , cReservedWords , isTypeName ) where import Control.Applicative import Control.Monad (msum, void, MonadPlus, unless, when) import Control.Monad.Reader (MonadReader, runReaderT, ReaderT, asks, ask) import Data.List (intersperse) import Data.Functor.Identity (Identity) import qualified Data.HashSet as HashSet import Data.Hashable (Hashable) import Data.Monoid ((<>)) import Data.String (IsString(..)) import Data.Typeable (Typeable) import qualified Text.Parsec as Parsec import Text.Parser.Char import Text.Parser.Combinators import Text.Parser.LookAhead import Text.Parser.Token import qualified Text.Parser.Token.Highlight as Highlight import Prettyprinter (Pretty(..), (<+>), Doc, hsep) import qualified Prettyprinter as PP #if __GLASGOW_HASKELL__ < 710 import Data.Foldable (Foldable) import Data.Traversable (Traversable) #endif ------------------------------------------------------------------------ -- Config -- | A collection of named types (typedefs) type TypeNames = HashSet.HashSet CIdentifier data CParserContext i = CParserContext { cpcIdentName :: String , cpcTypeNames :: TypeNames -- ^ Function used to determine whether an identifier is a type name. , cpcParseIdent :: forall m. CParser i m => m i -- ^ Parses an identifier, *without consuming whitespace afterwards*. , cpcIdentToString :: i -> String , cpcEnableCpp :: Bool } -- | A type for C identifiers. newtype CIdentifier = CIdentifier {unCIdentifier :: String} deriving (Typeable, Eq, Ord, Show, Hashable) cIdentifierFromString :: Bool -> String -> Either String CIdentifier cIdentifierFromString useCpp s = -- Note: it's important not to use 'cidentifier_raw' here, otherwise -- we go in a loop: -- -- @ -- cIdentifierFromString => fromString => cIdentifierFromString => ... -- @ case Parsec.parse (identNoLex useCpp cIdentStyle <* eof) "cIdentifierFromString" s of Left err -> Left $ show err Right x -> Right $ CIdentifier x instance IsString CIdentifier where fromString s = case cIdentifierFromString True s of Left err -> error $ "CIdentifier fromString: invalid string " ++ show s ++ "\n" ++ err Right x -> x cCParserContext :: Bool -> TypeNames -> CParserContext CIdentifier cCParserContext useCpp typeNames = CParserContext { cpcTypeNames = typeNames , cpcParseIdent = cidentifier_no_lex , cpcIdentToString = unCIdentifier , cpcIdentName = "C identifier" , cpcEnableCpp = useCpp } ------------------------------------------------------------------------ -- Parser -- | All the parsing is done using the type classes provided by the -- @parsers@ package. You can use the parsing routines with any of the parsers -- that implement the classes, such as @parsec@ or @trifecta@. -- -- We parametrize the parsing by the type of the variable identifiers, -- @i@. We do so because we use this parser to implement anti-quoters -- referring to Haskell variables, and thus we need to parse Haskell -- identifiers in certain positions. type CParser i m = ( Monad m , Functor m , Applicative m , MonadPlus m , Parsing m , CharParsing m , TokenParsing m , LookAheadParsing m , MonadReader (CParserContext i) m #if (MIN_VERSION_base(4,13,0)) , MonadFail m #endif , Hashable i ) -- | Runs a @'CParser'@ using @parsec@. runCParser :: Parsec.Stream s Identity Char => CParserContext i -> String -- ^ Source name. -> s -- ^ String to parse. -> (ReaderT (CParserContext i) (Parsec.Parsec s ()) a) -- ^ Parser. Anything with type @forall m. CParser i m => m a@ is a -- valid argument. -> Either Parsec.ParseError a runCParser typeNames fn s p = Parsec.parse (runReaderT p typeNames) fn s -- | Useful for quick testing. Uses @\"quickCParser\"@ as source name, and throws -- an 'error' if parsing fails. quickCParser :: CParserContext i -> String -- ^ String to parse. -> (ReaderT (CParserContext i) (Parsec.Parsec String ()) a) -- ^ Parser. Anything with type @forall m. CParser i m => m a@ is a -- valid argument. -> a quickCParser typeNames s p = case runCParser typeNames "quickCParser" s p of Left err -> error $ "quickCParser: " ++ show err Right x -> x -- | Like 'quickCParser', but uses @'cCParserContext' ('const' 'False')@ as -- 'CParserContext'. quickCParser_ :: Bool -> String -- ^ String to parse. -> (ReaderT (CParserContext CIdentifier) (Parsec.Parsec String ()) a) -- ^ Parser. Anything with type @forall m. CParser i m => m a@ is a -- valid argument. -> a quickCParser_ useCpp = quickCParser (cCParserContext useCpp HashSet.empty) cReservedWords :: HashSet.HashSet String cReservedWords = HashSet.fromList [ "auto", "else", "long", "switch" , "break", "enum", "register", "typedef" , "case", "extern", "return", "union" , "char", "float", "short", "unsigned" , "const", "for", "signed", "void" , "continue", "goto", "sizeof", "volatile" , "default", "if", "static", "while" , "do", "int", "struct", "double" ] cIdentStart :: [Char] cIdentStart = ['a'..'z'] ++ ['A'..'Z'] ++ ['_'] cIdentLetter :: [Char] cIdentLetter = ['a'..'z'] ++ ['A'..'Z'] ++ ['_'] ++ ['0'..'9'] cIdentStyle :: (TokenParsing m, Monad m) => IdentifierStyle m cIdentStyle = IdentifierStyle { _styleName = "C identifier" , _styleStart = oneOf cIdentStart , _styleLetter = oneOf cIdentLetter , _styleReserved = cReservedWords , _styleHighlight = Highlight.Identifier , _styleReservedHighlight = Highlight.ReservedIdentifier } data DeclarationSpecifier = StorageClassSpecifier StorageClassSpecifier | TypeSpecifier TypeSpecifier | TypeQualifier TypeQualifier | FunctionSpecifier FunctionSpecifier deriving (Typeable, Eq, Show) declaration_specifiers :: CParser i m => m [DeclarationSpecifier] declaration_specifiers = many1 $ msum [ StorageClassSpecifier <$> storage_class_specifier , TypeSpecifier <$> type_specifier , TypeQualifier <$> type_qualifier , FunctionSpecifier <$> function_specifier ] data StorageClassSpecifier = TYPEDEF | EXTERN | STATIC | AUTO | REGISTER deriving (Typeable, Eq, Show) storage_class_specifier :: CParser i m => m StorageClassSpecifier storage_class_specifier = msum [ TYPEDEF <$ reserve cIdentStyle "typedef" , EXTERN <$ reserve cIdentStyle "extern" , STATIC <$ reserve cIdentStyle "static" , AUTO <$ reserve cIdentStyle "auto" , REGISTER <$ reserve cIdentStyle "register" ] data TypeSpecifier = VOID | BOOL | CHAR | SHORT | INT | LONG | FLOAT | DOUBLE | SIGNED | UNSIGNED | Struct CIdentifier | Enum CIdentifier | TypeName CIdentifier | Template CIdentifier [[TypeSpecifier]] | TemplateConst String | TemplatePointer TypeSpecifier deriving (Typeable, Eq, Show) type_specifier :: CParser i m => m TypeSpecifier type_specifier = msum [ VOID <$ reserve cIdentStyle "void" , BOOL <$ reserve cIdentStyle "bool" , CHAR <$ reserve cIdentStyle "char" , SHORT <$ reserve cIdentStyle "short" , INT <$ reserve cIdentStyle "int" , LONG <$ reserve cIdentStyle "long" , FLOAT <$ reserve cIdentStyle "float" , DOUBLE <$ reserve cIdentStyle "double" , SIGNED <$ reserve cIdentStyle "signed" , UNSIGNED <$ reserve cIdentStyle "unsigned" , Struct <$> (reserve cIdentStyle "struct" >> cidentifier) , Enum <$> (reserve cIdentStyle "enum" >> cidentifier) , template_parser , TypeName <$> type_name ] identifier :: CParser i m => m i identifier = token identifier_no_lex isTypeName :: Bool -> TypeNames -> String -> Bool isTypeName useCpp typeNames id_ = case cIdentifierFromString useCpp id_ of -- If it's not a valid C identifier, then it's definitely not a C type name. Left _err -> False Right s -> HashSet.member s typeNames identifier_no_lex :: CParser i m => m i identifier_no_lex = try $ do ctx <- ask id_ <- cpcParseIdent ctx cpcIdentName ctx when (isTypeName (cpcEnableCpp ctx) (cpcTypeNames ctx) (cpcIdentToString ctx id_)) $ unexpected $ "type name " ++ cpcIdentToString ctx id_ return id_ -- | Same as 'cidentifier_no_lex', but does not check that the -- identifier is not a type name. cidentifier_raw :: (TokenParsing m, Monad m) => Bool -> m CIdentifier cidentifier_raw useCpp = identNoLex useCpp cIdentStyle -- | This parser parses a 'CIdentifier' and nothing else -- it does not consume -- trailing spaces and the like. cidentifier_no_lex :: CParser i m => m CIdentifier cidentifier_no_lex = try $ do ctx <- ask s <- cidentifier_raw (cpcEnableCpp ctx) typeNames <- asks cpcTypeNames when (HashSet.member s typeNames) $ unexpected $ "type name " ++ unCIdentifier s return s cidentifier :: CParser i m => m CIdentifier cidentifier = token cidentifier_no_lex type_name :: CParser i m => m CIdentifier type_name = try $ do ctx <- ask s <- ident' (cpcEnableCpp ctx) cIdentStyle "type name" typeNames <- asks cpcTypeNames unless (HashSet.member s typeNames) $ unexpected $ "identifier " ++ unCIdentifier s return s templateParser :: (Monad m, CharParsing m, CParser i m) => IdentifierStyle m -> m TypeSpecifier templateParser s = parse' where parse' = do id' <- cidentParserWithNamespace _ <- string "<" args <- templateArgParser _ <- string ">" return $ Template (CIdentifier id') args cidentParser = ((:) <$> _styleStart s <*> many (_styleLetter s) _styleName s) cidentParserWithNamespace = try (concat <$> sequence [cidentParser, (string "::"), cidentParserWithNamespace]) <|> cidentParser templateArgType = try ((TemplatePointer <$> (type_specifier)) <* (string "*")) <|> try type_specifier <|> (TemplateConst <$> (some $ oneOf ['0'..'9'])) templateArgParser' = do t <- some (token templateArgType) _ <- string "," tt <- templateArgParser return $ t:tt templateArgParser = try (templateArgParser') <|> ((:) <$> some (token templateArgType) <*> return []) template_parser :: CParser i m => m TypeSpecifier template_parser = try $ templateParser cIdentStyle "template name" data TypeQualifier = CONST | RESTRICT | VOLATILE deriving (Typeable, Eq, Show) type_qualifier :: CParser i m => m TypeQualifier type_qualifier = msum [ CONST <$ reserve cIdentStyle "const" , RESTRICT <$ reserve cIdentStyle "restrict" , VOLATILE <$ reserve cIdentStyle "volatile" ] data FunctionSpecifier = INLINE deriving (Typeable, Eq, Show) function_specifier :: CParser i m => m FunctionSpecifier function_specifier = msum [ INLINE <$ reserve cIdentStyle "inline" ] data Declarator i = Declarator { declaratorPointers :: [Pointer] , declaratorDirect :: (DirectDeclarator i) } deriving (Typeable, Eq, Show, Functor, Foldable, Traversable) declarator :: CParser i m => m (Declarator i) declarator = (Declarator <$> many pointer <*> direct_declarator) "declarator" data DirectDeclarator i = DeclaratorRoot i | ArrayOrProto (DirectDeclarator i) (ArrayOrProto i) | DeclaratorParens (Declarator i) deriving (Typeable, Eq, Show, Functor, Foldable, Traversable) data ArrayOrProto i = Array (ArrayType i) | Proto [ParameterDeclaration i] -- We don't include old prototypes. deriving (Eq, Show, Typeable, Functor, Foldable, Traversable) array_or_proto :: CParser i m => m (ArrayOrProto i) array_or_proto = msum [ Array <$> brackets array_type , Proto <$> parens parameter_list ] -- TODO handle more stuff in array brackets data ArrayType i = VariablySized | Unsized | SizedByInteger Integer | SizedByIdentifier i deriving (Typeable, Eq, Show, Functor, Foldable, Traversable) array_type :: CParser i m => m (ArrayType i) array_type = msum [ VariablySized <$ symbolic '*' , SizedByInteger <$> natural , SizedByIdentifier <$> identifier , return Unsized ] direct_declarator :: CParser i m => m (DirectDeclarator i) direct_declarator = do ddecltor <- msum [ DeclaratorRoot <$> identifier , DeclaratorParens <$> parens declarator ] aops <- many array_or_proto return $ foldl ArrayOrProto ddecltor aops data Pointer = Pointer [TypeQualifier] deriving (Typeable, Eq, Show) pointer :: CParser i m => m Pointer pointer = do void $ symbolic '*' Pointer <$> many type_qualifier parameter_list :: CParser i m => m [ParameterDeclaration i] parameter_list = sepBy parameter_declaration $ symbolic ',' data ParameterDeclaration i = ParameterDeclaration { parameterDeclarationSpecifiers :: [DeclarationSpecifier] , parameterDeclarationDeclarator :: DeclaratorOrAbstractDeclarator i } deriving (Eq, Show, Typeable, Functor, Foldable, Traversable) data DeclaratorOrAbstractDeclarator i = IsDeclarator (Declarator i) | IsAbstractDeclarator (AbstractDeclarator i) deriving (Eq, Show, Typeable, Functor, Foldable, Traversable) parameter_declaration :: CParser i m => m (ParameterDeclaration i) parameter_declaration = ParameterDeclaration <$> declaration_specifiers <*> mbabstract where mbabstract = IsDeclarator <$> try declarator <|> IsAbstractDeclarator <$> try abstract_declarator <|> return (IsAbstractDeclarator (AbstractDeclarator [] Nothing)) data AbstractDeclarator i = AbstractDeclarator { abstractDeclaratorPointers :: [Pointer] , abstractDeclaratorDirect :: Maybe (DirectAbstractDeclarator i) } deriving (Typeable, Eq, Show, Functor, Foldable, Traversable) abstract_declarator :: CParser i m => m (AbstractDeclarator i) abstract_declarator = do ptrs <- many pointer -- If there are no pointers, there must be an abstract declarator. let p = if null ptrs then Just <$> direct_abstract_declarator else (Just <$> try direct_abstract_declarator) <|> return Nothing AbstractDeclarator ptrs <$> p data DirectAbstractDeclarator i = ArrayOrProtoHere (ArrayOrProto i) | ArrayOrProtoThere (DirectAbstractDeclarator i) (ArrayOrProto i) | AbstractDeclaratorParens (AbstractDeclarator i) deriving (Typeable, Eq, Show, Functor, Foldable, Traversable) direct_abstract_declarator :: CParser i m => m (DirectAbstractDeclarator i) direct_abstract_declarator = do ddecltor <- msum [ try (ArrayOrProtoHere <$> array_or_proto) , AbstractDeclaratorParens <$> parens abstract_declarator ] "array, prototype, or parenthesised abstract declarator" aops <- many array_or_proto return $ foldl ArrayOrProtoThere ddecltor aops ------------------------------------------------------------------------ -- Pretty printing instance Pretty CIdentifier where pretty = fromString . unCIdentifier instance Pretty DeclarationSpecifier where pretty dspec = case dspec of StorageClassSpecifier x -> pretty x TypeSpecifier x -> pretty x TypeQualifier x -> pretty x FunctionSpecifier x -> pretty x instance Pretty StorageClassSpecifier where pretty storage = case storage of TYPEDEF -> "typedef" EXTERN -> "extern" STATIC -> "static" AUTO -> "auto" REGISTER -> "register" instance Pretty TypeSpecifier where pretty tySpec = case tySpec of VOID -> "void" BOOL -> "bool" CHAR -> "char" SHORT -> "short" INT -> "int" LONG -> "long" FLOAT -> "float" DOUBLE -> "double" SIGNED -> "signed" UNSIGNED -> "unsigned" Struct x -> "struct" <+> pretty x Enum x -> "enum" <+> pretty x TypeName x -> pretty x Template x args -> -- This code generates a c++ code of "template-identifier" like "std::vector". -- concat_with_space is used to concat multiple terms like "unsigned int". let concat_with_space = mconcat . (intersperse " ") . (map pretty) in pretty x <+> "<" <+> mconcat (intersperse "," (map concat_with_space args)) <+> ">" TemplateConst x -> pretty x TemplatePointer x -> pretty x <+> "*" instance Pretty TypeQualifier where pretty tyQual = case tyQual of CONST -> "const" RESTRICT -> "restrict" VOLATILE -> "volatile" instance Pretty FunctionSpecifier where pretty funSpec = case funSpec of INLINE -> "inline" instance Pretty i => Pretty (Declarator i) where pretty (Declarator ptrs ddecltor) = case ptrs of [] -> pretty ddecltor _:_ -> prettyPointers ptrs <+> pretty ddecltor prettyPointers :: [Pointer] -> Doc ann prettyPointers [] = "" prettyPointers (x : xs) = pretty x <> prettyPointers xs instance Pretty Pointer where pretty (Pointer tyQual) = "*" <> hsep (map pretty tyQual) instance Pretty i => Pretty (DirectDeclarator i) where pretty decltor = case decltor of DeclaratorRoot x -> pretty x DeclaratorParens x -> "(" <> pretty x <> ")" ArrayOrProto ddecltor aorp -> pretty ddecltor <> pretty aorp instance Pretty i => Pretty (ArrayOrProto i) where pretty aorp = case aorp of Array x -> "[" <> pretty x <> "]" Proto x -> "(" <> prettyParams x <> ")" prettyParams :: (Pretty a) => [a] -> Doc ann prettyParams xs = case xs of [] -> "" [x] -> pretty x x : xs'@(_:_) -> pretty x <> "," <+> prettyParams xs' instance Pretty i => Pretty (ArrayType i) where pretty at = case at of VariablySized -> "*" SizedByInteger n -> pretty n SizedByIdentifier s -> pretty s Unsized -> "" instance Pretty i => Pretty (ParameterDeclaration i) where pretty (ParameterDeclaration declSpecs decltor) = case declSpecs of [] -> decltorDoc _:_ -> hsep (map pretty declSpecs) <+> decltorDoc where decltorDoc = case decltor of IsDeclarator x -> pretty x IsAbstractDeclarator x -> pretty x instance Pretty i => Pretty (AbstractDeclarator i) where pretty (AbstractDeclarator ptrs mbDecltor) = case (ptrs, mbDecltor) of (_, Nothing) -> prettyPointers ptrs ([], Just x) -> pretty x (_:_, Just x) -> prettyPointers ptrs <+> pretty x instance Pretty i => Pretty (DirectAbstractDeclarator i) where pretty ddecltor = case ddecltor of AbstractDeclaratorParens x -> "(" <> pretty x <> ")" ArrayOrProtoHere aop -> pretty aop ArrayOrProtoThere ddecltor' aop -> pretty ddecltor' <> pretty aop ------------------------------------------------------------------------ -- Utils many1 :: CParser i m => m a -> m [a] many1 p = (:) <$> p <*> many p ------------------------------------------------------------------------ -- YACC grammar -- $yacc -- -- The parser above is derived from a modification of the YACC grammar -- for C99 found at , -- reproduced below. -- -- @ -- %token IDENTIFIER TYPE_NAME INTEGER -- -- %token TYPEDEF EXTERN STATIC AUTO REGISTER INLINE RESTRICT -- %token CHAR SHORT INT LONG SIGNED UNSIGNED FLOAT DOUBLE CONST VOLATILE VOID -- %token BOOL COMPLEX IMAGINARY -- %token STRUCT UNION ENUM -- -- %start parameter_list -- %% -- -- declaration_specifiers -- : storage_class_specifier -- | storage_class_specifier declaration_specifiers -- | type_specifier -- | type_specifier declaration_specifiers -- | type_qualifier -- | type_qualifier declaration_specifiers -- | function_specifier -- | function_specifier declaration_specifiers -- ; -- -- storage_class_specifier -- : TYPEDEF -- | EXTERN -- | STATIC -- | AUTO -- | REGISTER -- ; -- -- type_specifier -- : VOID -- | CHAR -- | SHORT -- | INT -- | LONG -- | FLOAT -- | DOUBLE -- | SIGNED -- | UNSIGNED -- | BOOL -- | COMPLEX -- | IMAGINARY -- | STRUCT IDENTIFIER -- | UNION IDENTIFIER -- | ENUM IDENTIFIER -- | TYPE_NAME -- ; -- -- type_qualifier -- : CONST -- | RESTRICT -- | VOLATILE -- ; -- -- function_specifier -- : INLINE -- ; -- -- declarator -- : pointer direct_declarator -- | direct_declarator -- ; -- -- direct_declarator -- : IDENTIFIER -- | '(' declarator ')' -- | direct_declarator '[' type_qualifier_list ']' -- | direct_declarator '[' type_qualifier_list '*' ']' -- | direct_declarator '[' '*' ']' -- | direct_declarator '[' IDENTIFIER ']' -- | direct_declarator '[' INTEGER ']' -- | direct_declarator '[' ']' -- | direct_declarator '(' parameter_list ')' -- | direct_declarator '(' ')' -- ; -- -- pointer -- : '*' -- | '*' type_qualifier_list -- | '*' pointer -- | '*' type_qualifier_list pointer -- ; -- -- type_qualifier_list -- : type_qualifier -- | type_qualifier_list type_qualifier -- ; -- -- parameter_list -- : parameter_declaration -- | parameter_list ',' parameter_declaration -- ; -- -- parameter_declaration -- : declaration_specifiers declarator -- | declaration_specifiers abstract_declarator -- | declaration_specifiers -- ; -- -- abstract_declarator -- : pointer -- | direct_abstract_declarator -- | pointer direct_abstract_declarator -- ; -- -- direct_abstract_declarator -- : '(' abstract_declarator ')' -- | '[' ']' -- | direct_abstract_declarator '[' ']' -- | '[' '*' ']' -- | direct_abstract_declarator '[' '*' ']' -- | '[' IDENTIFIER ']' -- | direct_abstract_declarator '[' IDENTIFIER ']' -- | '[' INTEGER ']' -- | direct_abstract_declarator '[' INTEGER ']' -- | '(' ')' -- | '(' parameter_list ')' -- | direct_abstract_declarator '(' ')' -- | direct_abstract_declarator '(' parameter_list ')' -- ; -- -- %% -- #include \ -- -- extern char yytext[]; -- extern int column; -- -- void yyerror(char const *s) -- { -- fflush(stdout); -- printf("\n%*s\n%*s\n", column, "^", column, s); -- } -- @ -- Utils ------------------------------------------------------------------------ cppIdentParser :: (Monad m, CharParsing m) => Bool -> IdentifierStyle m -> m [Char] cppIdentParser useCpp s = cidentParserWithNamespace where cidentParser = ((:) <$> _styleStart s <*> many (_styleLetter s) _styleName s) cidentParserWithNamespace = if useCpp then try (concat <$> sequence [cidentParser, (string "::"), cidentParserWithNamespace]) <|> cidentParser else cidentParser identNoLex :: (TokenParsing m, Monad m, IsString s) => Bool -> IdentifierStyle m -> m s identNoLex useCpp s = fmap fromString $ try $ do name <- highlight (_styleHighlight s) (cppIdentParser useCpp s) when (HashSet.member name (_styleReserved s)) $ unexpected $ "reserved " ++ _styleName s ++ " " ++ show name return name ident' :: (TokenParsing m, Monad m, IsString s) => Bool -> IdentifierStyle m -> m s ident' useCpp s = fmap fromString $ token $ try $ do name <- highlight (_styleHighlight s) (cppIdentParser useCpp s) when (HashSet.member name (_styleReserved s)) $ unexpected $ "reserved " ++ _styleName s ++ " " ++ show name return name inline-c-0.9.1.10/src/Language/C/Inline/FunPtr.hs0000644000000000000000000000537214505621771017327 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} module Language.C.Inline.FunPtr ( mkFunPtr , mkFunPtrFromName , peekFunPtr , uniqueFfiImportName ) where import Data.Maybe (isJust) import Foreign.Ptr (FunPtr) import System.Environment (lookupEnv) import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH ------------------------------------------------------------------------ -- FFI wrappers -- | @$('mkFunPtr' [t| 'CDouble' -> 'IO' 'CDouble' |] @ generates a foreign import -- wrapper of type -- -- @ -- ('CDouble' -> 'IO' 'CDouble') -> 'IO' ('FunPtr' ('CDouble' -> 'IO' 'CDouble')) -- @ -- -- And invokes it. mkFunPtr :: TH.TypeQ -> TH.ExpQ mkFunPtr hsTy = do ffiImportName <- uniqueFfiImportName -- See note [ghcide-support] usingGhcide <- TH.runIO $ isJust <$> lookupEnv "__GHCIDE__" if usingGhcide then do [e|error "inline-c: A 'usingGhcide' mkFunPtr stub was evaluated -- this should not happen" :: $(hsTy) -> IO (FunPtr $(hsTy)) |] else do -- Actual foreign function call generation. dec <- TH.forImpD TH.CCall TH.Safe "wrapper" ffiImportName [t| $(hsTy) -> IO (FunPtr $(hsTy)) |] TH.addTopDecls [dec] TH.varE ffiImportName -- | @$('mkFunPtrFromName' 'foo)@, if @foo :: 'CDouble' -> 'IO' -- 'CDouble'@, splices in an expression of type @'IO' ('FunPtr' -- ('CDouble' -> 'IO' 'CDouble'))@. mkFunPtrFromName :: TH.Name -> TH.ExpQ mkFunPtrFromName name = do i <- TH.reify name case i of #if MIN_VERSION_template_haskell(2,11,0) TH.VarI _ ty _ -> [| $(mkFunPtr (return ty)) $(TH.varE name) |] #else TH.VarI _ ty _ _ -> [| $(mkFunPtr (return ty)) $(TH.varE name) |] #endif _ -> fail "mkFunPtrFromName: expecting a variable as argument." -- | @$('peekFunPtr' [t| 'CDouble' -> 'IO' 'CDouble' |])@ generates a foreign import -- dynamic of type -- -- @ -- 'FunPtr' ('CDouble' -> 'IO' 'CDouble') -> ('CDouble' -> 'IO' 'CDouble') -- @ -- -- And invokes it. peekFunPtr :: TH.TypeQ -> TH.ExpQ peekFunPtr hsTy = do ffiImportName <- uniqueFfiImportName usingGhcide <- TH.runIO $ isJust <$> lookupEnv "__GHCIDE__" -- See note [ghcide-support] if usingGhcide then do [e|error "inline-c: A 'usingGhcide' peekFunPtr stub was evaluated -- this should not happen" :: FunPtr $(hsTy) -> $(hsTy) |] else do -- Actual foreign function call generation. dec <- TH.forImpD TH.CCall TH.Safe "dynamic" ffiImportName [t| FunPtr $(hsTy) -> $(hsTy) |] TH.addTopDecls [dec] TH.varE ffiImportName -- TODO absurdly, I need to 'newName' twice for things to work. I found -- this hack in language-c-inline. Why is this? uniqueFfiImportName :: TH.Q TH.Name uniqueFfiImportName = TH.newName . show =<< TH.newName "inline_c_ffi" inline-c-0.9.1.10/examples/gsl-ode.hs0000644000000000000000000001145314504254724015343 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiWayIf #-} import Unsafe.Coerce (unsafeCoerce) import Data.Monoid ((<>)) import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as VM import Foreign.C.Types import Foreign.ForeignPtr (newForeignPtr_) import Foreign.Ptr (Ptr) import Foreign.Storable (Storable) import qualified Language.C.Inline as C import qualified Language.C.Inline.Unsafe as CU import System.IO.Unsafe (unsafePerformIO) import Control.Monad (forM_) import System.IO (withFile, hPutStrLn, IOMode(..)) C.context (C.baseCtx <> C.vecCtx <> C.funCtx) C.include "" C.include "" C.include "" -- | Solves a system of ODEs. Every 'V.Vector' involved must be of the -- same size. {-# NOINLINE solveOdeC #-} solveOdeC :: (CDouble -> V.Vector CDouble -> V.Vector CDouble) -- ^ ODE to Solve -> CDouble -- ^ Start -> V.Vector CDouble -- ^ Solution at start point -> CDouble -- ^ End -> Either String (V.Vector CDouble) -- ^ Solution at end point, or error. solveOdeC fun x0 f0 xend = unsafePerformIO $ do let dim = V.length f0 let dim_c = fromIntegral dim -- This is in CInt -- Convert the function to something of the right type to C. let funIO x y f _ptr = do -- Convert the pointer we get from C (y) to a vector, and then -- apply the user-supplied function. fImm <- fun x <$> vectorFromC dim y -- Fill in the provided pointer with the resulting vector. vectorToC fImm dim f -- Unsafe since the function will be called many times. [CU.exp| int{ GSL_SUCCESS } |] -- Create a mutable vector from the initial solution. This will be -- passed to the ODE solving function provided by GSL, and will -- contain the final solution. fMut <- V.thaw f0 res <- [C.block| int { gsl_odeiv2_system sys = { $fun:(int (* funIO) (double t, const double y[], double dydt[], void * params)), // The ODE to solve, converted to function pointer using the `fun` // anti-quoter NULL, // We don't provide a Jacobian $(int dim_c), // The dimension NULL // We don't need the parameter pointer }; // Create the driver, using some sensible values for the stepping // function and the tolerances gsl_odeiv2_driver *d = gsl_odeiv2_driver_alloc_y_new ( &sys, gsl_odeiv2_step_rk8pd, 1e-6, 1e-6, 0.0); // Finally, apply the driver. int status = gsl_odeiv2_driver_apply( d, &$(double x0), $(double xend), $vec-ptr:(double *fMut)); // Free the driver gsl_odeiv2_driver_free(d); return status; } |] -- Check the error code maxSteps <- [C.exp| int{ GSL_EMAXITER } |] smallStep <- [C.exp| int{ GSL_ENOPROG } |] good <- [C.exp| int{ GSL_SUCCESS } |] if | res == good -> Right <$> V.freeze fMut | res == maxSteps -> return $ Left "Too many steps" | res == smallStep -> return $ Left "Step size dropped below minimum allowed size" | otherwise -> return $ Left $ "Unknown error code " ++ show res solveOde :: (Double -> V.Vector Double -> V.Vector Double) -- ^ ODE to Solve -> Double -- ^ Start -> V.Vector Double -- ^ Solution at start point -> Double -- ^ End -> Either String (V.Vector Double) -- ^ Solution at end point, or error. solveOde fun x0 f0 xend = unsafeCoerce $ solveOdeC (unsafeCoerce fun) (unsafeCoerce x0) (unsafeCoerce f0) (unsafeCoerce xend) lorenz :: Double -- ^ Starting point -> V.Vector Double -- ^ Solution at starting point -> Double -- ^ End point -> Either String (V.Vector Double) lorenz x0 f0 xend = solveOde fun x0 f0 xend where sigma = 10.0; _R = 28.0; b = 8.0 / 3.0; fun _x y = let y0 = y V.! 0 y1 = y V.! 1 y2 = y V.! 2 in V.fromList [ sigma * ( y1 - y0 ) , _R * y0 - y1 - y0 * y2 , -b * y2 + y0 * y1 ] main :: IO () main = withFile "lorenz.csv" WriteMode $ \h -> forM_ pts $ \(x,y) -> hPutStrLn h $ show x ++ ", " ++ show y where pts = [(f V.! 0, f V.! 2) | (_x, f) <- go 0 (V.fromList [10.0 , 1.0 , 1.0])] go x f | x > 40 = [(x, f)] go x f = let x' = x + 0.01 Right f' = lorenz x f x' in (x, f) : go x' f' -- Utils vectorFromC :: Storable a => Int -> Ptr a -> IO (V.Vector a) vectorFromC len ptr = do ptr' <- newForeignPtr_ ptr V.freeze $ VM.unsafeFromForeignPtr0 ptr' len vectorToC :: Storable a => V.Vector a -> Int -> Ptr a -> IO () vectorToC vec len ptr = do ptr' <- newForeignPtr_ ptr V.copy (VM.unsafeFromForeignPtr0 ptr' len) vec inline-c-0.9.1.10/test/tests.hs0000644000000000000000000002046214503767417014323 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} import Control.Monad (void) import Data.Monoid ((<>)) import qualified Data.Vector.Storable.Mutable as V import Foreign.C.Types import Foreign.ForeignPtr (mallocForeignPtrBytes) import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import qualified Language.Haskell.TH as TH import Prelude import qualified Test.Hspec as Hspec import Text.RawString.QQ (r) import Foreign.Marshal.Alloc (alloca) import Foreign.Storable (peek, poke) import qualified Language.C.Inline as C import qualified Language.C.Inline.Unsafe as CU import qualified Language.C.Inline.Interruptible as CI import qualified Language.C.Inline.Internal as C import qualified Language.C.Inline.ContextSpec import qualified Language.C.Inline.ParseSpec import qualified Language.C.Types as C import qualified Language.C.Types.ParseSpec import Dummy C.context (C.baseCtx <> C.fptrCtx <> C.funCtx <> C.vecCtx <> C.bsCtx) C.include "" C.include "" C.include "" C.include "" C.verbatim [r| int francescos_mul(int x, int y) { return x * y; } |] foreign import ccall "francescos_mul" francescos_mul :: Int -> Int -> Int main :: IO () main = Hspec.hspec $ do Hspec.describe "Language.C.Types.Parse" Language.C.Types.ParseSpec.spec Hspec.describe "Language.C.Inline.Context" Language.C.Inline.ContextSpec.spec Hspec.describe "Language.C.Inline.Parse" Language.C.Inline.ParseSpec.spec Hspec.describe "TH integration" $ do Hspec.it "inlineCode" $ do let c_add = $(C.inlineCode $ C.Code TH.Unsafe -- Call safety Nothing [t| Int -> Int -> Int |] -- Call type "francescos_add" -- Call name -- C Code [r| int francescos_add(int x, int y) { int z = x + y; return z; } |] False) -- not a function pointer c_add 3 4 `Hspec.shouldBe` 7 Hspec.it "inlineItems" $ do let c_add3 = $(do here <- TH.location C.inlineItems TH.Unsafe False -- not a function pointer Nothing -- no postfix here [t| CInt -> CInt |] (C.quickCParser_ True "int" C.parseType) [("x", C.quickCParser_ True "int" C.parseType)] [r| return x + 3; |]) c_add3 1 `Hspec.shouldBe` 1 + 3 Hspec.it "inlineExp" $ do let x = $(do here <- TH.location C.inlineExp TH.Safe here [t| CInt |] (C.quickCParser_ True "int" C.parseType) [] [r| 1 + 4 |]) x `Hspec.shouldBe` 1 + 4 Hspec.it "inlineCode" $ do francescos_mul 3 4 `Hspec.shouldBe` 12 Hspec.it "exp" $ do let x = 3 let y = 4 z <- [C.exp| int{ $(int x) + $(int y) + 5 } |] z `Hspec.shouldBe` x + y + 5 Hspec.it "pure" $ do let x = 2 let y = 10 let z = [C.pure| int{ $(int x) + 10 + $(int y) } |] z `Hspec.shouldBe` x + y + 10 Hspec.it "unsafe exp" $ do let x = 2 let y = 10 z <- [CU.exp| int{ 7 + $(int x) + $(int y) } |] z `Hspec.shouldBe` x + y + 7 Hspec.it "interruptible exp" $ do let x = 2 let y = 10 z <- [CI.exp| int{ 7 + $(int x) + $(int y) } |] z `Hspec.shouldBe` x + y + 7 Hspec.it "void exp" $ do [C.exp| void { printf("Hello\n") } |] Hspec.it "Foreign.C.Types library types" $ do let x = 1 pd <- [C.block| ptrdiff_t { char a[2]; return &a[1] - &a[0] + $(ptrdiff_t x); } |] pd `Hspec.shouldBe` 2 sz <- [C.exp| size_t { sizeof (char) } |] sz `Hspec.shouldBe` 1 um <- [C.exp| uintmax_t { UINTMAX_MAX } |] um `Hspec.shouldBe` maxBound Hspec.it "stdint.h types" $ do let x = 2 i16 <- [C.exp| int16_t { 1 + $(int16_t x) } |] i16 `Hspec.shouldBe` 3 let y = 9 u32 <- [C.exp| uint32_t { $(uint32_t y) * 7 } |] u32 `Hspec.shouldBe` 63 Hspec.it "foreign pointer argument" $ do fptr <- mallocForeignPtrBytes 32 ptr <- [C.exp| int* { $fptr-ptr:(int *fptr) } |] ptr `Hspec.shouldBe` unsafeForeignPtrToPtr fptr Hspec.it "function pointer argument" $ do let ackermann m n | m == 0 = n + 1 | m > 0 && n == 0 = ackermann (m - 1) 1 | m > 0 && n > 0 = ackermann (m - 1) (ackermann m (n - 1)) | otherwise = error "ackermann" ackermannPtr <- $(C.mkFunPtr [t| CInt -> CInt -> IO CInt |]) $ \m n -> return $ ackermann m n let x = 3 let y = 4 z <- [C.exp| int { $(int (*ackermannPtr)(int, int))($(int x), $(int y)) } |] z `Hspec.shouldBe` ackermann x y Hspec.it "function pointer result" $ do c_add <- [C.exp| int (*)(int, int) { &francescos_add } |] x <- $(C.peekFunPtr [t| CInt -> CInt -> IO CInt |]) c_add 1 2 x `Hspec.shouldBe` 1 + 2 Hspec.it "quick function pointer argument" $ do let ackermann m n | m == 0 = n + 1 | m > 0 && n == 0 = ackermann (m - 1) 1 | m > 0 && n > 0 = ackermann (m - 1) (ackermann m (n - 1)) | otherwise = error "ackermann" let ackermann_ m n = return $ ackermann m n let x = 3 let y = 4 z <- [C.exp| int { $fun:(int (*ackermann_)(int, int))($(int x), $(int y)) } |] z `Hspec.shouldBe` ackermann x y Hspec.it "function pointer argument (pure)" $ do let ackermann m n | m == 0 = n + 1 | m > 0 && n == 0 = ackermann (m - 1) 1 | m > 0 && n > 0 = ackermann (m - 1) (ackermann m (n - 1)) | otherwise = error "ackermann" ackermannPtr <- $(C.mkFunPtr [t| CInt -> CInt -> CInt |]) ackermann let x = 3 let y = 4 let z = [C.pure| int { $(int (*ackermannPtr)(int, int))($(int x), $(int y)) } |] z `Hspec.shouldBe` ackermann x y Hspec.it "quick function pointer argument (pure)" $ do let ackermann m n | m == 0 = n + 1 | m > 0 && n == 0 = ackermann (m - 1) 1 | m > 0 && n > 0 = ackermann (m - 1) (ackermann m (n - 1)) | otherwise = error "ackermann" let x = 3 let y = 4 let z = [C.pure| int { $fun:(int (*ackermann)(int, int))($(int x), $(int y)) } |] z `Hspec.shouldBe` ackermann x y Hspec.it "test mkFunPtrFromName" $ do fun <- $(C.mkFunPtrFromName 'dummyFun) z <- [C.exp| double { $(double (*fun)(double))(3.0) } |] z' <- dummyFun 3.0 z `Hspec.shouldBe` z' Hspec.it "vectors" $ do let n = 10 vec <- V.replicate (fromIntegral n) 3 sum' <- V.unsafeWith vec $ \ptr -> [C.block| int { int i; int x = 0; for (i = 0; i < $(int n); i++) { x += $(int *ptr)[i]; } return x; } |] sum' `Hspec.shouldBe` 3 * 10 Hspec.it "quick vectors" $ do vec <- V.replicate 10 3 sum' <- [C.block| int { int i; int x = 0; for (i = 0; i < $vec-len:vec; i++) { x += $vec-ptr:(int *vec)[i]; } return x; } |] sum' `Hspec.shouldBe` 3 * 10 Hspec.it "bytestrings" $ do let bs = "foo" bits <- [C.block| int { int i, bits = 0; for (i = 0; i < $bs-len:bs; i++) { char ch = $bs-ptr:bs[i]; bits += (ch * 01001001001ULL & 042104210421ULL) % 017; } return bits; } |] bits `Hspec.shouldBe` 16 Hspec.it "Haskell identifiers" $ do let x' = 3 void $ [C.exp| int { $(int x') } |] let ä = 3 void $ [C.exp| int { $(int ä) } |] void $ [C.exp| int { $(int Prelude.maxBound) } |] Hspec.it "Function pointers" $ do alloca $ \x_ptr -> do poke x_ptr 7 let fp = [C.funPtr| void poke42(int *ptr) { *ptr = 42; } |] [C.exp| void { $(void (*fp)(int *))($(int *x_ptr)) } |] x <- peek x_ptr x `Hspec.shouldBe` 42 Hspec.it "cpp namespace identifiers" $ do C.cIdentifierFromString True "Test::Test" `Hspec.shouldBe` Right "Test::Test" Hspec.it "cpp template identifiers" $ do C.cIdentifierFromString True "std::vector" `Hspec.shouldBe` Right "std::vector" inline-c-0.9.1.10/test/Dummy.hs0000644000000000000000000000027314503767417014252 0ustar0000000000000000-- | This module exists because of TH staging restrictions. module Dummy (dummyFun) where import Foreign.C.Types dummyFun :: CDouble -> IO CDouble dummyFun x = return $ cos x inline-c-0.9.1.10/test/Language/C/Inline/ContextSpec.hs0000644000000000000000000001202114503767417020533 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DataKinds #-} module Language.C.Inline.ContextSpec (spec) where import Control.Monad.Trans.Class (lift) import Data.Word import qualified Data.Map as Map import qualified Test.Hspec as Hspec import Text.Parser.Char import Text.Parser.Combinators import qualified Language.Haskell.TH as TH import Foreign.C.Types import Foreign.Ptr (Ptr, FunPtr) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<*), (*>)) #endif import qualified Language.C.Types as C import qualified Language.C.Types.Parse as P import Language.C.Inline.Context import GHC.Exts( IsString(..) ) data Vec a data Ary a spec :: Hspec.SpecWith () spec = do Hspec.it "converts simple type correctly (1)" $ do shouldBeType (cty "int") [t| CInt |] Hspec.it "converts simple type correctly (2)" $ do shouldBeType (cty "char") [t| CChar |] Hspec.it "converts bool" $ do shouldBeType (cty "bool") [t| CBool |] Hspec.it "converts void" $ do shouldBeType (cty "void") [t| () |] Hspec.it "converts signed" $ do shouldBeType (cty "signed") [t| CInt |] Hspec.it "converts unsigned" $ do shouldBeType (cty "unsigned") [t| CUInt |] Hspec.it "converts standard library types (1)" $ do shouldBeType (cty "FILE") [t| CFile |] Hspec.it "converts standard library types (2)" $ do shouldBeType (cty "uint16_t") [t| Word16 |] Hspec.it "converts standard library types (3)" $ do shouldBeType (cty "jmp_buf") [t| CJmpBuf |] Hspec.it "converts single ptr type" $ do shouldBeType (cty "long*") [t| Ptr CLong |] Hspec.it "converts double ptr type" $ do shouldBeType (cty "unsigned long**") [t| Ptr (Ptr CULong) |] Hspec.it "converts arrays" $ do shouldBeType (cty "double[]") [t| CArray CDouble |] Hspec.it "converts named things" $ do shouldBeType (cty "unsigned int foo[]") [t| CArray CUInt |] Hspec.it "converts arrays of pointers" $ do shouldBeType (cty "unsigned short *foo[]") [t| CArray (Ptr CUShort) |] Hspec.it "ignores qualifiers" $ do shouldBeType (cty "const short*") [t| Ptr CShort |] Hspec.it "ignores storage information" $ do shouldBeType (cty "extern unsigned long") [t| CULong |] Hspec.it "converts sized arrays" $ do shouldBeType (cty "float[4]") [t| CArray CFloat |] Hspec.it "converts variably sized arrays" $ do shouldBeType (cty "float[*]") [t| CArray CFloat |] Hspec.it "converts function pointers" $ do shouldBeType (cty "int (*f)(unsigned char, float)") [t| FunPtr (CUChar -> CFloat -> IO CInt) |] Hspec.it "converts complicated function pointers (1)" $ do -- pointer to function returning pointer to function returning int shouldBeType (cty "int (*(*)())()") [t| FunPtr (IO (FunPtr (IO CInt))) |] Hspec.it "converts complicated function pointerst (2)" $ do -- foo is an array of pointer to pointer to function returning -- pointer to array of pointer to char shouldBeType (cty "char *(*(**foo [])())[]") [t| CArray (Ptr (FunPtr (IO (Ptr (CArray (Ptr CChar)))))) |] Hspec.it "converts complicated function pointers (3)" $ do -- foo is an array of pointer to pointer to function taking int -- returning pointer to array of pointer to char shouldBeType (cty "char *(*(**foo [])(int x))[]") [t| CArray (Ptr (FunPtr (CInt -> IO (Ptr (CArray (Ptr CChar)))))) |] Hspec.it "converts vector" $ do shouldBeType (cty "vector") [t| Vec CInt |] Hspec.it "converts std::vector" $ do shouldBeType (cty "std::vector") [t| Vec CInt |] Hspec.it "converts std::vector*" $ do shouldBeType (cty "std::vector*") [t| Ptr (Vec CInt) |] Hspec.it "converts array" $ do shouldBeType (cty "array") [t| Ary '(CInt,10) |] Hspec.it "converts array*" $ do shouldBeType (cty "array*") [t| Ptr (Ary '(CInt,10)) |] where goodConvert cTy = do mbHsTy <- TH.runQ $ convertType IO baseTypes cTy case mbHsTy of Nothing -> error $ "Could not convert type (goodConvert)" Just hsTy -> return hsTy shouldBeType cTy hsTy = do x <- goodConvert cTy y <- TH.runQ hsTy x `Hspec.shouldBe` y assertParse p s = case C.runCParser (C.cCParserContext True (typeNamesFromTypesTable baseTypes)) "spec" s (lift spaces *> p <* lift eof) of Left err -> error $ "Parse error (assertParse): " ++ show err Right x -> x cty s = C.parameterDeclarationType $ assertParse C.parseParameterDeclaration s baseTypes = ctxTypesTable baseCtx `mappend` Map.fromList [ (C.TypeName (fromString "vector" :: P.CIdentifier), [t|Vec|]), (C.TypeName (fromString "std::vector" :: P.CIdentifier), [t|Vec|]), (C.TypeName (fromString "array" :: P.CIdentifier), [t|Ary|]) ] inline-c-0.9.1.10/test/Language/C/Inline/ParseSpec.hs0000644000000000000000000001113414503767417020165 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} module Language.C.Inline.ParseSpec (spec) where import Control.Exception (evaluate) import Control.Monad (void) import Control.Monad.Trans.Class (lift) import qualified Data.HashSet as HashSet import Data.Monoid ((<>)) import qualified Test.Hspec as Hspec import Text.Parser.Char import Text.Parser.Combinators import Text.RawString.QQ (r) import Text.Regex.Posix ((=~)) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<*), (*>)) #endif import Language.C.Inline.Context import Language.C.Inline.HaskellIdentifier import Language.C.Inline.Internal import qualified Language.C.Types as C spec :: Hspec.SpecWith () spec = do Hspec.describe "parsing" $ do Hspec.it "parses simple C expression" $ do (retType, params, cExp) <- goodParse [r| int { (int) ceil($(double x) + ((double) $(float y))) } |] retType `Hspec.shouldBe` (cty "int") params `shouldMatchParameters` [(cty "double", Plain "x"), (cty "float", Plain "y")] cExp `shouldMatchBody` " (int) ceil(x[a-z0-9_]+ \\+ ((double) y[a-z0-9_]+)) " Hspec.it "accepts anti quotes" $ do void $ goodParse [r| int { $(int x) } |] Hspec.it "accepts anti quotes with pointer" $ do void $ goodParse [r| int* { $(int* x) } |] Hspec.it "rejects if bad braces (1)" $ do badParse [r| int x |] Hspec.it "rejects if bad braces (2)" $ do badParse [r| int { x |] Hspec.it "parses function pointers" $ do void $ goodParse [r| int(int (*add)(int, int)) { add(3, 4) } |] Hspec.it "parses returning function pointers" $ do (retType, params, cExp) <- goodParse [r| double (*)(double) { &cos } |] retType `Hspec.shouldBe` (cty "double (*)(double)") params `shouldMatchParameters` [] cExp `shouldMatchBody` " &cos " Hspec.it "parses Haskell identifier (1)" $ do (retType, params, cExp) <- goodParse [r| double { $(double x') } |] retType `Hspec.shouldBe` (cty "double") params `shouldMatchParameters` [(cty "double", Plain "x'")] cExp `shouldMatchBody` " x[a-z0-9_]+ " Hspec.it "parses Haskell identifier (2)" $ do (retType, params, cExp) <- goodParse [r| double { $(double ä') } |] retType `Hspec.shouldBe` (cty "double") params `shouldMatchParameters` [(cty "double", Plain "ä'")] cExp `shouldMatchBody` " [a-z0-9_]+ " Hspec.it "parses Haskell identifier (3)" $ do (retType, params, cExp) <- goodParse [r| int { $(int Foo.bar) } |] retType `Hspec.shouldBe` (cty "int") params `shouldMatchParameters` [(cty "int", Plain "Foo.bar")] cExp `shouldMatchBody` " Foobar[a-z0-9_]+ " Hspec.it "does not parse Haskell identifier in bad position" $ do badParse [r| double (*)(double Foo.bar) { 3.0 } |] where ctx = baseCtx <> funCtx assertParse ctxF p s = case C.runCParser (ctxF HashSet.empty) "spec" s (lift spaces *> p <* lift eof) of Left err -> error $ "Parse error (assertParse): " ++ show err Right x -> x -- We use show + length to fully evaluate the result -- there -- might be exceptions hiding. TODO get rid of exceptions. strictParse :: String -> IO (C.Type C.CIdentifier, [(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String) strictParse s = do let ParseTypedC retType pars body = assertParse (haskellCParserContext True) (parseTypedC True (ctxAntiQuoters ctx)) s void $ evaluate $ length $ show (retType, pars, body) return (retType, pars, body) goodParse = strictParse badParse s = strictParse s `Hspec.shouldThrow` Hspec.anyException cty :: String -> C.Type C.CIdentifier cty s = C.parameterDeclarationType $ assertParse (C.cCParserContext True) C.parseParameterDeclaration s shouldMatchParameters :: [(C.CIdentifier, C.Type C.CIdentifier, ParameterType)] -> [(C.Type C.CIdentifier, ParameterType)] -> Hspec.Expectation shouldMatchParameters pars pars' = [(x, y) | (_, x, y) <- pars] `Hspec.shouldMatchList` pars' shouldMatchBody :: String -> String -> Hspec.Expectation shouldMatchBody x y = do let f ch' = case ch' of '(' -> "\\(" ')' -> "\\)" ch -> [ch] (x =~ concatMap f y) `Hspec.shouldBe` True inline-c-0.9.1.10/test/Language/C/Types/ParseSpec.hs0000644000000000000000000002516514503767417020064 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.C.Types.ParseSpec (spec) where import Control.Applicative import Control.Monad.Trans.Class (lift) import Data.Hashable (Hashable) import qualified Test.Hspec as Hspec import qualified Test.Hspec.QuickCheck import qualified Test.QuickCheck as QC import Text.Parser.Char import Text.Parser.Combinators import qualified Prettyprinter as PP import qualified Prettyprinter.Render.String as PP import Data.Typeable (Typeable) import qualified Data.HashSet as HashSet import Data.List (intercalate) import Data.String (fromString) import Data.Maybe (mapMaybe) import Data.List.Split (splitOn) import Language.C.Types.Parse import qualified Language.C.Types as Types import Language.C.Inline.HaskellIdentifier import Prelude -- Fix for 7.10 unused warnings. spec :: Hspec.SpecWith () -- modifyMaxDiscardRatio: -- 'isGoodType' and 'isGoodHaskellIdentifierType' usually make it within the -- discard ratio of 10, but we increase the ratio to avoid spurious build failures spec = Test.Hspec.QuickCheck.modifyMaxDiscardRatio (const 20) $ do Hspec.it "parses everything which is pretty-printable (C)" $ do #if MIN_VERSION_QuickCheck(2,9,0) QC.property $ QC.again $ do -- Work around #else QC.property $ do #endif ParameterDeclarationWithTypeNames typeNames ty <- arbitraryParameterDeclarationWithTypeNames unCIdentifier return $ isGoodType ty QC.==> let ty' = assertParse (cCParserContext True typeNames) parameter_declaration (prettyOneLine (PP.pretty ty)) in Types.untangleParameterDeclaration ty == Types.untangleParameterDeclaration ty' Hspec.it "parses everything which is pretty-printable (Haskell)" $ do #if MIN_VERSION_QuickCheck(2,9,0) QC.property $ QC.again $ do -- Work around #else QC.property $ do #endif ParameterDeclarationWithTypeNames typeNames ty <- arbitraryParameterDeclarationWithTypeNames unHaskellIdentifier return $ isGoodHaskellIdentifierType typeNames ty QC.==> let ty' = assertParse (haskellCParserContext True typeNames) parameter_declaration (prettyOneLine (PP.pretty ty)) in Types.untangleParameterDeclaration ty == Types.untangleParameterDeclaration ty' ------------------------------------------------------------------------ -- Utils assertParse :: (Hashable i) => CParserContext i -> (forall m. CParser i m => m a) -> String -> a assertParse ctx p s = case runCParser ctx "spec" s (lift spaces *> p <* lift eof) of Left err -> error $ "Parse error (assertParse): " ++ show err ++ " parsed string " ++ show s ++ " with type names " ++ show (cpcTypeNames ctx) Right x -> x prettyOneLine :: PP.Doc ann -> String prettyOneLine x = PP.renderString $ PP.layoutCompact x isGoodType :: ParameterDeclaration i -> Bool isGoodType ty = case Types.untangleParameterDeclaration ty of Left{} -> False Right{} -> True isGoodHaskellIdentifierType :: TypeNames -> ParameterDeclaration HaskellIdentifier -> Bool isGoodHaskellIdentifierType typeNames ty0 = case Types.untangleParameterDeclaration ty0 of Left{} -> False Right ty -> case Types.parameterDeclarationId ty of Nothing -> True Just i -> let -- see leadingSegment : _ = splitOn "." (unHaskellIdentifier i) in case cIdentifierFromString True leadingSegment of Left{} -> True Right seg -> not (seg `HashSet.member` typeNames) ------------------------------------------------------------------------ -- Arbitrary data OneOfSized a = Anyhow a | IfPositive a deriving (Typeable, Eq, Show) -- | Precondition: there is at least one 'Anyhow' in the list. oneOfSized :: [OneOfSized (QC.Gen a)] -> QC.Gen a oneOfSized xs = QC.sized $ \n -> do let f (Anyhow a) = Just a f (IfPositive x) | n > 0 = Just x f (IfPositive _) = Nothing QC.oneof $ mapMaybe f xs halveSize :: QC.Gen a -> QC.Gen a halveSize m = QC.sized $ \n -> QC.resize (n `div` 2) m instance QC.Arbitrary CIdentifier where arbitrary = do s <- ((:) <$> QC.elements cIdentStart <*> QC.listOf (QC.elements cIdentLetter)) if HashSet.member s cReservedWords then QC.arbitrary else return $ fromString s -- | Type used to generate an 'QC.Arbitrary' 'ParameterDeclaration' with -- arbitrary allowed type names. data ParameterDeclarationWithTypeNames i = ParameterDeclarationWithTypeNames { _pdwtnTypeNames :: HashSet.HashSet CIdentifier , _pdwtnParameterDeclaration :: (ParameterDeclaration i) } deriving (Typeable, Eq, Show) data ArbitraryContext i = ArbitraryContext { acTypeNames :: TypeNames , acIdentToString :: i -> String } arbitraryParameterDeclarationWithTypeNames :: (QC.Arbitrary i, Hashable i) => (i -> String) -> QC.Gen (ParameterDeclarationWithTypeNames i) arbitraryParameterDeclarationWithTypeNames identToString = do names <- HashSet.fromList <$> QC.listOf QC.arbitrary let ctx = ArbitraryContext names identToString decl <- arbitraryParameterDeclarationFrom ctx return $ ParameterDeclarationWithTypeNames names decl arbitraryDeclarationSpecifierFrom :: (QC.Arbitrary i, Hashable i) => ArbitraryContext i -> QC.Gen DeclarationSpecifier arbitraryDeclarationSpecifierFrom typeNames = QC.oneof $ [ StorageClassSpecifier <$> QC.arbitrary , TypeQualifier <$> QC.arbitrary , FunctionSpecifier <$> QC.arbitrary , TypeSpecifier <$> arbitraryTypeSpecifierFrom typeNames ] instance QC.Arbitrary StorageClassSpecifier where arbitrary = QC.oneof [ return TYPEDEF , return EXTERN , return STATIC , return AUTO , return REGISTER ] arbitraryTypeSpecifierFrom :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen TypeSpecifier arbitraryTypeSpecifierFrom ctx = QC.oneof $ [ return VOID , return CHAR , return SHORT , return INT , return LONG , return FLOAT , return DOUBLE , return SIGNED , return UNSIGNED , Struct <$> arbitraryCIdentifierFrom ctx , Enum <$> arbitraryCIdentifierFrom ctx ] ++ if HashSet.null (acTypeNames ctx) then [] else [TypeName <$> QC.elements (HashSet.toList (acTypeNames ctx))] instance QC.Arbitrary TypeQualifier where arbitrary = QC.oneof [ return CONST , return RESTRICT , return VOLATILE ] instance QC.Arbitrary FunctionSpecifier where arbitrary = QC.oneof [ return INLINE ] arbitraryDeclaratorFrom :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (Declarator i) arbitraryDeclaratorFrom typeNames = halveSize $ Declarator <$> QC.arbitrary <*> arbitraryDirectDeclaratorFrom typeNames arbitraryCIdentifierFrom :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen CIdentifier arbitraryCIdentifierFrom ctx = arbitraryIdentifierFrom ctx{acIdentToString = unCIdentifier} arbitraryIdentifierFrom :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen i arbitraryIdentifierFrom ctx = do id' <- QC.arbitrary if isTypeName True (acTypeNames ctx) (acIdentToString ctx id') then arbitraryIdentifierFrom ctx else return id' arbitraryDirectDeclaratorFrom :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (DirectDeclarator i) arbitraryDirectDeclaratorFrom typeNames = halveSize $ oneOfSized $ [ Anyhow $ DeclaratorRoot <$> arbitraryIdentifierFrom typeNames , IfPositive $ DeclaratorParens <$> arbitraryDeclaratorFrom typeNames , IfPositive $ ArrayOrProto <$> arbitraryDirectDeclaratorFrom typeNames <*> arbitraryArrayOrProtoFrom typeNames ] arbitraryArrayOrProtoFrom :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (ArrayOrProto i) arbitraryArrayOrProtoFrom typeNames = halveSize $ oneOfSized $ [ Anyhow $ Array <$> arbitraryArrayTypeFrom typeNames , IfPositive $ Proto <$> QC.listOf (arbitraryParameterDeclarationFrom typeNames) ] arbitraryArrayTypeFrom :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (ArrayType i) arbitraryArrayTypeFrom typeNames = QC.oneof [ return VariablySized , SizedByInteger . QC.getNonNegative <$> QC.arbitrary , SizedByIdentifier <$> arbitraryIdentifierFrom typeNames , return Unsized ] instance QC.Arbitrary Pointer where arbitrary = Pointer <$> QC.arbitrary arbitraryParameterDeclarationFrom :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (ParameterDeclaration i) arbitraryParameterDeclarationFrom typeNames = halveSize $ ParameterDeclaration <$> QC.listOf1 (arbitraryDeclarationSpecifierFrom typeNames) <*> QC.oneof [ IsDeclarator <$> arbitraryDeclaratorFrom typeNames , IsAbstractDeclarator <$> arbitraryAbstractDeclaratorFrom typeNames ] arbitraryAbstractDeclaratorFrom :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (AbstractDeclarator i) arbitraryAbstractDeclaratorFrom typeNames = halveSize $ do ptrs <- QC.arbitrary decl <- if null ptrs then Just <$> arbitraryDirectAbstractDeclaratorFrom typeNames else oneOfSized [ Anyhow $ return Nothing , IfPositive $ Just <$> arbitraryDirectAbstractDeclaratorFrom typeNames ] return $ AbstractDeclarator ptrs decl arbitraryDirectAbstractDeclaratorFrom :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (DirectAbstractDeclarator i) arbitraryDirectAbstractDeclaratorFrom typeNames = halveSize $ oneOfSized $ [ Anyhow $ ArrayOrProtoHere <$> arbitraryArrayOrProtoFrom typeNames , IfPositive $ AbstractDeclaratorParens <$> arbitraryAbstractDeclaratorFrom typeNames , IfPositive $ ArrayOrProtoThere <$> arbitraryDirectAbstractDeclaratorFrom typeNames <*> arbitraryArrayOrProtoFrom typeNames ] instance QC.Arbitrary HaskellIdentifier where arbitrary = do modIds <- QC.listOf arbitraryModId id_ <- QC.oneof [arbitraryConId, arbitraryVarId] if HashSet.member id_ haskellReservedWords then QC.arbitrary else return $ fromString $ intercalate "." $ modIds ++ [id_] where arbitraryModId = arbitraryConId arbitraryConId = ((:) <$> QC.elements large <*> QC.listOf (QC.elements (small ++ large ++ digit' ++ ['\'']))) arbitraryVarId = ((:) <$> QC.elements small <*> QC.listOf (QC.elements (small ++ large ++ digit' ++ ['\'']))) -- We currently do not generate unicode identifiers. large = ['A'..'Z'] small = ['a'..'z'] ++ ['_'] digit' = ['0'..'9'] inline-c-0.9.1.10/README.md0000644000000000000000000002417514503767417013132 0ustar0000000000000000# inline-c `inline-c` lets you seamlessly call C libraries and embed high-performance inline C code in Haskell modules. Haskell and C can be freely intermixed in the same source file, and data passed to and from code in either language with minimal overhead. No FFI required. `inline-c` is Haskell's escape hatch (or one of) to the wild world of legacy code and high-performance numerical and system libraries. It has other uses too: you can also think of `inline-c` as to Haskell what inline Assembly is to C — a convenient means to eke out a little bit of extra performance in those rare cases where C still beats Haskell. GHCi support is currently limited to using `-fobject-code`, see the [last section](#ghci) for more info. ## Getting started Let's say we want to compute the cosine of a number using C from Haskell. `inline-c` lets you write this function call inline, without any need for a binding to the foreign function: ``` {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} import qualified Language.C.Inline as C C.include "" main :: IO () main = do x <- [C.exp| double{ cos(1) } |] print x ``` `inline-c` leverages the [quasiquotation][ghc-manual-quasiquotation] language extension implemented in GHC. [Template Haskell][ghc-manual-template-haskell] is also required. Importing the `Language.C.Inline` module brings in scope most required Haskell definitions. `C.include ""` brings into scope the foreign function `cos()` that we wish to call. Finally, in the `main` function, `[C.exp| double { cos(1) } |]` denotes an inline C expression of type `double`. `cexp` stands for "C expression". It is a custom quasiquoter provided by `inline-c`. A `C.exp` quasiquotation always includes a type annotation for the inline C expression. This annotation determines the type of the quasiquotation in Haskell. Out of the box, `inline-c` knows how to map many common C types to Haskell types. In this case, ``` [C.exp| double { cos(1) } |] :: IO CDouble ``` For pure C expression like these we also provide `C.pure`, which works exactly the same but without the `IO`: ``` [C.pure| double { cos(1) } |] :: CDouble ``` Obviously extra care must be taken when using `C.pure`: the embedded C code must be referentially transparent. ## Multiple statements `inline-c` allows embedding arbitrary C code, not just expressions, in the form of a sequence of statements, using the `c` quasiquoter: ``` {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} import qualified Language.C.Inline as C C.include "" main :: IO () main = do x <- [C.block| int { // Read and sum 5 integers int i, sum = 0, tmp; for (i = 0; i < 5; i++) { scanf("%d", &tmp); sum += tmp; } return sum; } |] print x ``` Just as with `C.exp`, we need a type annotation on the entire C block. The annotation specifies the return type. That is, the type of the expression in any return statement. ## Capturing Haskell variables -- parameter declaration `inline-c` allows referring to Haskell variables inside C expressions and code blocks. We do so by "anti-quoting" them. Let's say that we wanted to parameterize the function we wrote above by how many numbers we should read. We can do so by defining a Haskell function whose parameter we can refer to from within C: ``` {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} import qualified Language.C.Inline as C import Foreign.C.Types C.include "" -- | @readAndSum n@ reads @n@ numbers from standard input and returns -- their sum. readAndSum :: CInt -> IO CInt readAndSum n = [C.block| int { // Read and sum n integers int i, sum = 0, tmp; for (i = 0; i < $(int n); i++) { scanf("%d", &tmp); sum += tmp; } return sum; } |] main :: IO () main = do x <- readAndSum 5 print x ``` Here, the Haskell variable `n` is captured right where we need it using `$(int n)`. Standard anti-quotation (we'll talk about additional ones later) consists of a `$` followed by a C declaration in parenthesis. Note that any valid Haskell identifiers can be used when anti-quoting, including ones including constructors, qualified names, names containing unicode, etc. For each anti-quotation, a variable with a matching type is expected in the Haskell environment. In this case `inline-c` expects a variable named `n` of type `CInt`, which is the case. ## What can be captured and returned? All C types correspond to exactly one Haskell type. Basic types (`int`, `long`, `double`, `float`, etc.) get converted to their Haskell equivalents `CInt`, `CLong`, `CDouble`, `CFloat`. Pointers and arrays get converted to `Ptr`. Function pointers get converted to `FunPtr`. `inline-c` can also handle user-defined structs and enums, provided that they are instances of `Storable` and that you tell `inline-c` about them using [contexts](#contexts). ## Contexts Everything beyond the base functionality provided by `inline-c` is specified in a structure that we call "`Context`". From a user perspective, if we want to use anything but the default context (`C.baseCtx`), we must set the `C.Context` explicitly using the `C.context` function. The next two sections include several examples. The `C.Context` allows to extend `inline-c` to support * Custom C types beyond the basic ones; * And [additional anti-quoters](#more-anti-quoters). `C.Context`s can be composed using their `Monoid` instance. Ideally a `C.Context` will be provided for each C library that should be used with `inline-c`. The user can then combine multiple contexts together if multiple libraries are to be used in the same program. See the [`inline-c-nag` package](https://github.com/fpco/inline-c-nag) for an example of using a `C.Context` tailored for a library. For information regarding how to define `C.Context`s, see the Haddock-generated API documentation for `Language.C.Inline.Context`. ## More anti-quoters Besides the basic anti-quoter, which captures variables as they are, some more anti-quoters are provided with additional functionality. As mentioned, `inline-c` can easily be extended with anti-quoters defined by the user, using [contexts](#contexts). ### Vectors The `vec-len` and `vec-ptr` anti-quoters in the `C.vecCtx` context let us easily use [Haskell vectors](http://hackage.haskell.org/package/vector) in C. Continuing along the "summing" theme, we can write code that sums Haskell vectors in C: ``` {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} import qualified Language.C.Inline as C import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as VM import Data.Monoid ((<>)) import Foreign.C.Types -- To use the vector anti-quoters, we need the 'C.vecCtx' along with the -- 'C.baseCtx'. C.context (C.baseCtx <> C.vecCtx) sumVec :: VM.IOVector CDouble -> IO CDouble sumVec vec = [C.block| double { double sum = 0; int i; for (i = 0; i < $vec-len:vec; i++) { sum += $vec-ptr:(double *vec)[i]; } return sum; } |] main :: IO () main = do x <- sumVec =<< V.thaw (V.fromList [1,2,3]) print x ``` The `vec-len` anti-quoter is used simply by specifying the vector we want to get the length of (in our case, `vec`). To use the `vec-ptr` anti-quoter it is also required to specify the pointer type we want. Since `vec` is a vector of `CDouble`s, we want a pointer to `double`s. ## ByteStrings The `bs-len` and `bs-ptr` anti-quoters in the `C.bsCtx` context work exactly the same as the `vec-len` and `vec-ptr` counterparts, but with strict `ByteString`s. The only difference is that it is not necessary to specify the type of the pointer from C -- it is always going to be `char *`: ``` {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} import qualified Data.ByteString as BS import Data.Monoid ((<>)) import Foreign.C.Types import qualified Language.C.Inline as C C.context (C.baseCtx <> C.bsCtx) -- | Count the number of set bits in a 'BS.ByteString'. countSetBits :: BS.ByteString -> IO CInt countSetBits bs = [C.block| int { int i, bits = 0; for (i = 0; i < $bs-len:bs; i++) { char ch = $bs-ptr:bs[i]; bits += (ch * 01001001001ULL & 042104210421ULL) % 017; } return bits; } |] ``` ### Function pointers Using the `fun` anti-quoter, present in the `C.funCtx` context, we can easily turn Haskell function into function pointers. ``` {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} import qualified Language.C.Inline as C -- To use the function pointer anti-quoter, we need the 'C.funCtx' along with -- the 'C.baseCtx'. C.context (C.baseCtx <> C.funCtx) ackermann :: CLong -> CLong -> CLong ackermann m n | m == 0 = n + 1 | m > 0 && n == 0 = ackermann (m - 1) 1 | otherwise = ackermann (m - 1) (ackermann m (n - 1)) main :: IO () main = do let ackermannIO m n = return $ ackermann m n let x = 3 let y = 4 z <- [C.exp| long{ $fun:(long (*ackermannIO)(long, long))($(long x), $(long y)) } |] print z ``` In this example, we capture a Haskell function of type `CLong -> CLong -> IO CLong`, `ackermannIO`, to a function pointer in C, using the `fun` anti-quoter. Note how we need to specify the function pointer type when we capture `ackermannIO`, using standard C declaration syntax. Also note that the `fun` anti-quoter works with `IO` functions, and so we needed to modify `ackermann` to make it have the right type. In general, when anti-quoting, if the type can be inferred (like in the case of `vec-len`), only the Haskell identifier appears. If it can't, the target C type and the Haskell identifier are mentioned using C declaration syntax. ## GHCi Currently `inline-c` does not work in interpreted mode. However, GHCi can still be used using the `-fobject-code` flag. For speed, we recommend passing `-fobject-code -O0`, for example ``` stack ghci --ghci-options='-fobject-code -O0' ``` or ``` cabal repl --ghc-options='-fobject-code -O0' ``` [ghc-manual-quasiquotation]: https://downloads.haskell.org/ghc/latest/docs/html/users_guide/glasgow_exts.html#template-haskell-quasi-quotation [ghc-manual-template-haskell]: https://downloads.haskell.org/ghc/latest/docs/html/users_guide/glasgow_exts.html#template-haskell inline-c-0.9.1.10/changelog.md0000644000000000000000000000470214505637060014106 0ustar0000000000000000- 0.9.1.10: * Add -fcompact-unwind for darwin exceptions(#131). * Fix Cpp.Exception error message line numbers(#133). * Skip generating foreign calls under ghcide(HSL), generate stubs instead(#128). * Add ctxRawObjectCompile option to support CUDA(#147). - 0.9.1.8: Tighten ansi-wl-pprint upper bound, see issue #144. - 0.9.1.7: Allow arbitrary number of C++ templates, see PR #141. - 0.9.1.6: Fix mistakenly unsafe call, see issue #137. - 0.9.1.5: Support multi-token types in C++ template arguments, see issue #125 and PR #126. - 0.9.1.4: Support GHC 8.10, including better C++ flags handling, see PR #121. - 0.9.1.3: Work around spurious test failures, see PR #118. - 0.9.1.2: Update haddock for `Language.C.Inline.Interruptible.pure`. - 0.9.1.1: Use `unsafeDupablePerformIO` rather than `unsafePerformIO`. See issue #115 and PR #117. - 0.9.1.0: Add `Language.C.Inline.substitute` and `Language.C.Inline.getHaskellType`. - 0.9.0.0: Add support for C++ namespace and template. - 0.8.0.1: Compatibility with GHC 8.8 - 0.8: Add code locations. - 0.7.0.1: Add more docs for `funPtr` - 0.7.0.0: Add `funPtr` quasi-quoter - 0.6.0.6: Support GHC 8.4 - 0.6.0.5: Update readme - 0.6.0.4: Remove QuickCheck dependency - 0.6.0.3: Remove cryptohash dependencies - 0.6.0.2: Update haddock - 0.6.0.0: Use `addDependentFile` so separate compilation is not needed. - 0.5.6.0: Add `ForeignPtr` anti-quoter - 0.5.5.9: Make tests work with QuickCheck < 2.9 - 0.5.5.8: Add workaround for QuickCheck-2.9 bug. See issue #51 - 0.5.5.2: Add docs regarding internals. See issue #41. - 0.5.5.1: Add support for Interruptible calls. The version skip is simply because I forgot to update the changelog for 0.5.5.0. - 0.5.4.3: Fix haddock docs. - 0.5.4.2: Generate unique C names by prefixing the already generated name with the Haskell module name. See issue #25. - 0.5.4.1: Do not generate C code when haddock is type checking. See issue #24. - 0.5.4.0: Allow Haskell identifiers in anti-quotes. See issue #23. - 0.5.3.4: Fix `bsCtx` docs. - 0.5.3.3: * Fix errors when using parallel builds. See issue #22. * Use `fail` rather than `error` in the `Q` monad. - 0.5.3.2: Make type errors with default anti-quoter much saner. - 0.5.3.1: Fix leak of `FunPtr` when using `funCtx`. - 0.5.3.0: Recognize more standard library types. See pull request #19. - 0.5.2.1: Convert `signed char` to `CSChar`. See pull request #18. - 0.5.2.0: Make `bs-ptr` use `char` instead of `unsigned char`. See issue #16. inline-c-0.9.1.10/LICENSE0000644000000000000000000000205414503767417012650 0ustar0000000000000000Copyright (c) 2015 FP Complete Corporation. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. inline-c-0.9.1.10/Setup.hs0000644000000000000000000000005614503767417013277 0ustar0000000000000000import Distribution.Simple main = defaultMain inline-c-0.9.1.10/inline-c.cabal0000644000000000000000000000614614505637060014323 0ustar0000000000000000name: inline-c version: 0.9.1.10 synopsis: Write Haskell source files including C code inline. No FFI required. description: See . license: MIT license-file: LICENSE author: Francesco Mazzoli, Mathieu Boespflug maintainer: f@mazzo.li copyright: (c) 2015-2016 FP Complete Corporation, (c) 2017-2019 Francesco Mazzoli category: FFI tested-with: GHC == 9.2.8, GHC == 9.4.7, GHC == 9.6.2 build-type: Simple cabal-version: >=1.10 Extra-Source-Files: README.md, changelog.md source-repository head type: git location: https://github.com/fpco/inline-c flag gsl-example description: Build GSL example default: False library exposed-modules: Language.C.Inline , Language.C.Inline.Context , Language.C.Inline.HaskellIdentifier , Language.C.Inline.Internal , Language.C.Inline.Unsafe , Language.C.Inline.Interruptible , Language.C.Types , Language.C.Types.Parse other-modules: Language.C.Inline.FunPtr ghc-options: -Wall build-depends: base >=4.7 && <5 , prettyprinter >=1.7 , bytestring , containers , hashable , mtl , parsec >= 3 , parsers , template-haskell >= 2.12.0.0 , transformers >= 0.1.3.0 , unordered-containers , vector hs-source-dirs: src default-language: Haskell2010 test-suite tests type: exitcode-stdio-1.0 hs-source-dirs: test main-is: tests.hs other-modules: Dummy , Language.C.Inline.ContextSpec , Language.C.Inline.ParseSpec , Language.C.Types.ParseSpec build-depends: base >=4 && <5 , QuickCheck , containers , hashable , hspec >= 2 , inline-c , parsers , QuickCheck , prettyprinter , raw-strings-qq , regex-posix , template-haskell , transformers , unordered-containers , vector , split default-language: Haskell2010 ghc-options: -Wall cc-options: -Wall -Werror executable gsl-ode hs-source-dirs: examples main-is: gsl-ode.hs default-language: Haskell2010 extra-libraries: gsl gslcblas m ghc-options: -Wall cc-options: -Wall -Werror if flag(gsl-example) buildable: True build-depends: base >=4 && <5 , inline-c , vector else buildable: False