[英]Monad transformer for progress tracking
我正在尋找一個可用於跟蹤程序進度的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),我使用Yield
懸掛仿函數查看了Control.Monad.Coroutine
。 對於解決方案(2),我不知道任何已經可用的monad變換器是有用的。
我正在尋找的解決方案不應該有太多的性能開銷,並盡可能多地控制過程(例如,不需要IO訪問或其他東西)。
這些解決方案中的一個聽起來是否可行,或者已經在某個地方解決了這個問題? 這個問題是否已經用我無法找到的monad變壓器解決了?
編輯:目標不是檢查是否已執行所有步驟。 目標是能夠在流程運行時“監控”流程,以便可以知道流程已經完成了多少。
這是我對這個問題的悲觀解決方案。 它使用Coroutine
來暫停每一步的計算,這使用戶可以執行任意計算來報告一些進度。
編輯:可以在此處找到此解決方案的完整實現。
這個解決方案可以改進嗎?
首先,它是如何使用的:
-- 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
最明顯的方法是使用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
約束來打印狀態。 如果需要與狀態有不同的效果,則可以使用不同類型的約束(例如,如果步數低於零,則拋出異常,或者其他)。
不確定這是否正是您想要的,但這是一個強制執行正確步驟數的實現,並要求在最后留下零步。 為簡單起見,我使用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')
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.