Pregunta Transformador Monad para el seguimiento del progreso


Estoy buscando un transformador de mónada que se pueda usar para rastrear el progreso de un procedimiento. Para explicar cómo se usarí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 ()

me di cuenta que step tiene que existir explícitamente debido a las leyes monádicas, y que task tiene que tener un parámetro de número de paso explícito debido al determinismo del programa / el problema de detención.

La mónada como se describe arriba podría, según lo veo, implementarse de una de dos maneras:

  1. A través de una función que devolvería el nombre de la tarea actual / pila de índice de pasos, y una continuación en el procedimiento en el punto que dejó. Llamar a esta función repetidamente en la continuación devuelta completaría la ejecución del procedimiento.
  2. A través de una función que tomó una acción que describe qué hacer cuando se ha completado un paso de la tarea. El procedimiento se ejecutará sin control hasta que se complete, "notificando" al entorno sobre los cambios a través de la acción proporcionada.

Para la solución (1), he visto Control.Monad.Coroutine con el Yield functor de suspensión. Para la solución (2), no sé de ningún transformador de mónada ya disponible que sea útil.

La solución que estoy buscando no debería tener demasiados gastos generales y permitir el mayor control posible sobre el procedimiento (por ejemplo, no requiere acceso IO o algo así).

¿Alguna de estas soluciones parece viable o existen 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 verificar 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.


17
2017-12-19 03:13


origen


Respuestas:


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

EDITAR: La implementación completa de esta solución se puede encontrar aquí.

¿Se puede mejorar esta solución?

Primero, cómo se usa:

-- 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 resultados del programa anterior:

--> 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 esta para una versión comentada):

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

4
2017-12-19 22:22



La forma más obvia de hacer esto 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 quieres la semántica de task ser, sin embargo ...

editar para mostrar cómo harías 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á el MonadIO restricción 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).


2
2017-12-19 17:19



No estoy seguro de si esto es exactamente lo que quiere, pero aquí hay una implementación que impone la cantidad correcta 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.

ACTUALIZAR:

Ahora puede extraer la cantidad 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')

1
2017-12-19 19:59



Preguntas populares