inline-c 0.5.3.2 → 0.5.3.3
raw patch · 6 files changed
+73/−62 lines, 6 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- changelog.md +3/−0
- inline-c.cabal +1/−1
- src/Language/C/Inline.hs +1/−1
- src/Language/C/Inline/Context.hs +9/−9
- src/Language/C/Inline/FunPtr.hs +1/−1
- src/Language/C/Inline/Internal.hs +58/−50
changelog.md view
@@ -1,3 +1,6 @@+- 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.
inline-c.cabal view
@@ -1,5 +1,5 @@ name: inline-c-version: 0.5.3.2+version: 0.5.3.3 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
src/Language/C/Inline.hs view
@@ -264,7 +264,7 @@ -- @ include :: String -> TH.DecsQ include s- | null s = error "inline-c: empty string (include)"+ | null s = fail "inline-c: empty string (include)" | head s == '<' = verbatim $ "#include " ++ s | otherwise = verbatim $ "#include \"" ++ s ++ "\""
src/Language/C/Inline/Context.hs view
@@ -272,15 +272,15 @@ getHsVariable err s = do mbHsName <- TH.lookupValueName s case mbHsName of- Nothing -> error $ "Cannot capture Haskell variable " ++ s ++- ", because it's not in scope. (" ++ err ++ ")"+ Nothing -> fail $ "Cannot capture Haskell variable " ++ s +++ ", because it's not in scope. (" ++ err ++ ")" Just hsName -> TH.varE hsName convertType_ :: String -> Purity -> TypesTable -> C.Type -> TH.Q TH.Type convertType_ err purity cTypes cTy = do mbHsType <- convertType purity cTypes cTy case mbHsType of- Nothing -> error $ "Cannot convert C type (" ++ err ++ ")"+ Nothing -> fail $ "Cannot convert C type (" ++ err ++ ")" Just hsType -> return hsType -- | This 'Context' includes a 'AntiQuoter' that removes the need for@@ -305,7 +305,7 @@ { aqParser = do cTy <- Parser.parens C.parseParameterDeclaration case C.parameterDeclarationId cTy of- Nothing -> error "Every captured function must be named (funCtx)"+ Nothing -> fail "Every captured function must be named (funCtx)" Just id' -> do let s = C.unIdentifier id' return (s, C.parameterDeclarationType cTy, s)@@ -321,7 +321,7 @@ return x |] return (hsTy, hsExp')- _ -> error "The `fun' marshaller captures function pointers only"+ _ -> fail "The `fun' marshaller captures function pointers only" } -- | This 'Context' includes two 'AntiQuoter's that allow to easily use@@ -371,7 +371,7 @@ { aqParser = do cTy <- Parser.parens C.parseParameterDeclaration case C.parameterDeclarationId cTy of- Nothing -> error "Every captured vector must be named (vecCtx)"+ Nothing -> fail "Every captured vector must be named (vecCtx)" Just id' -> do let s = C.unIdentifier id' return (s, C.parameterDeclarationType cTy, s)@@ -397,7 +397,7 @@ hsExp'' <- [| \cont -> cont $(return hsExp') |] return (hsTy, hsExp'') _ -> do- error "impossible: got type different from `long' (vecCtx)"+ fail "impossible: got type different from `long' (vecCtx)" } @@ -427,7 +427,7 @@ hsExp' <- [| \cont -> BS.unsafeUseAsCString $(return hsExp) $ \ptr -> cont ptr |] return (hsTy, hsExp') _ ->- error "impossible: got type different from `unsigned char' (bsCtx)"+ fail "impossible: got type different from `unsigned char' (bsCtx)" } bsLenAntiQuoter :: AntiQuoter String@@ -445,5 +445,5 @@ hsExp'' <- [| \cont -> cont $(return hsExp') |] return (hsTy, hsExp'') _ -> do- error "impossible: got type different from `long' (bsCtx)"+ fail "impossible: got type different from `long' (bsCtx)" }
src/Language/C/Inline/FunPtr.hs view
@@ -38,7 +38,7 @@ i <- TH.reify name case i of TH.VarI _ ty _ _ -> [| $(mkFunPtr (return ty)) $(TH.varE name) |]- _ -> error "mkFunPtrFromName: expecting a variable as argument."+ _ -> fail "mkFunPtrFromName: expecting a variable as argument." -- | @$('peekFunPtr' [t| 'CDouble' -> 'IO' 'CDouble' |])@ generates a foreign import -- dynamic of type
src/Language/C/Inline/Internal.hs view
@@ -48,14 +48,14 @@ ) where import Control.Applicative+import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, readMVar) import Control.Exception (catch, throwIO)-import Control.Monad (forM, void, msum, when, unless)+import Control.Monad (forM, void, msum, unless) import Control.Monad.State (evalStateT, StateT, get, put) import Control.Monad.Trans.Class (lift) import qualified Crypto.Hash as CryptoHash import qualified Data.Binary as Binary import Data.Foldable (forM_)-import Data.IORef (IORef, newIORef, readIORef, writeIORef) import qualified Data.Map as Map import Data.Maybe (fromMaybe) import Data.Typeable (Typeable, cast)@@ -80,17 +80,30 @@ import Language.C.Inline.FunPtr data ModuleState = ModuleState- { msModuleName :: String- , msContext :: Context+ { msContext :: Context , msGeneratedNames :: Int } -{-# NOINLINE moduleStateRef #-}-moduleStateRef :: IORef (Maybe ModuleState)-moduleStateRef = unsafePerformIO $ newIORef Nothing+-- | 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 --- | Make sure that 'moduleStateRef' and the respective C file are up--- to date.+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++-- | 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',@@ -98,23 +111,20 @@ -> TH.Q Context initialiseModuleState mbContext = do cFile <- cSourceLoc context- mbModuleState <- TH.runIO $ readIORef moduleStateRef- thisModule <- TH.loc_module <$> TH.location- let recordThisModule = TH.runIO $ do+ thisModule <- getModuleId+ TH.runIO $ modifyMVar moduleStatesVar $ \moduleStates -> do+ case Map.lookup thisModule moduleStates of+ Just moduleState -> return (moduleStates, msContext moduleState)+ Nothing -> do -- If the file exists and this is the first time we write -- something from this module (in other words, if we are -- recompiling the module), kill the file first. removeIfExists cFile- writeIORef moduleStateRef $ Just ModuleState- { msModuleName = thisModule- , msContext = context- , msGeneratedNames = 0- }- return context- case mbModuleState of- Nothing -> recordThisModule- Just ms | msModuleName ms == thisModule -> return $ msContext ms- Just _ms -> recordThisModule+ let moduleState = ModuleState+ { msContext = context+ , msGeneratedNames = 0+ }+ return (Map.insert thisModule moduleState moduleStates, context) where context = fromMaybe baseCtx mbContext @@ -123,14 +133,15 @@ getContext :: TH.Q Context getContext = initialiseModuleState Nothing -getModuleState :: TH.Q ModuleState-getModuleState = do- mbModuleState <- TH.runIO $ readIORef moduleStateRef- thisModule <- TH.loc_module <$> TH.location- case mbModuleState of- Nothing -> error "inline-c: ModuleState not present"- Just ms | msModuleName ms == thisModule -> return ms- Just _ms -> error "inline-c: stale ModuleState"+modifyModuleState :: (ModuleState -> (ModuleState, a)) -> TH.Q a+modifyModuleState f = do+ thisModule <- getModuleId+ TH.runIO $ modifyMVar moduleStatesVar $ \moduleStates ->+ case Map.lookup thisModule moduleStates of+ Nothing -> fail "inline-c: ModuleState not present"+ Just ms -> do+ let (ms', x) = f ms+ return (Map.insert thisModule ms' moduleStates, x) -- $context --@@ -144,20 +155,17 @@ -- module. Fails if that's not the case. setContext :: Context -> TH.Q () setContext ctx = do- mbModuleState <- TH.runIO $ readIORef moduleStateRef- forM_ mbModuleState $ \ms -> do- thisModule <- TH.loc_module <$> TH.location- when (msModuleName ms == thisModule) $- error "inline-c: The module has already been initialised (setContext)."+ thisModule <- getModuleId+ moduleStates <- TH.runIO $ readMVar moduleStatesVar+ forM_ (Map.lookup thisModule moduleStates) $ \_ms ->+ fail "inline-c: The module has already been initialised (setContext)." void $ initialiseModuleState $ Just ctx bumpGeneratedNames :: TH.Q Int bumpGeneratedNames = do- ms <- getModuleState- TH.runIO $ do+ modifyModuleState $ \ms -> let c' = msGeneratedNames ms- writeIORef moduleStateRef $ Just ms{msGeneratedNames = c' + 1}- return c'+ in (ms{msGeneratedNames = c' + 1}, c') ------------------------------------------------------------------------ -- Emitting@@ -335,7 +343,7 @@ case C.runCParser isTypeName' (TH.loc_filename loc) s p' of Left err -> do -- TODO consider prefixing with "error while parsing C" or similar- error $ show err+ fail $ show err Right res -> do return res @@ -436,9 +444,9 @@ -> TH.QuasiQuoter quoteCode p = TH.QuasiQuoter { TH.quoteExp = p- , TH.quotePat = error "inline-c: quotePat not implemented (quoteCode)"- , TH.quoteType = error "inline-c: quoteType not implemented (quoteCode)"- , TH.quoteDec = error "inline-c: quoteDec not implemented (quoteCode)"+ , TH.quotePat = fail "inline-c: quotePat not implemented (quoteCode)"+ , TH.quoteType = fail "inline-c: quoteType not implemented (quoteCode)"+ , TH.quoteDec = fail "inline-c: quoteDec not implemented (quoteCode)" } genericQuote@@ -459,8 +467,8 @@ mbHsName <- TH.lookupValueName s' hsExp <- case mbHsName of Nothing -> do- error $ "Cannot capture Haskell variable " ++ s' ++- ", because it's not in scope. (genericQuote)"+ fail $ "Cannot capture Haskell variable " ++ s' +++ ", because it's not in scope. (genericQuote)" Just hsName -> do hsExp <- TH.varE hsName [| \cont -> cont ($(return hsExp) :: $(return hsTy)) |]@@ -468,12 +476,12 @@ AntiQuote antiId dyn -> do case Map.lookup antiId (ctxAntiQuoters ctx) of Nothing ->- error $ "IMPOSSIBLE: could not find anti-quoter " ++ show antiId ++- ". (genericQuote)"+ fail $ "IMPOSSIBLE: could not find anti-quoter " ++ show antiId +++ ". (genericQuote)" Just (SomeAntiQuoter antiQ) -> case fromSomeEq dyn of Nothing ->- error $ "IMPOSSIBLE: could not cast value for anti-quoter " ++- show antiId ++ ". (genericQuote)"+ 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@@ -488,7 +496,7 @@ cToHs ctx cTy = do mbHsTy <- convertType purity (ctxTypesTable ctx) cTy case mbHsTy of- Nothing -> error $ "Could not resolve Haskell type for C type " ++ pretty80 cTy+ Nothing -> fail $ "Could not resolve Haskell type for C type " ++ pretty80 cTy Just hsTy -> return hsTy buildFunCall :: Context -> TH.ExpQ -> [TH.Exp] -> [TH.Name] -> TH.ExpQ