try で複数の例外をキャッチしたい場合

ExceptionUtil.hs

{-# LANGUAGE GADTs #-}

module Control.ExceptionUtil where

import Control.Exception

data TrySelection a where
  TrySelection :: Exception e => (e -> a) -> TrySelection a

trySelectionBuilder :: [TrySelection a] -> SomeException -> Maybe a
trySelectionBuilder ss e = foldr buildResult Nothing ss
  where
    buildResult (TrySelection selection) res = case fromException e of
      Just e' -> Just $ selection e'
      Nothing -> res
{-# INLINE trySelectionBuilder #-}

trySelection :: [TrySelection b] -> IO a -> IO (Either b a)
trySelection ss m = tryJust (trySelectionBuilder ss) m
{-# INLINE trySelection #-}

Sample.hs

{-# LANGUAGE BlockArguments #-}

module Main where

import Control.Exception
import Control.ExceptionUtil

main :: IO ()
main = do
  v1 <- trySelection selection
    $ print $ (head []) `div` (0 :: Int)
  fromLeftAction v1
  -- => some Prelude.head: empty list
  
  v2 <- trySelection selection
    $ print $ 1 `div` (0 :: Int)
  fromLeftAction v2
  -- => arith divide by zero
  
  v3 <- trySelection selection
    $ print $ 1 `div` (1 :: Int)
  fromLeftAction v3
  -- => 1
  where
    selection =
      [ TrySelection \e -> putStrLn $ "arith " <> displayException (e :: ArithException)
      , TrySelection \e -> putStrLn $ "some " <> displayException (e :: SomeException)
      ]
  
    fromLeftAction (Right v) = pure v
    fromLeftAction (Left  m) = m