PR

エラー・モナドとしてのIOモナド

 ErrorTモナド変換子を使って他のモナドmにエラー・モナドを合成すれば,そのモナドmにエラー処理の能力を加えられます。しかし,この方法で利用できるエラーは,あくまでfailまたはthrowErrorという特定のメソッドを通じて発生させられたものに限られます。「Haskellプログラムの広範な部分で発生し得る例外を解決できる例外処理」を実現できているわけではありません。

 この制限を突破する方法が一つあります。もともと例外処理の能力を備えているIOモナドに対してモナド変換子を適用し,新しいモナドを合成することです。

 このような視点から,Control.Monad.ErrorモジュールはIO型のMonadPlusクラスやMonadErrorクラスに対するインスタンスを提供しています。しかし,その能力はI/Oエラーに対する極めて限定されたものになっています。

instance MonadPlus IO where
    mzero       = ioError (userError "mzero")
    m `mplus` n = m `catch` \_ -> n

instance MonadError IOError IO where
    throwError = ioError
    catchError = catch

 このような制限は現在の例外処理の実情に即していないため,別のライブラリを利用することにしましょう。HackageDBには,Control.Exceptionで定義されている例外処理の基本的な関数をmtlのモナド変換子向けに再定義したMonadCatchIO-mtlというパッケージが公開されています。これをダウンロードしてインストールします。

 MonadCatch-mtlのControl.Monad.CatchIOモジュールでは,モナド変換子を使って合成したモナドに対して例外処理の能力を与えるため,MonadIOを継承したMonadCatchIOクラスを提供しています。

Prelude Control.Monad.CatchIO> :i MonadCatchIO
class (Control.Monad.Trans.MonadIO m) => MonadCatchIO m where
  Control.Monad.CatchIO.catch ::
    (Exception e) => m a -> (e -> m a) -> m a
  block :: m a -> m a
  unblock :: m a -> m a
        -- Defined in Control.Monad.CatchIO
instance MonadCatchIO IO -- Defined in Control.Monad.CatchIO

 MonadIOクラスのliftメソッドと同様に,MonadCatchIOクラスを通じて「モナド変換子を使って合成されたモナド」から「合成元のモナド」にcatch,block,unblockの三つのメソッドが受け渡されていきます。これにより,これらのメソッドは最終的にIOモナドでのアクションとして実行されます。

import qualified Control.Exception as E

~ 略 ~

instance MonadCatchIO IO where
    catch   = E.catch
    block   = E.block
    unblock = E.unblock

~ 略 ~

instance MonadCatchIO m => MonadCatchIO (StateT s m) where
    m `catch` f = StateT $ \s -> (runStateT m s)
                                   `catch` (\e -> runStateT (f e) s)
    block       = mapStateT block
    unblock     = mapStateT unblock

instance (MonadCatchIO m, Error e) => MonadCatchIO (ErrorT e m) where
    m `catch` f = mapErrorT (\m' -> m' `catch` (\e -> runErrorT $ f e)) m
    block       = mapErrorT block
    unblock     = mapErrorT unblock

 mapStateTとmapErrorTの定義は以下の通りです。

mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
mapStateT f m = StateT $ f . runStateT m

mapErrorT :: (m (Either e a) -> n (Either e' b))
          -> ErrorT e m a
          -> ErrorT e' n b
mapErrorT f m = ErrorT $ f (runErrorT m)

 まさに,モナド変換子から合成元のモナドに処理を受け渡し,その結果を使って合成モナドを再構成する処理になっているのがわかると思います。

 IOモナドでの例外処理と同等の使い勝手を実現するため,Control.Monad.CatchIOモジュールではいくつかの関数や型を用意しています。わかりやすいようコードを整理した形で,それぞれの定義を見ていきましょう。

-- | Generalized version of 'E.throwIO'
throw :: (MonadCatchIO m, E.Exception e) => e -> m a
throw = liftIO . E.throwIO

-- | Generalized version of 'E.try'
try :: (MonadCatchIO m, E.Exception e) => m a -> m (Either e a)
try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e))

~ 略 ~

-- | Generalized version of 'E.Handler'
data Handler m a = forall e . E.Exception e => Handler (e -> m a)

-- | Generalized version of 'E.catches'
catches :: MonadCatchIO m => m a -> [Handler m a] -> m a
catches a handlers = a `catch` handler
    where handler e = foldr tryH (throw e) handlers
            where tryH (Handler h) res = case E.fromException e of
                                             Just e' -> h e'
                                             Nothing -> res

 モナド内での実行順序を保証するため,MonadCatchIOのthrowはControl.ExceptionのthrowではなくthrowIOに対応する形になっています。tryやcatchesは,宣言されている型が異なるだけで,関数自体はControl.Exceptionのものと同じ定義になっています。

 それでは,モナド変換子とMonadCatchIOクラスを組み合わせて使ってみましょう。例外を発生させないioStateアクションとioErrorアクション,例外を発生させるcauseException*アクション,特定の例外を捕捉するcatch*関数を作成し,それぞれの働きを確かめます。

{-# LANGUAGE ScopedTypeVariables #-}
module CatchIOException where
import Control.Exception hiding (ioError, throw, catch, catches, Handler)
import Control.Monad.CatchIO
import Prelude hiding (ioError, catch)

import Control.Monad.Error
import Control.Monad.State

ioState :: StateT Int IO Int
ioState = do
    val <- get
    return val

ioError :: ErrorT String IO String
ioError = throwError noMsg
          `catchError`
          (\str -> do
              let str' = "error caught by catchError: " ++ str
              liftIO $ print str'
              return str')

causeException :: (MonadCatchIO m) => m a
causeException = throw $ ErrorCall "error occur."
causeException' :: (MonadCatchIO m) => m a
causeException' = throw $ LossOfPrecision

catchErrorCall :: (MonadCatchIO m) => m a -> a -> m a
catchErrorCall m val
 = catch m (\(e::ErrorCall) -> do
     liftIO $ print "error caught by catch."
     return val)

catchArithException :: (MonadCatchIO m) => m a -> a -> m a
catchArithException m val = catch m (\(e::ArithException)  -> return val)
catchArithException' :: (MonadCatchIO m) => m a -> a -> m a
catchArithException' m val
  = catch m
          (\e -> (case e of
                     Overflow -> liftIO $ print e
                     Underflow -> liftIO $ print e
                     LossOfPrecision -> liftIO $ print e
                     DivideByZero -> liftIO $ print e
                     Denormal -> liftIO $ print e)
                  >> liftIO (print "error caught by catch.")
                  >> return val)

catchExceptions :: (MonadCatchIO m) => m a -> a -> m a
catchExceptions m val
  = m `catches`
      [ Handler (\(e::ErrorCall) -> return val)
      , Handler (\(e::ArithException) -> liftIO $ print e >> return val)]

 Control.Monad.CatchIOモジュールでは例外型はエクスポートされていないため,Control.Exceptionモジュールをインポートして使用することにします。Control.Exceptionをインポートすると一部の関数や型がControl.Monad.CatchIOと衝突するため,hidingを使って事前に隠しておきます。また,ErrorMonadクラスでのエラー処理とMonadCatchIOクラスでの例外処理が共存できることを示すため,ioErrorアクションの内部ではErrorMonadクラスのメソッドを使ったエラーの発生と捕捉を行っています。

 ioStateを使ったStateT IOモナドでの実行結果は以下の通りです。

*CatchIOException> flip runStateT 22 $ ioState
(22,22)
*CatchIOException> flip runStateT 22 $ catchErrorCall ioState 01
(22,22)
*CatchIOException> flip runStateT 22 $ catchArithException ioState 01
(22,22)
*CatchIOException> flip runStateT 22 $ catchArithException' ioState 01
(22,22)
*CatchIOException> flip runStateT 22 $ catchExceptions ioState 01
(22,22)
*CatchIOException> flip runStateT 22 $ ioState >> causeException
*** Exception: error occur.
*CatchIOException> flip runStateT 22 $ ioState >> causeException'
*** Exception: loss of precision
*CatchIOException> flip runStateT 22 $ catchErrorCall (ioState >> causeException) 01
"error caught by catch."
(1,22)
*CatchIOException> flip runStateT 22 $ catchErrorCall (ioState >> causeException') 01
*** Exception: loss of precision
*CatchIOException> flip runStateT 22 $ catchArithException (ioState >> causeException) 01
*** Exception: error occur.
*CatchIOException> flip runStateT 22 $ catchArithException (ioState >> causeException') 01
(1,22)
*CatchIOException> flip runStateT 22 $ catchArithException' (ioState >> causeException) 01
*** Exception: error occur.
*CatchIOException> flip runStateT 22 $ catchArithException' (ioState >> causeException') 01
loss of precision
"error caught by catch."
(1,22)
*CatchIOException> flip runStateT 22 $ catchExceptions (ioState >> causeException) 01
(1,22)
*CatchIOException> flip runStateT 22 $ catchExceptions (ioState >> causeException') 01
loss of precision
(1,22)

 ioErrorを使ったErrorT IOモナドでの実行結果は以下の通りです。

*CatchIOException> runErrorT ioError
"error caught by catchError: "
Right "error caught by catchError: "
*CatchIOException> runErrorT (ioError >> causeException)
"error caught by catchError: "
*** Exception: error occur.
*CatchIOException> runErrorT (ioError >> causeException')
"error caught by catchError: "
*** Exception: loss of precision
*CatchIOException> runErrorT $ catchErrorCall (ioError >> causeException') "rei"
"error caught by catchError: "
*** Exception: loss of precision
*CatchIOException> runErrorT $ catchErrorCall (ioError >> causeException) "rei"
"error caught by catchError: "
"error caught by catch."
Right "rei"
*CatchIOException> runErrorT $ catchErrorCall (ioError >> causeException') "rei"
"error caught by catchError: "
*** Exception: loss of precision
*CatchIOException> runErrorT $ catchArithException (ioError >> causeException) "rei"
"error caught by catchError: "
*** Exception: error occur.
*CatchIOException> runErrorT $ catchArithException (ioError >> causeException') "rei"
"error caught by catchError: "
Right "rei"
*CatchIOException> runErrorT $ catchArithException' (ioError >> causeException) "rei"
"error caught by catchError: "
*** Exception: error occur.
*CatchIOException> runErrorT $ catchArithException' (ioError >> causeException') "rei"
"error caught by catchError: "
loss of precision
"error caught by catch."
Right "rei"
*CatchIOException> runErrorT $ catchExceptions (ioError >> causeException) "rei"
"error caught by catchError: "
Right "rei"
*CatchIOException> runErrorT $ catchExceptions (ioError >> causeException') "rei"
"error caught by catchError: "
loss of precision
Right "rei"

 StateT IOモナドとErrorT IOモナドの両方で,例外発生時に特定の例外を対象とした処理がきちんと行われているのがわかりますね。

 もちろん,捕捉の対象となる例外はControl.Monad.CatchIOモジュールのthrow関数を使って引き起こしたものでなくても構いません。

*CatchIOException> flip runStateT 22 $ error "error occur."
*** Exception: error occur.
*CatchIOException> flip runStateT 22 $ catchErrorCall (error "error occur.") 01
"error caught by catch."
(1,22)
*CatchIOException> flip runStateT 22 $ catchArithException (error "error occur.") 01
*** Exception: error occur.
*CatchIOException> flip runStateT 22 $ catchExceptions (error "error occur.") 01
(1,22)
*CatchIOException> flip runStateT 22 $ liftIO $ evaluate $ 100 `div` 0
*** Exception: divide by zero
*CatchIOException> flip runStateT 22 $ catchArithException (liftIO $ evaluate $ 100 `div` 0) 01
(1,22)
*CatchIOException> flip runStateT 22 $ catchArithException' (liftIO $ evaluate $ 100 `div` 0) 01
divide by zero
"error caught by catch."
(1,22)
*CatchIOException> flip runStateT 22 $ catchExceptions (liftIO $ evaluate $ 100 `div` 0) 01
divide by zero
(1,22)

 同様に,blockメソッドやunblockメソッドを利用することで,第26回で説明したような非同期例外に対する処理を記述できます。興味のある方は,第26回の説明や今回の例を参考にテスト用のプログラムを書いてみてください。