threads (empty) → 0.1
raw patch · 9 files changed
+906/−0 lines, 9 filesdep +HUnitdep +QuickCheckdep +basebuild-type:Customsetup-changed
Dependencies added: HUnit, QuickCheck, base, base-unicode-symbols, concurrent-extra, test-framework, test-framework-hunit, test-framework-quickcheck2
Files
- Control/Concurrent/Thread.hs +239/−0
- Control/Concurrent/Thread/Group.hs +139/−0
- Control/Concurrent/Thread/Internal.hs +58/−0
- LICENSE +32/−0
- Setup.hs +62/−0
- TestUtils.hs +56/−0
- Utils.hs +48/−0
- test.hs +179/−0
- threads.cabal +93/−0
+ Control/Concurrent/Thread.hs view
@@ -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 <v.dijk.bas@gmail.com>+-- , Roel van Dijk <vandijk.roel@gmail.com>+--+-- 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\"+(<http://research.microsoft.com/~simonpj/Papers/asynch-exns.htm>). 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 ---------------------------------------------------------------------
+ Control/Concurrent/Thread/Group.hs view
@@ -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 <v.dijk.bas@gmail.com>+-- , Roel van Dijk <vandijk.roel@gmail.com>+--+-- 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 ---------------------------------------------------------------------
+ Control/Concurrent/Thread/Internal.hs view
@@ -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 ---------------------------------------------------------------------
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -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 ---------------------------------------------------------------------
+ TestUtils.hs view
@@ -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 ---------------------------------------------------------------------
+ Utils.hs view
@@ -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 ---------------------------------------------------------------------
+ test.hs view
@@ -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 ---------------------------------------------------------------------
+ threads.cabal view
@@ -0,0 +1,93 @@+name: threads+version: 0.1+cabal-version: >= 1.6+build-type: Custom+stability: experimental+author: Bas van Dijk <v.dijk.bas@gmail.com>+ Roel van Dijk <vandijk.roel@gmail.com>+maintainer: Bas van Dijk <v.dijk.bas@gmail.com>+ Roel van Dijk <vandijk.roel@gmail.com>+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:+ <http://hackage.haskell.org/package/threadmanager>.+ 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++-------------------------------------------------------------------------------