{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE FlexibleContexts #-}

-- | Lifted 'STM' operations.
module Control.Monad.STM.Lifted
  ( STM
  , MonadSTM(..)
  , atomically
  , retry
  , check
  , throwSTM
  , catchSTM
  ) where

import Data.Monoid (Monoid)
import Control.Monad.Base
import Control.Monad.Trans.Identity
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Accum
import qualified Control.Monad.Trans.State.Lazy as L
import qualified Control.Monad.Trans.State.Strict as S
import qualified Control.Monad.Trans.Writer.Lazy as L
import qualified Control.Monad.Trans.Writer.Strict as S
import qualified Control.Monad.Trans.RWS.Lazy as L
import qualified Control.Monad.Trans.RWS.Strict as S
import Control.Monad.Trans.Finish
import Control.Monad.Exception
import Control.Monad.STM (STM)
import qualified Control.Monad.STM as STM

-- | Class of monads that have 'STM' as their base and support composing
-- alternative (vs retries) actions.
class (MonadBase STM μ, MonadCatch μ) ⇒ MonadSTM μ where
  -- | Equivalent to the first action, unless it retries. It which case the second
  -- action is performed in its place.
  orElse ∷ μ α → μ α → μ α

instance MonadSTM STM where
  orElse :: forall α. STM α -> STM α -> STM α
orElse = forall α. STM α -> STM α -> STM α
STM.orElse
  {-# INLINE orElse #-}

instance MonadSTM μ ⇒ MonadSTM (IdentityT μ) where
  orElse :: forall α. IdentityT μ α -> IdentityT μ α -> IdentityT μ α
orElse IdentityT μ α
m₁ IdentityT μ α
m₂ = forall {k} (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT forall a b. (a -> b) -> a -> b
$ forall (μ :: * -> *) α. MonadSTM μ => μ α -> μ α -> μ α
orElse (forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT IdentityT μ α
m₁) (forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT IdentityT μ α
m₂)
  {-# INLINE orElse #-}

instance MonadSTM μ ⇒ MonadSTM (MaybeT μ) where
  orElse :: forall α. MaybeT μ α -> MaybeT μ α -> MaybeT μ α
orElse MaybeT μ α
m₁ MaybeT μ α
m₂ = forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (μ :: * -> *) α. MonadSTM μ => μ α -> μ α -> μ α
orElse (forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT MaybeT μ α
m₁) (forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT MaybeT μ α
m₂)
  {-# INLINE orElse #-}

instance MonadSTM μ ⇒ MonadSTM (ReaderT w μ) where
  orElse :: forall α. ReaderT w μ α -> ReaderT w μ α -> ReaderT w μ α
orElse ReaderT w μ α
m₁ ReaderT w μ α
m₂ = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \w
r → forall (μ :: * -> *) α. MonadSTM μ => μ α -> μ α -> μ α
orElse (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT w μ α
m₁ w
r) (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT w μ α
m₂ w
r)
  {-# INLINE orElse #-}

instance (Monoid w, MonadSTM μ) ⇒ MonadSTM (AccumT w μ) where
  orElse :: forall α. AccumT w μ α -> AccumT w μ α -> AccumT w μ α
orElse AccumT w μ α
m₁ AccumT w μ α
m₂ = forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT forall a b. (a -> b) -> a -> b
$ \w
w → forall (μ :: * -> *) α. MonadSTM μ => μ α -> μ α -> μ α
orElse (forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT AccumT w μ α
m₁ w
w) (forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
runAccumT AccumT w μ α
m₂ w
w)
  {-# INLINE orElse #-}

instance MonadSTM μ ⇒ MonadSTM (L.StateT s μ) where
  orElse :: forall α. StateT s μ α -> StateT s μ α -> StateT s μ α
orElse StateT s μ α
m₁ StateT s μ α
m₂ = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
L.StateT forall a b. (a -> b) -> a -> b
$ \s
s → forall (μ :: * -> *) α. MonadSTM μ => μ α -> μ α -> μ α
orElse (forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
L.runStateT StateT s μ α
m₁ s
s) (forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
L.runStateT StateT s μ α
m₂ s
s)
  {-# INLINE orElse #-}

instance MonadSTM μ ⇒ MonadSTM (S.StateT s μ) where
  orElse :: forall α. StateT s μ α -> StateT s μ α -> StateT s μ α
orElse StateT s μ α
m₁ StateT s μ α
m₂ = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
S.StateT forall a b. (a -> b) -> a -> b
$ \s
s → forall (μ :: * -> *) α. MonadSTM μ => μ α -> μ α -> μ α
orElse (forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
S.runStateT StateT s μ α
m₁ s
s) (forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
S.runStateT StateT s μ α
m₂ s
s)
  {-# INLINE orElse #-}

instance (Monoid w, MonadSTM μ) ⇒ MonadSTM (L.WriterT w μ) where
  orElse :: forall α. WriterT w μ α -> WriterT w μ α -> WriterT w μ α
orElse WriterT w μ α
m₁ WriterT w μ α
m₂ = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
L.WriterT forall a b. (a -> b) -> a -> b
$ forall (μ :: * -> *) α. MonadSTM μ => μ α -> μ α -> μ α
orElse (forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
L.runWriterT WriterT w μ α
m₁) (forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
L.runWriterT WriterT w μ α
m₂)
  {-# INLINE orElse #-}

instance (Monoid w, MonadSTM μ) ⇒ MonadSTM (S.WriterT w μ) where
  orElse :: forall α. WriterT w μ α -> WriterT w μ α -> WriterT w μ α
orElse WriterT w μ α
m₁ WriterT w μ α
m₂ = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
S.WriterT forall a b. (a -> b) -> a -> b
$ forall (μ :: * -> *) α. MonadSTM μ => μ α -> μ α -> μ α
orElse (forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
S.runWriterT WriterT w μ α
m₁) (forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
S.runWriterT WriterT w μ α
m₂)
  {-# INLINE orElse #-}

instance (Monoid w, MonadSTM μ) ⇒ MonadSTM (L.RWST r w s μ) where
  orElse :: forall α. RWST r w s μ α -> RWST r w s μ α -> RWST r w s μ α
orElse RWST r w s μ α
m₁ RWST r w s μ α
m₂ = forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
L.RWST forall a b. (a -> b) -> a -> b
$ \r
r s
s → forall (μ :: * -> *) α. MonadSTM μ => μ α -> μ α -> μ α
orElse (forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
L.runRWST RWST r w s μ α
m₁ r
r s
s) (forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
L.runRWST RWST r w s μ α
m₂ r
r s
s)
  {-# INLINE orElse #-}

instance (Monoid w, MonadSTM μ) ⇒ MonadSTM (S.RWST r w s μ) where
  orElse :: forall α. RWST r w s μ α -> RWST r w s μ α -> RWST r w s μ α
orElse RWST r w s μ α
m₁ RWST r w s μ α
m₂ = forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
S.RWST forall a b. (a -> b) -> a -> b
$ \r
r s
s → forall (μ :: * -> *) α. MonadSTM μ => μ α -> μ α -> μ α
orElse (forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
S.runRWST RWST r w s μ α
m₁ r
r s
s) (forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
S.runRWST RWST r w s μ α
m₂ r
r s
s)
  {-# INLINE orElse #-}

instance MonadSTM μ ⇒ MonadSTM (FinishT r μ) where
  orElse :: forall α. FinishT r μ α -> FinishT r μ α -> FinishT r μ α
orElse FinishT r μ α
m₁ FinishT r μ α
m₂ = forall f (μ :: * -> *) α. μ (Either f α) -> FinishT f μ α
FinishT forall a b. (a -> b) -> a -> b
$ forall (μ :: * -> *) α. MonadSTM μ => μ α -> μ α -> μ α
orElse (forall f (μ :: * -> *) α. FinishT f μ α -> μ (Either f α)
runFinishT FinishT r μ α
m₁) (forall f (μ :: * -> *) α. FinishT f μ α -> μ (Either f α)
runFinishT FinishT r μ α
m₂)
  {-# INLINE orElse #-}

-- | A lifted version of 'STM.atomically'.
atomically ∷ MonadBase IO μ ⇒ STM α → μ α
atomically :: forall (μ :: * -> *) α. MonadBase IO μ => STM α -> μ α
atomically = forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
STM.atomically
{-# INLINE atomically #-}

-- | A lifted version of 'STM.retry'.
retry ∷ MonadBase STM μ ⇒ μ α
retry :: forall (μ :: * -> *) α. MonadBase STM μ => μ α
retry = forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a. STM a
STM.retry
{-# INLINE retry #-}

-- | A lifted version of 'STM.check'.
check ∷ MonadBase STM μ ⇒ Bool → μ ()
check :: forall (μ :: * -> *). MonadBase STM μ => Bool -> μ ()
check = forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> STM ()
STM.check
{-# INLINE check #-}

-- | A lifted version of 'STM.throwSTM'.
throwSTM ∷ (Exception e, MonadBase STM μ) ⇒ e → μ α
throwSTM :: forall e (μ :: * -> *) α.
(Exception e, MonadBase STM μ) =>
e -> μ α
throwSTM = forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => e -> STM a
STM.throwSTM
{-# INLINE throwSTM #-}

-- | A specialized version of 'catch'.
catchSTM ∷ (Exception e, MonadSTM μ) ⇒ μ α → (e → μ α) → μ α
catchSTM :: forall e (μ :: * -> *) α.
(Exception e, MonadSTM μ) =>
μ α -> (e -> μ α) -> μ α
catchSTM = forall (μ :: * -> *) e α.
(MonadCatch μ, Exception e) =>
μ α -> (e -> μ α) -> μ α
catch
{-# INLINE catchSTM #-}