From oleg at okmij.org Tue Feb  7 19:48:24 2006
To: haskell@haskell.org
Subject: generic catch in a MonadIO
Message-ID: <20060208034824.1AE94A9D0@Adric.metnet.navy.mil>
Date: Tue,  7 Feb 2006 19:48:24 -0800 (PST)
X-Comment: Updated for new exceptions; added Michael Snoyman's test
  Haskell-Cafe, Oct 15, 2010.
Status: OR


The ability to use functions 'catch', 'bracket', 'catchDyn', etc. in
MonadIO other than IO itself has been a fairly frequently requested
feature:

http://www.haskell.org/pipermail/glasgow-haskell-users/2003-September/005660.html
http://haskell.org/pipermail/libraries/2003-February/000774.html

The reason it is not implemented is because these functions cannot be
defined for a general MonadIO. However, these functions can be easily
defined for a large and interesting subset of MonadIO. The following
code demonstrates that. It uses no extensions (other than those needed
for the Monad Transformer Library itself), patches no compilers, and
proposes no extensions. The generic catch has been useful in a
database library (Takusen), where many operations work in a monad
(ReaderT Session IO): IO with the environment containing the database
session data. Many other foreign libraries have a pattern of passing
around various handles, which are better hidden in a monad. Still, we
should be able to handle IO errors and user exceptions that arise in
these computations.

> {-# LANGUAGE DeriveDataTypeable #-}
>
> module CaughtMonadIO where
>
> import Data.Typeable
> import Control.Exception
> import Control.Monad.Trans
> import Control.Monad.Error
> import Control.Monad.List
> import Control.Monad.Reader
> import Control.Monad.State
> import Control.Monad.Writer
> import Control.Monad.RWS
>
> ---------------------  Tests
>
> data MyException = MyException String deriving (Show, Typeable)
> instance Exception MyException
>
> testfn True = throw (MyException "thrown")
> testfn False = return True
>
> testc m = gcatch (m >>= return . show) (\ (MyException s) -> return s)
>
> test1 = do tf True >>= print; tf False >>= print
>  where
>   tf x = runReaderT (runWriterT (testc (do
>				          tell "begin"
> 					  r <- ask
> 					  testfn r))) x

*CaughtMonadIO> test1
("thrown","")
("True","begin")


> test2 = do tf True >>= print; tf False >>= print;
>  where
>   tf x = runReaderT (runErrorT (do
> 				  r <- ask
> 				  testfn r `gcatch` 
> 				   (\ (MyException s) -> throwError s))) x

*CaughtMonadIO> test2
Left "thrown"
Right True

Michael Snoyman's test, of using finally
Haskell Cafe, Thu Oct 14 06:01:59 EDT 2010
http://www.haskell.org/pipermail/haskell-cafe/2010-October/084890.html

First, we define the generalized finally that makes sure
that a sequel computation is executed always, no matter how successful
the main computation was.

> gfinally :: CaughtMonadIO m => m a -> m b -> m a
> a `gfinally` sequel = do
>     r <- a `gcatch` \e -> sequel >> throw (e :: SomeException)
>     sequel
>     return r

We now test that the sequel is indeed executed always.

> test3c go = runErrorT $ go `gfinally` (liftIO $ putStrLn "sequel called")

> test31 = test3c (return "return"         :: ErrorT String IO String)

*CaughtMonadIO> test31
sequel called
Right "return"

> test32 = test3c (error "error"           :: ErrorT String IO String)

*CaughtMonadIO> test32
sequel called
*** Exception: error

> test33 = test3c (throwError "throwError" :: ErrorT String IO String)

*CaughtMonadIO> test33
sequel called
Left "\"throwError\""

> test331 = fmap (== Left (show "throwError")) $ 
>           test3c (throwError "throwError" :: ErrorT String IO String)

*CaughtMonadIO> test331
sequel called
True


The implementation is quite trivial.

> class MonadIO m => CaughtMonadIO m where
>     gcatch :: Exception e => m a -> (e -> m a) -> m a

> instance CaughtMonadIO IO where
>     gcatch = Control.Exception.catch


We need some way to inject Errors (members of Error class) into
Exception's. We go for the lowest common denominator

> data ErrorException = ErrorException String deriving (Show, Typeable)
> instance Exception ErrorException

> instance (CaughtMonadIO m, Show e, Error e) 
>          => CaughtMonadIO (ErrorT e m) where
>     gcatch m f = mapErrorT inner m
>      where inner m = gcatch (m >>= error_catch) 
>                             (\e -> reflect (runErrorT $ f e))
>            -- Deal with the case the outer ErrorT reported an error
>            -- We convert the outer Error into an error in the underlying m
>            error_catch = either (throw  . ErrorException . show)
>                                 (return . Right)
>            -- If the error came from the outer monad, reflect it back into it
>            reflect m = gcatch m (\ (ErrorException e) -> 
>                                       return . Left $ strMsg e)


The following is almost verbatim from `Control.Monad.Error'
Section MonadError instances for other monad transformers

> instance CaughtMonadIO m => CaughtMonadIO (ReaderT r m) where
>     gcatch m f = ReaderT $ 
>                  \r -> gcatch (runReaderT m r) (\e -> runReaderT (f e) r)

The following instances presume that an exception that occurs in
'm' discard the state accumulated since the beginning of 'm's execution.
If that is not desired -- don't use the StateT. Rather, allocate
IORef and carry that _immutable_ value in a ReaderT. The accumulated
state will thus persist. One can always use IORefs within
any MonadIO.

> instance (Monoid w, CaughtMonadIO m) => CaughtMonadIO (WriterT w m) where
>         m `gcatch` h = WriterT $ runWriterT m
>                 `gcatch` \e -> runWriterT (h e)

> instance CaughtMonadIO m => CaughtMonadIO (StateT s m) where
>         m `gcatch` h = StateT $ \s -> runStateT m s
>                 `gcatch` \e -> runStateT (h e) s

> instance (Monoid w, CaughtMonadIO m) => CaughtMonadIO (RWST r w s m) where
>         m `gcatch` h = RWST $ \r s -> runRWST m r s
>                 `gcatch` \e -> runRWST (h e) r s