StackOverflow2013

Note that there are some explanatory texts on larger screens.

plurals

PO
text
Body
copied!<p>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.</p> <p><strong>EDIT:</strong> The full implementation of this solution can be found <a href="http://hpaste.org/55474" rel="nofollow">here</a>.</p> <p><strong>Can this solution be improved?</strong></p> <p>First, how it is used:</p> <pre><code>-- 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></pre> <p>The above program outputs:</p> <pre><code>--> 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)] </code></pre> <p>The actual implementation (See <a href="http://hpaste.org/55474" rel="nofollow">this</a> for a commented version):</p> <pre><code>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 </code></pre>

Querying!

Guidance

An individual column

Larger individual text columns get their own page to allow for proper reading.

SQuiL has stopped working due to an internal error.

If you are curious you may find further information in the browser console, which is accessible through the devtools (F12).

Reload