{-# OPTIONS_GHC -funbox-strict-fields #-}
module Control.Concurrent.Process.QSem
( QSem, newQSem, lookupQSem, waitQSem, tryWaitQSem, signalQSem, qSemName
) where
import Control.Monad (when)
import Data.Data (Typeable)
import Foreign.C.Error
import Foreign.C.String
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.SharedObjectName.Internal
data QSemT
data QSem = QSem !(SOName QSem) !(ForeignPtr QSemT)
deriving (Eq, Typeable)
newQSem :: Int -> IO QSem
newQSem initial
| initial < 0 = fail "newQSem: Initial quantity must be non-negative"
| otherwise = do
qsem <- checkNullPointer "newQSem" $ c'qsem_new initial
n <- newEmptySOName
unsafeWithSOName n $ c'qsem_name qsem
QSem n <$> newForeignPtr p'qsem_close qsem
lookupQSem :: SOName QSem -> IO QSem
lookupQSem n = do
qsem <- unsafeWithSOName n $ checkNullPointer "lookupQSem" . c'qsem_lookup
QSem n <$> newForeignPtr p'qsem_close qsem
qSemName :: QSem -> SOName QSem
qSemName (QSem r _) = r
waitQSem :: QSem -> IO ()
waitQSem (QSem _ p) = withForeignPtr p $ checkZeroReturn "waitQSem" . c'qsem_wait
tryWaitQSem :: QSem -> IO Bool
tryWaitQSem (QSem _ p) = withForeignPtr p $ fmap (0 ==) . c'qsem_trywait
signalQSem :: QSem -> IO ()
signalQSem (QSem _ p) = withForeignPtr p $ checkZeroReturn "signalQSem" . c'qsem_signal
checkNullPointer :: String -> IO (Ptr a) -> IO (Ptr a)
checkNullPointer s k = do
p <- k
if p == nullPtr
then throwErrno (s ++ " returned NULL pointer.")
else return p
checkZeroReturn :: String -> IO CInt -> IO ()
checkZeroReturn s k = do
p <- k
when (p /= 0) $
throwErrno (s ++ " returned non-zero result.")
foreign import ccall unsafe "qsem_new"
c'qsem_new :: Int -> IO (Ptr QSemT)
foreign import ccall unsafe "qsem_lookup"
c'qsem_lookup :: CString -> IO (Ptr QSemT)
foreign import ccall unsafe "&qsem_close"
p'qsem_close :: FunPtr (Ptr QSemT -> IO ())
foreign import ccall unsafe "qsem_signal"
c'qsem_signal :: Ptr QSemT -> IO CInt
foreign import ccall unsafe "qsem_wait"
c'qsem_wait :: Ptr QSemT -> IO CInt
foreign import ccall unsafe "qsem_trywait"
c'qsem_trywait :: Ptr QSemT -> IO CInt
foreign import ccall unsafe "qsem_name"
c'qsem_name :: Ptr QSemT -> CString -> IO ()