Pasted

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE TypeFamilies               #-}
 
module TestTryAny where
 
import           Control.Applicative          (Alternative, empty, (<|>))
import           Control.Exception            (Exception, fromException, throwIO)
import           Control.Exception.Enclosed   (tryAny, catchAny)
import           Control.Monad.Base           (MonadBase)
import           Control.Monad.IO.Class       (MonadIO, liftIO)
import           Control.Monad.Trans.Control  (MonadBaseControl, StM, liftBaseWith, restoreM)
import           Control.Monad.Trans.Resource ()
import           Data.Typeable                (Typeable)
 
-- Explore tryAny behavior, transformers and MonadBaseControl
 
data IOAlternativeEmpty = IOAlternativeEmpty deriving (Typeable, Show)
 
instance Exception IOAlternativeEmpty
 
newtype MyIO a = MyIO { runMyIO :: IO a }
  deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO)
 
instance MonadBaseControl IO MyIO where
  type StM MyIO a = a
  liftBaseWith f = liftIO $ f runMyIO
  restoreM = return
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}
 
instance Alternative MyIO where
    empty = liftIO $ throwIO IOAlternativeEmpty
    x <|> y = x `catchAny` \xe ->
        y `catchAny` \ye -> case fromException ye of
            Just IOAlternativeEmpty -> liftIO $ throwIO xe
            _ -> liftIO $ throwIO ye
 
testThis :: IO ()
testThis = runMyIO $ liftIO $ do
    print =<< tryAny (putStrLn "one" <|> putStrLn "two")
    print =<< tryAny (error "oops" <|> putStrLn "two")
    print =<< tryAny (error "oops" <|> error "here" :: IO ())
    print =<< tryAny (putStrLn "one" <|> empty)
    print =<< tryAny (empty <|> putStrLn "two")
    print =<< tryAny (empty <|> empty :: IO ())
    print =<< tryAny (error "oops" <|> empty :: IO ())
    print =<< tryAny (empty <|> error "here" :: IO ())