Monad transformer for progress tracking

Question

I am looking for a monad transformer that can be used to track the progress of a procedure. To explain how it would be used, consider the following code:

procedure :: ProgressT IO ()
procedure = task "Print some lines" 3 $ do
  liftIO $ putStrLn "line1"
  step
  task "Print a complicated line" 2 $ do
    liftIO $ putStr "li"
    step
    liftIO $ putStrLn "ne2"
  step
  liftIO $ putStrLn "line3"

-- Wraps an action in a task
task :: Monad m
     => String        -- Name of task
     -> Int           -- Number of steps to complete task
     -> ProgressT m a -- Action performing the task
     -> ProgressT m a

-- Marks one step of the current task as completed
step :: Monad m => ProgressT m ()

I realize that step has to exist explicitly because of the monadic laws, and that task has to have an explicit step number parameter because of program determinism/the halting problem.

The monad as described above could, as I see it, be implemented in one of two ways:

1. Via a function that would return the current task name/step index stack, and a continuation in the procedure at the point that it left off. Calling this function repeatedly on the returned continuation would complete the execution of the procedure.
2. Via a function that took an action describing what to do when a task step has been completed. The procedure would run uncontrollably until it completed, "notifying" the environment about changes via the provided action.

For solution (1), I have looked at Control.Monad.Coroutine with the Yield suspension functor. For solution (2), I don't know of any already available monad transformers that would be useful.

The solution I'm looking for should not have too much performance overhead and allow as much control over the procedure as possible (e.g. not require IO access or something).

Do one of these solutions sound viable, or are there other solutions to this problem somewhere already? Has this problem already been solved with a monad transformer that I've been unable to find?

EDIT: The goal isn't to check whether all the steps have been performed. The goal is to be able to "monitor" the process while it is running, so that one can tell how much of it has been completed.

Answer 1

This is my pessimistic solution to this problem. It uses Coroutines to suspend the computation on each step, which lets the user perform an arbitrary computation to report some progress.

EDIT: The full implementation of this solution can be found here.

Can this solution be improved?

First, how it is used:

-- The procedure that we want to run.
procedure :: ProgressT IO ()
procedure = task "Print some lines" 3 $ do
  liftIO $ putStrLn "--> line 1"
  step
  task "Print a set of lines" 2 $ do
    liftIO $ putStrLn "--> line 2.1"
    step
    liftIO $ putStrLn "--> line 2.2"
  step
  liftIO $ putStrLn "--> line 3"

main :: IO ()
main = runConsole procedure

-- A "progress reporter" that simply prints the task stack on each step
-- Note that the monad used for reporting, and the monad used in the procedure,
-- can be different.
runConsole :: ProgressT IO a -> IO a
runConsole proc = do
  result <- runProgress proc
  case result of
    -- We stopped at a step:
    Left (cont, stack) -> do
      print stack     -- Print the stack
      runConsole cont -- Continue the procedure
    -- We are done with the computation:
    Right a -> return a

The above program outputs:

--> line 1
[Print some lines (1/3)]
--> line 2.1
[Print a set of lines (1/2),Print some lines (1/3)]
--> line 2.2
[Print a set of lines (2/2),Print some lines (1/3)]
[Print some lines (2/3)]
--> line 3
[Print some lines (3/3)]

The actual implementation (See this for a commented version):

type Progress l = ProgressT l Identity

runProgress :: Progress l a
               -> Either (Progress l a, TaskStack l) a
runProgress = runIdentity . runProgressT

newtype ProgressT l m a =
  ProgressT
  {
    procedure ::
       Coroutine
       (Yield (TaskStack l))
       (StateT (TaskStack l) m) a
  }

instance MonadTrans (ProgressT l) where
  lift = ProgressT . lift . lift

instance Monad m => Monad (ProgressT l m) where
  return = ProgressT . return
  p >>= f = ProgressT (procedure p >>= procedure . f)

instance MonadIO m => MonadIO (ProgressT l m) where
  liftIO = lift . liftIO

runProgressT :: Monad m
                => ProgressT l m a
                -> m (Either (ProgressT l m a, TaskStack l) a)
runProgressT action = do
  result <- evalStateT (resume . procedure $ action) []
  return $ case result of
    Left (Yield stack cont) -> Left (ProgressT cont, stack)
    Right a -> Right a

type TaskStack l = [Task l]

data Task l =
  Task
  { taskLabel :: l
  , taskTotalSteps :: Word
  , taskStep :: Word
  } deriving (Show, Eq)

task :: Monad m
        => l
        -> Word
        -> ProgressT l m a
        -> ProgressT l m a
task label steps action = ProgressT $ do
  -- Add the task to the task stack
  lift . modify $ pushTask newTask

  -- Perform the procedure for the task
  result <- procedure action

  -- Insert an implicit step at the end of the task
  procedure step

  -- The task is completed, and is removed
  lift . modify $ popTask

  return result
  where
    newTask = Task label steps 0
    pushTask = (:)
    popTask = tail

step :: Monad m => ProgressT l m ()
step = ProgressT $ do
  (current : tasks) <- lift get
  let currentStep = taskStep current
      nextStep = currentStep + 1
      updatedTask = current { taskStep = nextStep }
      updatedTasks = updatedTask : tasks
  when (currentStep > taskTotalSteps current) $
    fail "The task has already completed"
  yield updatedTasks
  lift . put $ updatedTasks