Отложить действия в 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 был вызван дважды).

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

ОТВЕТЫ

Ответ 1

Как user2407038 уже объяснено, невозможно получить состояние (отложенные действия) в catch. Однако вы можете использовать ExceptT для явного обнаружения ошибок:

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"

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

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

Обратите внимание, что вы должны явно выявлять ошибки с помощью catchIOError. Если вы забудете его и просто вызовите liftIO, ошибка не будет обнаружена.

Обратите внимание, что вызов handleResult небезопасен. Если он выдает ошибку, отложенные действия не будут выполняться впоследствии. Вы можете рассмотреть возможность обработки результата после выполнения действий:

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: Ввести safeIO

Изменить 2:

  • использовать более простую обработку ошибок.
  • используйте safeIO во всех фрагментах
  • предупреждать об исключениях в handleResult

Изменить 3: Заменить safeIO на catchIOError.