Monad变压器用于进度跟踪

Question

我正在寻找一个可用于跟踪程序进度的monad变换器.要解释如何使用它,请考虑以下代码:

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 ()

我意识到step由于monadic定律task必须明确存在,并且由于程序确定性/停止问题,必须有明确的步数参数.

如我所见,上面描述的monad可以通过以下两种方式之一实现:

1. 通过一个函数返回当前任务名称/步骤索引堆栈,并在程序中从它停止的位置继续.在返回的continuation上重复调用此函数将完成该过程的执行.
2. 通过一个函数,该函数描述了在任务步骤完成时要执行的操作.该过程将无法控制地运行,直到它完成,通过提供的操作"通知"环境有关更改.

对于溶液(1),我已经看过Control.Monad.Coroutine与Yield悬浮液仿函数.对于解决方案(2),我不知道任何已经可用的monad变换器是有用的.

我正在寻找的解决方案不应该有太多的性能开销,并尽可能多地控制过程(例如,不需要IO访问或其他东西).

这些解决方案中的一个听起来是否可行,或者已经在某个地方解决了这个问题？这个问题是否已经用我无法找到的monad变压器解决了？

编辑:目标不是检查是否已执行所有步骤.目标是能够在流程运行时"监控"流程,以便人们知道流程已经完成了多少.

Answer 1

这是我对这个问题的悲观解决方案。它使用Coroutines 暂停每个步骤的计算，这使用户可以执行任意计算来报告某些进度。

编辑：可以在此处找到此解决方案的完整实现。

这个解决方案可以改进吗？

一、如何使用：

-- 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

上述程序输出：

--> 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)]

实际实现（请参阅此评论版本）：

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