{-# LANGUAGE UndecidableInstances #-}

module Control.Monad.Trans.Yield
  ( YieldT
  , runYieldT
  , hoistYieldT
  ) where

import Prelude

import Control.Monad (ap, liftM)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Reader (MonadReader (..))
import Control.Monad.State (MonadState (..))
import Control.Monad.Trans.Class (MonadTrans (..))
import Control.Monad.Trans.Codensity (CodensityT (..))
import Control.Monad.Yield.Aggregation (Aggregation (..))
import Control.Monad.Yield.Class (MonadYield (..))

-- | Monad transformer that adds dynamically interpretable 'MonadYield' support
newtype YieldT a m r = YieldT (CodensityT (Yielder a m) r)
  deriving newtype ((forall a b. (a -> b) -> YieldT a m a -> YieldT a m b)
-> (forall a b. a -> YieldT a m b -> YieldT a m a)
-> Functor (YieldT a m)
forall a b. a -> YieldT a m b -> YieldT a m a
forall a b. (a -> b) -> YieldT a m a -> YieldT a m b
forall a (m :: * -> *) a b. a -> YieldT a m b -> YieldT a m a
forall a (m :: * -> *) a b.
(a -> b) -> YieldT a m a -> YieldT a m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a (m :: * -> *) a b.
(a -> b) -> YieldT a m a -> YieldT a m b
fmap :: forall a b. (a -> b) -> YieldT a m a -> YieldT a m b
$c<$ :: forall a (m :: * -> *) a b. a -> YieldT a m b -> YieldT a m a
<$ :: forall a b. a -> YieldT a m b -> YieldT a m a
Functor, Functor (YieldT a m)
Functor (YieldT a m) =>
(forall a. a -> YieldT a m a)
-> (forall a b.
    YieldT a m (a -> b) -> YieldT a m a -> YieldT a m b)
-> (forall a b c.
    (a -> b -> c) -> YieldT a m a -> YieldT a m b -> YieldT a m c)
-> (forall a b. YieldT a m a -> YieldT a m b -> YieldT a m b)
-> (forall a b. YieldT a m a -> YieldT a m b -> YieldT a m a)
-> Applicative (YieldT a m)
forall a. a -> YieldT a m a
forall a b. YieldT a m a -> YieldT a m b -> YieldT a m a
forall a b. YieldT a m a -> YieldT a m b -> YieldT a m b
forall a b. YieldT a m (a -> b) -> YieldT a m a -> YieldT a m b
forall a b c.
(a -> b -> c) -> YieldT a m a -> YieldT a m b -> YieldT a m c
forall a (m :: * -> *). Functor (YieldT a m)
forall a (m :: * -> *) a. a -> YieldT a m a
forall a (m :: * -> *) a b.
YieldT a m a -> YieldT a m b -> YieldT a m a
forall a (m :: * -> *) a b.
YieldT a m a -> YieldT a m b -> YieldT a m b
forall a (m :: * -> *) a b.
YieldT a m (a -> b) -> YieldT a m a -> YieldT a m b
forall a (m :: * -> *) a b c.
(a -> b -> c) -> YieldT a m a -> YieldT a m b -> YieldT a m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a (m :: * -> *) a. a -> YieldT a m a
pure :: forall a. a -> YieldT a m a
$c<*> :: forall a (m :: * -> *) a b.
YieldT a m (a -> b) -> YieldT a m a -> YieldT a m b
<*> :: forall a b. YieldT a m (a -> b) -> YieldT a m a -> YieldT a m b
$cliftA2 :: forall a (m :: * -> *) a b c.
(a -> b -> c) -> YieldT a m a -> YieldT a m b -> YieldT a m c
liftA2 :: forall a b c.
(a -> b -> c) -> YieldT a m a -> YieldT a m b -> YieldT a m c
$c*> :: forall a (m :: * -> *) a b.
YieldT a m a -> YieldT a m b -> YieldT a m b
*> :: forall a b. YieldT a m a -> YieldT a m b -> YieldT a m b
$c<* :: forall a (m :: * -> *) a b.
YieldT a m a -> YieldT a m b -> YieldT a m a
<* :: forall a b. YieldT a m a -> YieldT a m b -> YieldT a m a
Applicative, Applicative (YieldT a m)
Applicative (YieldT a m) =>
(forall a b. YieldT a m a -> (a -> YieldT a m b) -> YieldT a m b)
-> (forall a b. YieldT a m a -> YieldT a m b -> YieldT a m b)
-> (forall a. a -> YieldT a m a)
-> Monad (YieldT a m)
forall a. a -> YieldT a m a
forall a b. YieldT a m a -> YieldT a m b -> YieldT a m b
forall a b. YieldT a m a -> (a -> YieldT a m b) -> YieldT a m b
forall a (m :: * -> *). Applicative (YieldT a m)
forall a (m :: * -> *) a. a -> YieldT a m a
forall a (m :: * -> *) a b.
YieldT a m a -> YieldT a m b -> YieldT a m b
forall a (m :: * -> *) a b.
YieldT a m a -> (a -> YieldT a m b) -> YieldT a m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a (m :: * -> *) a b.
YieldT a m a -> (a -> YieldT a m b) -> YieldT a m b
>>= :: forall a b. YieldT a m a -> (a -> YieldT a m b) -> YieldT a m b
$c>> :: forall a (m :: * -> *) a b.
YieldT a m a -> YieldT a m b -> YieldT a m b
>> :: forall a b. YieldT a m a -> YieldT a m b -> YieldT a m b
$creturn :: forall a (m :: * -> *) a. a -> YieldT a m a
return :: forall a. a -> YieldT a m a
Monad)

instance MonadTrans (YieldT a) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> YieldT a m a
lift = CodensityT (Yielder a m) a -> YieldT a m a
forall a (m :: * -> *) r.
CodensityT (Yielder a m) r -> YieldT a m r
YieldT (CodensityT (Yielder a m) a -> YieldT a m a)
-> (m a -> CodensityT (Yielder a m) a) -> m a -> YieldT a m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Yielder a m a -> CodensityT (Yielder a m) a
forall (m :: * -> *) a. Monad m => m a -> CodensityT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Yielder a m a -> CodensityT (Yielder a m) a)
-> (m a -> Yielder a m a) -> m a -> CodensityT (Yielder a m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> Yielder a m a
forall (m :: * -> *) a. Monad m => m a -> Yielder a m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

deriving newtype instance MonadIO m => MonadIO (YieldT a m)

deriving newtype instance Functor m => MonadYield a (YieldT a m)

deriving newtype instance MonadReader r m => MonadReader r (YieldT a m)

deriving newtype instance MonadState s m => MonadState s (YieldT a m)

-- | Transforms a 'YieldT''s base monad actions
hoistYieldT
  :: forall m n a r
   . Monad m
  => (forall x. m x -> n x)
  -> YieldT a m r
  -> YieldT a n r
hoistYieldT :: forall (m :: * -> *) (n :: * -> *) a r.
Monad m =>
(forall x. m x -> n x) -> YieldT a m r -> YieldT a n r
hoistYieldT forall x. m x -> n x
f (YieldT (CodensityT forall b. (r -> Yielder a m b) -> Yielder a m b
y0)) = CodensityT (Yielder a n) r -> YieldT a n r
forall a (m :: * -> *) r.
CodensityT (Yielder a m) r -> YieldT a m r
YieldT (CodensityT (Yielder a n) r -> YieldT a n r)
-> CodensityT (Yielder a n) r -> YieldT a n r
forall a b. (a -> b) -> a -> b
$ (forall b. (r -> Yielder a n b) -> Yielder a n b)
-> CodensityT (Yielder a n) r
forall (m :: * -> *) a.
(forall b. (a -> m b) -> m b) -> CodensityT m a
CodensityT \r -> Yielder a n b
continue ->
  let go :: Yielder a m r -> Yielder a n b
go = \case
        Pure r
r -> r -> Yielder a n b
continue r
r
        Yield a
a Yielder a m r
y -> a -> Yielder a n b -> Yielder a n b
forall a (m :: * -> *) r. a -> Yielder a m r -> Yielder a m r
Yield a
a (Yielder a m r -> Yielder a n b
go Yielder a m r
y)
        Act m (Yielder a m r)
m -> n (Yielder a n b) -> Yielder a n b
forall a (m :: * -> *) r. m (Yielder a m r) -> Yielder a m r
Act (m (Yielder a n b) -> n (Yielder a n b)
forall x. m x -> n x
f (m (Yielder a n b) -> n (Yielder a n b))
-> m (Yielder a n b) -> n (Yielder a n b)
forall a b. (a -> b) -> a -> b
$ (Yielder a m r -> Yielder a n b)
-> m (Yielder a m r) -> m (Yielder a n b)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Yielder a m r -> Yielder a n b
go (m (Yielder a m r) -> m (Yielder a n b))
-> m (Yielder a m r) -> m (Yielder a n b)
forall a b. (a -> b) -> a -> b
$ m (Yielder a m r) -> m (Yielder a m r)
forall {m :: * -> *} {a} {r}.
Monad m =>
m (Yielder a m r) -> m (Yielder a m r)
collapse m (Yielder a m r)
m)
         where
          collapse :: m (Yielder a m r) -> m (Yielder a m r)
collapse m (Yielder a m r)
mpipe = do
            Yielder a m r
pipe' <- m (Yielder a m r)
mpipe
            case Yielder a m r
pipe' of
              Act m (Yielder a m r)
mpipe' -> m (Yielder a m r) -> m (Yielder a m r)
collapse m (Yielder a m r)
mpipe'
              Yielder a m r
_ -> Yielder a m r -> m (Yielder a m r)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Yielder a m r
pipe'
  in  Yielder a m r -> Yielder a n b
go (Yielder a m r -> Yielder a n b) -> Yielder a m r -> Yielder a n b
forall a b. (a -> b) -> a -> b
$ (r -> Yielder a m r) -> Yielder a m r
forall b. (r -> Yielder a m b) -> Yielder a m b
y0 r -> Yielder a m r
forall a (m :: * -> *) r. r -> Yielder a m r
Pure

-- | Runs a 'YieldT' computation in the base monad
runYieldT
  :: forall a b m r
   . Monad m
  => Aggregation m a b
  -- ^ What to do with the values emitted from the stream
  -> YieldT a m r
  -> m (b, r)
  -- ^ The result of aggregating of stream values, and the result of the 'YieldT'
runYieldT :: forall a b (m :: * -> *) r.
Monad m =>
Aggregation m a b -> YieldT a m r -> m (b, r)
runYieldT Aggregation m a b
agg (YieldT (CodensityT forall b. (r -> Yielder a m b) -> Yielder a m b
y)) = Aggregation m a b -> Yielder a m r -> m (b, r)
forall (m :: * -> *) a b r.
Monad m =>
Aggregation m a b -> Yielder a m r -> m (b, r)
runYielder Aggregation m a b
agg ((r -> Yielder a m r) -> Yielder a m r
forall b. (r -> Yielder a m b) -> Yielder a m b
y r -> Yielder a m r
forall a (m :: * -> *) r. r -> Yielder a m r
Pure)

data Yielder a m r
  = Yield a (Yielder a m r)
  | Act (m (Yielder a m r))
  | Pure r
  deriving stock ((forall a b. (a -> b) -> Yielder a m a -> Yielder a m b)
-> (forall a b. a -> Yielder a m b -> Yielder a m a)
-> Functor (Yielder a m)
forall a b. a -> Yielder a m b -> Yielder a m a
forall a b. (a -> b) -> Yielder a m a -> Yielder a m b
forall a (m :: * -> *) a b.
Functor m =>
a -> Yielder a m b -> Yielder a m a
forall a (m :: * -> *) a b.
Functor m =>
(a -> b) -> Yielder a m a -> Yielder a m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a (m :: * -> *) a b.
Functor m =>
(a -> b) -> Yielder a m a -> Yielder a m b
fmap :: forall a b. (a -> b) -> Yielder a m a -> Yielder a m b
$c<$ :: forall a (m :: * -> *) a b.
Functor m =>
a -> Yielder a m b -> Yielder a m a
<$ :: forall a b. a -> Yielder a m b -> Yielder a m a
Functor)

instance Functor m => Applicative (Yielder a m) where
  pure :: forall a. a -> Yielder a m a
pure = a -> Yielder a m a
forall a (m :: * -> *) r. r -> Yielder a m r
Pure
  <*> :: forall a b. Yielder a m (a -> b) -> Yielder a m a -> Yielder a m b
(<*>) = Yielder a m (a -> b) -> Yielder a m a -> Yielder a m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Functor m => Monad (Yielder a m) where
  Yielder a m a
p0 >>= :: forall a b. Yielder a m a -> (a -> Yielder a m b) -> Yielder a m b
>>= a -> Yielder a m b
f = Yielder a m a -> Yielder a m b
go Yielder a m a
p0
   where
    go :: Yielder a m a -> Yielder a m b
go Yielder a m a
p = case Yielder a m a
p of
      Yield a
a Yielder a m a
continue -> a -> Yielder a m b -> Yielder a m b
forall a (m :: * -> *) r. a -> Yielder a m r -> Yielder a m r
Yield a
a (Yielder a m b -> Yielder a m b) -> Yielder a m b -> Yielder a m b
forall a b. (a -> b) -> a -> b
$ Yielder a m a -> Yielder a m b
go Yielder a m a
continue
      Act m (Yielder a m a)
m -> m (Yielder a m b) -> Yielder a m b
forall a (m :: * -> *) r. m (Yielder a m r) -> Yielder a m r
Act (Yielder a m a -> Yielder a m b
go (Yielder a m a -> Yielder a m b)
-> m (Yielder a m a) -> m (Yielder a m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Yielder a m a)
m)
      Pure a
r -> a -> Yielder a m b
f a
r

instance Functor m => MonadYield a (Yielder a m) where
  yield :: a -> Yielder a m ()
yield a
x = a -> Yielder a m () -> Yielder a m ()
forall a (m :: * -> *) r. a -> Yielder a m r -> Yielder a m r
Yield a
x (() -> Yielder a m ()
forall a (m :: * -> *) r. r -> Yielder a m r
Pure ())

instance MonadTrans (Yielder a) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> Yielder a m a
lift = m (Yielder a m a) -> Yielder a m a
forall a (m :: * -> *) r. m (Yielder a m r) -> Yielder a m r
Act (m (Yielder a m a) -> Yielder a m a)
-> (m a -> m (Yielder a m a)) -> m a -> Yielder a m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Yielder a m a) -> m a -> m (Yielder a m a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Yielder a m a
forall a (m :: * -> *) r. r -> Yielder a m r
Pure

instance MonadIO m => MonadIO (Yielder a m) where
  liftIO :: forall a. IO a -> Yielder a m a
liftIO = m a -> Yielder a m a
forall (m :: * -> *) a. Monad m => m a -> Yielder a m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> Yielder a m a) -> (IO a -> m a) -> IO a -> Yielder a m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

instance MonadReader r m => MonadReader r (Yielder a m) where
  ask :: Yielder a m r
ask = m r -> Yielder a m r
forall (m :: * -> *) a. Monad m => m a -> Yielder a m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m r
forall r (m :: * -> *). MonadReader r m => m r
ask
  local :: forall a. (r -> r) -> Yielder a m a -> Yielder a m a
local r -> r
f = (forall x. m x -> m x) -> Yielder a m a -> Yielder a m a
forall (n :: * -> *) (m :: * -> *) a r.
Functor n =>
(forall x. m x -> n x) -> Yielder a m r -> Yielder a n r
hoistYielder ((forall x. m x -> m x) -> Yielder a m a -> Yielder a m a)
-> (forall x. m x -> m x) -> Yielder a m a -> Yielder a m a
forall a b. (a -> b) -> a -> b
$ (r -> r) -> m x -> m x
forall a. (r -> r) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
f

instance MonadState s m => MonadState s (Yielder a m) where
  state :: forall a. (s -> (a, s)) -> Yielder a m a
state = m a -> Yielder a m a
forall (m :: * -> *) a. Monad m => m a -> Yielder a m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> Yielder a m a)
-> ((s -> (a, s)) -> m a) -> (s -> (a, s)) -> Yielder a m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> (a, s)) -> m a
forall a. (s -> (a, s)) -> m a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state

hoistYielder
  :: Functor n => (forall x. m x -> n x) -> Yielder a m r -> Yielder a n r
hoistYielder :: forall (n :: * -> *) (m :: * -> *) a r.
Functor n =>
(forall x. m x -> n x) -> Yielder a m r -> Yielder a n r
hoistYielder forall x. m x -> n x
f Yielder a m r
p0 = Yielder a m r -> Yielder a n r
go Yielder a m r
p0
 where
  go :: Yielder a m r -> Yielder a n r
go = \case
    Yield a
a Yielder a m r
p -> a -> Yielder a n r -> Yielder a n r
forall a (m :: * -> *) r. a -> Yielder a m r -> Yielder a m r
Yield a
a (Yielder a n r -> Yielder a n r) -> Yielder a n r -> Yielder a n r
forall a b. (a -> b) -> a -> b
$ Yielder a m r -> Yielder a n r
go Yielder a m r
p
    Act m (Yielder a m r)
m -> n (Yielder a n r) -> Yielder a n r
forall a (m :: * -> *) r. m (Yielder a m r) -> Yielder a m r
Act (n (Yielder a n r) -> Yielder a n r)
-> n (Yielder a n r) -> Yielder a n r
forall a b. (a -> b) -> a -> b
$ Yielder a m r -> Yielder a n r
go (Yielder a m r -> Yielder a n r)
-> n (Yielder a m r) -> n (Yielder a n r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Yielder a m r) -> n (Yielder a m r)
forall x. m x -> n x
f m (Yielder a m r)
m
    Pure r
r -> r -> Yielder a n r
forall a (m :: * -> *) r. r -> Yielder a m r
Pure r
r

-- | Runs a 'Yielder' computation in the base monad
runYielder
  :: Monad m
  => Aggregation m a b
  -- ^ What to do with the values emitted from the stream
  -> Yielder a m r
  -> m (b, r)
  -- ^ The result of aggregating of stream values, and the result of the 'Yielder'
runYielder :: forall (m :: * -> *) a b r.
Monad m =>
Aggregation m a b -> Yielder a m r -> m (b, r)
runYielder Aggregation {m x
begin :: m x
begin :: ()
begin, x -> a -> m x
step :: x -> a -> m x
step :: ()
step, x -> m b
done :: x -> m b
done :: ()
done} Yielder a m r
p0 = m x
begin m x -> (x -> m (b, r)) -> m (b, r)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Yielder a m r -> x -> m (b, r)
go Yielder a m r
p0
 where
  go :: Yielder a m r -> x -> m (b, r)
go Yielder a m r
p x
x = case Yielder a m r
p of
    Yield a
a Yielder a m r
continue -> (Yielder a m r -> x -> m (b, r)
go Yielder a m r
continue $!) (x -> m (b, r)) -> m x -> m (b, r)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< x -> a -> m x
step x
x a
a
    Act m (Yielder a m r)
m -> m (Yielder a m r)
m m (Yielder a m r) -> (Yielder a m r -> m (b, r)) -> m (b, r)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Yielder a m r
p' -> Yielder a m r -> x -> m (b, r)
go Yielder a m r
p' x
x
    Pure r
r -> (,r
r) (b -> (b, r)) -> m b -> m (b, r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> x -> m b
done x
x