Я ищу монаду-трансформер, которая может быть использована для отслеживания хода выполнения процедуры. Чтобы объяснить, как его можно использовать, рассмотрим следующий код:
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) я рассмотрел Control.Monad.Coroutine
с функтором приостановки Yield
. Для решения (2) я не знаю никаких уже имеющихся трансформаторов монад, которые были бы полезны.
Решение, которое я ищу, не должно иметь слишком больших накладных расходов на производительность и позволять как можно больше контроля над процедурой (например, не требовать доступа к IO или что-то в этом роде).
Звучит ли одно из этих решений жизнеспособным, или где-то уже есть другие решения этой проблемы? Была ли эта проблема уже решена с помощью трансформатора монад, который я не смог найти?
EDIT: Цель не в том, чтобы проверить, все ли шаги были выполнены. Цель состоит в том, чтобы иметь возможность "следить" за процессом во время его выполнения, чтобы можно было сказать, какая его часть была завершена.
Это мое пессимистическое решение этой проблемы. Он использует 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
Не уверен, что это именно то, что вам нужно, но вот реализация, которая обеспечивает правильное количество шагов и требует, чтобы в конце оставалось ноль шагов. Для простоты я использую монаду вместо монадного трансформатора через 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')