1{-# LANGUAGE DeriveDataTypeable, RankNTypes #-} 2 3module Main where 4 5 6-------------------------------------------------------------------------------- 7-- Imports 8-------------------------------------------------------------------------------- 9 10-- from base: 11import Prelude hiding (catch) 12import Control.Exception ( Exception, SomeException, throwIO ) 13import qualified Control.Exception as E ( mask, bracket, bracket_ ) 14import Data.Typeable 15import Control.Monad (join) 16 17-- from criterion: 18import Criterion.Main 19 20-- from transformers: 21import Control.Monad.IO.Class 22import Control.Monad.Trans.Maybe 23import Control.Monad.Trans.Reader 24import Control.Monad.Trans.State 25import Control.Monad.Trans.Writer 26 27-- from monad-peel: 28import qualified Control.Exception.Peel as MP 29import qualified Control.Monad.IO.Peel as MP 30 31-- from monad-control: 32import qualified Control.Monad.Trans.Control as MC 33 34-- from lifted-base: 35import qualified Control.Exception.Lifted as MC 36 37 38-------------------------------------------------------------------------------- 39-- Main 40-------------------------------------------------------------------------------- 41 42main :: IO () 43main = defaultMain 44 [ b "bracket" benchBracket MP.bracket MC.bracket 45 , b "bracket_" benchBracket_ MP.bracket_ MC.bracket_ 46 , b "catch" benchCatch MP.catch MC.catch 47 , b "try" benchTry MP.try MC.try 48 49 , bgroup "mask" 50 [ bench "monad-peel" $ whnfIO $ benchMask mpMask 51 , bench "monad-control" $ whnfIO $ benchMask MC.mask 52 ] 53 54 , bgroup "liftIOOp" 55 [ bench "monad-peel" $ whnfIO $ exe $ MP.liftIOOp (E.bracket nop (\_ -> nop)) 56 (\_ -> nop) 57 , bench "monad-control" $ whnfIO $ exe $ MC.liftBaseOp (E.bracket nop (\_ -> nop)) 58 (\_ -> nop) 59 ] 60 61 , bgroup "liftIOOp_" 62 [ bench "monad-peel" $ whnfIO $ exe $ MP.liftIOOp_ (E.bracket_ nop nop) nop 63 , bench "monad-control" $ whnfIO $ exe $ MC.liftBaseOp_ (E.bracket_ nop nop) nop 64 ] 65 ] 66 67b name bnch peel mndCtrl = bgroup name 68 [ bench "monad-peel" $ whnfIO $ bnch peel 69 , bench "monad-control" $ whnfIO $ bnch mndCtrl 70 ] 71 72-------------------------------------------------------------------------------- 73-- Monad stack 74-------------------------------------------------------------------------------- 75 76type M a = ReaderT Int (StateT Bool (WriterT String (MaybeT IO))) a 77 78type R a = IO (Maybe ((a, Bool), String)) 79 80runM :: Int -> Bool -> M a -> R a 81runM r s m = runMaybeT (runWriterT (runStateT (runReaderT m r) s)) 82 83exe :: M a -> R a 84exe = runM 0 False 85 86 87-------------------------------------------------------------------------------- 88-- Benchmarks 89-------------------------------------------------------------------------------- 90 91benchBracket bracket = exe $ bracket nop (\_ -> nop) (\_ -> nop) 92benchBracket_ bracket_ = exe $ bracket_ nop nop nop 93benchCatch catch = exe $ catch throwE (\E -> nop) 94benchTry try = exe $ try throwE :: R (Either E ()) 95 96benchMask :: (((forall a. M a -> M a) -> M ()) -> M ()) -> R () 97benchMask mask = exe $ mask $ \restore -> nop >> restore nop >> nop 98 99 100-------------------------------------------------------------------------------- 101-- Utils 102-------------------------------------------------------------------------------- 103 104nop :: Monad m => m () 105nop = return () 106 107data E = E deriving (Show, Typeable) 108 109instance Exception E 110 111throwE :: MonadIO m => m () 112throwE = liftIO $ throwIO E 113 114mpMask :: MP.MonadPeelIO m => ((forall a. m a -> m a) -> m b) -> m b 115mpMask f = do 116 k <- MP.peelIO 117 join $ liftIO $ E.mask $ \restore -> k $ f $ MP.liftIOOp_ restore 118