Defer actions in Haskell

Question

I'd like to defer actions. Therefore I use a WriterT that should remember actions that I tell him.

module Main where

import Control.Exception.Safe
       (Exception, MonadCatch, MonadThrow, SomeException,
        SomeException(SomeException), catch, throwM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Writer (WriterT, runWriterT, tell)

type Defer m a = WriterT (IO ()) m a

-- | Register an action that should be run later.
defer :: (Monad m) => IO () -> Defer m ()
defer = tell

-- | Ensures to run deferred actions even after an error has been thrown.
runDefer :: (MonadIO m, MonadCatch m) => Defer m () -> m ()
runDefer fn = do
  ((), deferredActions) <- runWriterT (catch fn onError)
  liftIO $ do
    putStrLn "run deferred actions"
    deferredActions

-- | Handle exceptions.
onError :: (MonadIO m) => MyException -> m ()
onError e = liftIO $ putStrLn $ "handle exception: " ++ show e

data MyException =
  MyException String

instance Exception MyException

instance Show MyException where
  show (MyException message) = "MyException(" ++ message ++ ")"

main :: IO ()
main = do
  putStrLn "start"
  runDefer $ do
    liftIO $ putStrLn "do stuff 1"
    defer $ putStrLn "cleanup 1"
    liftIO $ putStrLn "do stuff 2"
    defer $ putStrLn "cleanup 2"
    liftIO $ putStrLn "do stuff 3"
  putStrLn "end"

I get the expected output

start
do stuff 1
do stuff 2
do stuff 3
run deferred actions
cleanup 1
cleanup 2
end

However, if an exception is thrown

main :: IO ()
main = do
  putStrLn "start"
  runDefer $ do
    liftIO $ putStrLn "do stuff 1"
    defer $ putStrLn "cleanup 1"
    liftIO $ putStrLn "do stuff 2"
    defer $ putStrLn "cleanup 2"
    liftIO $ putStrLn "do stuff 3"
    throwM $ MyException "exception after do stuff 3"
  putStrLn "end"

none of the deferred actions is run

start
do stuff 1
do stuff 2
do stuff 3
handle exception: MyException(exception after do stuff 3)
run deferred actions
end

but I expect this

start
do stuff 1
do stuff 2
do stuff 3
handle exception: MyException(exception after do stuff 3)
run deferred actions
cleanup 1
cleanup 2
end

The writer somehow looses his state. If I use [IO ()] as state instead of IO ()

type Defer m a = WriterT [IO ()] m a

and print the length of deferredActions in runDefer it is 2 on success (because I called defer twice) and 0 on error (even though defer has been called twice).

What causes this issue? How can I run the deferred actions after an error?

Answer 1

Like user2407038 already explained it is not possible to get the state (deferred actions) in catch. However, you can use ExceptT to catch errors explicitly:

module Main where

import Control.Exception.Safe
       (Exception, Handler(Handler), MonadCatch,
        SomeException(SomeException), catch, catches, throw)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
import Control.Monad.Trans.Writer (WriterT, runWriterT, tell)

type DeferM m = WriterT (IO ()) m

type Defer m a = DeferM m a

-- | Register an action that should be run later.
--
defer :: (Monad m) => IO () -> Defer m ()
defer = tell

-- | Register an action that should be run later.
-- Use @deferE@ instead of @defer@ inside @ExceptT@.
deferE :: (Monad m) => IO () -> ExceptT e (DeferM m) ()
deferE = lift . defer

-- | Ensures to run deferred actions even after an error has been thrown.
--
runDefer :: (MonadIO m, MonadCatch m) => Defer m a -> m a
runDefer fn = do
  (result, deferredActions) <- runWriterT fn
  liftIO $ do
    putStrLn "run deferred actions"
    deferredActions
  return result

-- | Catch all errors that might be thrown in @f@.
--
catchIOError :: (MonadIO m) => IO a -> ExceptT SomeException m a
catchIOError f = do
  r <- liftIO (catch (Right <$> f) (return . Left))
  case r of
    (Left e) -> throwE e
    (Right c) -> return c

data MyException =
  MyException String

instance Exception MyException

instance Show MyException where
  show (MyException message) = "MyException(" ++ message ++ ")"

handleResult :: Show a => Either SomeException a -> IO ()
handleResult result =
  case result of
    Left e -> putStrLn $ "caught an exception " ++ show e
    Right _ -> putStrLn "no exception was thrown"

main :: IO ()
main = do
  putStrLn "start"
  runDefer $ do
    result <-runExceptT $ do
      catchIOError $ putStrLn "do stuff 1"
      deferE $ putStrLn "cleanup 1"
      catchIOError $ putStrLn "do stuff 2"
      deferE $ putStrLn "cleanup 2"
      catchIOError $ putStrLn "do stuff 3"
      catchIOError $ throw $ MyException "exception after do stuff 3"
      return "result"
    liftIO $ handleResult result
  putStrLn "end"

We get the expected output:

start
do stuff 1
do stuff 2
do stuff 3
handle my exception: "exception after do stuff 3"
run deferred actions
cleanup 1
cleanup 2
end

Notice that you have to catch errors explicitly using catchIOError. If you forget it and just call liftIO, the error will not be caught.

Note further that the call to handleResult is not safe. If it throws an error the deferred actions won't be run afterwards. You might consider to handle the result after the actions have been run:

main :: IO ()
main = do
  putStrLn "start"
  result <-
    runDefer $ do
      runExceptT $ do
        catchIOError $ putStrLn "do stuff 1"
        deferE $ putStrLn "cleanup 1"
        catchIOError $ putStrLn "do stuff 2"
        deferE $ putStrLn "cleanup 2"
        catchIOError $ putStrLn "do stuff 3"
        catchIOError $ throw $ MyException "exception after do stuff 3"
        return "result"
  handleResult result
  putStrLn "end"

Otherwise, you have to catch that error separately.

---

Edit 1: Introduce safeIO

Edit 2:

• use simpler error handling
• use safeIO in all snippets
• warn of exceptions in handleResult

Edit 3: Replace safeIO with catchIOError.