better freer coroutiner

bettercoroutine.hs

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeOperators         #-}
module Odin.Engine.Eff.Coroutine
  ( Yield
  , yield
  , Status (..)
  , runC
  , Next
  , next
  , raceEither
  ) where

import           Control.Monad.Freer.Internal

-- | 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 (Functor)

-- | Lifts a value and a function into the Coroutine effect.
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 x
    = Done x
    -- ^ Coroutine is done.
    | Continue a (b -> Eff effs (Status effs a b x))
    -- ^ Reporting a value of the type @a@, and resuming with the value of type
    -- @b@.

replyC
  :: Yield a b c
  -> Arr r c (Status r a b w)
  -> Eff r (Status r a b w)
replyC (Yield a k) arr = return $ Continue a (arr . k)

-- | Launch a coroutine and report its status.
runC :: Eff (Yield a b ': effs) w -> Eff effs (Status effs a b w)
runC = handleRelay (return . Done) replyC

runC' :: Member (Yield a b) r => Eff r w -> Eff r (Status r a b w)
runC' = interpose (return . Done) replyC

type Next = Yield () ()

-- | Pause a coroutine effect to be picked up later. This is useful for control
-- flow.
next :: Member Next r => Eff r a -> Eff r a
next eff = do
  yield () $ \() -> ()
  eff

withEither'
  :: Member Next r
  => Status r () () a
  -> Status r () () b
  -> Eff r (Either a b)
withEither' (Done a) _                        = return $ Left a
withEither' _        (Done b)                 = return $ Right b
withEither' (Continue () fa) (Continue () fb) = next $ do
  statusA <- fa ()
  statusB <- fb ()
  next $ withEither' statusA statusB

-- | Race two coroutine effects and return the result of the effect that finishes
-- first.
raceEither
  :: Member Next r => Eff r a -> Eff r b -> Eff r (Either a b)
raceEither effa effb = do
  statusA <- runC' effa
  statusB <- runC' effb
  withEither' statusA statusB