diff --git a/Control/Concurrent/Thread.hs b/Control/Concurrent/Thread.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Thread.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax #-} + +------------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.Thread +-- Copyright : (c) 2010 Bas van Dijk & Roel van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- , Roel van Dijk +-- +-- Standard threads extended with the ability to wait for their termination. +-- +-- This module exports equivalently named functions from +-- @Control.Concurrent@. Avoid ambiguities by importing one or both +-- qualified. We suggest importing this module like: +-- +-- @ +-- import qualified Control.Concurrent.Thread as Thread ( ... ) +-- @ +-- +------------------------------------------------------------------------------- + +module Control.Concurrent.Thread + ( ThreadId + , threadId + + -- * Forking threads + , forkIO + , forkOS + + -- * Waiting on threads + , wait + , wait_ + , unsafeWait + , unsafeWait_ + + -- * Querying thread status + , status + , isRunning + + -- * Convenience functions + , throwTo + , killThread + ) where + + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +-- from base: +import qualified Control.Concurrent as C ( ThreadId, forkIO, forkOS, throwTo ) +import Control.Concurrent.MVar ( newEmptyMVar, putMVar, readMVar ) +import Control.Exception ( Exception, SomeException + , AsyncException(ThreadKilled) + , blocked, block, unblock, try + ) +#ifdef __HADDOCK__ +import qualified Control.Concurrent as C ( killThread ) +#endif +import Control.Monad ( return, (>>=), (>>), fail ) +import Data.Bool ( Bool(..) ) +import Data.Either ( Either(..), either ) +import Data.Function ( ($), const ) +import Data.Functor ( fmap ) +import Data.Maybe ( Maybe(..), isNothing ) +import System.IO ( IO ) + +-- from base-unicode-symbols: +import Data.Function.Unicode ( (∘) ) + +-- from concurrent-extra: +import Utils ( void, throwInner, tryRead ) + +import Control.Concurrent.Thread.Internal ( ThreadId(ThreadId) + , result, threadId + ) + + +------------------------------------------------------------------------------- +-- * Forking threads +------------------------------------------------------------------------------- + +{-| +Sparks off a new thread to run the given 'IO' computation and returns the +'ThreadId' of the newly created 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'). +-} +forkIO ∷ IO α → IO (ThreadId α) +forkIO = fork C.forkIO + +{-| +Like 'forkIO', this sparks off a new thread to run the given 'IO' computation +and returns the 'ThreadId' of the newly created 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@. +-} +forkOS ∷ IO α → IO (ThreadId α) +forkOS = fork C.forkOS + +{-| +Internally used function which generalises 'forkIO' and 'forkOS'. Parametrised +by the function which does the actual forking. +-} +fork ∷ (IO () → IO C.ThreadId) → IO α → IO (ThreadId α) +fork doFork a = do + res ← newEmptyMVar + b ← blocked + fmap (ThreadId res) $ block $ doFork $ try (if b then a else unblock a) >>= + putMVar res + + +------------------------------------------------------------------------------- +-- * Waiting on threads +------------------------------------------------------------------------------- + +{-| +Block until the given thread is terminated. + +* Returns @'Right' x@ if the thread terminated normally and returned @x@. + +* Returns @'Left' e@ if some exception @e@ was thrown in the thread and wasn't +caught. +-} +wait ∷ ThreadId α → IO (Either SomeException α) +wait = readMVar ∘ result + +-- | Like 'wait' but will ignore the value returned by the thread. +wait_ ∷ ThreadId α → IO () +wait_ = void ∘ wait + +-- | Like 'wait' but will either rethrow the exception that was thrown in the +-- thread or return the value that was returned by the thread. +unsafeWait ∷ ThreadId α → IO α +unsafeWait tid = wait tid >>= either throwInner return + +-- | Like 'unsafeWait' in that it will rethrow the exception that was thrown in +-- the thread but it will ignore the value returned by the thread. +unsafeWait_ ∷ ThreadId α → IO () +unsafeWait_ tid = wait tid >>= either throwInner (const $ return ()) + + +------------------------------------------------------------------------------- +-- * Quering thread status +------------------------------------------------------------------------------- + +{-| +A non-blocking 'wait'. + +* Returns 'Nothing' if the thread is still running. + +* Returns @'Just' ('Right' x)@ if the thread terminated normally and returned @x@. + +* Returns @'Just' ('Left' e)@ if some exception @e@ was thrown in the thread and +wasn't caught. + +Notice that this observation is only a snapshot of a thread's state. By the time +a program reacts on its result it may already be out of date. +-} +status ∷ ThreadId α → IO (Maybe (Either SomeException α)) +status = tryRead ∘ result + +{-| +Returns 'True' if the thread is currently running and 'False' otherwise. + +Notice that this observation is only a snapshot of a thread's state. By the time +a program reacts on its result it may already be out of date. +-} +isRunning ∷ ThreadId α → IO Bool +isRunning = fmap isNothing ∘ status + + +------------------------------------------------------------------------------- +-- * Convenience functions +------------------------------------------------------------------------------- + +{-| +'throwTo' raises an arbitrary exception in the target thread (GHC only). + +'throwTo' does not return until the exception has been raised in the target +thread. The calling thread can thus be certain that the target thread has +received the exception. This is a useful property to know when dealing with race +conditions: eg. if there are two threads that can kill each other, it is +guaranteed that only one of the threads will get to kill the other. + +If the target thread is currently making a foreign call, then the exception will +not be raised (and hence 'throwTo' will not return) until the call has +completed. This is the case regardless of whether the call is inside a 'block' +or not. + +Important note: the behaviour of 'throwTo' differs from that described in the +paper \"Asynchronous exceptions in Haskell\" +(). In the paper, +'throwTo' is non-blocking; but the library implementation adopts a more +synchronous design in which 'throwTo' does not return until the exception is +received by the target thread. The trade-off is discussed in Section 9 of the +paper. Like any blocking operation, 'throwTo' is therefore interruptible (see +Section 5.3 of the paper). + +There is currently no guarantee that the exception delivered by 'throwTo' will +be delivered at the first possible opportunity. In particular, a thread may +'unblock' and then re-'block' exceptions without receiving a pending +'throwTo'. This is arguably undesirable behaviour. +-} +throwTo ∷ Exception e ⇒ ThreadId α → e → IO () +throwTo = C.throwTo ∘ threadId + +{-| +'killThread' terminates the given thread (GHC only). Any work already done by +the thread isn't lost: the computation is suspended until required by another +thread. The memory used by the thread will be garbage collected if it isn't +referenced from anywhere. The 'killThread' function is defined in terms of +'throwTo'. + +Note that this function is different than @Control.Concurrent.'C.killThread'@ in +that it blocks until the target thread is terminated: + +@killThread tid = 'throwTo' tid 'ThreadKilled' '>>' 'wait_' tid@ +-} +killThread ∷ ThreadId α → IO () +killThread tid = throwTo tid ThreadKilled >> wait_ tid + + +-- The End --------------------------------------------------------------------- diff --git a/Control/Concurrent/Thread/Group.hs b/Control/Concurrent/Thread/Group.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Thread/Group.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE CPP + , DeriveDataTypeable + , NoImplicitPrelude + , UnicodeSyntax + #-} + +------------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.Thread.Group +-- Copyright : (c) 2010 Bas van Dijk & Roel van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- , Roel van Dijk +-- +-- This module extends @Control.Concurrent.Thread@ with the ability to wait for +-- a group of threads to terminate. +-- +-- This module exports equivalently named functions from @Control.Concurrent@ +-- and @Control.Concurrent.Thread@. Avoid ambiguities by importing one or both +-- qualified. We suggest importing this module like: +-- +-- @ +-- import Control.Concurrent.Thread.Group ( ThreadGroup ) +-- import qualified Control.Concurrent.Thread.Group as ThreadGroup ( ... ) +-- @ +-- +--------------------------------------------------------------------------------- + +module Control.Concurrent.Thread.Group + ( -- * Creating + ThreadGroup + , new + + -- * Forking threads + , forkIO + , forkOS + + -- * Waiting & Status + , wait + , isAnyRunning + ) where + + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +-- from base: +import Control.Applicative ( (<*>) ) +import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar + , takeMVar, putMVar + ) +import Control.Exception ( blocked, block, unblock, try ) +import Control.Monad ( (>>=), (>>), fail ) +import Data.Bool ( Bool(..) ) +import Data.Function ( ($) ) +import Data.Functor ( (<$>), fmap ) +import Data.Typeable ( Typeable ) +import System.IO ( IO ) +import qualified Control.Concurrent as C ( ThreadId, forkIO, forkOS ) +import Prelude ( Integer, fromInteger, (+), (-), ($!) ) + +-- from base-unicode-symbols: +import Data.Eq.Unicode ( (≡) ) +import Data.Function.Unicode ( (∘) ) + +-- from concurrent-extra: +import Control.Concurrent.Lock ( Lock ) +import qualified Control.Concurrent.Lock as Lock ( new + , acquire, release + , wait, locked + ) +-- from threads: +import Control.Concurrent.Thread.Internal ( ThreadId( ThreadId ) ) + +import Utils ( whenThen ) + +#ifdef __HADDOCK__ +import qualified Control.Concurrent.Thread as Thread ( forkIO, forkOS ) +#endif + +------------------------------------------------------------------------------- +-- Thread groups +------------------------------------------------------------------------------- + +data ThreadGroup = ThreadGroup (MVar Integer) Lock deriving Typeable + +-- | Create a new empty group. +new ∷ IO ThreadGroup +new = ThreadGroup <$> newMVar 0 <*> Lock.new + +-- | Same as @Control.Concurrent.Thread.'Thread.forkIO'@ but additionaly adds +-- the thread to the group. +forkIO ∷ ThreadGroup → IO α → IO (ThreadId α) +forkIO = fork C.forkIO + +-- | Same as @Control.Concurrent.Thread.'Thread.forkOS'@ but additionaly adds +-- the thread to the group. +forkOS ∷ ThreadGroup → IO α → IO (ThreadId α) +forkOS = fork C.forkOS + +fork ∷ (IO () → IO C.ThreadId) → ThreadGroup → IO α → IO (ThreadId α) +fork doFork (ThreadGroup mc l) a = do + res ← newEmptyMVar + b ← blocked + block $ do + increment + fmap (ThreadId res) $ doFork $ do + try (if b then a else unblock a) >>= putMVar res + decrement + where + increment = do numThreads ← takeMVar mc + whenThen (numThreads ≡ 0) (Lock.acquire l) + (putMVar mc $! numThreads + 1) + + decrement = do numThreads ← takeMVar mc + whenThen (numThreads ≡ 1) (Lock.release l) + (putMVar mc $! numThreads - 1) + +lock ∷ ThreadGroup → Lock +lock (ThreadGroup _ l) = l + +-- | Block until all threads, that were added to the group before calling this +-- function, have terminated. +wait ∷ ThreadGroup → IO () +wait = Lock.wait ∘ lock + +{-| +Returns 'True' if any thread in the group is running and returns 'False' +otherwise. + +Notice that this observation is only a snapshot of a group's state. By the time +a program reacts on its result it may already be out of date. +-} +isAnyRunning ∷ ThreadGroup → IO Bool +isAnyRunning = Lock.locked ∘ lock + + +-- The End --------------------------------------------------------------------- diff --git a/Control/Concurrent/Thread/Internal.hs b/Control/Concurrent/Thread/Internal.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Thread/Internal.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude, UnicodeSyntax #-} + +module Control.Concurrent.Thread.Internal + ( ThreadId( ThreadId ) + , result, threadId + ) where + + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +-- from base: +import Control.Concurrent.MVar ( MVar ) +import Control.Exception ( SomeException ) +import Data.Eq ( Eq, (==) ) +import Data.Either ( Either ) +import Data.Function ( on ) +import Data.Ord ( Ord, compare ) +import Data.Typeable ( Typeable ) +import Text.Show ( Show, show ) +import qualified Control.Concurrent as C ( ThreadId ) + +-- from base-unicode-symbols: +import Data.Function.Unicode ( (∘) ) + + +------------------------------------------------------------------------------- +-- ThreadIds +------------------------------------------------------------------------------- + +{-| +A @'ThreadId' α@ is an abstract type representing a handle to a thread +that is executing or has executed a computation of type @'IO' α@. +-} +data ThreadId α = ThreadId + { result ∷ MVar (Either SomeException α) + , threadId ∷ C.ThreadId -- ^ Extract the native + -- @Control.Concurrent.'C.ThreadId'@. + } deriving Typeable + +instance Eq (ThreadId α) where + (==) = (==) `on` threadId + +-- | The @Ord@ instance implements an arbitrary total ordering over 'ThreadId's. +instance Ord (ThreadId α) where + compare = compare `on` threadId + +{-| +The @Show@ instance lets you convert an arbitrary-valued 'ThreadId' to string +form; showing a 'ThreadId' value is occasionally useful when debugging or +diagnosing the behaviour of a concurrent program. +-} +instance Show (ThreadId α) where + show = show ∘ threadId + + +-- The End --------------------------------------------------------------------- diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +Copyright (c) 2009 Bas van Dijk & Roel van Dijk + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of Bas van Dijk, Roel van Dijk and the names of + contributors may NOT be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,62 @@ +#! /usr/bin/env runhaskell + +{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-} + +module Main (main) where + + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +-- from base +import Control.Monad ( (>>), return ) +import Data.Bool ( Bool ) +import System.Cmd ( system ) +import System.FilePath ( () ) +import System.IO ( IO ) + +-- from cabal +import Distribution.Simple ( defaultMainWithHooks + , simpleUserHooks + , UserHooks(runTests, haddockHook) + , Args + ) + +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) +import Distribution.Simple.Program ( userSpecifyArgs ) +import Distribution.Simple.Setup ( HaddockFlags ) +import Distribution.PackageDescription ( PackageDescription(..) ) + + +------------------------------------------------------------------------------- +-- Cabal setup program with support for 'cabal test' and +-- which sets the CPP define '__HADDOCK __' when haddock is run. +------------------------------------------------------------------------------- + +main ∷ IO () +main = defaultMainWithHooks hooks + where + hooks = simpleUserHooks + { runTests = runTests' + , haddockHook = haddockHook' + } + +-- Run a 'test' binary that gets built when configured with '-ftest'. +runTests' ∷ Args → Bool → PackageDescription → LocalBuildInfo → IO () +runTests' _ _ _ _ = system testcmd >> return () + where testcmd = "." + "dist" + "build" + "test-threads" + "test-threads" + +-- Define __HADDOCK__ for CPP when running haddock. +haddockHook' ∷ PackageDescription → LocalBuildInfo → UserHooks → HaddockFlags → IO () +haddockHook' pkg lbi = + haddockHook simpleUserHooks pkg (lbi { withPrograms = p }) + where + p = userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] (withPrograms lbi) + + +-- The End --------------------------------------------------------------------- diff --git a/TestUtils.hs b/TestUtils.hs new file mode 100644 --- /dev/null +++ b/TestUtils.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE NoImplicitPrelude + , ScopedTypeVariables + , UnicodeSyntax + #-} + +module TestUtils where + + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +-- from base: +import Control.Applicative ( (<$>) ) +import Control.Concurrent ( threadDelay ) +import Control.Exception ( try, SomeException ) +import Control.Monad ( (>>=), return, fail ) +import Data.Bool ( Bool, not ) +import Data.Char ( String ) +import Data.Either ( Either(Left, Right) ) +import Data.Int ( Int ) +import Data.Maybe ( isJust ) +import Prelude ( fromInteger ) +import System.IO ( IO ) +import System.Timeout ( timeout ) + +-- from HUnit: +import Test.HUnit ( Assertion, assertFailure ) + + +------------------------------------------------------------------------------- +-- Utilities for testing +------------------------------------------------------------------------------- + +-- Exactly 1 moment. Currently equal to 0.005 seconds. +a_moment ∷ Int +a_moment = 5000 + +wait_a_moment ∷ IO () +wait_a_moment = threadDelay a_moment + +-- True if the action 'a' evaluates within 't' μs. +within ∷ Int → IO α → IO Bool +within t a = isJust <$> timeout t a + +notWithin ∷ Int → IO α → IO Bool +notWithin t a = not <$> within t a + +assertException ∷ String → IO α → Assertion +assertException errMsg a = do e ← try a + case e of + Left (_ ∷ SomeException ) → return () + Right _ → assertFailure errMsg + + +-- The End --------------------------------------------------------------------- diff --git a/Utils.hs b/Utils.hs new file mode 100644 --- /dev/null +++ b/Utils.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-} + +module Utils where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Control.Concurrent.MVar ( MVar, putMVar, tryTakeMVar ) +import Control.Exception ( SomeException(SomeException) + , block, throwIO + ) +import Control.Monad ( Monad, return, (>>=), (>>), fail ) +import Data.Bool ( Bool ) +import Data.Function ( ($), flip ) +import Data.Functor ( Functor, (<$>), (<$) ) +import Data.Maybe ( Maybe(Nothing, Just) ) +import System.IO ( IO ) + + +-------------------------------------------------------------------------------- +-- Utility functions +-------------------------------------------------------------------------------- + +(<$$>) ∷ Functor f ⇒ f α → (α → β) → f β +(<$$>) = flip (<$>) + +void ∷ Functor f ⇒ f α → f () +void = (() <$) + +ifM ∷ Monad m ⇒ m Bool → m α → m α → m α +ifM c t e = c >>= \b → if b then t else e + +whenThen ∷ Monad m ⇒ Bool → m () → m α → m α +whenThen b t a = if b then t >> a else a + +throwInner ∷ SomeException → IO α +throwInner (SomeException e) = throwIO e + +tryRead ∷ MVar α → IO (Maybe α) +tryRead mv = block $ do mx ← tryTakeMVar mv + case mx of + Nothing → return mx + Just x → putMVar mv x >> return mx + + +-- The End --------------------------------------------------------------------- diff --git a/test.hs b/test.hs new file mode 100644 --- /dev/null +++ b/test.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax, DeriveDataTypeable #-} + +module Main where + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +-- from base: +import Control.Concurrent ( threadDelay ) +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 ( ($), id, const ) +import Data.Functor ( fmap ) +import Data.IORef ( newIORef, readIORef, writeIORef ) +import Data.Maybe ( maybe ) +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.Eq.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 qualified Control.Concurrent.Thread as Thread +import qualified Control.Concurrent.Thread.Group as ThreadGroup + +import TestUtils ( a_moment ) +import Utils ( (<$$>) ) + + +------------------------------------------------------------------------------- +-- Tests +------------------------------------------------------------------------------- + +main ∷ IO () +main = defaultMain tests + +tests ∷ [Test] +tests = [ testGroup "Thread" $ + [ 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 "ThreadGroup" $ + [ testCase "wait" $ wrap test_wait + , testCase "isRunning" $ wrap test_isRunning + , testCase "blockedState" $ wrap test_blockedState + , testCase "unblockedState" $ wrap test_unblockedState + , testCase "sync exception" $ wrap test_sync_exception + , testCase "async exception" $ wrap test_async_exception + + , testCase "group single wait" test_group_single_wait + , testCase "group single isRunning" test_group_single_isRunning + ] + ] + + +------------------------------------------------------------------------------- +-- General properties +------------------------------------------------------------------------------- + +type Fork α = IO α → IO (Thread.ThreadId α) + +test_wait ∷ Fork () → Assertion +test_wait fork = assert + $ fmap (maybe False id) + $ timeout (10 ⋅ a_moment) $ do + r ← newIORef False + tid ← fork $ do + threadDelay $ 2 ⋅ a_moment + writeIORef r True + _ ← Thread.wait tid + readIORef r + +test_isRunning ∷ Fork () → Assertion +test_isRunning fork = assert + $ fmap (maybe False id) + $ timeout (10 ⋅ a_moment) $ do + l ← Lock.newAcquired + tid ← fork $ Lock.acquire l + r ← Thread.isRunning tid + Lock.release l + return r + +test_blockedState ∷ Fork Bool → Assertion +test_blockedState fork = (block $ fork $ blocked) >>= + Thread.unsafeWait >>= assert + +test_unblockedState ∷ Fork Bool → Assertion +test_unblockedState fork = (unblock $ fork $ fmap not $ blocked) >>= + Thread.unsafeWait >>= assert + +test_sync_exception ∷ Fork () → Assertion +test_sync_exception fork = assert $ + fork (throwIO MyException) >>= waitForException MyException + +waitForException ∷ (Exception e, Eq e) ⇒ e → Thread.ThreadId α → IO Bool +waitForException e tid = Thread.wait tid <$$> + either (maybe False (≡ e) ∘ fromException) + (const False) + +test_async_exception ∷ Fork () → Assertion +test_async_exception fork = assert $ do + l ← Lock.newAcquired + tid ← fork $ Lock.acquire l + Thread.throwTo tid MyException + waitForException MyException tid + +data MyException = MyException deriving (Show, Eq, Typeable) +instance Exception MyException + +test_killThread ∷ Fork () → Assertion +test_killThread fork = assert $ do + l ← Lock.newAcquired + tid ← fork $ Lock.acquire l + Thread.killThread tid + waitForException ThreadKilled tid + + +------------------------------------------------------------------------------- +-- ThreadGroup +------------------------------------------------------------------------------- + +wrap ∷ (Fork α → IO β) → IO β +wrap test = ThreadGroup.new >>= test ∘ ThreadGroup.forkIO + +test_group_single_wait ∷ Assertion +test_group_single_wait = assert + $ fmap (maybe False id) + $ timeout (10 ⋅ a_moment) $ do + tg ← ThreadGroup.new + r ← newIORef False + _ ← ThreadGroup.forkIO tg $ do + threadDelay $ 2 ⋅ a_moment + writeIORef r True + _ ← ThreadGroup.wait tg + readIORef r + + +test_group_single_isRunning ∷ Assertion +test_group_single_isRunning = assert + $ fmap (maybe False id) + $ timeout (10 ⋅ a_moment) $ do + tg ← ThreadGroup.new + l ← Lock.newAcquired + _ ← ThreadGroup.forkIO tg $ Lock.acquire l + r ← ThreadGroup.isAnyRunning tg + Lock.release l + return r + + +-- The End --------------------------------------------------------------------- diff --git a/threads.cabal b/threads.cabal new file mode 100644 --- /dev/null +++ b/threads.cabal @@ -0,0 +1,93 @@ +name: threads +version: 0.1 +cabal-version: >= 1.6 +build-type: Custom +stability: experimental +author: Bas van Dijk + Roel van Dijk +maintainer: Bas van Dijk + Roel van Dijk +copyright: (c) 2010 Bas van Dijk & Roel van Dijk +license: BSD3 +license-file: LICENSE +category: Concurrency +synopsis: Fork threads and wait for their result +description: This package provides functions to fork threads and + wait for their termination. The result of a thread can + also be retrieved, whether it's an exception or a + normal value. + . + Besides waiting for the termination of a single thread + this packages also provides functions to wait for a + group of threads to terminate. + . + This package is similar to: + . + The advantages of this package are: + . + * Simpler API. + . + * More efficient in both space and time. + . + * No space-leak when forking a large number of threads. + . + * Correct handling of asynchronous exceptions. + +source-repository head + Type: darcs + Location: http://code.haskell.org/~basvandijk/code/threads + +------------------------------------------------------------------------------- + +flag test + description: Build the testing suite + default: False + +flag hpc + description: Enable program coverage on test executable + default: False + +flag nolib + description: Don't build the library + default: False + +------------------------------------------------------------------------------- + +library + build-depends: base >= 3 && < 4.3 + , base-unicode-symbols >= 0.1.1 && < 0.3 + , concurrent-extra >= 0.5 && < 0.6 + exposed-modules: Control.Concurrent.Thread + , Control.Concurrent.Thread.Group + other-modules: Control.Concurrent.Thread.Internal + , Utils + ghc-options: -Wall + + if flag(nolib) + buildable: False + +------------------------------------------------------------------------------- + +executable test-threads + main-is: test.hs + other-modules: TestUtils + + ghc-options: -Wall + + if flag(test) + build-depends: base >= 3 && < 4.3 + , base-unicode-symbols >= 0.1.1 && < 0.3 + , concurrent-extra >= 0.5 && < 0.6 + , HUnit >= 1.2.2 && < 1.3 + , QuickCheck >= 2.1.0 && < 2.2 + , test-framework >= 0.2.4 && < 0.3 + , test-framework-hunit >= 0.2.4 && < 0.3 + , test-framework-quickcheck2 >= 0.2.4 && < 0.3 + buildable: True + else + buildable: False + + if flag(hpc) + ghc-options: -fhpc + +-------------------------------------------------------------------------------