threads 0.4.0.2 → 0.5
raw patch · 6 files changed
+385/−191 lines, 6 filesdep +threadsdep ~basedep ~stm
Dependencies added: threads
Dependency ranges changed: base, stm
Files
- Control/Concurrent/Thread.hs +51/−92
- Control/Concurrent/Thread/Group.hs +48/−64
- LICENSE +1/−1
- Mask.hs +0/−15
- test/test.hs +268/−0
- threads.cabal +17/−19
Control/Concurrent/Thread.hs view
@@ -1,18 +1,14 @@-{-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax #-}--#if MIN_VERSION_base(4,3,0)-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- For block and unblock-#endif+{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax, RankNTypes #-} -------------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.Thread--- Copyright : (c) 2010 Bas van Dijk & Roel van Dijk+-- Copyright : (c) 2010-2012 Bas van Dijk & Roel van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com> -- , Roel van Dijk <vandijk.roel@gmail.com> ----- Standard threads extended with the ability to wait for their termination.+-- Standard threads extended with the ability to /wait/ for their return value. -- -- This module exports equivalently named functions from @Control.Concurrent@ -- (and @GHC.Conc@). Avoid ambiguities by importing this module qualified. May@@ -41,12 +37,10 @@ ( -- * Forking threads forkIO , forkOS-#ifdef __GLASGOW_HASKELL__- , forkOnIO-#if MIN_VERSION_base(4,3,0)- , forkIOUnmasked-#endif-#endif+ , forkOn+ , forkIOWithUnmask+ , forkOnWithUnmask+ -- * Results , Result , result@@ -58,111 +52,80 @@ -------------------------------------------------------------------------------- -- from base:-import qualified Control.Concurrent ( forkIO, forkOS )+import qualified Control.Concurrent ( forkIO+ , forkOS+ , forkOn+ , forkIOWithUnmask+ , forkOnWithUnmask+ ) import Control.Concurrent ( ThreadId ) import Control.Concurrent.MVar ( newEmptyMVar, putMVar, readMVar )-import Control.Exception ( SomeException, try, throwIO )-#if MIN_VERSION_base(4,3,0)-import Control.Exception ( block, unblock )-#endif+import Control.Exception ( SomeException, try, throwIO, mask ) import Control.Monad ( return, (>>=) ) import Data.Either ( Either(..), either ) import Data.Function ( ($) )-import System.IO ( IO )--#if __GLASGOW_HASKELL__ < 700-import Control.Monad ( fail )-#endif--#ifdef __GLASGOW_HASKELL__-import qualified GHC.Conc ( forkOnIO ) import Data.Int ( Int )-#endif+import System.IO ( IO ) -- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) --- from ourselves:-import Mask ( mask ) - -------------------------------------------------------------------------------- -- * Forking threads -------------------------------------------------------------------------------- -{-|-Sparks off a new thread to run the given 'IO' computation and returns the-'ThreadId' of the newly created thread paired with an IO computation that waits-for the result of the thread.--The new thread will be a lightweight thread; if you want to use a foreign-library that uses thread-local storage, use 'forkOS' instead.--GHC note: the new thread inherits the blocked state of the parent (see-'Control.Exception.block').--}+-- | Like @Control.Concurrent.'Control.Concurrent.forkIO'@ but returns+-- a computation that when executed blocks until the thread terminates+-- then returns the final value of the thread. forkIO ∷ IO α → IO (ThreadId, IO (Result α)) forkIO = fork Control.Concurrent.forkIO -{-|-Like 'forkIO', this sparks off a new thread to run the given 'IO' computation-and returns the 'ThreadId' of the newly created thread paired with an IO-computation that waits for the result of the thread.--Unlike 'forkIO', 'forkOS' creates a /bound/ thread, which is necessary if you-need to call foreign (non-Haskell) libraries that make use of thread-local-state, such as OpenGL (see 'Control.Concurrent').--Using 'forkOS' instead of 'forkIO' makes no difference at all to the scheduling-behaviour of the Haskell runtime system. It is a common misconception that you-need to use 'forkOS' instead of 'forkIO' to avoid blocking all the Haskell-threads when making a foreign call; this isn't the case. To allow foreign calls-to be made without blocking all the Haskell threads (with GHC), it is only-necessary to use the @-threaded@ option when linking your program, and to make-sure the foreign import is not marked @unsafe@.--}+-- | Like @Control.Concurrent.'Control.Concurrent.forkOS'@ but returns+-- a computation that when executed blocks until the thread terminates+-- then returns the final value of the thread. forkOS ∷ IO α → IO (ThreadId, IO (Result α)) forkOS = fork Control.Concurrent.forkOS -#ifdef __GLASGOW_HASKELL__-{-|-Like 'forkIO', but lets you specify on which CPU the thread is-created. Unlike a 'forkIO' thread, a thread created by 'forkOnIO'-will stay on the same CPU for its entire lifetime ('forkIO' threads-can migrate between CPUs according to the scheduling policy).-'forkOnIO' is useful for overriding the scheduling policy when you-know in advance how best to distribute the threads.+-- | Like @Control.Concurrent.'Control.Concurrent.forkOn'@ but returns+-- a computation that when executed blocks until the thread terminates+-- then returns the final value of the thread.+forkOn ∷ Int → IO α → IO (ThreadId, IO (Result α))+forkOn = fork ∘ Control.Concurrent.forkOn -The 'Int' argument specifies the CPU number; it is interpreted modulo-'numCapabilities' (note that it actually specifies a capability number-rather than a CPU number, but to a first approximation the two are-equivalent).--}-forkOnIO ∷ Int → IO α → IO (ThreadId, IO (Result α))-forkOnIO = fork ∘ GHC.Conc.forkOnIO+-- | Like @Control.Concurrent.'Control.Concurrent.forkIOWithUnmask'@ but returns+-- a computation that when executed blocks until the thread terminates+-- then returns the final value of the thread.+forkIOWithUnmask ∷ ((∀ β. IO β → IO β) → IO α) → IO (ThreadId, IO (Result α))+forkIOWithUnmask = forkWithUnmask Control.Concurrent.forkIOWithUnmask -#if MIN_VERSION_base(4,3,0)--- | Like 'forkIO', but the child thread is created with asynchronous exceptions--- unmasked (see 'Control.Exception.mask').-forkIOUnmasked ∷ IO α → IO (ThreadId, IO (Result α))-forkIOUnmasked a = do- res ← newEmptyMVar- tid ← block $ Control.Concurrent.forkIO $ try (unblock a) >>= putMVar res- return (tid, readMVar res)-#endif-#endif+-- | Like @Control.Concurrent.'Control.Concurrent.forkOnWithUnmask'@ but returns+-- a computation that when executed blocks until the thread terminates+-- then returns the final value of the thread.+forkOnWithUnmask ∷ Int → ((∀ β. IO β → IO β) → IO α) → IO (ThreadId, IO (Result α))+forkOnWithUnmask = forkWithUnmask ∘ Control.Concurrent.forkOnWithUnmask + --------------------------------------------------------------------------------+-- Utils+-------------------------------------------------------------------------------- --- | Internally used function which generalises 'forkIO', 'forkOS' and--- 'forkOnIO' by parameterizing the function which does the actual forking. fork ∷ (IO () → IO ThreadId) → (IO α → IO (ThreadId, IO (Result α))) fork doFork = \a → do res ← newEmptyMVar tid ← mask $ \restore → doFork $ try (restore a) >>= putMVar res return (tid, readMVar res) +forkWithUnmask ∷ (((∀ β. IO β → IO β) → IO ()) → IO ThreadId)+ → ((∀ β. IO β → IO β) → IO α) → IO (ThreadId, IO (Result α))+forkWithUnmask doForkWithUnmask = \f → do+ res ← newEmptyMVar+ tid ← mask $ \restore →+ doForkWithUnmask $ \unmask →+ try (restore $ f unmask) >>= putMVar res+ return (tid, readMVar res) + -------------------------------------------------------------------------------- -- Results --------------------------------------------------------------------------------@@ -171,12 +134,8 @@ -- and wasn't catched or the actual value that was returned by the thread. type Result α = Either SomeException α -{-| Retrieve the actual value from the result.--When the result is 'SomeException' the exception is thrown.--}+-- | Retrieve the actual value from the result.+--+-- When the result is 'SomeException' the exception is thrown. result ∷ Result α → IO α result = either throwIO return----- The End ---------------------------------------------------------------------
Control/Concurrent/Thread/Group.hs view
@@ -2,16 +2,13 @@ , DeriveDataTypeable , NoImplicitPrelude , UnicodeSyntax+ , RankNTypes #-} -#if MIN_VERSION_base(4,3,0)-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- For block and unblock-#endif- -------------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.Thread.Group--- Copyright : (c) 2010 Bas van Dijk & Roel van Dijk+-- Copyright : (c) 2010-2012 Bas van Dijk & Roel van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com> -- , Roel van Dijk <vandijk.roel@gmail.com>@@ -39,12 +36,9 @@ -- * Forking threads , forkIO , forkOS-#ifdef __GLASGOW_HASKELL__- , forkOnIO-#if MIN_VERSION_base(4,3,0)- , forkIOUnmasked-#endif-#endif+ , forkOn+ , forkIOWithUnmask+ , forkOnWithUnmask ) where @@ -53,31 +47,24 @@ -------------------------------------------------------------------------------- -- from base:-import qualified Control.Concurrent ( forkIO, forkOS )+import qualified Control.Concurrent ( forkIO+ , forkOS+ , forkOn+ , forkIOWithUnmask+ , forkOnWithUnmask+ ) import Control.Concurrent ( ThreadId ) import Control.Concurrent.MVar ( newEmptyMVar, putMVar, readMVar )-import Control.Exception ( try )-#if MIN_VERSION_base(4,3,0)-import Control.Exception ( block, unblock )-#endif+import Control.Exception ( try, mask ) import Control.Monad ( return, (>>=), when ) import Data.Function ( ($) ) import Data.Functor ( fmap ) import Data.Eq ( Eq )+import Data.Int ( Int ) import Data.Typeable ( Typeable )-import Prelude ( ($!), Integer, succ, pred )+import Prelude ( ($!), (+), subtract ) import System.IO ( IO ) -#if __GLASGOW_HASKELL__ < 700-import Prelude ( fromInteger )-import Control.Monad ( (>>), fail )-#endif--#ifdef __GLASGOW_HASKELL__-import qualified GHC.Conc ( forkOnIO )-import Data.Int ( Int )-#endif- -- from base-unicode-symbols: import Data.Eq.Unicode ( (≢) ) import Data.Function.Unicode ( (∘) )@@ -92,19 +79,13 @@ #ifdef __HADDOCK__ import qualified Control.Concurrent.Thread as Thread ( forkIO , forkOS-#ifdef __GLASGOW_HASKELL__- , forkOnIO-#if MIN_VERSION_base(4,3,0)- , forkIOUnmasked-#endif-#endif+ , forkOn+ , forkIOWithUnmask+ , forkOnWithUnmask ) #endif --- from ourselves:-import Mask ( mask ) - -------------------------------------------------------------------------------- -- * Thread groups --------------------------------------------------------------------------------@@ -125,7 +106,7 @@ * 'wait' blocks as long as the counter is not 0. -}-newtype ThreadGroup = ThreadGroup (TVar Integer) deriving (Eq, Typeable)+newtype ThreadGroup = ThreadGroup (TVar Int) deriving (Eq, Typeable) -- | Create an empty group of threads. new ∷ IO ThreadGroup@@ -137,7 +118,7 @@ Note that because this function yields a 'STM' computation, the returned number is guaranteed to be consistent inside the transaction. -}-nrOfRunning ∷ ThreadGroup → STM Integer+nrOfRunning ∷ ThreadGroup → STM Int nrOfRunning (ThreadGroup numThreadsTV) = readTVar numThreadsTV -- | Convenience function which blocks until all threads, that were added to the@@ -160,41 +141,47 @@ forkOS ∷ ThreadGroup → IO α → IO (ThreadId, IO (Result α)) forkOS = fork Control.Concurrent.forkOS -#ifdef __GLASGOW_HASKELL__--- | Same as @Control.Concurrent.Thread.'Thread.forkOnIO'@ but--- additionaly adds the thread to the group. (GHC only)-forkOnIO ∷ Int → ThreadGroup → IO α → IO (ThreadId, IO (Result α))-forkOnIO = fork ∘ GHC.Conc.forkOnIO+-- | Same as @Control.Concurrent.Thread.'Thread.forkOn'@ but+-- additionaly adds the thread to the group.+forkOn ∷ Int → ThreadGroup → IO α → IO (ThreadId, IO (Result α))+forkOn = fork ∘ Control.Concurrent.forkOn -#if MIN_VERSION_base(4,3,0)--- | Same as @Control.Concurrent.Thread.'Thread.forkIOUnmasked'@ but--- additionaly adds the thread to the group. (GHC only)-forkIOUnmasked ∷ ThreadGroup → IO α → IO (ThreadId, IO (Result α))-forkIOUnmasked (ThreadGroup numThreadsTV) a = do- res ← newEmptyMVar- tid ← block $ do- atomically $ modifyTVar numThreadsTV succ- Control.Concurrent.forkIO $ do- try (unblock a) >>= putMVar res- atomically $ modifyTVar numThreadsTV pred- return (tid, readMVar res)-#endif-#endif+-- | Same as @Control.Concurrent.Thread.'Thread.forkIOWithUnmask'@ but+-- additionaly adds the thread to the group.+forkIOWithUnmask ∷ ThreadGroup → ((∀ β. IO β → IO β) → IO α) → IO (ThreadId, IO (Result α))+forkIOWithUnmask = forkWithUnmask Control.Concurrent.forkIOWithUnmask +-- | Like @Control.Concurrent.Thread.'Thread.forkOnWithUnmask'@ but+-- additionaly adds the thread to the group.+forkOnWithUnmask ∷ Int → ThreadGroup → ((∀ β. IO β → IO β) → IO α) → IO (ThreadId, IO (Result α))+forkOnWithUnmask = forkWithUnmask ∘ Control.Concurrent.forkOnWithUnmask++ --------------------------------------------------------------------------------+-- Utils+-------------------------------------------------------------------------------- --- | Internally used function which generalises 'forkIO', 'forkOS' and--- 'forkOnIO' by parameterizing the function which does the actual forking. fork ∷ (IO () → IO ThreadId) → ThreadGroup → IO α → IO (ThreadId, IO (Result α)) fork doFork (ThreadGroup numThreadsTV) a = do res ← newEmptyMVar tid ← mask $ \restore → do- atomically $ modifyTVar numThreadsTV succ+ atomically $ modifyTVar numThreadsTV (+ 1) doFork $ do try (restore a) >>= putMVar res- atomically $ modifyTVar numThreadsTV pred+ atomically $ modifyTVar numThreadsTV (subtract 1) return (tid, readMVar res) +forkWithUnmask ∷ (((∀ β. IO β → IO β) → IO ()) → IO ThreadId)+ → ThreadGroup → ((∀ β. IO β → IO β) → IO α) → IO (ThreadId, IO (Result α))+forkWithUnmask doForkWithUnmask = \(ThreadGroup numThreadsTV) f → do+ res ← newEmptyMVar+ tid ← mask $ \restore → do+ atomically $ modifyTVar numThreadsTV (+ 1)+ doForkWithUnmask $ \unmask → do+ try (restore $ f unmask) >>= putMVar res+ atomically $ modifyTVar numThreadsTV (subtract 1)+ return (tid, readMVar res)+ -- | Strictly modify the contents of a 'TVar'. modifyTVar ∷ TVar α → (α → α) → STM () modifyTVar tv f = readTVar tv >>= writeTVar tv ∘! f@@ -202,6 +189,3 @@ -- | Strict function composition (∘!) ∷ (β → γ) → (α → β) → (α → γ) f ∘! g = \x → f $! g x----- The End ---------------------------------------------------------------------
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2010 Bas van Dijk & Roel van Dijk+Copyright (c) 2010-2012 Bas van Dijk & Roel van Dijk All rights reserved.
− Mask.hs
@@ -1,15 +0,0 @@-{-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax #-}--module Mask ( mask ) where--#if MIN_VERSION_base(4,3,0)-import Control.Exception ( mask )-#else-import Control.Monad ( (>>=) )-import Control.Exception ( blocked, block, unblock )-import Data.Function ( ($), id )-import System.IO ( IO )--mask ∷ ((IO α → IO α) → IO β) → IO β-mask io = blocked >>= \b → if b then io id else block $ io unblock-#endif
+ test/test.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE 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, (>>=), replicateM_ )+import Data.Bool ( Bool(False, True), not )+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 )++-- from base-unicode-symbols:+import Data.Eq.Unicode ( (≡) )+import Prelude.Unicode ( (⋅) )+import Data.Function.Unicode ( (∘) )++-- 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 "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 "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+ ]+ , testGroup "forkOn 0" $+ [ testCase "wait" $ test_wait $ Thread.forkOn 0+ , testCase "blockedState" $ test_blockedState $ Thread.forkOn 0+ , testCase "unblockedState" $ test_unblockedState $ 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 "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 nrOfRunning" $ test_group_nrOfRunning ThreadGroup.forkIO+ ]+ , testGroup "forkOS" $+ [ testCase "wait" $ wrapOS test_wait+ , 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 nrOfRunning" $ test_group_nrOfRunning ThreadGroup.forkOS+ ]+ , testGroup "forkOn 0" $+ [ testCase "wait" $ wrapOn_0 test_wait+ , testCase "blockedState" $ wrapOn_0 test_blockedState+ , testCase "unblockedState" $ wrapOn_0 test_unblockedState+ , 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 α = IO α → IO (ThreadId, IO (Result α))++wrapUnmask ∷ ((β → α) → t) → α → 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_blockedState ∷ Fork Bool → Assertion+test_blockedState fork = do (_, wait) ← block $ fork $ blocked+ wait >>= result >>= assert++test_unblockedState ∷ Fork Bool → Assertion+test_unblockedState fork = do (_, wait) ← unblock $ fork $ not <$> blocked+ 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 α) → 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 α → IO β) → IO β+wrapIO = wrap ThreadGroup.forkIO++wrapOS ∷ (Fork α → IO β) → IO β+wrapOS = wrap ThreadGroup.forkOS++wrapOn_0 ∷ (Fork α → IO β) → IO β+wrapOn_0 = wrap $ ThreadGroup.forkOn 0++wrapIOWithUnmask ∷ (Fork α → IO β) → IO β+wrapIOWithUnmask = wrap $ \tg m -> ThreadGroup.forkIOWithUnmask tg $ const m++wrapOnWithUnmask ∷ (Fork α → IO β) → IO β+wrapOnWithUnmask = wrap $ \tg m -> ThreadGroup.forkOnWithUnmask 0 tg $ const m++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_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 α ⇒ α → Maybe α → Bool+justEq = maybe False ∘ (≡)++-- | A flipped '<$>'.+(<$$>) ∷ Functor f ⇒ f α → (α → β) → f β+(<$$>) = flip (<$>)
threads.cabal view
@@ -1,5 +1,5 @@ name: threads-version: 0.4.0.2+version: 0.5 cabal-version: >= 1.9.2 build-type: Custom stability: experimental@@ -10,7 +10,7 @@ copyright: 2010–2012 Bas van Dijk & Roel van Dijk license: BSD3 license-file: LICENSE-homepage: https://github.com/basvandijk/threads/+homepage: https://github.com/basvandijk/threads bug-reports: https://github.com/basvandijk/threads/issues category: Concurrency synopsis: Fork threads and wait for their result@@ -34,7 +34,7 @@ . * Correct handling of asynchronous exceptions. .- * GHC specific functionality like @forkOnIO@ and @forkIOUnmasked@.+ * GHC specific functionality like @forkOn@ and @forkIOWithUnmask@. extra-source-files: README.markdown @@ -45,28 +45,26 @@ ------------------------------------------------------------------------------- library- build-depends: base >= 3 && < 4.6+ build-depends: base >= 4.4 && < 4.6 , base-unicode-symbols >= 0.1.1 && < 0.3- , stm >= 2.1 && < 2.3+ , stm >= 2.1 && < 2.4 exposed-modules: Control.Concurrent.Thread , Control.Concurrent.Thread.Group- other-modules: Mask ghc-options: -Wall ------------------------------------------------------------------------------- test-suite test-threads- type: exitcode-stdio-1.0- main-is: test.hs-- ghc-options: -Wall -threaded-- build-depends: base >= 3 && < 4.6- , base-unicode-symbols >= 0.1.1 && < 0.3- , stm >= 2.1 && < 2.3- , concurrent-extra >= 0.5.1 && < 0.8- , HUnit >= 1.2.2 && < 1.3- , test-framework >= 0.2.4 && < 0.6- , test-framework-hunit >= 0.2.4 && < 0.3+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: test.hs+ ghc-options: -Wall -threaded --------------------------------------------------------------------------------+ build-depends: threads+ , base >= 4.4 && < 4.6+ , base-unicode-symbols >= 0.1.1 && < 0.3+ , stm >= 2.1 && < 2.4+ , concurrent-extra >= 0.5.1 && < 0.8+ , HUnit >= 1.2.2 && < 1.3+ , test-framework >= 0.2.4 && < 0.6+ , test-framework-hunit >= 0.2.4 && < 0.3