PauseT monad transformer, using operational monad

{-# LANGUAGE GADTs, RankNTypes #-}

-- | Example of using the operational monad to pause computations of
-- any other monad.
module PauseT where

import Control.Monad ((<=<), liftM)
import Control.Monad.Trans (lift)
import Control.Monad.Operational
import Control.Concurrent (threadDelay)

-- | 'PauseT' is the language of monadic programs that can pause
-- themselves--return prematurely to their callers, who have the
-- option of resuming them where they paused.
--
-- 'PauseT' is a monad transformer, which means that we can \"stack\"
-- it on top of any monad.  So what it does is it adds the pause
-- feature to a smaller language (the @m@ type variable).
type PauseT m a = ProgramT PauseInstruction m a

-- | The 'PauseT' language has only one primitive instruction, that
-- produces no useful intermediate value.
--
-- If just one instruction sounds useless, remember that 'PauseT' is a
-- monad transformer, so in practice this will work as an *add-on* to
-- another language.
data PauseInstruction a where
    Pause :: PauseInstruction ()

-- | Convenience wrapper around 'Pause' to encapsulate the fact that
-- it's a primitive instruction.
pause = singleton Pause

-- | This function is the interepreter for 'PauseT' programs.
runPauseT :: Monad m => PauseT m a -> m (Either (PauseT m a) a)
runPauseT = eval <=< viewT
    where
      -- Intepreting a program breaks into two subcases.  The first
      -- one is the 'Return' case, where we specify how to handle a
      -- program that has completed.
      eval (Return a) = return (Right a)
      -- The second subcase is @instruction :>>= continuation@; here
      -- we specify how to interpret each instruction of the language.
      -- The continuation is represented as a function that takes a
      -- result of the same type as the instruction's result type, and
      -- returns the rest of the program.  In this case, the only
      -- primitive instruction is 'Pause', and what we do is package
      -- up the continuation into a 'Left' constructor for 'Either'.
      eval (Pause :>>= k) = return (Left (k ()))

-- | A driver function to step through a 'PauseT' program.  The first
-- argument, the stepper, is an action that can execute actions of its
-- own choice, but must at some point execute the rest of the 'PauseT'
-- program.
step :: Monad m => (forall a. m a -> m a) -> PauseT m a -> m a
step stepper pausable =
    do result <- runPauseT pausable
       case result of
         Left continuation -> stepper (step stepper continuation)
         Right result -> return result

-- | We're going to use this helper function with 'step' in the examples.
pressReturn :: IO ()
pressReturn = do putStr "Press <return> to continue..."
                 getLine
                 return ()

-- | Example PauseT program.
example :: PauseT IO ()
example = do lift $ putStrLn "Goodbye"
             pause
             lift $ putStrLn "Cruel"
             pause
             lift $ putStrLn "World!"

-- Now, using 'step' and different steppers.  The first one just
-- ignores the pauses:
--
-- @
-- *Main> step id example
-- Goodbye
-- Cruel
-- World!
-- @
--
-- The second one prompts us to press return at each pause, then
-- continues the program:
--
-- @
-- *Main> step (pressReturn>>) example
-- Goodbye
-- Press <return> to continue...
-- Cruel
-- Press <return> to continue...
-- World!
-- @
--
-- The third and final one pauses 1.5 seconds at each 'pause':
--
-- @
-- *Main> step (threadDelay 1500000>>) example
-- Goodbye
--   (pause 1.5s)
-- Cruel
--   (pause 1.5s)
-- World!
-- @