{-# LANGUAGE TupleSections #-}
module Control.Effect.Type.Unravel where

import Control.Effect.Internal.Union
import Control.Monad.Trans
import Control.Monad.Trans.Reader (ReaderT(..))
import Control.Monad.Trans.Except (ExceptT(..))
-- import qualified Control.Monad.Trans.State.Strict as SSt

-- import qualified Control.Monad.Trans.State.Lazy as LSt

-- import qualified Control.Monad.Trans.Writer.Lazy as LWr

-- import qualified Control.Monad.Trans.Writer.Strict as SWr

-- import qualified Control.Monad.Trans.Writer.CPS as CPSWr


-- | A primitive effect which allows you to break a computation into layers.

-- This is the primitive effect underlying

-- 'Control.Effect.Intercept.Intercept' and

-- 'Control.Effect.Intercept.InterceptCont'.

--

-- Note: 'ThreadsEff' instances are not allowed to assume that @p@ is a functor.

--

-- __'Unravel' is typically used as a primitive effect.__

-- If you define a 'Control.Effect.Carrier' that relies on a novel

-- non-trivial monad transformer @t@, then you need to make

-- a @'ThreadsEff' t ('Unravel' p)@ instance (if possible).

--

-- The following threading constraints accept 'Unravel':

--

-- * 'Control.Effect.ReaderThreads'

-- * 'Control.Effect.Error.ErrorThreads'

-- * 'Control.Effect.NonDet.NonDetThreads'

-- * 'Control.Effect.Stepped.SteppedThreads'

-- * 'Control.Effect.Cont.ContThreads'

data Unravel p :: Effect where
  Unravel :: p a -> (m a -> a) -> m a -> Unravel p m a

instance ThreadsEff (ReaderT i) (Unravel p) where
  threadEff :: (forall x. Unravel p m x -> m x)
-> Unravel p (ReaderT i m) a -> ReaderT i m a
threadEff forall x. Unravel p m x -> m x
alg (Unravel p a
p ReaderT i m a -> a
cataM ReaderT i m a
main) = (i -> m a) -> ReaderT i m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((i -> m a) -> ReaderT i m a) -> (i -> m a) -> ReaderT i m a
forall a b. (a -> b) -> a -> b
$ \i
i ->
    Unravel p m a -> m a
forall x. Unravel p m x -> m x
alg (Unravel p m a -> m a) -> Unravel p m a -> m a
forall a b. (a -> b) -> a -> b
$ p a -> (m a -> a) -> m a -> Unravel p m a
forall (p :: * -> *) a (m :: * -> *).
p a -> (m a -> a) -> m a -> Unravel p m a
Unravel p a
p (ReaderT i m a -> a
cataM (ReaderT i m a -> a) -> (m a -> ReaderT i m a) -> m a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ReaderT i m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) (ReaderT i m a -> i -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT i m a
main i
i)
  {-# INLINE threadEff #-}

instance ThreadsEff (ExceptT e) (Unravel p) where
  threadEff :: (forall x. Unravel p m x -> m x)
-> Unravel p (ExceptT e m) a -> ExceptT e m a
threadEff forall x. Unravel p m x -> m x
alg (Unravel p a
p ExceptT e m a -> a
cataM (ExceptT m (Either e a)
main)) = m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ExceptT e m a) -> m a -> ExceptT e m a
forall a b. (a -> b) -> a -> b
$
    Unravel p m a -> m a
forall x. Unravel p m x -> m x
alg (Unravel p m a -> m a) -> Unravel p m a -> m a
forall a b. (a -> b) -> a -> b
$ p a -> (m a -> a) -> m a -> Unravel p m a
forall (p :: * -> *) a (m :: * -> *).
p a -> (m a -> a) -> m a -> Unravel p m a
Unravel p a
p (ExceptT e m a -> a
cataM (ExceptT e m a -> a) -> (m a -> ExceptT e m a) -> m a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) ((Either e a -> a) -> m (Either e a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ExceptT e m a -> a
cataM (ExceptT e m a -> a)
-> (Either e a -> ExceptT e m a) -> Either e a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Either e a) -> ExceptT e m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e a) -> ExceptT e m a)
-> (Either e a -> m (Either e a)) -> Either e a -> ExceptT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either e a -> m (Either e a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure) m (Either e a)
main)
  {-# INLINE threadEff #-}

-- NOTE: These instances have very unintuitive semantics, so

-- we don't make them available.

{-
instance ThreadsEff (LSt.StateT s) (Unravel p) where
  threadEff alg (Unravel p cataM main) = LSt.StateT $ \s ->
    fmap (, s) $
      alg $ Unravel p
                    (cataM . lift)
                    (    (\t -> cataM (LSt.StateT $ \_ -> pure t))
                     <$> LSt.runStateT main s
                    )
  {-# INLINE threadEff #-}

instance ThreadsEff (SSt.StateT s) (Unravel p) where
  threadEff alg (Unravel p cataM main) = SSt.StateT $ \s ->
    fmap (, s) $
      alg $ Unravel p
                    (cataM . lift)
                    (    (\t -> cataM (SSt.StateT $ \_ -> pure t))
                     <$> SSt.runStateT main s
                    )
  {-# INLINE threadEff #-}

instance Monoid w => ThreadsEff (LWr.WriterT w) (Unravel p) where
  threadEff alg (Unravel p cataM main) = lift $
      alg $ Unravel p
                    (cataM . lift)
                    (    (\t -> cataM (LWr.WriterT $ pure t))
                     <$> LWr.runWriterT main
                    )
  {-# INLINE threadEff #-}

instance Monoid w => ThreadsEff (SWr.WriterT w) (Unravel p) where
  threadEff alg (Unravel p cataM main) = lift $
      alg $ Unravel p
                    (cataM . lift)
                    (    (\t -> cataM (SWr.WriterT $ pure t))
                     <$> SWr.runWriterT main
                    )
  {-# INLINE threadEff #-}

instance Monoid w => ThreadsEff (CPSWr.WriterT w) (Unravel p) where
  threadEff alg (Unravel p cataM main) = lift $
      alg $ Unravel p
                    (cataM . lift)
                    (    (\t -> cataM (CPSWr.writerT $ pure t))
                     <$> CPSWr.runWriterT main
                    )
  {-# INLINE threadEff #-}
-}