{-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE Safe #-}
#elif __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Trustworthy #-}
#endif
module Control.Concurrent.STM.Lock
( Lock
, new
, newAcquired
, acquire
, tryAcquire
, release
, with
, tryWith
, wait
, locked
) where
import Control.Applicative ( liftA2 )
import Control.Exception ( bracket_, onException )
import Control.Monad ( return, when )
import Data.Bool ( Bool, not )
#ifdef __HADDOCK_VERSION__
import Data.Bool ( Bool(False, True) )
#endif
import Data.Eq ( Eq )
import Data.Function ( ($), (.) )
import Data.Functor ( fmap, (<$>) )
import Data.Maybe ( Maybe(Nothing, Just), isJust )
import Data.Typeable ( Typeable )
import Prelude ( error )
import System.IO ( IO )
#if __GLASGOW_HASKELL__ < 700
import Control.Monad ( (>>=), fail )
#endif
#if __GLASGOW_HASKELL__ < 700
import Control.Monad ( Monad )
#endif
import Control.Concurrent.STM ( STM, atomically )
#ifdef __HADDOCK_VERSION__
import Control.Concurrent.STM ( retry )
#endif
import Control.Concurrent.STM.TMVar ( TMVar, newTMVar, newEmptyTMVar
, takeTMVar, tryTakeTMVar
, tryPutTMVar, readTMVar, isEmptyTMVar
)
import Utils ( mask )
newtype Lock = Lock {Lock -> TMVar ()
un :: TMVar ()}
deriving (Typeable, Lock -> Lock -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Lock -> Lock -> Bool
$c/= :: Lock -> Lock -> Bool
== :: Lock -> Lock -> Bool
$c== :: Lock -> Lock -> Bool
Eq)
new :: STM Lock
new :: STM Lock
new = TMVar () -> Lock
Lock forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> STM (TMVar a)
newTMVar ()
newAcquired :: STM Lock
newAcquired :: STM Lock
newAcquired = TMVar () -> Lock
Lock forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. STM (TMVar a)
newEmptyTMVar
acquire :: Lock -> STM ()
acquire :: Lock -> STM ()
acquire = forall a. TMVar a -> STM a
takeTMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lock -> TMVar ()
un
tryAcquire :: Lock -> STM Bool
tryAcquire :: Lock -> STM Bool
tryAcquire = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lock -> TMVar ()
un
release :: Lock -> STM ()
release :: Lock -> STM ()
release (Lock TMVar ()
tmv) = do
Bool
b <- forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar ()
tmv ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
b) forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> a
error [Char]
"Control.Concurrent.STM.Lock.release: Can't release unlocked Lock!"
with :: Lock -> IO a -> IO a
with :: forall a. Lock -> IO a -> IO a
with = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lock -> STM ()
acquire) (forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lock -> STM ()
release)
tryWith :: Lock -> IO a -> IO (Maybe a)
tryWith :: forall a. Lock -> IO a -> IO (Maybe a)
tryWith Lock
l IO a
a = forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
Bool
acquired <- forall a. STM a -> IO a
atomically (Lock -> STM Bool
tryAcquire Lock
l)
if Bool
acquired
then do a
r <- forall a. IO a -> IO a
restore IO a
a forall a b. IO a -> IO b -> IO a
`onException` forall a. STM a -> IO a
atomically (Lock -> STM ()
release Lock
l)
forall a. STM a -> IO a
atomically (Lock -> STM ()
release Lock
l)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
r
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
wait :: Lock -> STM ()
wait :: Lock -> STM ()
wait (Lock TMVar ()
tmv) = forall a. TMVar a -> STM a
readTMVar TMVar ()
tmv
locked :: Lock -> STM Bool
locked :: Lock -> STM Bool
locked = forall a. TMVar a -> STM Bool
isEmptyTMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lock -> TMVar ()
un