推迟Haskell中的行动

Question

我想推迟采取行动.因此,我使用的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已经被调用两次).

是什么导致这个问题？如何在出错后运行延迟操作？

Answer 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 @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"

我们得到预期的输出：

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"

请注意，您必须使用 显式捕获错误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.