Transformador de mónada para seguimiento de progreso

Question

Estoy buscando un transformador de mónada que se pueda usar para rastrear el progreso de un procedimiento. Para explicar la forma en que se utilizaría, considere el siguiente código:

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

que darse cuenta de que step tiene que existir explícitamente debido a las leyes monádicos, y que task tiene que tener un parámetro explícito número de paso a causa de determinismo programa/el problema de detenerse

La mónada como se describió anteriormente podría, tal como lo veo, ser implementado en una de dos maneras:

1. través de una función que devuelva la pila índice de nombre de la tarea/paso actual, y una continuación en el procedimiento en el punto que lo dejó. Llamar a esta función repetidamente en la continuación devuelta completaría la ejecución del procedimiento.
2. Mediante una función que realizó una acción que describe qué hacer cuando se completa un paso de la tarea. El procedimiento se ejecutaría incontrolablemente hasta que se completara, "notificando" al entorno sobre los cambios a través de la acción proporcionada.

Para la solución (1), he examinado Control.Monad.Coroutine con el Yield functor de suspensión. Para la solución (2), no conozco ningún transformador de mónada ya disponible que pueda ser útil.

La solución que estoy buscando no debe tener demasiada sobrecarga de rendimiento y permitir tanto control sobre el procedimiento como sea posible (por ejemplo, no requiere acceso a IO o algo así).

¿Alguna de estas soluciones parece viable o hay otras soluciones a este problema en alguna parte? ¿Este problema ya se ha resuelto con un transformador de mónada que no he podido encontrar?

EDITAR: El objetivo no es comprobar si se han realizado todos los pasos. El objetivo es poder "monitorear" el proceso mientras se está ejecutando, para que uno pueda decir cuánto se ha completado.

Answer 1

Esta es mi solución pesimista a este problema. Utiliza Coroutine para suspender el cálculo en cada paso, lo que permite al usuario realizar un cálculo arbitrario para informar algún progreso.

EDIT: La implementación completa de esta solución se puede encontrar here.

¿Se puede mejorar esta solución?

En primer lugar, cómo se utiliza:

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

Los anteriores resultados de los programas:

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

la implementación real (Ver this para una versión comentado):

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

La forma más obvia de hacerlo es con StateT.

import Control.Monad.State 

type ProgressT m a = StateT Int m a 

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

no estoy seguro de lo que quiere la semántica de task a ser, sin embargo ...

de edición para mostrar cómo se haría esto con IO

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

Tenga en cuenta que necesitará la restricción MonadIO para imprimir el estado. Puede tener un tipo de restricción diferente si necesita un efecto diferente con el estado (es decir, lanzar una excepción si el número de pasos es inferior a cero, o lo que sea).

Answer 3

No estoy seguro de si esto es exactamente lo que quiere, pero aquí hay una implementación que impone el número correcto de pasos y requiere que haya cero pasos al final. Para simplificar, estoy usando una mónada en lugar de un transformador de mónada sobre IO. Tenga en cuenta que no estoy usando la mónada Preludio para hacer lo que estoy haciendo.

ACTUALIZACIÓN:

Ahora puede extraer el número de pasos restantes. Ejecute lo siguiente con -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')