module Control.Monad.Ology.General.Trans.AskUnlift where

import Control.Monad.Ology.General.Extract
import Control.Monad.Ology.General.Function
import Control.Monad.Ology.General.IO
import Control.Monad.Ology.General.Outer
import Control.Monad.Ology.General.Trans.Constraint
import Control.Monad.Ology.General.Trans.Trans
import Control.Monad.Ology.General.Trans.Tunnel
import Control.Monad.Ology.General.Trans.Unlift
import Control.Monad.Ology.Specific.ComposeOuter
import Import

-- | A transformer that has no effects (such as state change or output).
class MonadTransUnlift t => MonadTransAskUnlift t where
    askUnlift ::
           forall m. Monad m
        => t m (WUnlift Monad t)
    default askUnlift :: forall m. Monad m => t m (WUnlift Monad t)
    askUnlift = ((forall (m1 :: Type -> Type) a.
  Monad m1 =>
  t m1 a -> m1 (Tunnel t a))
 -> m (Tunnel t (WUnlift Monad t)))
-> t m (WUnlift Monad t)
forall (m :: Type -> Type) r.
Monad m =>
((forall (m1 :: Type -> Type) a.
  Monad m1 =>
  t m1 a -> m1 (Tunnel t a))
 -> m (Tunnel t r))
-> t m r
forall (t :: TransKind) (m :: Type -> Type) r.
(MonadTransTunnel t, Monad m) =>
((forall (m1 :: Type -> Type) a.
  Monad m1 =>
  t m1 a -> m1 (Tunnel t a))
 -> m (Tunnel t r))
-> t m r
tunnel (((forall (m1 :: Type -> Type) a.
   Monad m1 =>
   t m1 a -> m1 (Tunnel t a))
  -> m (Tunnel t (WUnlift Monad t)))
 -> t m (WUnlift Monad t))
-> ((forall (m1 :: Type -> Type) a.
     Monad m1 =>
     t m1 a -> m1 (Tunnel t a))
    -> m (Tunnel t (WUnlift Monad t)))
-> t m (WUnlift Monad t)
forall a b. (a -> b) -> a -> b
$ \forall (m1 :: Type -> Type) a.
Monad m1 =>
t m1 a -> m1 (Tunnel t a)
unlift -> Tunnel t (WUnlift Monad t) -> m (Tunnel t (WUnlift Monad t))
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Tunnel t (WUnlift Monad t) -> m (Tunnel t (WUnlift Monad t)))
-> Tunnel t (WUnlift Monad t) -> m (Tunnel t (WUnlift Monad t))
forall a b. (a -> b) -> a -> b
$ WUnlift Monad t -> Tunnel t (WUnlift Monad t)
forall a. a -> Tunnel t a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (WUnlift Monad t -> Tunnel t (WUnlift Monad t))
-> WUnlift Monad t -> Tunnel t (WUnlift Monad t)
forall a b. (a -> b) -> a -> b
$ Unlift Monad t -> WUnlift Monad t
forall (c :: (Type -> Type) -> Constraint) (t :: TransKind).
Unlift c t -> WUnlift c t
MkWUnlift (Unlift Monad t -> WUnlift Monad t)
-> Unlift Monad t -> WUnlift Monad t
forall a b. (a -> b) -> a -> b
$ \t m a
tma -> (Tunnel t a -> a) -> m (Tunnel t a) -> m a
forall a b. (a -> b) -> m a -> m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Tunnel t a -> a
Extract (Tunnel t)
forall (m :: Type -> Type). MonadExtract m => Extract m
mToValue (m (Tunnel t a) -> m a) -> m (Tunnel t a) -> m a
forall a b. (a -> b) -> a -> b
$ t m a -> m (Tunnel t a)
forall (m1 :: Type -> Type) a.
Monad m1 =>
t m1 a -> m1 (Tunnel t a)
unlift t m a
tma

-- | A monad that has no effects over IO (such as state change or output).
class MonadUnliftIO m => MonadAskUnliftIO m where
    askUnliftIO :: m (WRaised m IO)
    askUnliftIO = ((forall a. m a -> IO (TunnelIO m a))
 -> IO (TunnelIO m (WRaised m IO)))
-> m (WRaised m IO)
forall r.
((forall a. m a -> IO (TunnelIO m a)) -> IO (TunnelIO m r)) -> m r
forall (m :: Type -> Type) r.
MonadTunnelIO m =>
((forall a. m a -> IO (TunnelIO m a)) -> IO (TunnelIO m r)) -> m r
tunnelIO (((forall a. m a -> IO (TunnelIO m a))
  -> IO (TunnelIO m (WRaised m IO)))
 -> m (WRaised m IO))
-> ((forall a. m a -> IO (TunnelIO m a))
    -> IO (TunnelIO m (WRaised m IO)))
-> m (WRaised m IO)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO (TunnelIO m a)
unlift -> TunnelIO m (WRaised m IO) -> IO (TunnelIO m (WRaised m IO))
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TunnelIO m (WRaised m IO) -> IO (TunnelIO m (WRaised m IO)))
-> TunnelIO m (WRaised m IO) -> IO (TunnelIO m (WRaised m IO))
forall a b. (a -> b) -> a -> b
$ WRaised m IO -> TunnelIO m (WRaised m IO)
forall a. a -> TunnelIO m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (WRaised m IO -> TunnelIO m (WRaised m IO))
-> WRaised m IO -> TunnelIO m (WRaised m IO)
forall a b. (a -> b) -> a -> b
$ (m --> IO) -> WRaised m IO
forall k (p :: k -> Type) (q :: k -> Type).
(p --> q) -> WRaised p q
MkWRaised ((m --> IO) -> WRaised m IO) -> (m --> IO) -> WRaised m IO
forall a b. (a -> b) -> a -> b
$ \m a
ma -> (TunnelIO m a -> a) -> IO (TunnelIO m a) -> IO a
forall a b. (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap TunnelIO m a -> a
Extract (TunnelIO m)
forall (m :: Type -> Type). MonadExtract m => Extract m
mToValue (IO (TunnelIO m a) -> IO a) -> IO (TunnelIO m a) -> IO a
forall a b. (a -> b) -> a -> b
$ m a -> IO (TunnelIO m a)
forall a. m a -> IO (TunnelIO m a)
unlift m a
ma

instance MonadAskUnliftIO IO where
    askUnliftIO :: IO (WRaised IO IO)
askUnliftIO = WRaised IO IO -> IO (WRaised IO IO)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (WRaised IO IO -> IO (WRaised IO IO))
-> WRaised IO IO -> IO (WRaised IO IO)
forall a b. (a -> b) -> a -> b
$ (IO --> IO) -> WRaised IO IO
forall k (p :: k -> Type) (q :: k -> Type).
(p --> q) -> WRaised p q
MkWRaised IO a -> IO a
forall a. a -> a
IO --> IO
forall {k} (cat :: k -> k -> Type) (a :: k).
Category cat =>
cat a a
id

instance (MonadTransAskUnlift t, MonadAskUnliftIO m, MonadFail (t m), MonadIO (t m), MonadFix (t m)) =>
             MonadAskUnliftIO (t m) where
    askUnliftIO :: t m (WRaised (t m) IO)
askUnliftIO = do
        MkWUnlift Unlift Monad t
unlift <- t m (WUnlift Monad t)
forall (m :: Type -> Type). Monad m => t m (WUnlift Monad t)
forall (t :: TransKind) (m :: Type -> Type).
(MonadTransAskUnlift t, Monad m) =>
t m (WUnlift Monad t)
askUnlift
        MkWRaised m --> IO
unliftIO <- m (WRaised m IO) -> t m (WRaised m IO)
forall (m :: Type -> Type) a. Monad m => m a -> t m a
forall (t :: TransKind) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (WRaised m IO)
forall (m :: Type -> Type). MonadAskUnliftIO m => m (WRaised m IO)
askUnliftIO
        WRaised (t m) IO -> t m (WRaised (t m) IO)
forall a. a -> t m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (WRaised (t m) IO -> t m (WRaised (t m) IO))
-> WRaised (t m) IO -> t m (WRaised (t m) IO)
forall a b. (a -> b) -> a -> b
$ (t m --> IO) -> WRaised (t m) IO
forall k (p :: k -> Type) (q :: k -> Type).
(p --> q) -> WRaised p q
MkWRaised ((t m --> IO) -> WRaised (t m) IO)
-> (t m --> IO) -> WRaised (t m) IO
forall a b. (a -> b) -> a -> b
$ m a -> IO a
m --> IO
unliftIO (m a -> IO a) -> (t m a -> m a) -> t m a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. t m a -> m a
t m --> m
Unlift Monad t
unlift

instance MonadTransAskUnlift t => TransConstraint MonadAskUnliftIO t where
    hasTransConstraint :: forall (m :: Type -> Type).
MonadAskUnliftIO m =>
Dict (MonadAskUnliftIO (t m))
hasTransConstraint =
        forall (c :: (Type -> Type) -> Constraint) (t :: TransKind)
       (m :: Type -> Type) (c' :: (Type -> Type) -> Constraint).
(TransConstraint c t, c m) =>
(c (t m) => Dict (c' (t m))) -> Dict (c' (t m))
withTransConstraintDict @MonadFail ((MonadFail (t m) => Dict (MonadAskUnliftIO (t m)))
 -> Dict (MonadAskUnliftIO (t m)))
-> (MonadFail (t m) => Dict (MonadAskUnliftIO (t m)))
-> Dict (MonadAskUnliftIO (t m))
forall a b. (a -> b) -> a -> b
$ forall (c :: (Type -> Type) -> Constraint) (t :: TransKind)
       (m :: Type -> Type) (c' :: (Type -> Type) -> Constraint).
(TransConstraint c t, c m) =>
(c (t m) => Dict (c' (t m))) -> Dict (c' (t m))
withTransConstraintDict @MonadIO ((MonadIO (t m) => Dict (MonadAskUnliftIO (t m)))
 -> Dict (MonadAskUnliftIO (t m)))
-> (MonadIO (t m) => Dict (MonadAskUnliftIO (t m)))
-> Dict (MonadAskUnliftIO (t m))
forall a b. (a -> b) -> a -> b
$ forall (c :: (Type -> Type) -> Constraint) (t :: TransKind)
       (m :: Type -> Type) (c' :: (Type -> Type) -> Constraint).
(TransConstraint c t, c m) =>
(c (t m) => Dict (c' (t m))) -> Dict (c' (t m))
withTransConstraintDict @MonadFix ((MonadFix (t m) => Dict (MonadAskUnliftIO (t m)))
 -> Dict (MonadAskUnliftIO (t m)))
-> (MonadFix (t m) => Dict (MonadAskUnliftIO (t m)))
-> Dict (MonadAskUnliftIO (t m))
forall a b. (a -> b) -> a -> b
$ Dict (MonadAskUnliftIO (t m))
MonadFix (t m) => Dict (MonadAskUnliftIO (t m))
forall (a :: Constraint). a => Dict a
Dict

instance forall outer. MonadOuter outer => MonadTransAskUnlift (ComposeOuter outer)

contractT ::
       forall (t :: TransKind) m. (MonadTransAskUnlift t, Monad m)
    => t (t m) --> t m
contractT :: forall (t :: TransKind) (m :: Type -> Type).
(MonadTransAskUnlift t, Monad m) =>
t (t m) --> t m
contractT t (t m) a
ttma =
    case forall (c :: (Type -> Type) -> Constraint) (t :: TransKind)
       (m :: Type -> Type).
(TransConstraint c t, c m) =>
Dict (c (t m))
hasTransConstraint @Monad @t @m of
        Dict (Monad (t m))
Dict -> do
            MkWUnlift Unlift Monad t
unlift <- t m (WUnlift Monad t)
forall (m :: Type -> Type). Monad m => t m (WUnlift Monad t)
forall (t :: TransKind) (m :: Type -> Type).
(MonadTransAskUnlift t, Monad m) =>
t m (WUnlift Monad t)
askUnlift
            t (t m) a -> t m a
t (t m) --> t m
Unlift Monad t
unlift t (t m) a
ttma

contractTBack ::
       forall (t :: TransKind) m. (MonadTransAskUnlift t, Monad m)
    => t (t m) -/-> t m
contractTBack :: forall (t :: TransKind) (m :: Type -> Type).
(MonadTransAskUnlift t, Monad m) =>
t (t m) -/-> t m
contractTBack (t m --> t (t m)) -> t (t m) r
call =
    case forall (c :: (Type -> Type) -> Constraint) (t :: TransKind)
       (m :: Type -> Type).
(TransConstraint c t, c m) =>
Dict (c (t m))
hasTransConstraint @Monad @t @m of
        Dict (Monad (t m))
Dict -> t (t m) r -> t m r
t (t m) --> t m
forall (t :: TransKind) (m :: Type -> Type).
(MonadTransAskUnlift t, Monad m) =>
t (t m) --> t m
contractT (t (t m) r -> t m r) -> t (t m) r -> t m r
forall a b. (a -> b) -> a -> b
$ (t m --> t (t m)) -> t (t m) r
call t m a -> t (t m) a
t m --> t (t m)
forall (m :: Type -> Type) a. Monad m => m a -> t m a
forall (t :: TransKind) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift