Отложить действия в Haskell - программирование

Я бы хотел отложить действия. Поэтому я использую WriterT, который должен помнить действия, которые я tell ему.

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"

Я получаю ожидаемый результат

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

Однако, если исключение выбрано

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"

ни одно из отложенных действий не выполняется

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

но я ожидаю этого

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

Писатель как-то теряет свое состояние. Если я использую [IO ()] как состояние вместо IO ()

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

и напечатать длину deferredActions в runDefer, это 2 при успехе (потому что я дважды вызывал defer) и 0 при ошибке (даже если defer был вызван дважды).

В чем причина этой проблемы? Как запустить отложенные действия после ошибки?

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 @[email protected] instead of @[email protected] inside @[email protected] 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 @[email protected] -- 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"

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"

Ответ 1