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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
|
{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts #-}
-- from base:
#if !MIN_VERSION_base(4,6,0)
import Prelude hiding (catch)
#endif
import Data.IORef
import Data.Maybe
import Data.Typeable (Typeable)
-- from transformers-base:
import Control.Monad.Base (liftBase)
-- from transformers:
import Control.Monad.Trans.Identity
import Control.Monad.Trans.List
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Writer
import Control.Monad.Trans.Except
import Control.Monad.Trans.State
import qualified Control.Monad.Trans.RWS as RWS
-- from monad-control:
import Control.Monad.Trans.Control (MonadBaseControl)
-- from lifted-base (this package):
import Control.Exception.Lifted
-- from test-framework:
import Test.Framework (defaultMain, testGroup, Test)
-- from test-framework-hunit:
import Test.Framework.Providers.HUnit
-- from hunit:
import Test.HUnit hiding (Test)
main :: IO ()
main = defaultMain
[ testSuite "IdentityT" runIdentityT
, testSuite "ListT" $ fmap head . runListT
, testSuite "MaybeT" $ fmap fromJust . runMaybeT
, testSuite "ReaderT" $ flip runReaderT "reader state"
, testSuite "WriterT" runWriterT'
, testSuite "ExceptT" runExceptT'
, testSuite "StateT" $ flip evalStateT "state state"
, testSuite "RWST" $ \m -> runRWST' m "RWS in" "RWS state"
, testCase "ExceptT throwE" case_throwE
, testCase "WriterT tell" case_tell
]
where
runWriterT' :: Functor m => WriterT [Int] m a -> m a
runWriterT' = fmap fst . runWriterT
runExceptT' :: Functor m => ExceptT String m () -> m ()
runExceptT' = fmap (either (const ()) id) . runExceptT
runRWST' :: (Monad m, Functor m) => RWS.RWST r [Int] s m a -> r -> s -> m a
runRWST' m r s = fmap fst $ RWS.evalRWST m r s
testSuite :: MonadBaseControl IO m => String -> (m () -> IO ()) -> Test
testSuite s run = testGroup s
[ testCase "finally" $ case_finally run
, testCase "catch" $ case_catch run
, testCase "bracket" $ case_bracket run
, testCase "bracket_" $ case_bracket_ run
, testCase "onException" $ case_onException run
]
ignore :: IO () -> IO ()
ignore x =
catch x go
where
go :: SomeException -> IO ()
go _ = return ()
data Exc = Exc
deriving (Show, Typeable)
instance Exception Exc
one :: Int
one = 1
case_finally :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion
case_finally run = do
i <- newIORef one
ignore
(run $ (do
liftBase $ writeIORef i 2
error "error") `finally` (liftBase $ writeIORef i 3))
j <- readIORef i
j @?= 3
case_catch :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion
case_catch run = do
i <- newIORef one
run $ (do
liftBase $ writeIORef i 2
throw Exc) `catch` (\Exc -> liftBase $ writeIORef i 3)
j <- readIORef i
j @?= 3
case_bracket :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion
case_bracket run = do
i <- newIORef one
ignore $ run $ bracket
(liftBase $ writeIORef i 2)
(\() -> liftBase $ writeIORef i 4)
(\() -> liftBase $ writeIORef i 3)
j <- readIORef i
j @?= 4
case_bracket_ :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion
case_bracket_ run = do
i <- newIORef one
ignore $ run $ bracket_
(liftBase $ writeIORef i 2)
(liftBase $ writeIORef i 4)
(liftBase $ writeIORef i 3)
j <- readIORef i
j @?= 4
case_onException :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion
case_onException run = do
i <- newIORef one
ignore $ run $ onException
(liftBase (writeIORef i 2) >> error "ignored")
(liftBase $ writeIORef i 3)
j <- readIORef i
j @?= 3
ignore $ run $ onException
(liftBase $ writeIORef i 4)
(liftBase $ writeIORef i 5)
k <- readIORef i
k @?= 4
case_throwE :: Assertion
case_throwE = do
i <- newIORef one
Left "throwE" <- runExceptT $
(liftBase (writeIORef i 2) >> throwE "throwE")
`finally`
(liftBase $ writeIORef i 3)
j <- readIORef i
j @?= 3
case_tell :: Assertion
case_tell = do
i <- newIORef one
((), w) <- runWriterT $ bracket_
(liftBase (writeIORef i 2) >> tell [1 :: Int])
(liftBase (writeIORef i 4) >> tell [3])
(liftBase (writeIORef i 3) >> tell [2])
j <- readIORef i
j @?= 4
w @?= [2]
((), w') <- runWriterT $ bracket
(liftBase (writeIORef i 5) >> tell [5 :: Int])
(const $ liftBase (writeIORef i 7) >> tell [7])
(const $ liftBase (writeIORef i 6) >> tell [6])
j' <- readIORef i
j' @?= 7
w' @?= [5, 6]
|
