{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Concurrent.Classy.Lock
(
Lock
, newLock
, newAcquired
, acquire
, tryAcquire
, release
, with
, tryWith
, wait
, locked
) where
import Control.Applicative (pure, (<*>))
import Control.Monad (when)
import Data.Bool (Bool, not)
import Data.Eq (Eq((==)))
import Data.Function (($), (.))
import Data.Functor (fmap, (<$>))
import Data.Maybe (Maybe(Just, Nothing), isJust)
import Data.Typeable (Typeable)
import Prelude (error)
import qualified Control.Concurrent.Classy.MVar as MVar
import Control.Monad.Catch (bracket_, mask, onException)
import Control.Monad.Conc.Class (MonadConc(MVar))
newtype Lock m
= Lock
{ forall (m :: * -> *). Lock m -> MVar m ()
_fromLock :: MVar m ()
}
deriving (Typeable)
instance (Eq (MVar m ())) => Eq (Lock m) where
== :: Lock m -> Lock m -> Bool
(==) (Lock MVar m ()
a) (Lock MVar m ()
b) = MVar m ()
a MVar m () -> MVar m () -> Bool
forall a. Eq a => a -> a -> Bool
== MVar m ()
b
newLock :: (MonadConc m) => m (Lock m)
newLock :: forall (m :: * -> *). MonadConc m => m (Lock m)
newLock = MVar m () -> Lock m
forall (m :: * -> *). MVar m () -> Lock m
Lock (MVar m () -> Lock m) -> m (MVar m ()) -> m (Lock m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> () -> m (MVar m ())
forall (m :: * -> *) a. MonadConc m => a -> m (MVar m a)
MVar.newMVar ()
newAcquired :: (MonadConc m) => m (Lock m)
newAcquired :: forall (m :: * -> *). MonadConc m => m (Lock m)
newAcquired = MVar m () -> Lock m
forall (m :: * -> *). MVar m () -> Lock m
Lock (MVar m () -> Lock m) -> m (MVar m ()) -> m (Lock m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (MVar m ())
forall a. m (MVar m a)
forall (m :: * -> *) a. MonadConc m => m (MVar m a)
MVar.newEmptyMVar
acquire :: (MonadConc m) => Lock m -> m ()
acquire :: forall (m :: * -> *). MonadConc m => Lock m -> m ()
acquire = MVar m () -> m ()
forall a. MVar m a -> m a
forall (m :: * -> *) a. MonadConc m => MVar m a -> m a
MVar.takeMVar (MVar m () -> m ()) -> (Lock m -> MVar m ()) -> Lock m -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lock m -> MVar m ()
forall (m :: * -> *). Lock m -> MVar m ()
_fromLock
tryAcquire :: (MonadConc m) => Lock m -> m Bool
tryAcquire :: forall (m :: * -> *). MonadConc m => Lock m -> m Bool
tryAcquire = (Maybe () -> Bool) -> m (Maybe ()) -> m Bool
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (m (Maybe ()) -> m Bool)
-> (Lock m -> m (Maybe ())) -> Lock m -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar m () -> m (Maybe ())
forall a. MVar m a -> m (Maybe a)
forall (m :: * -> *) a. MonadConc m => MVar m a -> m (Maybe a)
MVar.tryTakeMVar (MVar m () -> m (Maybe ()))
-> (Lock m -> MVar m ()) -> Lock m -> m (Maybe ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lock m -> MVar m ()
forall (m :: * -> *). Lock m -> MVar m ()
_fromLock
release :: (MonadConc m) => Lock m -> m ()
release :: forall (m :: * -> *). MonadConc m => Lock m -> m ()
release (Lock MVar m ()
mv) = do
Bool
b <- MVar m () -> () -> m Bool
forall a. MVar m a -> a -> m Bool
forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m Bool
MVar.tryPutMVar MVar m ()
mv ()
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
b) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
[Char] -> m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Control.Concurrent.Classy.Lock.release: cannot release an unlocked Lock!"
with :: (MonadConc m) => Lock m -> m a -> m a
with :: forall (m :: * -> *) a. MonadConc m => Lock m -> m a -> m a
with = m () -> m () -> m a -> m a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
bracket_ (m () -> m () -> m a -> m a)
-> (Lock m -> m ()) -> Lock m -> m () -> m a -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lock m -> m ()
forall (m :: * -> *). MonadConc m => Lock m -> m ()
acquire (Lock m -> m () -> m a -> m a)
-> (Lock m -> m ()) -> Lock m -> m a -> m a
forall a b. (Lock m -> a -> b) -> (Lock m -> a) -> Lock m -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Lock m -> m ()
forall (m :: * -> *). MonadConc m => Lock m -> m ()
release
tryWith :: (MonadConc m) => Lock m -> m a -> m (Maybe a)
tryWith :: forall (m :: * -> *) a. MonadConc m => Lock m -> m a -> m (Maybe a)
tryWith Lock m
l m a
a = ((forall a. m a -> m a) -> m (Maybe a)) -> m (Maybe a)
forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m (Maybe a)) -> m (Maybe a))
-> ((forall a. m a -> m a) -> m (Maybe a)) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
Bool
acquired <- Lock m -> m Bool
forall (m :: * -> *). MonadConc m => Lock m -> m Bool
tryAcquire Lock m
l
if Bool
acquired
then do a
r <- m a -> m a
forall a. m a -> m a
restore m a
a m a -> m () -> m a
forall (m :: * -> *) a b.
(HasCallStack, MonadCatch m) =>
m a -> m b -> m a
`onException` Lock m -> m ()
forall (m :: * -> *). MonadConc m => Lock m -> m ()
release Lock m
l
Lock m -> m ()
forall (m :: * -> *). MonadConc m => Lock m -> m ()
release Lock m
l
Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
r)
else Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
wait :: (MonadConc m) => Lock m -> m ()
wait :: forall (m :: * -> *). MonadConc m => Lock m -> m ()
wait (Lock MVar m ()
mv) = MVar m () -> m ()
forall a. MVar m a -> m a
forall (m :: * -> *) a. MonadConc m => MVar m a -> m a
MVar.readMVar MVar m ()
mv
locked :: (MonadConc m) => Lock m -> m Bool
locked :: forall (m :: * -> *). MonadConc m => Lock m -> m Bool
locked = MVar m () -> m Bool
forall (m :: * -> *) a. MonadConc m => MVar m a -> m Bool
MVar.isEmptyMVar (MVar m () -> m Bool) -> (Lock m -> MVar m ()) -> Lock m -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lock m -> MVar m ()
forall (m :: * -> *). Lock m -> MVar m ()
_fromLock