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
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
|
{-# LANGUAGE NoImplicitPrelude, DeriveDataTypeable, ImpredicativeTypes #-}
module Main where
--------------------------------------------------------------------------------
-- Imports
--------------------------------------------------------------------------------
-- from base:
import Control.Concurrent ( ThreadId, threadDelay, throwTo, killThread )
import Control.Exception ( Exception, fromException
, AsyncException(ThreadKilled)
, throwIO, mask_
, getMaskingState, MaskingState(MaskedInterruptible)
)
import Control.Monad ( return, (>>=), replicateM_ )
import Data.Bool ( Bool(False, True) )
import Data.Eq ( Eq, (==) )
import Data.Either ( either )
import Data.Function ( (.), ($), id, const, flip )
import Data.Functor ( Functor(fmap), (<$>) )
import Data.Int ( Int )
import Data.Maybe ( Maybe, maybe )
import Data.IORef ( newIORef, readIORef, writeIORef )
import Data.Typeable ( Typeable )
import System.Timeout ( timeout )
import System.IO ( IO )
import Text.Show ( Show )
import Prelude ( (*) )
-- from concurrent-extra:
import qualified Control.Concurrent.Lock as Lock
-- from stm:
import Control.Concurrent.STM ( atomically )
-- from HUnit:
import Test.HUnit ( Assertion, assert )
-- from test-framework:
import Test.Framework ( Test, defaultMain, testGroup )
-- from test-framework-hunit:
import Test.Framework.Providers.HUnit ( testCase )
-- from threads:
import Control.Concurrent.Thread ( Result, result )
import Control.Concurrent.Thread.Group ( ThreadGroup )
import qualified Control.Concurrent.Thread as Thread
import qualified Control.Concurrent.Thread.Group as ThreadGroup
--------------------------------------------------------------------------------
-- Tests
--------------------------------------------------------------------------------
main :: IO ()
main = defaultMain tests
tests :: [Test]
tests = [ testGroup "Thread" $
[ testGroup "forkIO" $
[ testCase "wait" $ test_wait Thread.forkIO
, testCase "maskingState" $ test_maskingState Thread.forkIO
, testCase "sync exception" $ test_sync_exception Thread.forkIO
, testCase "async exception" $ test_async_exception Thread.forkIO
]
, testGroup "forkOS" $
[ testCase "wait" $ test_wait Thread.forkOS
, testCase "maskingState" $ test_maskingState Thread.forkOS
, testCase "sync exception" $ test_sync_exception Thread.forkOS
, testCase "async exception" $ test_async_exception Thread.forkOS
]
, testGroup "forkOn 0" $
[ testCase "wait" $ test_wait $ Thread.forkOn 0
, testCase "maskingState" $ test_maskingState $ Thread.forkOn 0
, testCase "sync exception" $ test_sync_exception $ Thread.forkOn 0
, testCase "async exception" $ test_async_exception $ Thread.forkOn 0
]
, testGroup "forkIOWithUnmask" $
[ testCase "wait" $ test_wait $ wrapUnmask Thread.forkIOWithUnmask
, testCase "sync exception" $ test_sync_exception $ wrapUnmask Thread.forkIOWithUnmask
, testCase "async exception" $ test_async_exception $ wrapUnmask Thread.forkIOWithUnmask
]
, testGroup "forkOnWithUnmask 0" $
[ testCase "wait" $ test_wait $ wrapUnmask $ Thread.forkOnWithUnmask 0
, testCase "sync exception" $ test_sync_exception $ wrapUnmask $ Thread.forkOnWithUnmask 0
, testCase "async exception" $ test_async_exception $ wrapUnmask $ Thread.forkOnWithUnmask 0
]
]
, testGroup "ThreadGroup" $
[ testGroup "forkIO" $
[ testCase "wait" $ wrapIO test_wait
, testCase "maskingState" $ wrapIO test_maskingState
, testCase "sync exception" $ wrapIO test_sync_exception
, testCase "async exception" $ wrapIO test_async_exception
, testCase "group single wait" $ test_group_single_wait ThreadGroup.forkIO
, testCase "group nrOfRunning" $ test_group_nrOfRunning ThreadGroup.forkIO
]
, testGroup "forkOS" $
[ testCase "wait" $ wrapOS test_wait
, testCase "maskingState" $ wrapOS test_maskingState
, testCase "sync exception" $ wrapOS test_sync_exception
, testCase "async exception" $ wrapOS test_async_exception
, testCase "group single wait" $ test_group_single_wait ThreadGroup.forkOS
, testCase "group nrOfRunning" $ test_group_nrOfRunning ThreadGroup.forkOS
]
, testGroup "forkOn 0" $
[ testCase "wait" $ wrapOn_0 test_wait
, testCase "maskingState" $ wrapOn_0 test_maskingState
, testCase "sync exception" $ wrapOn_0 test_sync_exception
, testCase "async exception" $ wrapOn_0 test_async_exception
, testCase "group single wait" $ test_group_single_wait $ ThreadGroup.forkOn 0
, testCase "group nrOfRunning" $ test_group_nrOfRunning $ ThreadGroup.forkOn 0
]
, testGroup "forkIOWithUnmask" $
[ testCase "wait" $ wrapIOWithUnmask test_wait
, testCase "sync exception" $ wrapIOWithUnmask test_sync_exception
, testCase "async exception" $ wrapIOWithUnmask test_async_exception
, testCase "group single wait" $ test_group_single_wait $ wrapUnmask . ThreadGroup.forkIOWithUnmask
, testCase "group nrOfRunning" $ test_group_nrOfRunning $ wrapUnmask . ThreadGroup.forkIOWithUnmask
]
, testGroup "forkOnWithUnmask 0" $
[ testCase "wait" $ wrapOnWithUnmask test_wait
, testCase "sync exception" $ wrapOnWithUnmask test_sync_exception
, testCase "async exception" $ wrapOnWithUnmask test_async_exception
, testCase "group single wait" $ test_group_single_wait $ wrapUnmask . ThreadGroup.forkOnWithUnmask 0
, testCase "group nrOfRunning" $ test_group_nrOfRunning $ wrapUnmask . ThreadGroup.forkOnWithUnmask 0
]
]
]
-- Exactly 1 moment. Currently equal to 0.005 seconds.
a_moment :: Int
a_moment = 5000
--------------------------------------------------------------------------------
-- General properties
--------------------------------------------------------------------------------
type Fork a = IO a -> IO (ThreadId, IO (Result a))
wrapUnmask :: ((b -> a) -> t) -> a -> t
wrapUnmask forkWithUnmask = \m -> forkWithUnmask $ const m
test_wait :: Fork () -> Assertion
test_wait fork = assert $ fmap isJustTrue $ timeout (10 * a_moment) $ do
r <- newIORef False
(_, wait) <- fork $ do
threadDelay $ 2 * a_moment
writeIORef r True
_ <- wait
readIORef r
test_maskingState :: Fork Bool -> Assertion
test_maskingState fork = do (_, wait) <- mask_ $ fork $
(MaskedInterruptible ==) <$> getMaskingState
wait >>= result >>= assert
test_sync_exception :: Fork () -> Assertion
test_sync_exception fork = assert $ do
(_, wait) <- fork $ throwIO MyException
waitForException MyException wait
waitForException :: (Exception e, Eq e) => e -> IO (Result a) -> IO Bool
waitForException e wait = wait <&> either (justEq e . fromException)
(const False)
test_async_exception :: Fork () -> Assertion
test_async_exception fork = assert $ do
l <- Lock.newAcquired
(tid, wait) <- fork $ Lock.acquire l
throwTo tid MyException
waitForException MyException wait
data MyException = MyException deriving (Show, Eq, Typeable)
instance Exception MyException
test_killThread :: Fork () -> Assertion
test_killThread fork = assert $ do
l <- Lock.newAcquired
(tid, wait) <- fork $ Lock.acquire l
killThread tid
waitForException ThreadKilled wait
--------------------------------------------------------------------------------
-- ThreadGroup
--------------------------------------------------------------------------------
wrapIO :: (Fork a -> IO b) -> IO b
wrapIO = wrap ThreadGroup.forkIO
wrapOS :: (Fork a -> IO b) -> IO b
wrapOS = wrap ThreadGroup.forkOS
wrapOn_0 :: (Fork a -> IO b) -> IO b
wrapOn_0 = wrap $ ThreadGroup.forkOn 0
wrapIOWithUnmask :: (Fork a -> IO b) -> IO b
wrapIOWithUnmask = wrap $ \tg m -> ThreadGroup.forkIOWithUnmask tg (\_ -> m)
wrapOnWithUnmask :: (Fork a -> IO b) -> IO b
wrapOnWithUnmask = wrap $ \tg m -> ThreadGroup.forkOnWithUnmask 0 tg (\_ -> m)
wrap :: (ThreadGroup -> Fork a) -> (Fork a -> IO b) -> IO b
wrap doFork test = ThreadGroup.new >>= test . doFork
test_group_single_wait :: (ThreadGroup -> Fork ()) -> Assertion
test_group_single_wait doFork = assert $ fmap isJustTrue $ timeout (10 * a_moment) $ do
tg <- ThreadGroup.new
r <- newIORef False
_ <- doFork tg $ do
threadDelay $ 2 * a_moment
writeIORef r True
_ <- ThreadGroup.wait tg
readIORef r
test_group_nrOfRunning :: (ThreadGroup -> Fork ()) -> Assertion
test_group_nrOfRunning doFork = assert $ fmap isJustTrue $ timeout (10 * a_moment) $ do
tg <- ThreadGroup.new
l <- Lock.newAcquired
replicateM_ n $ doFork tg $ Lock.acquire l
true <- fmap (== n) $ (atomically $ ThreadGroup.nrOfRunning tg :: IO Int)
Lock.release l
return true
where
-- Don't set this number too big otherwise forkOS might throw an exception
-- indicating that too many OS threads have been created:
n :: Int
n = 100
--------------------------------------------------------------------------------
-- Utils
--------------------------------------------------------------------------------
-- | Check if the given value equals 'Just' 'True'.
isJustTrue :: Maybe Bool -> Bool
isJustTrue = maybe False id
-- | Check if the given value in the 'Maybe' equals the given reference value.
justEq :: Eq a => a -> Maybe a -> Bool
justEq = maybe False . (==)
-- | A flipped '<$>'.
(<&>) :: (Functor f) => f a -> (a -> b) -> f b
(<&>) = flip (<$>)
|
