[Haskell-cafe] Fail-back monad

[oleg at okmij.org]

Alberto G. Corona wrote about a monad to set a checkpoint and be able
to repeatedly go to that checkpoint and re-execute the computations
following the checkpoint.
  http://haskell-web.blogspot.com.es/2012/03/failback-monad.html

The typical example is as follows.

> test= runBackT $ do
>        lift $ print "will not return back here"
>         liftBackPoint $ print "will return here"
>         n2  <- lift $ getLine
>         lift $ print "second input"
>         n3  <- lift $  getLine
>         if n3 == "back"
>                    then  fail ""
>                    else lift $ print  $ n2++n3

Let us first consider a slightly simplified problem, with a different
signature for liftBackPoint. Rather than writing
	do 
        liftBackPoint $ print "will return here"
	other_computation

we will write

	do
	backPoint $ do
	  lift $ print "will return here"
	  other_computation

In that case, backPoint will be implemented with the Exception or
Error monad. For example,

> backPoint :: Monad m =>
>   ErrorT SomeException m a -> ErrorT SomeException m a
> backPoint m = catchError m handler 
>  where
>  handler e | Just RestartMe <- fromException e = backPoint m
>  handler e = throwError e		-- other errors propagate up

We designate one exception RestartMe as initiating the restart from
the checkpoint. Other exceptions will propagate as usual.

Obviously, if we are in IO or some MonadIO, we could use the regular
exception-handling facilities: throw/catch.

Suppose however that marking of the checkpoint should be a single
action rather that exception-like handling form. Then we need the
continuation monad:

> type BackT r m a = ContT r (ErrorT SomeException m) a
>
> backPointC :: Monad m => ContT e (ErrorT SomeException m) ()
> backPointC = ContT (\k -> backPoint (k ()))

(we have re-used the earlier backPoint). Incidentally, the
continuation monad will be faster than BackT in the original article.
Attentive reader must have noticed that backPointC is shift in disguise.

Here is the complete code.

> {-# LANGUAGE DeriveDataTypeable #-}
>
> module BackT where
>
> import Control.Monad.Trans
> import Control.Monad.Error
> import Control.Monad.Cont
> import Control.Exception
> import Data.Typeable
>
>
> data RestartMe = RestartMe deriving (Show, Typeable)
> instance Exception RestartMe
> instance Error SomeException
>
> -- Make a `restartable' exception 
> -- (restartable from the beginning, that is)
> -- We redo the computation once we catch the exception RestartMe
> -- Other exceptions propagate up as usual.
>
> -- First, we use ErrorT
>
> backPoint :: Monad m =>
>   ErrorT SomeException m a -> ErrorT SomeException m a
> backPoint m = catchError m handler 
>  where
>  handler e | Just RestartMe <- fromException e = backPoint m
>  handler e = throwError e               -- other errors propagate up
>
> test1 = runErrorT $ do
>   lift $ print "will not return back here"
>   backPoint $ do
>     lift $ print "will return here"
>     n2  <- lift $ getLine
>     lift $ print "second input"
>     n3  <- lift $  getLine
>     if n3 == "back"
>        then  throwError (toException RestartMe)
>        else lift $ print  $ n2++n3
>
> -- Obviously we can use error handling in the IO monad...
>
> -- Suppose we don't want backPoint that takes monad as argument.
> -- We wish backPoint that is a simple m () action.
>
> -- We will use Cont monad then: That is, we use Cont + Error Monad
> -- We reuse the old backPoint
>
> type BackT r m a = ContT r (ErrorT SomeException m) a
>
> backPointC :: Monad m => ContT e (ErrorT SomeException m) ()
> backPointC = ContT (\k -> backPoint (k ()))
>
> abort e = ContT(\k -> e)
>
> test2 :: BackT r IO ()
> test2 =  do
>   liftIO $ print "will not return back here"
>   backPointC                            -- This line differs
>   liftIO $ print "will return here"     -- (and the indentation on here)
>   n2  <- liftIO $ getLine
>   liftIO $ print "second input"
>   n3  <- liftIO $  getLine
>   if n3 == "back"
>        then  abort $ throwError (toException RestartMe)
>        else liftIO $ print  $ n2++n3
>
> test2r = runErrorT $ runContT test2 return