{-# LANGUAGE ConstraintKinds         #-}
{-# LANGUAGE CPP                     #-}
{-# LANGUAGE FlexibleContexts        #-}
{-# LANGUAGE FlexibleInstances       #-}
{-# LANGUAGE FunctionalDependencies  #-}
{-# LANGUAGE MultiParamTypeClasses   #-}
{-# LANGUAGE RankNTypes              #-}
{-# LANGUAGE ScopedTypeVariables     #-}
{-# LANGUAGE TypeFamilies            #-}
{-# LANGUAGE TypeOperators           #-}
{-# LANGUAGE UndecidableInstances    #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE UndecidableSuperClasses #-}
#endif
-- | See overview in the README.md
module Control.Monad.Trans.Unlift
    ( -- * Trans
      MonadTransUnlift
    , Unlift (..)
    , askUnlift
    , askRun
      -- * Base
    , MonadBaseUnlift
    , UnliftBase (..)
    , askUnliftBase
    , askRunBase
      -- * Reexports
    , MonadTrans (..)
    , MonadBase (..)
    , MonadTransControl (..)
    , MonadBaseControl (..)
    ) where

import           Control.Monad               (liftM)
import           Control.Monad.Base          (MonadBase (..))
import           Control.Monad.Trans.Class   (MonadTrans (..))
import           Control.Monad.Trans.Control (MonadBaseControl (..),
                                              MonadTransControl (..))
import           Data.Constraint             ((:-), (\\))
import           Data.Constraint.Forall      (Forall, inst)

-- | A function which can move an action down the monad transformer stack, by
-- providing any necessary environment to the action.
--
-- Note that, if ImpredicativeTypes worked reliably, this type wouldn't be
-- necessary, and 'askUnlift' would simply include a more generalized type.
--
-- Since 0.1.0
newtype Unlift t = Unlift { Unlift t -> forall a (n :: * -> *). Monad n => t n a -> n a
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

-- | A monad transformer which can be unlifted, obeying the monad morphism laws.
--
-- Since 0.1.0
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 :: (forall (n :: * -> *) b. Monad n => t n b -> n (StT t b))
-> t m a -> m a
mkUnlift r :: forall (n :: * -> *) b. Monad n => t n b -> n (StT t b)
r act :: t m a
act = t m a -> m (StT t a)
forall (n :: * -> *) b. Monad n => t n b -> n (StT t b)
r t m a
act (Identical t a => m a)
-> (Forall_ (Identical t) :- Identical t a) -> m a
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ (Forall (Identical t) :- Identical t a
forall k (p :: k -> Constraint) (a :: k). Forall p :- p a
inst :: Forall (Identical t) :- Identical t a)

-- | Get the 'Unlift' action for the current transformer layer.
--
-- Since 0.1.0
askUnlift :: forall t m. (MonadTransUnlift t, Monad m) => t m (Unlift t)
askUnlift :: t m (Unlift t)
askUnlift = (Run t -> m (Unlift t)) -> t m (Unlift t)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run t -> m a) -> t m a
liftWith Run t -> m (Unlift t)
unlifter
  where
    unlifter :: (forall n b. Monad n => t n b -> n (StT t b)) -> m (Unlift t)
    unlifter :: Run t -> m (Unlift t)
unlifter r :: Run t
r = Unlift t -> m (Unlift t)
forall (m :: * -> *) a. Monad m => a -> m a
return (Unlift t -> m (Unlift t)) -> Unlift t -> m (Unlift t)
forall a b. (a -> b) -> a -> b
$ (forall a (n :: * -> *). Monad n => t n a -> n a) -> Unlift t
forall (t :: (* -> *) -> * -> *).
(forall a (n :: * -> *). Monad n => t n a -> n a) -> Unlift t
Unlift (Run t -> t n a -> n a
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 Run t
r)

-- | A simplified version of 'askUnlift' which addresses the common case where
-- polymorphism isn't necessary.
--
-- Since 0.1.0
askRun :: (MonadTransUnlift t, Monad (t m), Monad m) => t m (t m a -> m a)
askRun :: t m (t m a -> m a)
askRun = (Unlift t -> t m a -> m a) -> t m (Unlift t) -> t m (t m a -> m a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Unlift t -> t m a -> m a
forall (t :: (* -> *) -> * -> *).
Unlift t -> forall a (n :: * -> *). Monad n => t n a -> n a
unlift t m (Unlift t)
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(MonadTransUnlift t, Monad m) =>
t m (Unlift t)
askUnlift
{-# INLINE askRun #-}

-- | Similar to 'Unlift', but instead of moving one layer down the stack, moves
-- the action to the base monad.
--
-- Since 0.1.0
newtype UnliftBase b m = UnliftBase { UnliftBase b m -> forall a. m a -> b a
unliftBase :: forall a. m a -> b a }

class    (StM m a ~ a) => IdenticalBase m a
instance (StM m a ~ a) => IdenticalBase m a

-- | A monad transformer stack which can be unlifted, obeying the monad morphism laws.
--
-- Since 0.1.0
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 :: (forall c. m c -> b (StM m c)) -> m a -> b a
mkUnliftBase r :: forall c. m c -> b (StM m c)
r act :: m a
act = m a -> b (StM m a)
forall c. m c -> b (StM m c)
r m a
act (IdenticalBase m a => b a)
-> (Forall_ (IdenticalBase m) :- IdenticalBase m a) -> b a
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ (Forall (IdenticalBase m) :- IdenticalBase m a
forall k (p :: k -> Constraint) (a :: k). Forall p :- p a
inst :: Forall (IdenticalBase m) :- IdenticalBase m a)

-- | Get the 'UnliftBase' action for the current transformer stack.
--
-- Since 0.1.0
askUnliftBase :: forall b m. (MonadBaseUnlift b m) => m (UnliftBase b m)
askUnliftBase :: m (UnliftBase b m)
askUnliftBase = (RunInBase m b -> b (UnliftBase b m)) -> m (UnliftBase b m)
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith RunInBase m b -> b (UnliftBase b m)
unlifter
  where
    unlifter :: (forall c. m c -> b (StM m c)) -> b (UnliftBase b m)
    unlifter :: RunInBase m b -> b (UnliftBase b m)
unlifter r :: RunInBase m b
r = UnliftBase b m -> b (UnliftBase b m)
forall (m :: * -> *) a. Monad m => a -> m a
return (UnliftBase b m -> b (UnliftBase b m))
-> UnliftBase b m -> b (UnliftBase b m)
forall a b. (a -> b) -> a -> b
$ (forall a. m a -> b a) -> UnliftBase b m
forall (b :: * -> *) (m :: * -> *).
(forall a. m a -> b a) -> UnliftBase b m
UnliftBase (RunInBase m b -> m a -> b a
forall (m :: * -> *) a (b :: * -> *).
(Forall (IdenticalBase m), Monad b) =>
(forall c. m c -> b (StM m c)) -> m a -> b a
mkUnliftBase RunInBase m b
r)

-- | A simplified version of 'askUnliftBase' which addresses the common case
-- where polymorphism isn't necessary.
--
-- Since 0.1.0
askRunBase :: (MonadBaseUnlift b m)
           => m (m a -> b a)
askRunBase :: m (m a -> b a)
askRunBase = (UnliftBase b m -> m a -> b a)
-> m (UnliftBase b m) -> m (m a -> b a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM UnliftBase b m -> m a -> b a
forall (b :: * -> *) (m :: * -> *).
UnliftBase b m -> forall a. m a -> b a
unliftBase m (UnliftBase b m)
forall (b :: * -> *) (m :: * -> *).
MonadBaseUnlift b m =>
m (UnliftBase b m)
askUnliftBase
{-# INLINE askRunBase #-}