blocks|key|3133015|text|最明显的方法是使用StateT。|type|unstyled|depth|inlineStyleRanges|offset|length|style|CODE|entityRanges|data|3133016|import+Control.Monad.State

type+ProgressT+m+a+=+StateT+Int+m+a

step+::+Monad+m+=>+ProgressT+m+()
step+=+modify+(subtract+1)|code-block|syntax|javascript|3133017|我不确定您希望task的语义是什么，但是...|3133018|编辑以显示如何使用IO执行此操作|BOLD|3133019|step+::+(Monad+m,+MonadIO+m)+=>+ProgressT+m+()
step+=+do
++modify+(subtract+1)
++s+<-+get
++liftIO+$+putStrLn+$+"steps+remaining:+"+%2B%2B+show+s|3133020|请注意，您将需要MonadIO约束来打印状态。如果你需要对状态产生不同的效果，你可以使用不同的约束(例如，如果步数小于零就抛出异常，或者其他任何东西)。|3133021|entityMap^0|9|6|0|0|7|4|0|0|B|0|0|8|7|0^^$0|@$1|2|3|4|5|6|7|V|8|@$9|W|A|X|B|C]]|D|@]|E|$]]|$1|F|3|G|5|H|7|Y|8|@]|D|@]|E|$I|J]]|$1|K|3|L|5|6|7|Z|8|@$9|10|A|11|B|C]]|D|@]|E|$]]|$1|M|3|N|5|6|7|12|8|@$9|13|A|14|B|O]]|D|@]|E|$]]|$1|P|3|Q|5|H|7|15|8|@]|D|@]|E|$I|J]]|$1|R|3|S|5|6|7|16|8|@$9|17|A|18|B|C]]|D|@]|E|$]]|$1|T|3|-4|5|6|7|19|8|@]|D|@]|E|$]]]|U|$]]

The most obvious way to do this is with <code>StateT</code>.

<pre><code>import Control.Monad.State

type ProgressT m a = StateT Int m a

step :: Monad m =&gt; ProgressT m ()
step = modify (subtract 1)
</code></pre>

I'm not sure what you want the semantics of <code>task</code> to be, however...

edit to show how you'd do this with IO

<pre><code>step :: (Monad m, MonadIO m) =&gt; ProgressT m ()
step = do
 modify (subtract 1)
 s &lt;- get
 liftIO $ putStrLn $ "steps remaining: " ++ show s
</code></pre>

Note that you'll need the <code>MonadIO</code> constraint to print the state. You can have a different sort of constraint if you need a different effect with the state (i.e. throw an exception if the number of steps goes below zero, or whatever).

blocks|key|3133031|text|不确定这是否是您想要的，但这里有一个实现，它强制执行正确的步骤数，并要求在结束时没有留下任何步骤。为简单起见，我在IO上使用monad而不是monad+transformer。请注意，我并没有使用Prelude+monad来做我正在做的事情。|type|unstyled|depth|inlineStyleRanges|entityRanges|data|3133032|更新|offset|length|style|BOLD|3133033|现在可以提取剩余的步数。使用-XRebindableSyntax运行以下命令|3133034|{-#+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+%2B+1)
++++where
++++++prev+::+S+(S+n)+->+(S+n)
++++++prev+S+=+S
++++++n+=+fromPeano+$+prev+s

-----------------------------------------------------------

class+(Peano+s,+Peano+p)+=>+Succ+s+p+%7C+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')|code-block|syntax|javascript|3133035|entityMap^0|0|0|2|0|0|0^^$0|@$1|2|3|4|5|6|7|Q|8|@]|9|@]|A|$]]|$1|B|3|C|5|6|7|R|8|@$D|S|E|T|F|G]]|9|@]|A|$]]|$1|H|3|I|5|6|7|U|8|@]|9|@]|A|$]]|$1|J|3|K|5|L|7|V|8|@]|9|@]|A|$M|N]]|$1|O|3|-4|5|6|7|W|8|@]|9|@]|A|$]]]|P|$]]

Not sure if this is exactly what you want, but here is an implementation that enforces the correct number of steps and requires there to be zero steps left at the end. For simplicity, I'm using a monad instead of a monad transformer over IO. Note that I am not using the Prelude monad to do what I'm doing.

UPDATE:

Now can extract the number of remaining steps. Run the following with -XRebindableSyntax

<pre><code>{-# 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 -&gt; Integer

instance Peano Z where
 peano = Z
 fromPeano Z = 0

instance Peano (S Z) where
 peano = S
 fromPeano S = 1

instance Peano (S n) =&gt; Peano (S (S n)) where
 peano = S
 fromPeano s = n `seq` (n + 1)
 where
 prev :: S (S n) -&gt; (S n)
 prev S = S
 n = fromPeano $ prev s

-----------------------------------------------------------

class (Peano s, Peano p) =&gt; Succ s p | s -&gt; p where
instance Succ (S Z) Z where
instance Succ (S n) n =&gt; Succ (S (S n)) (S n) where

-----------------------------------------------------------

infixl 1 &gt;&gt;=, &gt;&gt;

class ParameterisedMonad m where
 return :: a -&gt; m s s a
 (&gt;&gt;=) :: m s1 s2 t -&gt; (t -&gt; m s2 s3 a) -&gt; m s1 s3 a
 fail :: String -&gt; m s1 s2 a
 fail = error

(&gt;&gt;) :: ParameterisedMonad m =&gt; m s1 s2 t -&gt; m s2 s3 a -&gt; m s1 s3 a
x &gt;&gt; f = x &gt;&gt;= \_ -&gt; f

-----------------------------------------------------------

newtype PIO p q a = PIO { runPIO :: IO a }

instance ParameterisedMonad PIO where
 return = PIO . Old.return
 PIO io &gt;&gt;= f = PIO $ (Old.&gt;&gt;=) io $ runPIO . f

-----------------------------------------------------------

data Progress p n a = Progress a

instance ParameterisedMonad Progress where
 return = Progress
 Progress x &gt;&gt;= f = let Progress y = f x in Progress y

runProgress :: Peano n =&gt; n -&gt; Progress n Zero a -&gt; a
runProgress _ (Progress x) = x

runProgress' :: Progress p Zero a -&gt; a
runProgress' (Progress x) = x

task :: Peano n =&gt; n -&gt; Progress n n ()
task _ = return ()

task' :: Peano n =&gt; Progress n n ()
task' = task peano

step :: Succ s n =&gt; Progress s n ()
step = Progress ()

stepsLeft :: Peano s2 =&gt; Progress s1 s2 a -&gt; (a -&gt; Integer -&gt; Progress s2 s3 b) -&gt; Progress s1 s3 b
stepsLeft prog f = prog &gt;&gt;= flip f (fromPeano $ getPeano prog)
 where
 getPeano :: Peano n =&gt; Progress s n a -&gt; 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) =&gt; Progress two zero Integer
procedure2 = do
 task'
 step `stepsLeft` \_ n -&gt; do
 step
 return n

main :: IO ()
main = runPIO $ do
 PIO $ putStrLn $ runProgress' procedure1
 PIO $ print $ runProgress (peano :: Four) $ do
 n &lt;- procedure2
 n' &lt;- procedure2
 return (n, n')
</code></pre>

blocks|key|2918822|text|这是我对这个问题的悲观解决方案。它使用Coroutines来暂停每一步的计算，这让用户可以执行任意计算来报告一些进度。|type|unstyled|depth|inlineStyleRanges|offset|length|style|CODE|entityRanges|data|2918823|EDIT:这个解决方案的完整实现可以在here上找到。|BOLD|2918824|这个解决方案还能改进吗？|2918825|首先，如何使用它：|2918826|--+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|code-block|syntax|javascript|2918827|上面的程序输出：|2918828|-->+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)]|2918829|实际的实现(参见this的注释版本)：|2918830|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+%2B+1
++++++updatedTask+=+current+{+taskStep+=+nextStep+}
++++++updatedTasks+=+updatedTask+:+tasks
++when+(currentStep+>+taskTotalSteps+current)+$
++++fail+"The+task+has+already+completed"
++yield+updatedTasks
++lift+.+put+$+updatedTasks|2918831|entityMap|0|LINK|mutability|MUTABLE|url|http://hpaste.org/55474|1^0|J|9|0|0|5|J|4|0|0|0|C|0|0|0|0|0|8|4|1|0|0^^$0|@$1|2|3|4|5|6|7|18|8|@$9|19|A|1A|B|C]]|D|@]|E|$]]|$1|F|3|G|5|6|7|1B|8|@$9|1C|A|1D|B|H]]|D|@$9|1E|A|1F|1|1G]]|E|$]]|$1|I|3|J|5|6|7|1H|8|@$9|1I|A|1J|B|H]]|D|@]|E|$]]|$1|K|3|L|5|6|7|1K|8|@]|D|@]|E|$]]|$1|M|3|N|5|O|7|1L|8|@]|D|@]|E|$P|Q]]|$1|R|3|S|5|6|7|1M|8|@]|D|@]|E|$]]|$1|T|3|U|5|O|7|1N|8|@]|D|@]|E|$P|Q]]|$1|V|3|W|5|6|7|1O|8|@]|D|@$9|1P|A|1Q|1|1R]]|E|$]]|$1|X|3|Y|5|O|7|1S|8|@]|D|@]|E|$P|Q]]|$1|Z|3|-4|5|6|7|1T|8|@]|D|@]|E|$]]]|10|$11|$5|12|13|14|E|$15|16]]|17|$5|12|13|14|E|$15|16]]]]

This is my pessimistic solution to this problem. It uses <code>Coroutine</code>s to suspend the computation on each step, which lets the user perform an arbitrary computation to report some progress.

EDIT: The full implementation of this solution can be found <a href="http://hpaste.org/55474" rel="nofollow">here</a>.

Can this solution be improved?

First, how it is used:

<pre><code>-- The procedure that we want to run.
procedure :: ProgressT IO ()
procedure = task "Print some lines" 3 $ do
 liftIO $ putStrLn "--&gt; line 1"
 step
 task "Print a set of lines" 2 $ do
 liftIO $ putStrLn "--&gt; line 2.1"
 step
 liftIO $ putStrLn "--&gt; line 2.2"
 step
 liftIO $ putStrLn "--&gt; 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 -&gt; IO a
runConsole proc = do
 result &lt;- runProgress proc
 case result of
 -- We stopped at a step:
 Left (cont, stack) -&gt; do
 print stack -- Print the stack
 runConsole cont -- Continue the procedure
 -- We are done with the computation:
 Right a -&gt; return a
</code></pre>

The above program outputs:

<pre><code>--&gt; line 1
[Print some lines (1/3)]
--&gt; line 2.1
[Print a set of lines (1/2),Print some lines (1/3)]
--&gt; line 2.2
[Print a set of lines (2/2),Print some lines (1/3)]
[Print some lines (2/3)]
--&gt; line 3
[Print some lines (3/3)]
</code></pre>

The actual implementation (See <a href="http://hpaste.org/55474" rel="nofollow">this</a> for a commented version):

<pre><code>type Progress l = ProgressT l Identity

runProgress :: Progress l a
 -&gt; 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 =&gt; Monad (ProgressT l m) where
 return = ProgressT . return
 p &gt;&gt;= f = ProgressT (procedure p &gt;&gt;= procedure . f)

instance MonadIO m =&gt; MonadIO (ProgressT l m) where
 liftIO = lift . liftIO

runProgressT :: Monad m
 =&gt; ProgressT l m a
 -&gt; m (Either (ProgressT l m a, TaskStack l) a)
runProgressT action = do
 result &lt;- evalStateT (resume . procedure $ action) []
 return $ case result of
 Left (Yield stack cont) -&gt; Left (ProgressT cont, stack)
 Right a -&gt; Right a

type TaskStack l = [Task l]

data Task l =
 Task
 { taskLabel :: l
 , taskTotalSteps :: Word
 , taskStep :: Word
 } deriving (Show, Eq)

task :: Monad m
 =&gt; l
 -&gt; Word
 -&gt; ProgressT l m a
 -&gt; 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 &lt;- 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 =&gt; ProgressT l m ()
step = ProgressT $ do
 (current : tasks) &lt;- lift get
 let currentStep = taskStep current
 nextStep = currentStep + 1
 updatedTask = current { taskStep = nextStep }
 updatedTasks = updatedTask : tasks
 when (currentStep &gt; taskTotalSteps current) $
 fail "The task has already completed"
 yield updatedTasks
 lift . put $ updatedTasks
</code></pre>

I am looking for a monad transformer that can be used to track the progress of a procedure. To explain how it would be used, consider the following code:

<pre><code>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
 =&gt; String -- Name of task
 -&gt; Int -- Number of steps to complete task
 -&gt; ProgressT m a -- Action performing the task
 -&gt; ProgressT m a

-- Marks one step of the current task as completed
step :: Monad m =&gt; ProgressT m ()
</code></pre>

I realize that <code>step</code> has to exist explicitly because of the monadic laws, and that <code>task</code> has to have an explicit step number parameter because of program determinism/the halting problem.

The monad as described above could, as I see it, be implemented in one of two ways:

<ol>
<li>Via a function that would return the current task name/step index stack, and a continuation in the procedure at the point that it left off. Calling this function repeatedly on the returned continuation would complete the execution of the procedure.</li>
<li>Via a function that took an action describing what to do when a task step has been completed. The procedure would run uncontrollably until it completed, "notifying" the environment about changes via the provided action.</li>
</ol>

For solution (1), I have looked at <code>Control.Monad.Coroutine</code> with the <code>Yield</code> suspension functor. For solution (2), I don't know of any already available monad transformers that would be useful.

The solution I'm looking for should not have too much performance overhead and allow as much control over the procedure as possible (e.g. not require IO access or something).

Do one of these solutions sound viable, or are there other solutions to this problem somewhere already? Has this problem already been solved with a monad transformer that I've been unable to find?

EDIT: The goal isn't to check whether all the steps have been performed. The goal is to be able to "monitor" the process while it is running, so that one can tell how much of it has been completed.

Monad transformer for progress tracking

我正在寻找一个单变压器，可以用来跟踪程序的进展。要解释如何使用它，请考虑以下代码：procedure :: ProgressT IO ()procedure = task "Print some lines" 3 $ do  liftIO $ putStrLn "line1"  step  task "Print a ...

问用于进度跟踪的Monad转换器
EN

社区

活动

资源

关于

腾讯云开发者

热门产品

热门推荐

更多推荐

问用于进度跟踪的Monad转换器EN

社区

活动

资源

关于

腾讯云开发者

热门产品

热门推荐

更多推荐

问用于进度跟踪的Monad转换器
EN