Monad transformer для отслеживания прогресса

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), я рассмотрел Control.Monad.Coroutine с функцией подвески Yield. Для решения (2) я не знаю никаких уже доступных монадных трансформаторов, которые были бы полезны.

Решение, которое я ищу, не должно иметь слишком больших служебных затрат и позволяет как можно больше контролировать процедуру (например, не требует доступа к IO или чего-то еще).

Сделайте одно из этих решений жизнеспособным, или есть другие решения этой проблемы где-то уже? Эта проблема уже решена с помощью трансформатора монады, которого я не смог найти?

EDIT: Цель состоит не в том, чтобы проверить, выполнены ли все этапы. Цель состоит в том, чтобы иметь возможность «контролировать» процесс во время его работы, чтобы можно было узнать, сколько из них было выполнено.

Answer 1

Это мое пессимистическое решение этой проблемы. Он использует Coroutine s для приостановки вычисления на каждом шаге, который позволяет пользователю выполнить произвольное вычисление, чтобы сообщить о некотором прогрессе.

EDIT: Полная реализация этого решения может быть найдена 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 

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. У вас может быть другое ограничение, если вам нужно другое действие с состоянием (т. Е. Исключение, если количество шагов меньше нуля или что-то еще).

Answer 3

Не уверен, что это именно то, что вы хотите, но вот реализация, которая обеспечивает правильное количество шагов и требует, чтобы в конце были нулевые шаги. Для простоты я использую монаду вместо монадного трансформатора над IO. Заметьте, что я не использую монаду Прелюдии, чтобы делать то, что я делаю.

UPDATE:

Теперь можно извлечь количество оставшихся шагов. Запустите следующее: -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')