module MonadVar
( MonadNew(..)
, MonadLock(..)
, MonadRead(..)
, MonadWrite(..)
, MonadSwap(..)
, MonadFoldMutateM(..)
, MonadMutateM(..)
, MonadMutateM_(..)
, MonadFoldMutate(..)
, MonadMutate(..)
, MonadMutate_(..)
, defaultLockUnsafeWrite
, defaultReadWriteSwap
, defaultLockUnsafeSwap
, defaultReadWriteMutateM
, defaultReadWriteMutateM_
, defaultReadWriteMutate
, defaultReadWriteMutate_
, defaultLockUnsafeMutateM
, defaultLockUnsafeMutateM_
, defaultLockUnsafeMutate
, defaultLockUnsafeMutate_
, defaultLockIOMutateM
, defaultLockIOMutateM_
, postMutateM
, preMutateM
, postMutateM_
, preMutateM_
, postMutate
, preMutate
, postMutate_
, preMutate_
) where
import Prelude hiding (read)
import Data.Function
import Data.STRef
import Data.IORef
import Control.Exception (mask, mask_, evaluate, onException)
import Control.Concurrent.MVar
import Control.Concurrent.STM
import Control.Monad.ST
import Control.Monad.Trans.Class
infixr 9 .*
infixl 1 <&>
(<&>) :: Functor f => f a -> (a -> b) -> f b
x <&> f = f <$> x
(.*) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
g .* f = \x y -> g (f x y)
class Monad m => MonadNew m v where
new :: a -> m (v a)
class (MonadRead m v, Monad m) => MonadLock m v where
hold :: v a -> m a
fill :: v a -> a -> m ()
tryHold :: v a -> m (Maybe a)
tryFill :: v a -> a -> m Bool
tryRead :: v a -> m (Maybe a)
newEmpty :: m (v a)
isEmpty :: v a -> m Bool
class Monad m => MonadRead m v where
read :: v a -> m a
class Monad m => MonadWrite m v where
write :: v a -> a -> m ()
class Monad m => MonadSwap m v where
swap :: v a -> a -> m a
class (MonadRead m v, MonadWrite m v) => MonadFoldMutateM m n v where
foldMutateM :: Monoid b => v a -> (a -> m (a, b)) -> n b
class (MonadRead m v, MonadWrite m v) => MonadMutateM m n v where
mutateM :: v a -> (a -> m (a, b)) -> n b
class MonadWrite m v => MonadMutateM_ m n v where
mutateM_ :: v a -> (a -> m a) -> n ()
class MonadWrite m v => MonadFoldMutate m v where
foldMutate :: Monoid b => v a -> (a -> (a, b)) -> m b
class (MonadRead m v, MonadWrite m v) => MonadMutate m v where
mutate :: v a -> (a -> (a, b)) -> m b
class MonadWrite m v => MonadMutate_ m v where
mutate_ :: v a -> (a -> a) -> m ()
defaultLockUnsafeWrite
:: MonadLock m v => v a -> a -> m ()
defaultLockUnsafeWrite v y = tryHold v *> fill v y
defaultReadWriteSwap
:: (MonadRead m v, MonadWrite m v) => v a -> a -> m a
defaultReadWriteSwap v y = read v <* write v y
defaultLockUnsafeSwap
:: MonadLock m v => v a -> a -> m a
defaultLockUnsafeSwap v y = hold v <* fill v y
defaultReadWriteMutateM
:: (MonadRead m v, MonadWrite m v) => v a -> (a -> m (a, b)) -> m b
defaultReadWriteMutateM v f = do
x <- read v
!(!y, z) <- f x
write v y
return z
defaultReadWriteMutateM_
:: (MonadRead m v, MonadWrite m v) => v a -> (a -> m a) -> m ()
defaultReadWriteMutateM_ v f = do
x <- read v
!y <- f x
write v y
defaultReadWriteMutate
:: (MonadRead m v, MonadWrite m v) => v a -> (a -> (a, b)) -> m b
defaultReadWriteMutate v f = do
x <- read v
let !(!y, z) = f x
write v y
return z
defaultReadWriteMutate_
:: (MonadRead m v, MonadWrite m v) => v a -> (a -> a) -> m ()
defaultReadWriteMutate_ v f = do
x <- read v
let !y = f x
write v y
defaultLockUnsafeMutateM
:: MonadLock m v => v a -> (a -> m (a, b)) -> m b
defaultLockUnsafeMutateM v f = do
x <- hold v
!(!y, z) <- f x
fill v y
return z
defaultLockUnsafeMutateM_
:: MonadLock m v => v a -> (a -> m a) -> m ()
defaultLockUnsafeMutateM_ v f = do
x <- hold v
!y <- f x
fill v y
defaultLockUnsafeMutate
:: MonadLock m v => v a -> (a -> (a, b)) -> m b
defaultLockUnsafeMutate v f = do
x <- hold v
let !(!y, z) = f x
fill v y
return z
defaultLockUnsafeMutate_
:: MonadLock m v => v a -> (a -> a) -> m ()
defaultLockUnsafeMutate_ v f = do
x <- hold v
let !y = f x
fill v y
defaultLockIOMutateM :: MonadLock IO v => v a -> (a -> IO (a, b)) -> IO b
defaultLockIOMutateM v f = mask $ \restore -> do
x <- hold v
(y, z) <- restore (f x >>= evaluate) `onException` fill v x
fill v y
evaluate y
return z
defaultLockIOMutateM_ :: MonadLock IO v => v a -> (a -> IO a) -> IO ()
defaultLockIOMutateM_ v f = mask $ \restore -> do
x <- hold v
y <- restore (f x) `onException` fill v x
fill v y
evaluate y
return ()
postMutateM
:: MonadMutateM m n v => v a -> (a -> m (a, b)) -> n (a, b)
postMutateM v f = mutateM v $ \x -> f x <&> \(y, z) -> (y, (x, z))
preMutateM
:: MonadMutateM m n v => v a -> (a -> m (a, b)) -> n (a, b)
preMutateM v f = mutateM v $ \x -> f x <&> \(y, z) -> (y, (y, z))
postMutateM_
:: MonadMutateM m n v => v a -> (a -> m a) -> n a
postMutateM_ v f = mutateM v $ \x -> f x <&> \y -> (y, x)
preMutateM_
:: MonadMutateM m n v => v a -> (a -> m a) -> n a
preMutateM_ v f = mutateM v $ \x -> f x <&> \y -> (y, y)
postMutate
:: MonadMutate m v => v a -> (a -> (a, b)) -> m (a, b)
postMutate v f = mutate v $ \x -> f x & \(y, z) -> (y, (x, z))
preMutate
:: MonadMutate m v => v a -> (a -> (a, b)) -> m (a, b)
preMutate v f = mutate v $ \x -> f x & \(y, z) -> (y, (y, z))
postMutate_
:: MonadMutate m v => v a -> (a -> a) -> m a
postMutate_ v f = mutate v $ \x -> f x & \y -> (y, x)
preMutate_
:: MonadMutate m v => v a -> (a -> a) -> m a
preMutate_ v f = mutate v $ \x -> f x & \y -> (y, y)
instance (MonadTrans t, Monad (t m), MonadRead m v) => MonadRead (t m) v where
read = lift . read
instance (MonadTrans t, Monad (t m), MonadWrite m v) => MonadWrite (t m) v where
write = lift .* write
instance (MonadTrans t, Monad (t m), MonadSwap m v) => MonadSwap (t m) v where
swap = lift .* swap
instance (MonadTrans t, Monad (t m), MonadLock m v) => MonadLock (t m) v where
hold = lift . hold
fill = lift .* fill
tryHold = lift . tryHold
tryFill = lift .* tryFill
tryRead = lift . tryRead
newEmpty = lift newEmpty
isEmpty = lift . isEmpty
instance (MonadTrans t, Monad (t m), MonadMutate m v) => MonadMutate (t m) v where
mutate = lift .* mutate
instance (MonadTrans t, Monad (t m), MonadMutate_ m v) => MonadMutate_ (t m) v where
mutate_ = lift .* mutate_
instance MonadNew IO IORef where
new = newIORef
instance MonadRead IO IORef where
read = readIORef
instance MonadWrite IO IORef where
write = writeIORef
instance MonadSwap IO IORef where
swap = defaultReadWriteSwap
instance IO ~ io => MonadMutateM io IO IORef where
mutateM = defaultReadWriteMutateM
instance IO ~ io => MonadMutateM_ io IO IORef where
mutateM_ = defaultReadWriteMutateM_
instance MonadMutate IO IORef where
mutate = defaultReadWriteMutate
instance MonadMutate_ IO IORef where
mutate_ = defaultReadWriteMutate_
instance MonadNew (ST s) (STRef s) where
new = newSTRef
instance MonadRead (ST s) (STRef s) where
read = readSTRef
instance MonadWrite (ST s) (STRef s) where
write = writeSTRef
instance MonadSwap (ST s) (STRef s) where
swap = defaultReadWriteSwap
instance ST s ~ st_s => MonadMutateM st_s (ST s) (STRef s) where
mutateM = defaultReadWriteMutateM
instance ST s ~ st_s => MonadMutateM_ st_s (ST s) (STRef s) where
mutateM_ = defaultReadWriteMutateM_
instance MonadMutate (ST s) (STRef s) where
mutate = defaultReadWriteMutate
instance MonadMutate_ (ST s) (STRef s) where
mutate_ = defaultReadWriteMutate_
instance MonadNew IO MVar where
new = newMVar
instance MonadLock IO MVar where
hold = takeMVar
fill = putMVar
tryHold = tryTakeMVar
tryFill = tryPutMVar
tryRead = tryReadMVar
newEmpty = newEmptyMVar
isEmpty = isEmptyMVar
instance MonadRead IO MVar where
read = readMVar
instance MonadWrite IO MVar where
write = mask_ .* defaultLockUnsafeWrite
instance MonadSwap IO MVar where
swap = mask_ .* defaultLockUnsafeSwap
instance IO ~ io => MonadMutateM io IO MVar where
mutateM = defaultLockIOMutateM
instance IO ~ io => MonadMutateM_ io IO MVar where
mutateM_ = defaultLockIOMutateM_
instance MonadMutate IO MVar where
mutate v f = mutateM v $ return . f
instance MonadMutate_ IO MVar where
mutate_ v f = mutateM_ v $ return . f
instance MonadNew STM TVar where
new = newTVar
instance MonadRead STM TVar where
read = readTVar
instance MonadWrite STM TVar where
write = writeTVar
instance MonadSwap STM TVar where
swap = defaultReadWriteSwap
instance STM ~ stm => MonadMutateM stm STM TVar where
mutateM = defaultReadWriteMutateM
instance STM ~ stm => MonadMutateM_ stm STM TVar where
mutateM_ = defaultReadWriteMutateM_
instance MonadMutate STM TVar where
mutate = defaultReadWriteMutate
instance MonadMutate_ STM TVar where
mutate_ = defaultReadWriteMutate_
instance MonadNew IO TVar where
new = newTVarIO
instance MonadRead IO TVar where
read = readTVarIO
instance MonadWrite IO TVar where
write = atomically .* writeTVar
instance MonadSwap IO TVar where
swap = atomically .* swap
instance STM ~ stm => MonadMutateM stm IO TVar where
mutateM = atomically .* mutateM
instance STM ~ stm => MonadMutateM_ stm IO TVar where
mutateM_ = atomically .* mutateM_
instance MonadMutate IO TVar where
mutate = atomically .* mutate
instance MonadMutate_ IO TVar where
mutate_ = atomically .* mutate_
instance MonadNew STM TMVar where
new = newTMVar
instance MonadLock STM TMVar where
hold = takeTMVar
fill = putTMVar
tryHold = tryTakeTMVar
tryFill = tryPutTMVar
tryRead = tryReadTMVar
newEmpty = newEmptyTMVar
isEmpty = isEmptyTMVar
instance MonadRead STM TMVar where
read = readTMVar
instance MonadWrite STM TMVar where
write = defaultLockUnsafeWrite
instance MonadSwap STM TMVar where
swap = defaultLockUnsafeSwap
instance STM ~ stm => MonadMutateM stm STM TMVar where
mutateM = defaultLockUnsafeMutateM
instance STM ~ stm => MonadMutateM_ stm STM TMVar where
mutateM_ = defaultLockUnsafeMutateM_
instance MonadMutate STM TMVar where
mutate = defaultLockUnsafeMutate
instance MonadMutate_ STM TMVar where
mutate_ = defaultLockUnsafeMutate_
instance MonadNew IO TMVar where
new = newTMVarIO
instance MonadLock IO TMVar where
hold = atomically . hold
fill = atomically .* fill
tryHold = atomically . tryHold
tryFill = atomically .* tryFill
tryRead = atomically . tryRead
newEmpty = newEmptyTMVarIO
isEmpty = atomically . isEmpty
instance MonadRead IO TMVar where
read = atomically . read
instance MonadWrite IO TMVar where
write = atomically .* write
instance MonadSwap IO TMVar where
swap = atomically .* swap
instance MonadMutateM STM IO TMVar where
mutateM = atomically .* mutateM
instance MonadMutateM_ STM IO TMVar where
mutateM_ = atomically .* mutateM_
instance MonadMutateM IO IO TMVar where
mutateM = defaultLockIOMutateM
instance MonadMutateM_ IO IO TMVar where
mutateM_ = defaultLockIOMutateM_
instance MonadMutate IO TMVar where
mutate = atomically .* mutate
instance MonadMutate_ IO TMVar where
mutate_ = atomically .* mutate_