module Control.Monad.Trans.Unlift
(
MonadTransUnlift
, Unlift (..)
, askUnlift
, askRun
, MonadBaseUnlift
, UnliftBase (..)
, askUnliftBase
, askRunBase
, MonadTrans (..)
, MonadBase (..)
, MonadTransControl (..)
, MonadBaseControl (..)
) where
import Control.Monad (ap, liftM)
import Control.Monad.Base (MonadBase (..))
import Control.Monad.ST (ST)
import Control.Monad.STM (STM)
import Control.Monad.Trans.Class (MonadTrans (..))
import Control.Monad.Trans.Control (MonadBaseControl (..),
MonadTransControl (..))
import Control.Monad.Trans.Reader (ReaderT)
import Data.Constraint ((:-), (\\))
import Data.Constraint.Forall (Forall, inst)
import Data.Functor.Identity (Identity)
newtype Unlift t = Unlift { unlift :: forall a n. Monad n => t n a -> n a }
class (StT t a ~ a) => Identical t a
instance (StT t a ~ a) => Identical t a
class (MonadTransControl t, Forall (Identical t)) => MonadTransUnlift t
instance (MonadTransControl t, Forall (Identical t)) => MonadTransUnlift t
mkUnlift :: forall t m a . (Forall (Identical t), Monad m)
=> (forall n b. Monad n => t n b -> n (StT t b)) -> t m a -> m a
mkUnlift r act = r act \\ (inst :: Forall (Identical t) :- Identical t a)
askUnlift :: forall t m. (MonadTransUnlift t, Monad m) => t m (Unlift t)
askUnlift = liftWith unlifter
where
unlifter :: (forall n b. Monad n => t n b -> n (StT t b)) -> m (Unlift t)
unlifter r = return $ Unlift (mkUnlift r)
askRun :: (MonadTransUnlift t, Monad (t m), Monad m) => t m (t m a -> m a)
askRun = liftM unlift askUnlift
newtype UnliftBase b m = UnliftBase { unliftBase :: forall a. m a -> b a }
class (StM m a ~ a) => IdenticalBase m a
instance (StM m a ~ a) => IdenticalBase m a
class (MonadBaseControl b m, Forall (IdenticalBase m)) => MonadBaseUnlift b m | m -> b
instance (MonadBaseControl b m, Forall (IdenticalBase m)) => MonadBaseUnlift b m
mkUnliftBase :: forall m a b. (Forall (IdenticalBase m), Monad b)
=> (forall c. m c -> b (StM m c)) -> m a -> b a
mkUnliftBase r act = r act \\ (inst :: Forall (IdenticalBase m) :- IdenticalBase m a)
askUnliftBase :: forall b m. (MonadBaseUnlift b m) => m (UnliftBase b m)
askUnliftBase = liftBaseWith unlifter
where
unlifter :: (forall c. m c -> b (StM m c)) -> b (UnliftBase b m)
unlifter r = return $ UnliftBase (mkUnliftBase r)
askRunBase :: (MonadBaseUnlift b m)
=> m (m a -> b a)
askRunBase = liftM unliftBase askUnliftBase