Monad变换器用于进度跟踪

Question

我正在寻找一个可以用来跟踪过程进度的单子变换器。为了说明它将如何使用，请考虑以下代码：

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必须明确存在，因为要遵守单子律，并且task必须有一个显式的步骤编号参数，因为程序确定性/停机问题。

上述单子可以通过以下两种方式之一实现：

1. 通过一个函数返回当前任务名称/步骤索引堆栈和在离开点处过程的继续。重复调用此函数会完成过程的执行。
2. 通过一个函数采取描述完成任务步骤后要执行的操作。该过程将不受控制地运行直到完成，通过提供的操作“通知”环境中的更改。

对于解决方案（1），我看了看带有Yield暂停函子的Control.Monad.Coroutine。对于解决方案（2），我不知道是否有任何已经可用的单子变换器会有用。

我正在寻找的解决方案不应具有太多的性能开销，并允许尽可能多的控制过程（例如，不需要IO访问或其他什么东西）。

这些解决方案中是否有一个可行的解决方案，或者已经有其他解决此问题的解决方案了吗？是否有单子变换器已经解决了我无法找到的问题？

编辑：目标不是检查是否已执行所有步骤。目标是能够在运行时“监视”过程，以便可以告诉完成了多少。

- dflemstr

---

你提到了continuations...也许我错过了一些显而易见的东西，但我想知道你是否可以只使用continuation monad transformer ContT。 - mergeconflict

除非你使用类型String -> ProgressT IO ()重新实现了putStr和putStrLn，否则你需要将它们提升。使用liftIO来完成这个任务。 - Thomas Eding

生成和显示进度信息是一个发布/订阅系统。如何在底层实现将取决于主线程还是特殊的其他线程或许多其他线程是否会对进度状态进行操作。 - Chris Kuklewicz

你的进度区域很微妙。除非使用“forall s. (ST s)”技巧，否则这些区域不会是类型安全的。尝试查看http://hackage.haskell.org/packages/archive/pkg-list.html#cat:monadic%20regions下的单子区域库以获得实现思路。 - Chris Kuklewicz

@ChrisKuklewicz，我不明白在这种情况下泄漏单子值会有什么危害？ - dflemstr

（2）听起来像是Chan和/或他的朋友们的工作。 - Dan Burton

Answer 1

这是我对这个问题的悲观解决方案。它使用协程在每一步上暂停计算，使用户能够执行任意计算以报告一些进展。 编辑: 这个解决方案的完整实现可以在这里找到。 这个解决方案可以改进吗？ 首先，看一下它的用法：

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

- dflemstr

Answer 2

最明显的方法是使用StateT。

import Control.Monad.State

type ProgressT m a = StateT Int m a

step :: Monad m => ProgressT m ()
step = modify (subtract 1)

我不确定您想要“任务”（task）的语义是什么，但是...

编辑以展示如何使用IO完成此操作。

step :: (Monad m, MonadIO m) => ProgressT m ()
step = do
  modify (subtract 1)
  s <- get
  liftIO $ putStrLn $ "steps remaining: " ++ show s

请注意，您需要MonadIO约束条件才能打印状态。如果您需要使用不同的效果来处理状态（例如，如果步骤数低于零，则抛出异常等），则可以使用不同类型的约束条件。

- sclv

---

这并不实用，因为只有在过程完成后才能访问状态，这根本无法跟踪进度。 - dflemstr

如果我有 procedure :: StateT Int IO (); procedure = forever step，我该如何运行 procedure，以便每次调用 step 时它都会打印当前步骤值？这在 State monad 中是不可能的。 - dflemstr

@dflemstr：使用StateT_IO monad是可以实现的。可以编写“step”来同时更改状态和执行任意IO，例如打印当前步骤。 - Chris Kuklewicz

@ChrisKuklewicz，但这会强制要求过程和“进度报告操作”在同一个单子中，这意味着失去了很多控制。例如，如果我想监视替换长文本中的单词的过程（例如），我不希望该过程处于IO单子中，仅仅因为进度报告操作需要IO。 - dflemstr

@dflemstr：那么你就无法获胜（没有unsafePerformIO）。纯计算无法与监控进程通信。另一方面，考虑强制评估纯质数列表并定期打印您的进度。 - Chris Kuklewicz

@ChrisKuklewicz 我能赢！看看这个解决方案。 - dflemstr

Answer 3

不确定这是否正是您想要的，但这里有一个实现，强制执行正确数量的步骤，并要求最后没有剩余步骤。为简单起见，我使用了一个单子而不是在IO上使用单子变换器。请注意，我没有使用Prelude单子来做我正在做的事情。

更新：

现在可以提取剩余步骤的数量。使用-XRebindableSyntax运行以下内容

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}

module Test where

import Prelude hiding (Monad(..))
import qualified Prelude as Old (Monad(..))

-----------------------------------------------------------

data Z = Z
data S n = S

type Zero = Z
type One = S Zero
type Two = S One
type Three = S Two
type Four = S Three

-----------------------------------------------------------

class Peano n where
  peano :: n
  fromPeano :: n -> Integer

instance Peano Z where
  peano = Z
  fromPeano Z = 0

instance Peano (S Z) where
  peano = S
  fromPeano S = 1

instance Peano (S n) => Peano (S (S n)) where
  peano = S
  fromPeano s = n `seq` (n + 1)
    where
      prev :: S (S n) -> (S n)
      prev S = S
      n = fromPeano $ prev s

-----------------------------------------------------------

class (Peano s, Peano p) => Succ s p | s -> p where
instance Succ (S Z) Z where
instance Succ (S n) n => Succ (S (S n)) (S n) where

-----------------------------------------------------------

infixl 1 >>=, >>

class ParameterisedMonad m where
  return :: a -> m s s a
  (>>=) :: m s1 s2 t -> (t -> m s2 s3 a) -> m s1 s3 a
  fail :: String -> m s1 s2 a
  fail = error

(>>) :: ParameterisedMonad m => m s1 s2 t -> m s2 s3 a -> m s1 s3 a
x >> f = x >>= \_ -> f

-----------------------------------------------------------

newtype PIO p q a = PIO { runPIO :: IO a }

instance ParameterisedMonad PIO where
  return = PIO . Old.return
  PIO io >>= f = PIO $ (Old.>>=) io $ runPIO . f

-----------------------------------------------------------

data Progress p n a = Progress a

instance ParameterisedMonad Progress where
  return = Progress
  Progress x >>= f = let Progress y = f x in Progress y

runProgress :: Peano n => n -> Progress n Zero a -> a
runProgress _ (Progress x) = x

runProgress' :: Progress p Zero a -> a
runProgress' (Progress x) = x

task :: Peano n => n -> Progress n n ()
task _ = return ()

task' :: Peano n => Progress n n ()
task' = task peano

step :: Succ s n => Progress s n ()
step = Progress ()

stepsLeft :: Peano s2 => Progress s1 s2 a -> (a -> Integer -> Progress s2 s3 b) -> Progress s1 s3 b
stepsLeft prog f = prog >>= flip f (fromPeano $ getPeano prog)
  where
    getPeano :: Peano n => Progress s n a -> n
    getPeano prog = peano

procedure1 :: Progress Three Zero String
procedure1 = do
  task'
  step
  task (peano :: Two) -- any other Peano is a type error
  --step -- uncommenting this is a type error
  step -- commenting this is a type error
  step
  return "hello"

procedure2 :: (Succ two one, Succ one zero) => Progress two zero Integer
procedure2 = do
  task'
  step `stepsLeft` \_ n -> do
    step
    return n

main :: IO ()
main = runPIO $ do
  PIO $ putStrLn $ runProgress' procedure1
  PIO $ print $ runProgress (peano :: Four) $ do
    n <- procedure2
    n' <- procedure2
    return (n, n')

- Thomas Eding

---

这是一个非常好的解决方案，但它解决的是不同的问题。请查看我在原始问题中的编辑。 - dflemstr

这仍然解决了一个不同的问题。在任何情况下，静态地见证进度步骤并不重要。而使用 procedure x = task "foo" x . forM_ [1..x] $ const step 将变得不可能。这个解决方案可以解决问题，但可能不是最理想的。 - dflemstr

啊，我明白了。不过我会让其他人来处理它。 - Thomas Eding