-- |
-- Module:       Control.Monad.Freer.Coroutine
-- Description:  Composable coroutine effects layer.
-- Copyright:    (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King
-- License:      BSD3
-- Maintainer:   Alexis King <lexi.lambda@gmail.com>
-- Stability:    experimental
-- Portability:  GHC specific language extensions.
--
-- An effect to compose functions with the ability to yield.
--
-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.
module Control.Monad.Freer.Coroutine
  ( -- * Yield Control
    Yield(..)
  , yield

    -- * Handle Yield Effect
  , Status(..)
  , runC
  , interposeC
  , replyC
  ) where

import Control.Monad.Freer.Internal (Eff, Member, handleRelay, interpose, send)

-- | A type representing a yielding of control.
--
-- Type variables have following meaning:
--
-- [@a@]
--   The current type.
--
-- [@b@]
--   The input to the continuation function.
--
-- [@c@]
--   The output of the continuation.
data Yield a b c = Yield a (b -> c)
  deriving (a -> Yield a b b -> Yield a b a
(a -> b) -> Yield a b a -> Yield a b b
(forall a b. (a -> b) -> Yield a b a -> Yield a b b)
-> (forall a b. a -> Yield a b b -> Yield a b a)
-> Functor (Yield a b)
forall a b. a -> Yield a b b -> Yield a b a
forall a b. (a -> b) -> Yield a b a -> Yield a b b
forall a b a b. a -> Yield a b b -> Yield a b a
forall a b a b. (a -> b) -> Yield a b a -> Yield a b b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Yield a b b -> Yield a b a
$c<$ :: forall a b a b. a -> Yield a b b -> Yield a b a
fmap :: (a -> b) -> Yield a b a -> Yield a b b
$cfmap :: forall a b a b. (a -> b) -> Yield a b a -> Yield a b b
Functor)

-- | Lifts a value and a function into the Coroutine effect.
yield :: Member (Yield a b) effs => a -> (b -> c) -> Eff effs c
yield :: a -> (b -> c) -> Eff effs c
yield a
x b -> c
f = Yield a b c -> Eff effs c
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send (a -> (b -> c) -> Yield a b c
forall a b c. a -> (b -> c) -> Yield a b c
Yield a
x b -> c
f)

-- | Represents status of a coroutine.
data Status effs a b r
  = Done r
  -- ^ Coroutine is done with a result value of type @r@.
  | Continue a (b -> Eff effs (Status effs a b r))
  -- ^ Reporting a value of the type @a@, and resuming with the value of type
  -- @b@, possibly ending with a value of type @x@.

-- | Reply to a coroutine effect by returning the Continue constructor.
replyC
  :: Yield a b c
  -> (c -> Eff effs (Status effs a b r))
  -> Eff effs (Status effs a b r)
replyC :: Yield a b c
-> (c -> Eff effs (Status effs a b r))
-> Eff effs (Status effs a b r)
replyC (Yield a
a b -> c
k) c -> Eff effs (Status effs a b r)
arr = Status effs a b r -> Eff effs (Status effs a b r)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Status effs a b r -> Eff effs (Status effs a b r))
-> Status effs a b r -> Eff effs (Status effs a b r)
forall a b. (a -> b) -> a -> b
$ a -> (b -> Eff effs (Status effs a b r)) -> Status effs a b r
forall (effs :: [* -> *]) a b r.
a -> (b -> Eff effs (Status effs a b r)) -> Status effs a b r
Continue a
a (c -> Eff effs (Status effs a b r)
arr (c -> Eff effs (Status effs a b r))
-> (b -> c) -> b -> Eff effs (Status effs a b r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> c
k)

-- | Launch a coroutine and report its status.
runC :: Eff (Yield a b ': effs) r -> Eff effs (Status effs a b r)
runC :: Eff (Yield a b : effs) r -> Eff effs (Status effs a b r)
runC = (r -> Eff effs (Status effs a b r))
-> (forall v.
    Yield a b v
    -> Arr effs v (Status effs a b r) -> Eff effs (Status effs a b r))
-> Eff (Yield a b : effs) r
-> Eff effs (Status effs a b r)
forall a (effs :: [* -> *]) b (eff :: * -> *).
(a -> Eff effs b)
-> (forall v. eff v -> Arr effs v b -> Eff effs b)
-> Eff (eff : effs) a
-> Eff effs b
handleRelay (Status effs a b r -> Eff effs (Status effs a b r)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Status effs a b r -> Eff effs (Status effs a b r))
-> (r -> Status effs a b r) -> r -> Eff effs (Status effs a b r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Status effs a b r
forall (effs :: [* -> *]) a b r. r -> Status effs a b r
Done) forall v.
Yield a b v
-> Arr effs v (Status effs a b r) -> Eff effs (Status effs a b r)
forall a b c (effs :: [* -> *]) r.
Yield a b c
-> (c -> Eff effs (Status effs a b r))
-> Eff effs (Status effs a b r)
replyC

-- | Launch a coroutine and report its status, without handling (removing)
-- 'Yield' from the typelist. This is useful for reducing nested coroutines.
interposeC
  :: Member (Yield a b) effs
  => Eff effs r
  -> Eff effs (Status effs a b r)
interposeC :: Eff effs r -> Eff effs (Status effs a b r)
interposeC = (r -> Eff effs (Status effs a b r))
-> (forall v.
    Yield a b v
    -> Arr effs v (Status effs a b r) -> Eff effs (Status effs a b r))
-> Eff effs r
-> Eff effs (Status effs a b r)
forall (eff :: * -> *) (effs :: [* -> *]) a b.
Member eff effs =>
(a -> Eff effs b)
-> (forall v. eff v -> Arr effs v b -> Eff effs b)
-> Eff effs a
-> Eff effs b
interpose (Status effs a b r -> Eff effs (Status effs a b r)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Status effs a b r -> Eff effs (Status effs a b r))
-> (r -> Status effs a b r) -> r -> Eff effs (Status effs a b r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Status effs a b r
forall (effs :: [* -> *]) a b r. r -> Status effs a b r
Done) forall v.
Yield a b v
-> Arr effs v (Status effs a b r) -> Eff effs (Status effs a b r)
forall a b c (effs :: [* -> *]) r.
Yield a b c
-> (c -> Eff effs (Status effs a b r))
-> Eff effs (Status effs a b r)
replyC