Better coroutine

src/Control/Monad/Freer/Coroutine.hs

@@ -9,25 +9,31 @@
 -- Copyright:    (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.
 -- License:      BSD3
 -- Maintainer:   ixcom-core@ixperta.com
--- Stability:    broken
+-- 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(..)
+    (
+    -- * Yield Control
+      Yield(..)
     , yield
+
+    -- * Handle Yield Effect
     , Status(..)
     , runC
+    , interposeC
+    , replyC
     )
   where
 
-import Control.Monad (return)
+import Control.Applicative (pure)
 import Data.Function (($), (.))
 import Data.Functor (Functor)
 
-import Control.Monad.Freer.Internal (Arr, Eff, Member, handleRelay, send)
+import Control.Monad.Freer.Internal (Eff, Member, handleRelay, interpose, send)
 
 
 -- | A type representing a yielding of control.
@@ -50,19 +56,28 @@ yield :: Member (Yield a b) effs => a -> (b -> c) -> Eff effs c
 yield x f = send (Yield x f)
 
 -- | Represents status of a coroutine.
-data Status effs a b
-    = Done
-    -- ^ Coroutine is done.
-    | Continue a (b -> Eff effs (Status effs a b))
+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@.
+    -- @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 k) arr = pure $ Continue a (arr . k)
 
 -- | Launch a coroutine and report its status.
-runC :: Eff (Yield a b ': effs) w -> Eff effs (Status effs a b)
-runC = handleRelay (\_ -> return Done) handler
-  where
-    handler
-        :: Yield a b c
-        -> Arr effs c (Status effs a b)
-        -> Eff effs (Status effs a b)
-    handler (Yield a k) arr = return $ Continue a (arr . k)
+runC :: Eff (Yield a b ': effs) r -> Eff effs (Status effs a b r)
+runC = handleRelay (pure . Done) 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 = interpose (pure . Done) replyC

tests/Tests/Coroutine.hs

@@ -55,6 +55,6 @@ runTestCoroutine list = snd . run $ runState effTestCoroutine 0
 
     effTestCoroutine = runC testCoroutine >>= handleStatus list
       where
-        handleStatus _      Done            = pure ()
+        handleStatus _      (Done ())       = pure ()
         handleStatus (i:is) (Continue () k) = k i >>= handleStatus is
         handleStatus []     _               = pure ()