{-# LANGUAGE DefaultSignatures      #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE QuantifiedConstraints  #-}
{-# LANGUAGE TypeFamilyDependencies #-}

module Control.Concurrent.Class.MonadMVar
  ( MonadMVar (..)
  , MonadInspectMVar (..)
  ) where

import qualified Control.Concurrent.MVar as IO
import           Control.Monad.Class.MonadThrow

import           Control.Monad.Reader (ReaderT (..))
import           Control.Monad.Trans (lift)

import           Data.Kind (Type)


class Monad m => MonadMVar m where
  {-# MINIMAL newEmptyMVar,
              takeMVar, tryTakeMVar,
              putMVar,  tryPutMVar,
              readMVar, tryReadMVar,
              isEmptyMVar #-}

  type MVar m :: Type -> Type

  -- | See 'IO.newEmptyMVar'.
  newEmptyMVar      :: m (MVar m a)
  -- | See 'IO.takeMVar'.
  takeMVar          :: MVar m a -> m a
  -- | See 'IO.putMVar'.
  putMVar           :: MVar m a -> a -> m ()
  -- | See 'IO.tryTakeMVar'.
  tryTakeMVar       :: MVar m a -> m (Maybe a)
  -- | See 'IO.tryPutMVar'.
  tryPutMVar        :: MVar m a -> a -> m Bool
  -- | See 'IO.isEmptyMVar'.
  isEmptyMVar       :: MVar m a -> m Bool

  -- methods with a default implementation
  -- | See 'IO.newMVar'.
  newMVar           :: a -> m (MVar m a)
  -- | See 'IO.readMVar'.
  readMVar          :: MVar m a -> m a
  -- | See 'IO.tryReadMVar'.
  tryReadMVar       :: MVar m a -> m (Maybe a)
  -- | See 'IO.swapMVar'.
  swapMVar          :: MVar m a -> a -> m a
  -- | See 'IO.withMVar'.
  withMVar          :: MVar m a -> (a -> m b) -> m b
  -- | See 'IO.withMVarMasked'.
  withMVarMasked    :: MVar m a -> (a -> m b) -> m b
  -- | See 'IO.modifyMVar_'.
  modifyMVar_       :: MVar m a -> (a -> m a) -> m ()
  -- | See 'IO.modifyMVar'.
  modifyMVar        :: MVar m a -> (a -> m (a, b)) -> m b
  -- | See 'IO.modifyMVarMasked_'.
  modifyMVarMasked_ :: MVar m a -> (a -> m a) -> m ()
  -- | See 'IO.modifyMVarMasked'.
  modifyMVarMasked  :: MVar m a -> (a -> m (a,b)) -> m b

  default newMVar :: a -> m (MVar m a)
  newMVar a
a = do
    MVar m a
v <- forall (m :: * -> *) a. MonadMVar m => m (MVar m a)
newEmptyMVar
    forall (m :: * -> *) a. MonadMVar m => MVar m a -> a -> m ()
putMVar MVar m a
v a
a
    forall (m :: * -> *) a. Monad m => a -> m a
return MVar m a
v
  {-# INLINE newMVar #-}

  default swapMVar :: MonadMask m => MVar m a -> a -> m a
  swapMVar MVar m a
mvar a
new =
    forall (m :: * -> *) a. MonadMask m => m a -> m a
mask_ forall a b. (a -> b) -> a -> b
$ do
      a
old <- forall (m :: * -> *) a. MonadMVar m => MVar m a -> m a
takeMVar MVar m a
mvar
      forall (m :: * -> *) a. MonadMVar m => MVar m a -> a -> m ()
putMVar MVar m a
mvar a
new
      forall (m :: * -> *) a. Monad m => a -> m a
return a
old
  {-# INLINE swapMVar #-}

  default withMVar :: MonadMask m => MVar m a -> (a -> m b) -> m b
  withMVar MVar m a
m a -> m b
io =
    forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
      a
a <- forall (m :: * -> *) a. MonadMVar m => MVar m a -> m a
takeMVar MVar m a
m
      b
b <- forall a. m a -> m a
restore (a -> m b
io a
a) forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` forall (m :: * -> *) a. MonadMVar m => MVar m a -> a -> m ()
putMVar MVar m a
m a
a
      forall (m :: * -> *) a. MonadMVar m => MVar m a -> a -> m ()
putMVar MVar m a
m a
a
      forall (m :: * -> *) a. Monad m => a -> m a
return b
b
  {-# INLINE withMVar #-}

  default withMVarMasked :: MonadMask m => MVar m a -> (a -> m b) -> m b
  withMVarMasked MVar m a
m a -> m b
io =
    forall (m :: * -> *) a. MonadMask m => m a -> m a
mask_ forall a b. (a -> b) -> a -> b
$ do
      a
a <- forall (m :: * -> *) a. MonadMVar m => MVar m a -> m a
takeMVar MVar m a
m
      b
b <- a -> m b
io a
a forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` forall (m :: * -> *) a. MonadMVar m => MVar m a -> a -> m ()
putMVar MVar m a
m a
a
      forall (m :: * -> *) a. MonadMVar m => MVar m a -> a -> m ()
putMVar MVar m a
m a
a
      forall (m :: * -> *) a. Monad m => a -> m a
return b
b
  {-# INLINE withMVarMasked #-}

  default modifyMVar_ :: MonadMask m => MVar m a -> (a -> m a) -> m ()
  modifyMVar_ MVar m a
m a -> m a
io =
    forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
      a
a  <- forall (m :: * -> *) a. MonadMVar m => MVar m a -> m a
takeMVar MVar m a
m
      a
a' <- forall a. m a -> m a
restore (a -> m a
io a
a) forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` forall (m :: * -> *) a. MonadMVar m => MVar m a -> a -> m ()
putMVar MVar m a
m a
a
      forall (m :: * -> *) a. MonadMVar m => MVar m a -> a -> m ()
putMVar MVar m a
m a
a'
  {-# INLINE modifyMVar_ #-}

  default modifyMVar :: (MonadMask m, MonadEvaluate m)
                     => MVar m a -> (a -> m (a,b)) -> m b
  modifyMVar MVar m a
m a -> m (a, b)
io =
    forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
      a
a      <- forall (m :: * -> *) a. MonadMVar m => MVar m a -> m a
takeMVar MVar m a
m
      (a
a',b
b) <- forall a. m a -> m a
restore (a -> m (a, b)
io a
a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadEvaluate m => a -> m a
evaluate) forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` forall (m :: * -> *) a. MonadMVar m => MVar m a -> a -> m ()
putMVar MVar m a
m a
a
      forall (m :: * -> *) a. MonadMVar m => MVar m a -> a -> m ()
putMVar MVar m a
m a
a'
      forall (m :: * -> *) a. Monad m => a -> m a
return b
b
  {-# INLINE modifyMVar #-}

  default modifyMVarMasked_ :: MonadMask m => MVar m a -> (a -> m a) -> m ()
  modifyMVarMasked_ MVar m a
m a -> m a
io =
    forall (m :: * -> *) a. MonadMask m => m a -> m a
mask_ forall a b. (a -> b) -> a -> b
$ do
      a
a  <- forall (m :: * -> *) a. MonadMVar m => MVar m a -> m a
takeMVar MVar m a
m
      a
a' <- a -> m a
io a
a forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` forall (m :: * -> *) a. MonadMVar m => MVar m a -> a -> m ()
putMVar MVar m a
m a
a
      forall (m :: * -> *) a. MonadMVar m => MVar m a -> a -> m ()
putMVar MVar m a
m a
a'
  {-# INLINE modifyMVarMasked_ #-}

  default modifyMVarMasked :: (MonadMask m, MonadEvaluate m)
                           => MVar m a -> (a -> m (a,b)) -> m b
  modifyMVarMasked MVar m a
m a -> m (a, b)
io =
    forall (m :: * -> *) a. MonadMask m => m a -> m a
mask_ forall a b. (a -> b) -> a -> b
$ do
      a
a      <- forall (m :: * -> *) a. MonadMVar m => MVar m a -> m a
takeMVar MVar m a
m
      (a
a',b
b) <- (a -> m (a, b)
io a
a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadEvaluate m => a -> m a
evaluate) forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` forall (m :: * -> *) a. MonadMVar m => MVar m a -> a -> m ()
putMVar MVar m a
m a
a
      forall (m :: * -> *) a. MonadMVar m => MVar m a -> a -> m ()
putMVar MVar m a
m a
a'
      forall (m :: * -> *) a. Monad m => a -> m a
return b
b
  {-# INLINE modifyMVarMasked #-}

--
-- IO instance
--

instance MonadMVar IO where
    type MVar IO      = IO.MVar
    newEmptyMVar :: forall a. IO (MVar IO a)
newEmptyMVar      = forall a. IO (MVar a)
IO.newEmptyMVar
    newMVar :: forall a. a -> IO (MVar IO a)
newMVar           = forall a. a -> IO (MVar a)
IO.newMVar
    takeMVar :: forall a. MVar IO a -> IO a
takeMVar          = forall a. MVar a -> IO a
IO.takeMVar
    putMVar :: forall a. MVar IO a -> a -> IO ()
putMVar           = forall a. MVar a -> a -> IO ()
IO.putMVar
    readMVar :: forall a. MVar IO a -> IO a
readMVar          = forall a. MVar a -> IO a
IO.readMVar
    swapMVar :: forall a. MVar IO a -> a -> IO a
swapMVar          = forall a. MVar a -> a -> IO a
IO.swapMVar
    tryTakeMVar :: forall a. MVar IO a -> IO (Maybe a)
tryTakeMVar       = forall a. MVar a -> IO (Maybe a)
IO.tryTakeMVar
    tryPutMVar :: forall a. MVar IO a -> a -> IO Bool
tryPutMVar        = forall a. MVar a -> a -> IO Bool
IO.tryPutMVar
    tryReadMVar :: forall a. MVar IO a -> IO (Maybe a)
tryReadMVar       = forall a. MVar a -> IO (Maybe a)
IO.tryReadMVar
    isEmptyMVar :: forall a. MVar IO a -> IO Bool
isEmptyMVar       = forall a. MVar a -> IO Bool
IO.isEmptyMVar
    withMVar :: forall a b. MVar IO a -> (a -> IO b) -> IO b
withMVar          = forall a b. MVar a -> (a -> IO b) -> IO b
IO.withMVar
    withMVarMasked :: forall a b. MVar IO a -> (a -> IO b) -> IO b
withMVarMasked    = forall a b. MVar a -> (a -> IO b) -> IO b
IO.withMVarMasked
    modifyMVar_ :: forall a. MVar IO a -> (a -> IO a) -> IO ()
modifyMVar_       = forall a. MVar a -> (a -> IO a) -> IO ()
IO.modifyMVar_
    modifyMVar :: forall a b. MVar IO a -> (a -> IO (a, b)) -> IO b
modifyMVar        = forall a b. MVar a -> (a -> IO (a, b)) -> IO b
IO.modifyMVar
    modifyMVarMasked_ :: forall a. MVar IO a -> (a -> IO a) -> IO ()
modifyMVarMasked_ = forall a. MVar a -> (a -> IO a) -> IO ()
IO.modifyMVarMasked_
    modifyMVarMasked :: forall a b. MVar IO a -> (a -> IO (a, b)) -> IO b
modifyMVarMasked  = forall a b. MVar a -> (a -> IO (a, b)) -> IO b
IO.modifyMVarMasked


--
-- ReaderT instance
--

newtype WrappedMVar r (m :: Type -> Type) a = WrappedMVar { forall r (m :: * -> *) a. WrappedMVar r m a -> MVar m a
unwrapMVar :: MVar m a }

instance ( MonadMask m
         , MonadMVar m
         ) => MonadMVar (ReaderT r m) where
    type MVar (ReaderT r m) = WrappedMVar r m
    newEmptyMVar :: forall a. ReaderT r m (MVar (ReaderT r m) a)
newEmptyMVar = forall r (m :: * -> *) a. MVar m a -> WrappedMVar r m a
WrappedMVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *) a. MonadMVar m => m (MVar m a)
newEmptyMVar
    newMVar :: forall a. a -> ReaderT r m (MVar (ReaderT r m) a)
newMVar      = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall r (m :: * -> *) a. MVar m a -> WrappedMVar r m a
WrappedMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadMVar m => a -> m (MVar m a)
newMVar
    takeMVar :: forall a. MVar (ReaderT r m) a -> ReaderT r m a
takeMVar     = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
.   forall (m :: * -> *) a. MonadMVar m => MVar m a -> m a
takeMVar    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. WrappedMVar r m a -> MVar m a
unwrapMVar
    putMVar :: forall a. MVar (ReaderT r m) a -> a -> ReaderT r m ()
putMVar      = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: (forall (m :: * -> *) a. MonadMVar m => MVar m a -> a -> m ()
putMVar     forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. WrappedMVar r m a -> MVar m a
unwrapMVar)
    readMVar :: forall a. MVar (ReaderT r m) a -> ReaderT r m a
readMVar     = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
.   forall (m :: * -> *) a. MonadMVar m => MVar m a -> m a
readMVar    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. WrappedMVar r m a -> MVar m a
unwrapMVar
    tryReadMVar :: forall a. MVar (ReaderT r m) a -> ReaderT r m (Maybe a)
tryReadMVar  = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
.   forall (m :: * -> *) a. MonadMVar m => MVar m a -> m (Maybe a)
tryReadMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. WrappedMVar r m a -> MVar m a
unwrapMVar
    swapMVar :: forall a. MVar (ReaderT r m) a -> a -> ReaderT r m a
swapMVar     = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: (forall (m :: * -> *) a. MonadMVar m => MVar m a -> a -> m a
swapMVar    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. WrappedMVar r m a -> MVar m a
unwrapMVar)
    tryTakeMVar :: forall a. MVar (ReaderT r m) a -> ReaderT r m (Maybe a)
tryTakeMVar  = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
.   forall (m :: * -> *) a. MonadMVar m => MVar m a -> m (Maybe a)
tryTakeMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. WrappedMVar r m a -> MVar m a
unwrapMVar
    tryPutMVar :: forall a. MVar (ReaderT r m) a -> a -> ReaderT r m Bool
tryPutMVar   = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: (forall (m :: * -> *) a. MonadMVar m => MVar m a -> a -> m Bool
tryPutMVar  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. WrappedMVar r m a -> MVar m a
unwrapMVar)
    isEmptyMVar :: forall a. MVar (ReaderT r m) a -> ReaderT r m Bool
isEmptyMVar  = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
.   forall (m :: * -> *) a. MonadMVar m => MVar m a -> m Bool
isEmptyMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. WrappedMVar r m a -> MVar m a
unwrapMVar
    withMVar :: forall a b.
MVar (ReaderT r m) a -> (a -> ReaderT r m b) -> ReaderT r m b
withMVar (WrappedMVar MVar m a
v) a -> ReaderT r m b
f = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \r
r ->
      forall (m :: * -> *) a b.
MonadMVar m =>
MVar m a -> (a -> m b) -> m b
withMVar MVar m a
v (\a
a -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> ReaderT r m b
f a
a) r
r)
    withMVarMasked :: forall a b.
MVar (ReaderT r m) a -> (a -> ReaderT r m b) -> ReaderT r m b
withMVarMasked (WrappedMVar MVar m a
v) a -> ReaderT r m b
f = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \r
r ->
      forall (m :: * -> *) a b.
MonadMVar m =>
MVar m a -> (a -> m b) -> m b
withMVarMasked MVar m a
v (\a
a -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> ReaderT r m b
f a
a) r
r)
    modifyMVar_ :: forall a.
MVar (ReaderT r m) a -> (a -> ReaderT r m a) -> ReaderT r m ()
modifyMVar_ (WrappedMVar MVar m a
v) a -> ReaderT r m a
f = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \r
r ->
      forall (m :: * -> *) a.
MonadMVar m =>
MVar m a -> (a -> m a) -> m ()
modifyMVar_ MVar m a
v (\a
a -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> ReaderT r m a
f a
a) r
r)
    modifyMVar :: forall a b.
MVar (ReaderT r m) a -> (a -> ReaderT r m (a, b)) -> ReaderT r m b
modifyMVar (WrappedMVar MVar m a
v) a -> ReaderT r m (a, b)
f = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \r
r ->
      forall (m :: * -> *) a b.
MonadMVar m =>
MVar m a -> (a -> m (a, b)) -> m b
modifyMVar MVar m a
v (\a
a -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> ReaderT r m (a, b)
f a
a) r
r)
    modifyMVarMasked_ :: forall a.
MVar (ReaderT r m) a -> (a -> ReaderT r m a) -> ReaderT r m ()
modifyMVarMasked_ (WrappedMVar MVar m a
v) a -> ReaderT r m a
f = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \r
r ->
      forall (m :: * -> *) a.
MonadMVar m =>
MVar m a -> (a -> m a) -> m ()
modifyMVarMasked_ MVar m a
v (\a
a -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> ReaderT r m a
f a
a) r
r)
    modifyMVarMasked :: forall a b.
MVar (ReaderT r m) a -> (a -> ReaderT r m (a, b)) -> ReaderT r m b
modifyMVarMasked (WrappedMVar MVar m a
v) a -> ReaderT r m (a, b)
f = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \r
r ->
      forall (m :: * -> *) a b.
MonadMVar m =>
MVar m a -> (a -> m (a, b)) -> m b
modifyMVarMasked MVar m a
v (\a
a -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> ReaderT r m (a, b)
f a
a) r
r)

--
-- MonadInspectMVar
--

-- | This type class is intended for
-- ['io-sim'](https://hackage.haskell.org/package/io-sim), where one might want
-- to access an 'MVar' in the underlying 'ST' monad.
class (MonadMVar m, Monad (InspectMVarMonad m)) => MonadInspectMVar m where
  type InspectMVarMonad m :: Type -> Type
  -- | Return the value of an 'MVar' as an 'InspectMVarMonad' computation. Can
  -- be 'Nothing' if the 'MVar' is empty.
  inspectMVar :: proxy m -> MVar m a -> InspectMVarMonad m (Maybe a)

instance MonadInspectMVar IO where
  type InspectMVarMonad IO = IO
  inspectMVar :: forall (proxy :: (* -> *) -> *) a.
proxy IO -> MVar IO a -> InspectMVarMonad IO (Maybe a)
inspectMVar proxy IO
_ = forall (m :: * -> *) a. MonadMVar m => MVar m a -> m (Maybe a)
tryReadMVar

--
-- Utilities
--

(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)
(c -> d
f .: :: forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: a -> b -> c
g) a
x b
y = c -> d
f (a -> b -> c
g a
x b
y)