Is it possible to write a continuation effect?

[schell]

I've been trying to write a Cont effect, where a computation either ends in a value Left a or should be continued later (at your choice) Right eff. Here's my idea so far:

import           Control.Monad                 (when)
import           Control.Monad.Freer           as F
import           Control.Monad.Freer.Coroutine as F
import           Control.Monad.Freer.Exception as F
import           Control.Monad.Freer.Internal
import           Data.Function                 (fix)

newtype AnyIO a = AnyIO (IO a)

io :: Member AnyIO r => IO a -> Eff r a
io = send . AnyIO

runAnyIO :: Member IO r => Eff (AnyIO ': r) a -> Eff r a
runAnyIO = runIt $ \(AnyIO f) -> f
  where runIt :: Member IO r => (forall a. AnyIO a -> IO a)
              -> Eff (AnyIO ': r) w -> Eff r w
        runIt = runNat

data Cont r a where
  Cont :: Eff r a -> Cont r a

cont :: Member (Cont r) r => Eff r a -> Eff r a
cont = send . Cont

runCont :: Eff (Cont r ': r) a -> Eff r (Either a (Eff r a))
runCont = undefined

blah :: (Member AnyIO r, Member (Cont r) r) => Eff r ()
blah = do
  io $ putStrLn "enter something:"
  ln <- io getLine

  when ('x' `elem` ln) $ fix $ \loop -> do
    io $ putStrLn "found an x! will loop getLine until another x is found..."
    ln2 <- io getLine
    if 'x' `elem` ln2
      then io $ putStrLn "found another x, breaking."
      else cont loop

  if 'e' `elem` ln
    then do
      io $ putStrLn "found an e, recursing with Eph"
      cont blah
    else io $ putStrLn "bye!"

The above compiles, but my problem is that I seem to be running into overlapping instances when trying to write the interpreter runCont, as well as writing a concrete effect type, since the type is recursive type MyEff = Eff '[Cont MyEff, AnyIO] (this will not compile).

Thoughts?

[schell]

I didn't realize this can be done with Coroutine! Thanks :)

[trskop]

@schell, would you mind sending us an example of how you use Coroutine? We would like to enhance its documentation.

[schell]

Sure! I realized that Coroutine really is a continuation effect, but it's the kind where you can supply some intermediate value a, the a in Yield a b v, which your interpreter can then use in some "under the hood" computation in order to give back a b to supply to the rest of your suspended effect. The only bummer I see with Coroutine as it stands is that your effect's result value is discarded because Status r a b's Done constructor doesn't take a parameter.

Here is how I'm using it currently, which doesn't use any "under the hood" computation - it simply uses the suspension (I'm using it for a frame based game loop where I'd like to run some game logic, suspend, present the frame and then continue next frame):

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeOperators         #-}
module Lib
    ( someFunc
    , module F
    ) where

import           Control.Monad                 (when)
import           Control.Monad.Freer           as F
import           Control.Monad.Freer.Coroutine as F
import           Control.Monad.Freer.Exception as F
import           Control.Monad.Freer.State     as F
import           Data.Function                 (fix)

io :: Member IO r => IO a -> Eff r a
io = send

--------------------------------------------------------------------------------
-- Better Fresh
--------------------------------------------------------------------------------
-- | Fresh effect model
data Fresh v where
  Fresh :: Fresh Int

-- | Request a fresh effect
fresh :: Member Fresh r => Eff r Int
fresh = send Fresh

-- | Handler for Fresh effects, with an Int for a starting value
runFresh :: Eff (Fresh ': r) w -> Int -> Eff r (w, Int)
runFresh m s =
  handleRelayS s (\_s x -> return (x, _s))
                 (\s' Fresh k -> (k $! s'+1) s')
                 m

next :: Member (Yield () ()) r => Eff r a -> Eff r a
next eff = do
  yield () $ \() -> ()
  eff

blah :: ( Member (State String) r
        , Member Fresh r
        , Member IO r
        , Member (Yield () ()) r
        )
     => Eff r ()
blah = fix $ \loopTop -> do
  n <- fresh
  io $ putStrLn $ "enter something (" ++ show n ++ "):"
  ln <- io getLine
  put ln

  when ('x' `elem` ln) $ do
    io $ putStrLn "found an x! will loop getLine until another x is found..."
    fix $ \loop -> do
      ln2 <- io getLine
      if 'x' `elem` ln2
        then io $ putStrLn "found another x, breaking."
        else next loop

  if 'e' `elem` ln
    then do
      io $ putStrLn "found an e, recursing with Coroutine"
      next loopTop
    else do
      ln <- get
      io $ putStrLn $ ln ++ " bye!"

type MyEffectsAll = '[Yield () (), Fresh, State String, IO]
type MyEffects = '[Fresh, State String, IO]

newtype MyLoop = MyLoop (IO (Maybe MyLoop))

runRemainder
  :: String
  -> Int
  -> Eff MyEffects (Status MyEffects x x)
  -> IO (Maybe MyLoop)
runRemainder str int eff = runIt eff >>= \case
  ((Done, _), _)            -> return Nothing
  ((Continue x f, n), str2) -> return $ Just $ MyLoop $ runRemainder str2 n $ f x
  where runIt = runM . flip runState str
                     . flip runFresh int

runMyEff
  :: Eff MyEffectsAll w
  -> IO (Maybe MyLoop)
runMyEff = runRemainder "" 0 . runC

someFunc :: IO ()
someFunc = runMyEff blah >>= runLoop
  where runLoop Nothing = return ()
        runLoop (Just (MyLoop loop)) = do
          putStrLn "Got a loop"
          loop >>= runLoop

Also included in there is a slight re-implementation on Fresh because the current implementation doesn't return the result index, which makes it impossible to run a continuation effect that also has fresh effects, unless you're cool with possible fresh collisions.

I think I'll try to write a Coroutine that supplies a parameter to Done. If I can, would you welcome that PR?

[schell]

Well that turned out to be trivial so maybe I'll just make a PR for Coroutine and Fresh, respectively.

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeOperators         #-}
module Lib
    ( someFunc
    , module F
    ) where

import           Control.Monad                 (when)
import           Control.Monad.Freer           as F
import           Control.Monad.Freer.Exception as F
import           Control.Monad.Freer.Internal  (Arr, Eff, Member, handleRelay,
                                                send)
import           Control.Monad.Freer.State     as F
import           Data.Function                 (fix)
--------------------------------------------------------------------------------
-- Slightly better Coroutine, IMO
--------------------------------------------------------------------------------
-- | 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@.

-- | 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) handler
  where
    handler
        :: Yield a b c
        -> Arr effs c (Status effs a b w)
        -> Eff effs (Status effs a b w)
    handler (Yield a k) arr = return $ Continue a (arr . k)
--------------------------------------------------------------------------------
-- Everybody needs IO
--------------------------------------------------------------------------------
io :: Member IO r => IO a -> Eff r a
io = send
--------------------------------------------------------------------------------
-- Better Fresh
--------------------------------------------------------------------------------
-- | Fresh effect model
data Fresh v where
  Fresh :: Fresh Int

-- | Request a fresh effect
fresh :: Member Fresh r => Eff r Int
fresh = send Fresh

-- | Handler for Fresh effects, with an Int for a starting value
runFresh :: Eff (Fresh ': r) w -> Int -> Eff r (w, Int)
runFresh m s =
  handleRelayS s (\_s x -> return (x, _s))
                 (\s' Fresh k -> (k $! s'+1) s')
                 m

--------------------------------------------------------------------------------
-- Using the "better" Coroutine
--------------------------------------------------------------------------------
next :: Member (Yield () ()) r => Eff r a -> Eff r a
next eff = do
  yield () $ \() -> ()
  eff

newtype MyResult = MyResult String

blah :: ( Member (State String) r
        , Member Fresh r
        , Member IO r
        , Member (Yield () ()) r
        )
     => Eff r MyResult
blah = fix $ \loopTop -> do
  n <- fresh
  io $ putStrLn $ "enter something (" ++ show n ++ "):"
  ln <- io getLine
  put ln

  when ('x' `elem` ln) $ do
    io $ putStrLn "found an x! will loop getLine until another x is found..."
    fix $ \loop -> do
      ln2 <- io getLine
      if 'x' `elem` ln2
        then io $ putStrLn "found another x, breaking."
        else next loop

  if 'e' `elem` ln
    then do
      io $ putStrLn "found an e, recursing with Coroutine"
      next loopTop
    else do
      ln' <- get
      io $ putStrLn $ "Exiting and the last state was: " ++ ln'
      return $ MyResult "finished with an end result"

type MyEffectsAll = '[Yield () (), Fresh, State String, IO]
type MyEffects = '[Fresh, State String, IO]

newtype MyLoop x = MyLoop (IO (Either x (MyLoop x)))

runRemainder
  :: String
  -> Int
  -> Eff MyEffects (Status MyEffects x x w)
  -> IO (Either w (MyLoop w))
runRemainder str int eff = runIt eff >>= \case
  ((Done w, _), _)          -> return $ Left w
  ((Continue x f, n), str2) ->
    return $ Right $ MyLoop $ runRemainder str2 n $ f x
  where runIt = runM . flip runState str
                     . flip runFresh int

runMyEff
  :: Eff MyEffectsAll w
  -> IO (Either w (MyLoop w))
runMyEff = runRemainder "" 0 . runC

someFunc :: IO ()
someFunc = runMyEff blah >>= runLoop >>= \(MyResult str) -> do
  putStrLn str
  where runLoop = either return $ \(MyLoop loop) -> do
          putStrLn "Got a loop"
          loop >>= runLoop

[schell]

Also - have you guys taken over the freer hackage listing?

[liskin]

Someone (possible even me) will answer the rest later, but regarding freer hackage listing, see https://github.com/fpco/stackage/pull/2239#issuecomment-275864214. tl;dr we have not and we will release to hackage as freer-effects-0.3.0.0 soon.

[trskop]

@schell, if you're interested then we would welcome advancement in any direction. My suggestion was to remove Coroutine and Fresh for 0.3 release, and reintroduce them only when we have correct implementations available. IMHO, current state of these effects is not suitable for real use.