inline-c 0.6.1.0 → 0.7.0.0

raw patch · 9 files changed

+140/−24 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• changelog.md +1/−0
• examples/gsl-ode.hs +0/−4
• inline-c.cabal +3/−3
• src/Language/C/Inline.hs +12/−1
• src/Language/C/Inline/Internal.hs +108/−12
• src/Language/C/Inline/Interruptible.hs +1/−1
• src/Language/C/Inline/Unsafe.hs +1/−1
• test/Language/C/Types/ParseSpec.hs +1/−1
• test/tests.hs +13/−1

@@ -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

@@ -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 "<gsl/gsl_errno.h>"

@@ -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 <https://github.com/fpco/inline-c/blob/master/README.md>. 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

@@ -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

@@ -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 <https://ghc.haskell.org/trac/ghc/ticket/10596> #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

@@ -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

@@ -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

@@ -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   }

@@ -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