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