Future monad

Future.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

data FutureM i o a
  = Await (i -> FutureM i o a)
  | Yield o (FutureM i o a)
  | Done a

instance Functor (FutureM i o) where
  fmap f (Await g)   = Await (fmap f . g)
  fmap f (Yield o m) = Yield o (fmap f m)
  fmap f (Done a)    = Done (f a)

instance Applicative (FutureM i o) where
  pure             = Done
  Await g   <*> fa = Await (\i -> g i <*> fa)
  Yield o m <*> fa = Yield o (m <*> fa)
  Done f    <*> fa = f <$> fa

instance Monad (FutureM i o) where
  Await g   >>= k = Await (\i -> g i >>= k)
  Yield o m >>= k = Yield o (m >>= k)
  Done a    >>= k = k a

class Monad (m i o) => Future m i o where
  await :: m i o i
  yield :: o -> m i o ()

instance Future FutureM i o where
  await   = Await pure
  yield o = Yield o (pure ())

runFutureM :: FutureM i o a -> [i] -> (a, [o])
-- BUG: Non-total pattern match.
runFutureM (Await g)   (i:ins) = runFutureM (g i) ins
runFutureM (Yield o m) ins     = (o:) <$> runFutureM m ins
runFutureM (Done a)    _       = (a, [])

FutureTotal.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

data FutureM i o a
  = Await (Maybe i -> FutureM i o a)
  | Yield o (FutureM i o a)
  | Done a

instance Functor (FutureM i o) where
  fmap f (Await g)   = Await (fmap f . g)
  fmap f (Yield o m) = Yield o (fmap f m)
  fmap f (Done a)    = Done (f a)

instance Applicative (FutureM i o) where
  pure             = Done
  Await g   <*> fa = Await (\i -> g i <*> fa)
  Yield o m <*> fa = Yield o (m <*> fa)
  Done f    <*> fa = f <$> fa

instance Monad (FutureM i o) where
  Await g   >>= k = Await (\i -> g i >>= k)
  Yield o m >>= k = Yield o (m >>= k)
  Done a    >>= k = k a

class Monad (m i o) => Future m i o where
  await :: m i o (Maybe i)
  yield :: o -> m i o ()

instance Future FutureM i o where
  await   = Await pure
  yield o = Yield o (pure ())

runFutureM :: FutureM i o a -> [i] -> (a, [o])
runFutureM (Await g)   []      = runFutureM (g Nothing) []
runFutureM (Await g)   (i:ins) = runFutureM (g $ Just i) ins
runFutureM (Yield o m) ins     = (o:) <$> runFutureM m ins
runFutureM (Done a)    _       = (a, [])