{-# LANGUAGE CPP
, DeriveDataTypeable
, NamedFieldPuns
, NoImplicitPrelude
#-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
#endif
module Control.Concurrent.ReadWriteLock
( RWLock
, new
, newAcquiredRead
, newAcquiredWrite
, acquireRead
, releaseRead
, withRead
, waitRead
, tryAcquireRead
, tryWithRead
, acquireWrite
, releaseWrite
, withWrite
, waitWrite
, tryAcquireWrite
, tryWithWrite
) where
import Control.Applicative ( liftA2, liftA3 )
import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, putMVar )
import Control.Exception ( bracket_, onException )
import Control.Monad ( return, (>>) )
import Data.Bool ( Bool(False, True) )
import Data.Eq ( Eq, (==) )
import Data.Function ( ($), (.), on )
import Data.Int ( Int )
import Data.Maybe ( Maybe(Nothing, Just) )
import Data.List ( (++))
import Data.Typeable ( Typeable )
import Prelude ( String, ($!), succ, pred, error )
import System.IO ( IO )
#if __GLASGOW_HASKELL__ < 700
import Prelude ( fromInteger )
import Control.Monad ( (>>=), fail )
#endif
import Control.Concurrent.Lock ( Lock )
import qualified Control.Concurrent.Lock as Lock
( new, newAcquired, acquire, release, wait )
import Utils ( mask, mask_ )
data RWLock = RWLock { RWLock -> MVar State
state :: MVar State
, RWLock -> Lock
readLock :: Lock
, RWLock -> Lock
writeLock :: Lock
} deriving Typeable
instance Eq RWLock where
== :: RWLock -> RWLock -> Bool
(==) = MVar State -> MVar State -> Bool
forall a. Eq a => a -> a -> Bool
(==) (MVar State -> MVar State -> Bool)
-> (RWLock -> MVar State) -> RWLock -> RWLock -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` RWLock -> MVar State
state
data State = Free | Read Int | Write
new :: IO RWLock
new :: IO RWLock
new = (MVar State -> Lock -> Lock -> RWLock)
-> IO (MVar State) -> IO Lock -> IO Lock -> IO RWLock
forall (f :: * -> *) a b c d.
Applicative f =>
(a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 MVar State -> Lock -> Lock -> RWLock
RWLock (State -> IO (MVar State)
forall a. a -> IO (MVar a)
newMVar State
Free)
IO Lock
Lock.new
IO Lock
Lock.new
newAcquiredRead :: IO RWLock
newAcquiredRead :: IO RWLock
newAcquiredRead = (MVar State -> Lock -> Lock -> RWLock)
-> IO (MVar State) -> IO Lock -> IO Lock -> IO RWLock
forall (f :: * -> *) a b c d.
Applicative f =>
(a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 MVar State -> Lock -> Lock -> RWLock
RWLock (State -> IO (MVar State)
forall a. a -> IO (MVar a)
newMVar (State -> IO (MVar State)) -> State -> IO (MVar State)
forall a b. (a -> b) -> a -> b
$ Int -> State
Read Int
1)
IO Lock
Lock.newAcquired
IO Lock
Lock.new
newAcquiredWrite :: IO RWLock
newAcquiredWrite :: IO RWLock
newAcquiredWrite = (MVar State -> Lock -> Lock -> RWLock)
-> IO (MVar State) -> IO Lock -> IO Lock -> IO RWLock
forall (f :: * -> *) a b c d.
Applicative f =>
(a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 MVar State -> Lock -> Lock -> RWLock
RWLock (State -> IO (MVar State)
forall a. a -> IO (MVar a)
newMVar State
Write)
IO Lock
Lock.new
IO Lock
Lock.newAcquired
acquireRead :: RWLock -> IO ()
acquireRead :: RWLock -> IO ()
acquireRead (RWLock {MVar State
state :: RWLock -> MVar State
state :: MVar State
state, Lock
readLock :: RWLock -> Lock
readLock :: Lock
readLock, Lock
writeLock :: RWLock -> Lock
writeLock :: Lock
writeLock}) = IO () -> IO ()
forall a. IO a -> IO a
mask_ IO ()
acqRead
where
acqRead :: IO ()
acqRead = do State
st <- MVar State -> IO State
forall a. MVar a -> IO a
takeMVar MVar State
state
case State
st of
State
Free -> do Lock -> IO ()
Lock.acquire Lock
readLock
MVar State -> State -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar State
state (State -> IO ()) -> State -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> State
Read Int
1
Read Int
n -> MVar State -> State -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar State
state (State -> IO ()) -> (Int -> State) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> State
Read (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$! Int -> Int
forall a. Enum a => a -> a
succ Int
n
State
Write -> do MVar State -> State -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar State
state State
st
Lock -> IO ()
Lock.wait Lock
writeLock
IO ()
acqRead
tryAcquireRead :: RWLock -> IO Bool
tryAcquireRead :: RWLock -> IO Bool
tryAcquireRead (RWLock {MVar State
state :: RWLock -> MVar State
state :: MVar State
state, Lock
readLock :: RWLock -> Lock
readLock :: Lock
readLock}) = IO Bool -> IO Bool
forall a. IO a -> IO a
mask_ (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
State
st <- MVar State -> IO State
forall a. MVar a -> IO a
takeMVar MVar State
state
case State
st of
State
Free -> do Lock -> IO ()
Lock.acquire Lock
readLock
MVar State -> State -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar State
state (State -> IO ()) -> State -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> State
Read Int
1
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Read Int
n -> do MVar State -> State -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar State
state (State -> IO ()) -> (Int -> State) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> State
Read (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$! Int -> Int
forall a. Enum a => a -> a
succ Int
n
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
State
Write -> do MVar State -> State -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar State
state State
st
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
releaseRead :: RWLock -> IO ()
releaseRead :: RWLock -> IO ()
releaseRead (RWLock {MVar State
state :: RWLock -> MVar State
state :: MVar State
state, Lock
readLock :: RWLock -> Lock
readLock :: Lock
readLock}) = IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
State
st <- MVar State -> IO State
forall a. MVar a -> IO a
takeMVar MVar State
state
case State
st of
Read Int
1 -> do Lock -> IO ()
Lock.release Lock
readLock
MVar State -> State -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar State
state State
Free
Read Int
n -> MVar State -> State -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar State
state (State -> IO ()) -> (Int -> State) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> State
Read (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$! Int -> Int
forall a. Enum a => a -> a
pred Int
n
State
_ -> do MVar State -> State -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar State
state State
st
[Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
moduleName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".releaseRead: already released"
withRead :: RWLock -> IO a -> IO a
withRead :: forall a. RWLock -> IO a -> IO a
withRead = (IO () -> IO () -> IO a -> IO a)
-> (RWLock -> IO ()) -> (RWLock -> IO ()) -> RWLock -> IO a -> IO a
forall a b c.
(a -> b -> c) -> (RWLock -> a) -> (RWLock -> b) -> RWLock -> 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_ RWLock -> IO ()
acquireRead RWLock -> IO ()
releaseRead
tryWithRead :: RWLock -> IO a -> IO (Maybe a)
tryWithRead :: forall a. RWLock -> IO a -> IO (Maybe a)
tryWithRead RWLock
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 <- RWLock -> IO Bool
tryAcquireRead RWLock
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` RWLock -> IO ()
releaseRead RWLock
l
RWLock -> IO ()
releaseRead RWLock
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
waitRead :: RWLock -> IO ()
waitRead :: RWLock -> IO ()
waitRead RWLock
l = IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ RWLock -> IO ()
acquireRead RWLock
l IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RWLock -> IO ()
releaseRead RWLock
l
acquireWrite :: RWLock -> IO ()
acquireWrite :: RWLock -> IO ()
acquireWrite (RWLock {MVar State
state :: RWLock -> MVar State
state :: MVar State
state, Lock
readLock :: RWLock -> Lock
readLock :: Lock
readLock, Lock
writeLock :: RWLock -> Lock
writeLock :: Lock
writeLock}) = IO () -> IO ()
forall a. IO a -> IO a
mask_ IO ()
acqWrite
where
acqWrite :: IO ()
acqWrite = do State
st <- MVar State -> IO State
forall a. MVar a -> IO a
takeMVar MVar State
state
case State
st of
State
Free -> do Lock -> IO ()
Lock.acquire Lock
writeLock
MVar State -> State -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar State
state State
Write
Read Int
_ -> do MVar State -> State -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar State
state State
st
Lock -> IO ()
Lock.wait Lock
readLock
IO ()
acqWrite
State
Write -> do MVar State -> State -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar State
state State
st
Lock -> IO ()
Lock.wait Lock
writeLock
IO ()
acqWrite
tryAcquireWrite :: RWLock -> IO Bool
tryAcquireWrite :: RWLock -> IO Bool
tryAcquireWrite (RWLock {MVar State
state :: RWLock -> MVar State
state :: MVar State
state, Lock
writeLock :: RWLock -> Lock
writeLock :: Lock
writeLock}) = IO Bool -> IO Bool
forall a. IO a -> IO a
mask_ (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
State
st <- MVar State -> IO State
forall a. MVar a -> IO a
takeMVar MVar State
state
case State
st of
State
Free -> do Lock -> IO ()
Lock.acquire Lock
writeLock
MVar State -> State -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar State
state State
Write
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
State
_ -> do MVar State -> State -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar State
state State
st
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
releaseWrite :: RWLock -> IO ()
releaseWrite :: RWLock -> IO ()
releaseWrite (RWLock {MVar State
state :: RWLock -> MVar State
state :: MVar State
state, Lock
writeLock :: RWLock -> Lock
writeLock :: Lock
writeLock}) = IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
State
st <- MVar State -> IO State
forall a. MVar a -> IO a
takeMVar MVar State
state
case State
st of
State
Write -> do Lock -> IO ()
Lock.release Lock
writeLock
MVar State -> State -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar State
state State
Free
State
_ -> do MVar State -> State -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar State
state State
st
[Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
moduleName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".releaseWrite: already released"
withWrite :: RWLock -> IO a -> IO a
withWrite :: forall a. RWLock -> IO a -> IO a
withWrite = (IO () -> IO () -> IO a -> IO a)
-> (RWLock -> IO ()) -> (RWLock -> IO ()) -> RWLock -> IO a -> IO a
forall a b c.
(a -> b -> c) -> (RWLock -> a) -> (RWLock -> b) -> RWLock -> 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_ RWLock -> IO ()
acquireWrite RWLock -> IO ()
releaseWrite
tryWithWrite :: RWLock -> IO a -> IO (Maybe a)
tryWithWrite :: forall a. RWLock -> IO a -> IO (Maybe a)
tryWithWrite RWLock
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 <- RWLock -> IO Bool
tryAcquireWrite RWLock
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` RWLock -> IO ()
releaseWrite RWLock
l
RWLock -> IO ()
releaseWrite RWLock
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
waitWrite :: RWLock -> IO ()
waitWrite :: RWLock -> IO ()
waitWrite RWLock
l = IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ RWLock -> IO ()
acquireWrite RWLock
l IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RWLock -> IO ()
releaseWrite RWLock
l
moduleName :: String
moduleName :: [Char]
moduleName = [Char]
"Control.Concurrent.ReadWriteLock"