Монадный трансформатор для отслеживания прогресса

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), я не знаю ни одного уже доступного монадного трансформатора, который был бы полезен.

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

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

РЕДАКТИРОВАТЬ: Цель состоит не в том, чтобы проверить, все ли шаги были выполнены.Цель состоит в том, чтобы иметь возможность «контролировать» процесс во время его выполнения, чтобы можно было определить, сколько из него завершено.

Answer 1

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

РЕДАКТИРОВАТЬ: Полная реализация этого решения можно найти здесь .

Можно ли улучшить это решение?

Во-первых, как это используется:

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

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. Обратите внимание, что я не использую монаду Prelude, чтобы делать то, что я делаю.

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