diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,4 @@ +- 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 diff --git a/examples/gsl-ode.hs b/examples/gsl-ode.hs --- a/examples/gsl-ode.hs +++ b/examples/gsl-ode.hs @@ -17,10 +17,6 @@ import qualified Language.C.Inline.Unsafe as CU import System.IO.Unsafe (unsafePerformIO) -#if __GLASGOW_HASKELL__ < 710 -import Data.Functor ((<$>)) -#endif - C.context (C.baseCtx <> C.vecCtx <> C.funCtx) C.include "" diff --git a/inline-c.cabal b/inline-c.cabal --- a/inline-c.cabal +++ b/inline-c.cabal @@ -1,14 +1,14 @@ name: inline-c -version: 0.6.1.0 +version: 0.7.0.0 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: francesco@fpcomplete.com -copyright: (c) 2015-2016 FP Complete Corporation, (c) 2017 Francesco Mazzoli +copyright: (c) 2015-2016 FP Complete Corporation, (c) 2017-2018 Francesco Mazzoli category: FFI -tested-with: GHC == 8.2.1 +tested-with: GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1 build-type: Simple cabal-version: >=1.10 Extra-Source-Files: README.md, changelog.md diff --git a/src/Language/C/Inline.hs b/src/Language/C/Inline.hs --- a/src/Language/C/Inline.hs +++ b/src/Language/C/Inline.hs @@ -36,6 +36,7 @@ , exp , pure , block + , funPtr , include , verbatim @@ -244,7 +245,17 @@ -- | C code blocks (i.e. statements). block :: TH.QuasiQuoter -block = genericQuote IO $ inlineItems TH.Safe +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. +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 diff --git a/src/Language/C/Inline/Internal.hs b/src/Language/C/Inline/Internal.hs --- a/src/Language/C/Inline/Internal.hs +++ b/src/Language/C/Inline/Internal.hs @@ -49,6 +49,7 @@ -- * Utility functions for writing quasiquoters , genericQuote + , funPtrQuote ) where import Control.Applicative @@ -74,6 +75,8 @@ import qualified Text.PrettyPrint.ANSI.Leijen as PP import qualified Data.List as L import qualified Data.Char as C +import Data.Hashable (Hashable) +import Foreign.Ptr (FunPtr) -- We cannot use getQ/putQ before 7.10.3 because of #define USE_GETQ (__GLASGOW_HASKELL__ > 710 || (__GLASGOW_HASKELL__ == 710 && __GLASGOW_HASKELL_PATCHLEVEL1__ >= 3)) @@ -242,6 +245,9 @@ -- ^ 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 @@ -275,19 +281,23 @@ void $ emitVerbatim $ out codeDefs -- Create and add the FFI declaration. ffiImportName <- uniqueFfiImportName - dec <- TH.forImpD TH.CCall codeCallSafety codeFunName ffiImportName codeType + 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 :: TH.Q String -uniqueCName = do +uniqueCName :: Maybe String -> TH.Q String +uniqueCName mbPostfix = do -- The name looks like this: - -- inline_c_MODULE_INDEX + -- 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 @@ -297,7 +307,10 @@ module_ <- TH.loc_module <$> TH.location let replaceDot '.' = '_' replaceDot c = c - return $ "inline_c_" ++ map replaceDot module_ ++ "_" ++ show 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. -- @@ -323,7 +336,7 @@ -- ^ The C expression -> TH.ExpQ inlineExp callSafety type_ cRetType cParams cExp = - inlineItems callSafety type_ cRetType cParams cItems + inlineItems callSafety False Nothing type_ cRetType cParams cItems where cItems = case cRetType of C.TypeSpecifier _quals C.Void -> cExp ++ ";" @@ -337,6 +350,7 @@ -- c_cos :: Double -> Double -- c_cos = $(inlineItems -- TH.Unsafe +-- False -- [t| Double -> Double |] -- (quickCParser_ \"double\" parseType) -- [("x", quickCParser_ \"double\" parseType)] @@ -345,6 +359,10 @@ 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.TypeQ -- ^ Type of the foreign call -> C.Type C.CIdentifier @@ -354,10 +372,10 @@ -> String -- ^ The C items -> TH.ExpQ -inlineItems callSafety type_ cRetType cParams cItems = do +inlineItems callSafety funPtr mbPostfix type_ cRetType cParams cItems = do let mkParam (id', paramTy) = C.ParameterDeclaration (Just id') paramTy let proto = C.Proto cRetType (map mkParam cParams) - funName <- uniqueCName + funName <- uniqueCName mbPostfix cFunName <- case C.cIdentifierFromString funName of Left err -> fail $ "inlineItems: impossible, generated bad C identifier " ++ "funName:\n" ++ err @@ -371,19 +389,23 @@ , codeType = type_ , codeFunName = funName , codeDefs = defs + , codeFunPtr = funPtr } ------------------------------------------------------------------------ -- Parsing runParserInQ - :: String -> C.TypeNames -> (forall m. C.CParser HaskellIdentifier m => m a) -> TH.Q a -runParserInQ s typeNames' p = do + :: (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 (haskellCParserContext typeNames') (TH.loc_filename loc) s p' of + 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 @@ -531,7 +553,9 @@ genericQuote purity build = quoteCode $ \s -> do ctx <- getContext ParseTypedC cType cParams cExp <- - runParserInQ s (typeNamesFromTypesTable (ctxTypesTable ctx)) $ parseTypedC $ ctxAntiQuoters ctx + runParserInQ s + (haskellCParserContext (typeNamesFromTypesTable (ctxTypesTable ctx))) + (parseTypedC (ctxAntiQuoters ctx)) hsType <- cToHs ctx cType hsParams <- forM cParams $ \(_cId, cTy, parTy) -> do case parTy of @@ -590,6 +614,78 @@ r -> r) where (ty, body) = span (/= '{') s trim x = L.dropWhileEnd C.isSpace (dropWhile C.isSpace x) + +-- | 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 $ \code -> do + ctx <- getContext + FunPtrDecl{..} <- runParserInQ code (C.cCParserContext (typeNamesFromTypesTable (ctxTypesTable ctx))) parse + hsRetType <- cToHs ctx funPtrReturnType + hsParams <- forM funPtrParameters (\(_ident, typ_) -> cToHs ctx typ_) + let hsFunType = convertCFunSig hsRetType hsParams + inlineItems callSafety True funPtrName hsFunType funPtrReturnType funPtrParameters funPtrBody + where + cToHs :: Context -> C.Type C.CIdentifier -> TH.TypeQ + cToHs ctx cTy = do + mbHsTy <- convertType IO (ctxTypesTable ctx) cTy + case mbHsTy of + Nothing -> fail $ "Could not resolve Haskell type for C type " ++ pretty80 cTy + Just hsTy -> return hsTy + + 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') ------------------------------------------------------------------------ -- Utils diff --git a/src/Language/C/Inline/Interruptible.hs b/src/Language/C/Inline/Interruptible.hs --- a/src/Language/C/Inline/Interruptible.hs +++ b/src/Language/C/Inline/Interruptible.hs @@ -43,4 +43,4 @@ -- | C code blocks (i.e. statements). block :: TH.QuasiQuoter -block = genericQuote IO $ inlineItems TH.Interruptible +block = genericQuote IO $ inlineItems TH.Unsafe False Nothing diff --git a/src/Language/C/Inline/Unsafe.hs b/src/Language/C/Inline/Unsafe.hs --- a/src/Language/C/Inline/Unsafe.hs +++ b/src/Language/C/Inline/Unsafe.hs @@ -46,4 +46,4 @@ -- | C code blocks (i.e. statements). block :: TH.QuasiQuoter -block = genericQuote IO $ inlineItems TH.Unsafe +block = genericQuote IO $ inlineItems TH.Unsafe False Nothing diff --git a/test/Language/C/Types/ParseSpec.hs b/test/Language/C/Types/ParseSpec.hs --- a/test/Language/C/Types/ParseSpec.hs +++ b/test/Language/C/Types/ParseSpec.hs @@ -104,7 +104,7 @@ , _pdwtnParameterDeclaration :: (ParameterDeclaration i) } deriving (Typeable, Eq, Show) -data (QC.Arbitrary i) => ArbitraryContext i = ArbitraryContext +data ArbitraryContext i = ArbitraryContext { acTypeNames :: TypeNames , acIdentToString :: i -> String } diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -12,6 +12,8 @@ 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 @@ -51,11 +53,14 @@ [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; } |]) + [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 = $(C.inlineItems TH.Unsafe + False -- not a function pointer + Nothing -- no postfix [t| CInt -> CInt |] (C.quickCParser_ "int" C.parseType) [("x", C.quickCParser_ "int" C.parseType)] @@ -204,3 +209,10 @@ 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