我正在寻找可用于跟踪程序进度的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 ()
我意识到由于monadic定律，step必须明确存在，并且由于程序确定性/暂停问题，task必须有明确的步数参数。
如上所述，如上所述的monad可以通过以下两种方式之一实现：
对于解决方案（1），我使用Control.Monad.Coroutine暂停仿函数查看了Yield。对于解决方案（2），我不知道任何已有的monad变换器是否有用。
我正在寻找的解决方案不应该有太多的性能开销，并且尽可能多地控制过程（例如，不需要IO访问或其他东西）。
这些解决方案中的一个听起来是否可行，或者已经在某个地方解决了这个问题？这个问题是否已经用我无法找到的monad变压器解决了？
编辑：目标不是检查是否已执行所有步骤。目标是能够在流程运行时“监控”流程，以便人们知道流程已经完成了多少。
答案 0 :(得分：4)
这是我对这个问题的悲观解决方案。它使用Coroutine来暂停每一步的计算，这使用户可以执行任意计算来报告某些进度。
编辑：可以找到此解决方案的完整实施here。
可以改进此解决方案吗？
首先，如何使用它：
-- 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)]
实际实施（请参阅this注释版本）：
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
答案 1 :(得分：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约束来打印状态。如果您需要对状态产生不同的影响，则可以使用不同类型的约束（例如，如果步数低于零，则抛出异常，或者其他）。
答案 2 :(得分：1)
不确定这是否正是您想要的，但这是一个强制执行正确步骤数的实现，并要求在最后留下零步骤。为简单起见，我使用monad而不是IO上的monad转换器。请注意，我没有使用Prelude monad来做我正在做的事情。
<强>更新：
现在可以提取剩余步骤的数量。使用-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')