{-|
Module      : Control.Monad.STM.Unlift
Licesnse    : BSD-2
Stability   : experimental

A typeclass which abstracts over monads that can be "unlifted" back down to
'STM'. (This is essentially a copy of "Control.Monad.IO.Unlift", modified for
the 'STM' monad.)

In a manner that is analagous to 'MonadUnliftIO', instances of this typeclass
are essentially limited to:

    * The 'STM' monad itself
    * Monad transformer stacks based on 'ReaderT' or 'IdentityT', with
      'STM' at the "bottom".
-}

{-# Language RankNTypes #-}

module Control.Monad.STM.Unlift
    ( MonadUnliftSTM(..)
    , UnliftSTM(..)
    , askRunInSTM
    , withUnliftSTM
    , toSTM
    ) where

import Control.Concurrent.STM (STM)
import Control.Monad.Trans.Identity
import Control.Monad.Trans.Reader
import Control.Monad.STM.Class
import Data.Functor

-- | Analagous to 'MonadUnliftIO'. (It is an abstraction for monads that can
--   be "unlifted" back down to the 'STM' monad.)
class MonadSTM m => MonadUnliftSTM m where
    askUnliftSTM :: m (UnliftSTM m)
    askUnliftSTM = ((forall a. m a -> STM a) -> STM (UnliftSTM m)) -> m (UnliftSTM m)
forall (m :: * -> *) b.
MonadUnliftSTM m =>
((forall a. m a -> STM a) -> STM b) -> m b
withRunInSTM (((forall a. m a -> STM a) -> STM (UnliftSTM m))
 -> m (UnliftSTM m))
-> ((forall a. m a -> STM a) -> STM (UnliftSTM m))
-> m (UnliftSTM m)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> STM a
f -> UnliftSTM m -> STM (UnliftSTM m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((forall a. m a -> STM a) -> UnliftSTM m
forall (m :: * -> *). (forall a. m a -> STM a) -> UnliftSTM m
UnliftSTM forall a. m a -> STM a
f)

    withRunInSTM :: ((forall a. m a -> STM a) -> STM b) -> m b
    withRunInSTM (forall a. m a -> STM a) -> STM b
f = m (UnliftSTM m)
forall (m :: * -> *). MonadUnliftSTM m => m (UnliftSTM m)
askUnliftSTM m (UnliftSTM m) -> (UnliftSTM m -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \UnliftSTM m
u -> STM b -> m b
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM ((forall a. m a -> STM a) -> STM b
f (UnliftSTM m -> forall a. m a -> STM a
forall (m :: * -> *). UnliftSTM m -> forall a. m a -> STM a
unliftSTM UnliftSTM m
u))

    {-# MINIMAL askUnliftSTM | withRunInSTM #-}


instance MonadUnliftSTM STM where
    askUnliftSTM :: STM (UnliftSTM STM)
askUnliftSTM = UnliftSTM STM -> STM (UnliftSTM STM)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((forall a. STM a -> STM a) -> UnliftSTM STM
forall (m :: * -> *). (forall a. m a -> STM a) -> UnliftSTM m
UnliftSTM forall a. a -> a
forall a. STM a -> STM a
id)
    withRunInSTM :: ((forall a. STM a -> STM a) -> STM b) -> STM b
withRunInSTM (forall a. STM a -> STM a) -> STM b
f = (forall a. STM a -> STM a) -> STM b
f forall a. a -> a
forall a. STM a -> STM a
id

instance MonadUnliftSTM m => MonadUnliftSTM (ReaderT r m) where
    askUnliftSTM :: ReaderT r m (UnliftSTM (ReaderT r m))
askUnliftSTM = (r -> m (UnliftSTM (ReaderT r m)))
-> ReaderT r m (UnliftSTM (ReaderT r m))
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m (UnliftSTM (ReaderT r m)))
 -> ReaderT r m (UnliftSTM (ReaderT r m)))
-> (r -> m (UnliftSTM (ReaderT r m)))
-> ReaderT r m (UnliftSTM (ReaderT r m))
forall a b. (a -> b) -> a -> b
$ \r
r -> m (UnliftSTM m)
forall (m :: * -> *). MonadUnliftSTM m => m (UnliftSTM m)
askUnliftSTM m (UnliftSTM m)
-> (UnliftSTM m -> UnliftSTM (ReaderT r m))
-> m (UnliftSTM (ReaderT r m))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \UnliftSTM m
u ->
        (forall a. ReaderT r m a -> STM a) -> UnliftSTM (ReaderT r m)
forall (m :: * -> *). (forall a. m a -> STM a) -> UnliftSTM m
UnliftSTM ((forall a. ReaderT r m a -> STM a) -> UnliftSTM (ReaderT r m))
-> (forall a. ReaderT r m a -> STM a) -> UnliftSTM (ReaderT r m)
forall a b. (a -> b) -> a -> b
$ UnliftSTM m -> forall a. m a -> STM a
forall (m :: * -> *). UnliftSTM m -> forall a. m a -> STM a
unliftSTM UnliftSTM m
u (m a -> STM a) -> (ReaderT r m a -> m a) -> ReaderT r m a -> STM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT r m a -> r -> m a) -> r -> ReaderT r m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT r m a -> r -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT r
r

    withRunInSTM :: ((forall a. ReaderT r m a -> STM a) -> STM b) -> ReaderT r m b
withRunInSTM (forall a. ReaderT r m a -> STM a) -> STM b
f = (r -> m b) -> ReaderT r m b
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m b) -> ReaderT r m b) -> (r -> m b) -> ReaderT r m b
forall a b. (a -> b) -> a -> b
$ \r
r -> ((forall a. m a -> STM a) -> STM b) -> m b
forall (m :: * -> *) b.
MonadUnliftSTM m =>
((forall a. m a -> STM a) -> STM b) -> m b
withRunInSTM (((forall a. m a -> STM a) -> STM b) -> m b)
-> ((forall a. m a -> STM a) -> STM b) -> m b
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> STM a
run ->
        (forall a. ReaderT r m a -> STM a) -> STM b
f (m a -> STM a
forall a. m a -> STM a
run (m a -> STM a) -> (ReaderT r m a -> m a) -> ReaderT r m a -> STM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT r m a -> r -> m a) -> r -> ReaderT r m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT r m a -> r -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT r
r) 

instance MonadUnliftSTM m => MonadUnliftSTM (IdentityT m) where
    askUnliftSTM :: IdentityT m (UnliftSTM (IdentityT m))
askUnliftSTM = m (UnliftSTM (IdentityT m))
-> IdentityT m (UnliftSTM (IdentityT m))
forall k (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT (m (UnliftSTM (IdentityT m))
 -> IdentityT m (UnliftSTM (IdentityT m)))
-> m (UnliftSTM (IdentityT m))
-> IdentityT m (UnliftSTM (IdentityT m))
forall a b. (a -> b) -> a -> b
$ m (UnliftSTM m)
forall (m :: * -> *). MonadUnliftSTM m => m (UnliftSTM m)
askUnliftSTM m (UnliftSTM m)
-> (UnliftSTM m -> UnliftSTM (IdentityT m))
-> m (UnliftSTM (IdentityT m))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \UnliftSTM m
u ->
        (forall a. IdentityT m a -> STM a) -> UnliftSTM (IdentityT m)
forall (m :: * -> *). (forall a. m a -> STM a) -> UnliftSTM m
UnliftSTM ((forall a. IdentityT m a -> STM a) -> UnliftSTM (IdentityT m))
-> (forall a. IdentityT m a -> STM a) -> UnliftSTM (IdentityT m)
forall a b. (a -> b) -> a -> b
$ UnliftSTM m -> forall a. m a -> STM a
forall (m :: * -> *). UnliftSTM m -> forall a. m a -> STM a
unliftSTM UnliftSTM m
u (m a -> STM a) -> (IdentityT m a -> m a) -> IdentityT m a -> STM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdentityT m a -> m a
forall k (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT

    withRunInSTM :: ((forall a. IdentityT m a -> STM a) -> STM b) -> IdentityT m b
withRunInSTM (forall a. IdentityT m a -> STM a) -> STM b
f = m b -> IdentityT m b
forall k (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT (m b -> IdentityT m b) -> m b -> IdentityT m b
forall a b. (a -> b) -> a -> b
$ ((forall a. m a -> STM a) -> STM b) -> m b
forall (m :: * -> *) b.
MonadUnliftSTM m =>
((forall a. m a -> STM a) -> STM b) -> m b
withRunInSTM (((forall a. m a -> STM a) -> STM b) -> m b)
-> ((forall a. m a -> STM a) -> STM b) -> m b
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> STM a
run -> (forall a. IdentityT m a -> STM a) -> STM b
f (m a -> STM a
forall a. m a -> STM a
run (m a -> STM a) -> (IdentityT m a -> m a) -> IdentityT m a -> STM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdentityT m a -> m a
forall k (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT)

-- | Analagous to 'UnliftIO'
newtype UnliftSTM m = UnliftSTM { UnliftSTM m -> forall a. m a -> STM a
unliftSTM :: forall a. m a -> STM a }

-- | Analagous to 'askRunInIO'
askRunInSTM :: MonadUnliftSTM m => m (m a -> STM a)
askRunInSTM :: m (m a -> STM a)
askRunInSTM = ((forall a. m a -> STM a) -> STM (m a -> STM a))
-> m (m a -> STM a)
forall (m :: * -> *) b.
MonadUnliftSTM m =>
((forall a. m a -> STM a) -> STM b) -> m b
withRunInSTM (\forall a. m a -> STM a
run -> (m a -> STM a) -> STM (m a -> STM a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\m a
ma -> m a -> STM a
forall a. m a -> STM a
run m a
ma))

-- | Analagous to 'withUnliftIO'
withUnliftSTM :: MonadUnliftSTM m => (UnliftSTM m -> STM a) -> m a
withUnliftSTM :: (UnliftSTM m -> STM a) -> m a
withUnliftSTM UnliftSTM m -> STM a
inner = m (UnliftSTM m)
forall (m :: * -> *). MonadUnliftSTM m => m (UnliftSTM m)
askUnliftSTM m (UnliftSTM m) -> (UnliftSTM m -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM a -> m a) -> (UnliftSTM m -> STM a) -> UnliftSTM m -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnliftSTM m -> STM a
inner

-- | Analagous to 'toIO'
toSTM :: MonadUnliftSTM m => m a -> m (STM a)
toSTM :: m a -> m (STM a)
toSTM m a
m = ((forall a. m a -> STM a) -> STM (STM a)) -> m (STM a)
forall (m :: * -> *) b.
MonadUnliftSTM m =>
((forall a. m a -> STM a) -> STM b) -> m b
withRunInSTM (((forall a. m a -> STM a) -> STM (STM a)) -> m (STM a))
-> ((forall a. m a -> STM a) -> STM (STM a)) -> m (STM a)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> STM a
run -> STM a -> STM (STM a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m a -> STM a
forall a. m a -> STM a
run m a
m)