File: bench.hs

package info (click to toggle)
haskell-lifted-base 0.2.3.12-2
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 144 kB
  • sloc: haskell: 982; makefile: 3; ansic: 3
file content (117 lines) | stat: -rw-r--r-- 3,729 bytes parent folder | download | duplicates (5)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
{-# LANGUAGE DeriveDataTypeable, RankNTypes #-}

module Main where


--------------------------------------------------------------------------------
-- Imports
--------------------------------------------------------------------------------

-- from base:
import Prelude hiding (catch)
import Control.Exception ( Exception, SomeException, throwIO )
import qualified Control.Exception as E ( mask, bracket, bracket_ )
import Data.Typeable
import Control.Monad (join)

-- from criterion:
import Criterion.Main

-- from transformers:
import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State
import Control.Monad.Trans.Writer

-- from monad-peel:
import qualified Control.Exception.Peel as MP
import qualified Control.Monad.IO.Peel  as MP

-- from monad-control:
import qualified Control.Monad.Trans.Control as MC

-- from lifted-base:
import qualified Control.Exception.Lifted as MC


--------------------------------------------------------------------------------
-- Main
--------------------------------------------------------------------------------

main :: IO ()
main = defaultMain
  [ b "bracket"   benchBracket  MP.bracket   MC.bracket
  , b "bracket_"  benchBracket_ MP.bracket_  MC.bracket_
  , b "catch"     benchCatch    MP.catch     MC.catch
  , b "try"       benchTry      MP.try       MC.try

  , bgroup "mask"
    [ bench "monad-peel"    $ whnfIO $ benchMask mpMask
    , bench "monad-control" $ whnfIO $ benchMask MC.mask
    ]

  , bgroup "liftIOOp"
    [ bench "monad-peel"    $ whnfIO $ exe $ MP.liftIOOp   (E.bracket nop (\_ -> nop))
                                                           (\_ -> nop)
    , bench "monad-control" $ whnfIO $ exe $ MC.liftBaseOp (E.bracket nop (\_ -> nop))
                                                           (\_ -> nop)
    ]

  , bgroup "liftIOOp_"
    [ bench "monad-peel"    $ whnfIO $ exe $ MP.liftIOOp_   (E.bracket_ nop nop) nop
    , bench "monad-control" $ whnfIO $ exe $ MC.liftBaseOp_ (E.bracket_ nop nop) nop
    ]
  ]

b name bnch peel mndCtrl = bgroup name
  [ bench "monad-peel"    $ whnfIO $ bnch peel
  , bench "monad-control" $ whnfIO $ bnch mndCtrl
  ]

--------------------------------------------------------------------------------
-- Monad stack
--------------------------------------------------------------------------------

type M a = ReaderT Int (StateT Bool (WriterT String (MaybeT IO))) a

type R a = IO (Maybe ((a, Bool), String))

runM :: Int -> Bool -> M a -> R a
runM r s m = runMaybeT (runWriterT (runStateT (runReaderT m r) s))

exe :: M a -> R a
exe = runM 0 False


--------------------------------------------------------------------------------
-- Benchmarks
--------------------------------------------------------------------------------

benchBracket   bracket   = exe $              bracket  nop (\_ -> nop)  (\_ -> nop)
benchBracket_  bracket_  = exe $              bracket_ nop nop          nop
benchCatch     catch     = exe $ catch throwE (\E -> nop)
benchTry       try       = exe $ try throwE :: R (Either E ())

benchMask :: (((forall a. M a -> M a) -> M ()) -> M ()) -> R ()
benchMask mask = exe $ mask $ \restore -> nop >> restore nop >> nop


--------------------------------------------------------------------------------
-- Utils
--------------------------------------------------------------------------------

nop :: Monad m => m ()
nop = return ()

data E = E deriving (Show, Typeable)

instance Exception E

throwE :: MonadIO m => m ()
throwE = liftIO $ throwIO E

mpMask :: MP.MonadPeelIO m => ((forall a. m a -> m a) -> m b) -> m b
mpMask f = do
  k <- MP.peelIO
  join $ liftIO $ E.mask $ \restore -> k $ f $ MP.liftIOOp_ restore