Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- {-# 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 ())
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement