{-# LANGUAGE CPP
, NoImplicitPrelude
, UnicodeSyntax
, DeriveDataTypeable
#-}
module Main where
--------------------------------------------------------------------------------
-- Imports
--------------------------------------------------------------------------------
-- from base:
import Control.Concurrent ( ThreadId, threadDelay, throwTo, killThread )
import Control.Exception ( Exception, fromException
, AsyncException(ThreadKilled)
, throwIO
, unblock, block, blocked
)
import Control.Monad ( return, (>>=), fail, (>>) )
import Data.Bool ( Bool(False, True), not )
import Data.Eq ( Eq )
import Data.Either ( either )
import Data.Function ( ($), const )
import Data.Functor ( fmap, (<$>) )
import Data.Int ( Int )
import Data.IORef ( newIORef, readIORef, writeIORef )
import Data.Typeable ( Typeable )
import Prelude ( fromInteger )
import System.Timeout ( timeout )
import System.IO ( IO )
import Text.Show ( Show )
-- from base-unicode-symbols:
import Prelude.Unicode ( (⋅) )
import Data.Function.Unicode ( (∘) )
-- from concurrent-extra:
import qualified Control.Concurrent.Lock as Lock
-- 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 )
import Control.Concurrent.Thread.Group ( ThreadGroup )
import qualified Control.Concurrent.Thread as Thread
import qualified Control.Concurrent.Thread.Group as ThreadGroup
import Utils ( isJustTrue, justEq, (<$$>) )
--------------------------------------------------------------------------------
-- Tests
--------------------------------------------------------------------------------
main ∷ IO ()
main = defaultMain tests
tests ∷ [Test]
tests = [ testGroup "Thread" $
[ testGroup "forkIO" $
[ testCase "wait" $ test_wait Thread.forkIO
, testCase "isRunning" $ test_isRunning Thread.forkIO
, testCase "blockedState" $ test_blockedState Thread.forkIO
, testCase "unblockedState" $ test_unblockedState 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 "isRunning" $ test_isRunning Thread.forkOS
, testCase "blockedState" $ test_blockedState Thread.forkOS
, testCase "unblockedState" $ test_unblockedState Thread.forkOS
, testCase "sync exception" $ test_sync_exception Thread.forkOS
, testCase "async exception" $ test_async_exception Thread.forkOS
]
#ifdef __GLASGOW_HASKELL__
, testGroup "forkOnIO 0" $
[ testCase "wait" $ test_wait (Thread.forkOnIO 0)
, testCase "isRunning" $ test_isRunning (Thread.forkOnIO 0)
, testCase "blockedState" $ test_blockedState (Thread.forkOnIO 0)
, testCase "unblockedState" $ test_unblockedState (Thread.forkOnIO 0)
, testCase "sync exception" $ test_sync_exception (Thread.forkOnIO 0)
, testCase "async exception" $ test_async_exception (Thread.forkOnIO 0)
]
#endif
]
, testGroup "ThreadGroup" $
[ testGroup "forkIO" $
[ testCase "wait" $ wrapIO test_wait
, testCase "isRunning" $ wrapIO test_isRunning
, testCase "blockedState" $ wrapIO test_blockedState
, testCase "unblockedState" $ wrapIO test_unblockedState
, 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 single isRunning" $ test_group_single_isRunning ThreadGroup.forkIO
]
, testGroup "forkOS" $
[ testCase "wait" $ wrapOS test_wait
, testCase "isRunning" $ wrapOS test_isRunning
, testCase "blockedState" $ wrapOS test_blockedState
, testCase "unblockedState" $ wrapOS test_unblockedState
, 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 single isRunning" $ test_group_single_isRunning ThreadGroup.forkOS
]
#ifdef __GLASGOW_HASKELL__
, testGroup "forkOnIO 0" $
[ testCase "wait" $ wrapOnIO_0 test_wait
, testCase "isRunning" $ wrapOnIO_0 test_isRunning
, testCase "blockedState" $ wrapOnIO_0 test_blockedState
, testCase "unblockedState" $ wrapOnIO_0 test_unblockedState
, testCase "sync exception" $ wrapOnIO_0 test_sync_exception
, testCase "async exception" $ wrapOnIO_0 test_async_exception
, testCase "group single wait" $ test_group_single_wait (ThreadGroup.forkOnIO 0)
, testCase "group single isRunning" $ test_group_single_isRunning (ThreadGroup.forkOnIO 0)
]
#endif
]
]
-- Exactly 1 moment. Currently equal to 0.005 seconds.
a_moment ∷ Int
a_moment = 5000
--------------------------------------------------------------------------------
-- General properties
--------------------------------------------------------------------------------
type Fork α = IO α → IO (ThreadId, Result α)
test_wait ∷ Fork () → Assertion
test_wait fork = assert $ fmap isJustTrue $ timeout (10 ⋅ a_moment) $ do
r ← newIORef False
(_, result) ← fork $ do
threadDelay $ 2 ⋅ a_moment
writeIORef r True
_ ← Thread.wait result
readIORef r
test_isRunning ∷ Fork () → Assertion
test_isRunning fork = assert $ fmap isJustTrue $ timeout (10 ⋅ a_moment) $ do
l ← Lock.newAcquired
(_, result) ← fork $ Lock.acquire l
r ← Thread.isRunning result
Lock.release l
return r
test_blockedState ∷ Fork Bool → Assertion
test_blockedState fork = do (_, result) ← block $ fork $ blocked
Thread.unsafeWait result >>= assert
test_unblockedState ∷ Fork Bool → Assertion
test_unblockedState fork = do (_, result) ← unblock $ fork $ not <$> blocked
Thread.unsafeWait result >>= assert
test_sync_exception ∷ Fork () → Assertion
test_sync_exception fork = assert $ do
(_, result) ← fork $ throwIO MyException
waitForException MyException result
waitForException ∷ (Exception e, Eq e) ⇒ e → Result α → IO Bool
waitForException e result = Thread.wait result <$$>
either (justEq e ∘ fromException)
(const False)
test_async_exception ∷ Fork () → Assertion
test_async_exception fork = assert $ do
l ← Lock.newAcquired
(tid, result) ← fork $ Lock.acquire l
throwTo tid MyException
waitForException MyException result
data MyException = MyException deriving (Show, Eq, Typeable)
instance Exception MyException
test_killThread ∷ Fork () → Assertion
test_killThread fork = assert $ do
l ← Lock.newAcquired
(tid, result) ← fork $ Lock.acquire l
killThread tid
waitForException ThreadKilled result
--------------------------------------------------------------------------------
-- ThreadGroup
--------------------------------------------------------------------------------
wrapIO ∷ (Fork α → IO β) → IO β
wrapIO = wrap ThreadGroup.forkIO
wrapOS ∷ (Fork α → IO β) → IO β
wrapOS = wrap ThreadGroup.forkOS
#ifdef __GLASGOW_HASKELL__
wrapOnIO_0 ∷ (Fork α → IO β) → IO β
wrapOnIO_0 = wrap $ ThreadGroup.forkOnIO 0
#endif
wrap ∷ (ThreadGroup → Fork α) → (Fork α → IO β) → IO β
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_single_isRunning ∷ (ThreadGroup → Fork ()) → Assertion
test_group_single_isRunning doFork = assert $ fmap isJustTrue $ timeout (10 ⋅ a_moment) $ do
tg ← ThreadGroup.new
l ← Lock.newAcquired
_ ← doFork tg $ Lock.acquire l
r ← ThreadGroup.isAnyRunning tg
Lock.release l
return r
-- The End ---------------------------------------------------------------------