Request Monad Transformer, allows suspending any monadic computation

RequestMonad.hs

{-# LANGUAGE ExistentialQuantification, DeriveFunctor, StandaloneDeriving, TupleSections #-}
module Request where

import Data.Maybe (fromMaybe)

import Control.Monad (ap, liftM)
import Control.Monad.Trans.Class (MonadTrans, lift)

import Control.Applicative (Alternative(..))

-- | The Suspension functor
data Suspension m c = forall a. Suspension (m a) (a -> Maybe c)
deriving instance Functor (Suspension m)

-- | Request
data Request m a = Done a | Await (Suspension m (Request m a))
deriving instance Functor (Request m)

instance Monad m => Applicative (Request m) where
  pure = Done
  (<*>) = ap

instance Monad m => Monad (Request m) where
  Done a >>= f = f a
  (Await (Suspension m f)) >>= g = Await (Suspension m (fmap (>>= g) . f))

-- Lift an underlying monad into Request
instance MonadTrans Request where
  lift m = Await $ Suspension m (Just . Done)

-- You can also choose to simply complete a Request down to its underlying monad
complete :: Monad m => Request m a -> m a
complete (Done a) = return a
complete r@(Await (Suspension m f)) = m >>= complete . fromMaybe r . f

-- A Request that will never be satisfied
ignore :: m a -> Request m b
ignore m = Await (Suspension m (const Nothing))

-- Examples
-- Two layers
example1 :: Request IO Int
example1 = do
  l1 <- lift getLine
  l2 <- lift getLine
  return (length l1 + length l2)

-- One layer
example2 :: Request IO Int
example2 = do
  (l1,l2) <- lift $ do
    l1 <- getLine
    l2 <- getLine
    return (l1,l2)
  return (length l1 + length l2)

-- How is (Request IO Int) better than (IO Int)?
-- 1. We can peel it one layer at a time
peel :: Applicative m => Request m a -> m (Request m a)
peel r@(Await (Suspension m f)) = (fromMaybe r . f) <$> m
peel r = pure r

-- 2. Which allows us to define fancy new operations such as interleaving monadic ops with controlled granularity
instance (Monad m, Alternative m) => Alternative (Request m) where
  empty = ignore empty
  Done a <|> _ = Done a
  _ <|> Done b = Done b
  (Await (Suspension m1 f1)) <|> (Await (Suspension m2 f2)) = Await (Suspension (liftM Left m1 <|> liftM Right m2) f)
    where
      -- Once any one request has been initiated, the other request will be abandoned
      -- That's because <|> doesn't return the remaining request
      f (Left a) = f1 a
      f (Right b) = f2 b