{-# 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
(Lock -> Lock -> Bool) -> (Lock -> Lock -> Bool) -> Eq Lock
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Lock -> Lock -> Bool
== :: Lock -> Lock -> Bool
$c/= :: Lock -> Lock -> Bool
/= :: Lock -> Lock -> Bool
Eq)
new :: STM Lock
new :: STM Lock
new = TMVar () -> Lock
Lock (TMVar () -> Lock) -> STM (TMVar ()) -> STM Lock
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> () -> STM (TMVar ())
forall a. a -> STM (TMVar a)
newTMVar ()
newAcquired :: STM Lock
newAcquired :: STM Lock
newAcquired = TMVar () -> Lock
Lock (TMVar () -> Lock) -> STM (TMVar ()) -> STM Lock
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (TMVar ())
forall a. STM (TMVar a)
newEmptyTMVar
acquire :: Lock -> STM ()
acquire :: Lock -> STM ()
acquire = TMVar () -> STM ()
forall a. TMVar a -> STM a
takeTMVar (TMVar () -> STM ()) -> (Lock -> TMVar ()) -> Lock -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lock -> TMVar ()
un
tryAcquire :: Lock -> STM Bool
tryAcquire :: Lock -> STM Bool
tryAcquire = (Maybe () -> Bool) -> STM (Maybe ()) -> STM Bool
forall a b. (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (STM (Maybe ()) -> STM Bool)
-> (Lock -> STM (Maybe ())) -> Lock -> STM Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar () -> STM (Maybe ())
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar (TMVar () -> STM (Maybe ()))
-> (Lock -> TMVar ()) -> Lock -> STM (Maybe ())
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 <- TMVar () -> () -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar ()
tmv ()
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
b) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> STM ()
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 = (IO () -> IO () -> IO a -> IO a)
-> (Lock -> IO ()) -> (Lock -> IO ()) -> Lock -> IO a -> IO a
forall a b c.
(a -> b -> c) -> (Lock -> a) -> (Lock -> b) -> Lock -> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (Lock -> STM ()) -> Lock -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lock -> STM ()
acquire) (STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (Lock -> STM ()) -> Lock -> IO ()
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 a. IO a -> IO a) -> IO (Maybe a)) -> IO (Maybe a)
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO (Maybe a)) -> IO (Maybe a))
-> ((forall a. IO a -> IO a) -> IO (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
Bool
acquired <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (Lock -> STM Bool
tryAcquire Lock
l)
if Bool
acquired
then do a
r <- IO a -> IO a
forall a. IO a -> IO a
restore IO a
a IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`onException` STM () -> IO ()
forall a. STM a -> IO a
atomically (Lock -> STM ()
release Lock
l)
STM () -> IO ()
forall a. STM a -> IO a
atomically (Lock -> STM ()
release Lock
l)
Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
r
else Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
wait :: Lock -> STM ()
wait :: Lock -> STM ()
wait (Lock TMVar ()
tmv) = TMVar () -> STM ()
forall a. TMVar a -> STM a
readTMVar TMVar ()
tmv
locked :: Lock -> STM Bool
locked :: Lock -> STM Bool
locked = TMVar () -> STM Bool
forall a. TMVar a -> STM Bool
isEmptyTMVar (TMVar () -> STM Bool) -> (Lock -> TMVar ()) -> Lock -> STM Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lock -> TMVar ()
un