threads 0.4 → 0.4.0.1
raw patch · 6 files changed
+48/−336 lines, 6 filesdep ~basedep ~concurrent-extradep ~test-frameworksetup-changed
Dependency ranges changed: base, concurrent-extra, test-framework
Files
- Control/Concurrent/Thread.hs +1/−1
- Control/Concurrent/Thread/Group.hs +1/−1
- README.markdown +24/−0
- Setup.hs +4/−21
- test.hs +0/−283
- threads.cabal +18/−30
Control/Concurrent/Thread.hs view
@@ -70,7 +70,7 @@ import Data.Function ( ($) ) import System.IO ( IO ) -#if __GLASGOW_HASKELL__ < 701+#if __GLASGOW_HASKELL__ < 700 import Control.Monad ( fail ) #endif
Control/Concurrent/Thread/Group.hs view
@@ -68,7 +68,7 @@ import Prelude ( ($!), Integer, succ, pred ) import System.IO ( IO ) -#if __GLASGOW_HASKELL__ < 701+#if __GLASGOW_HASKELL__ < 700 import Prelude ( fromInteger ) import Control.Monad ( (>>), fail ) #endif
+ README.markdown view
@@ -0,0 +1,24 @@+This package provides functions to fork threads and wait for their+result, 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 [threadmanager], [async] and [spawn]+packages. 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.++* GHC specific functionality like [forkOnIO] and [forkIOUnmasked].++[threadmanager]: http://hackage.haskell.org/package/threadmanager+[async]: http://hackage.haskell.org/package/async+[spawn]: http://hackage.haskell.org/package/spawn+[forkOnIO]: http://hackage.haskell.org/packages/archive/base/latest/doc/html/GHC-Conc-Sync.html#v:forkOnIO+[forkIOUnmasked]: http://hackage.haskell.org/packages/archive/base/latest/doc/html/GHC-Conc-Sync.html#v:forkOnIOUnmasked
Setup.hs view
@@ -10,16 +10,12 @@ ------------------------------------------------------------------------------- -- from base-import Control.Monad ( (>>), return )-import Data.Bool ( Bool )-import System.Cmd ( system )-import System.FilePath ( (</>) )-import System.IO ( IO )+import System.IO ( IO ) -- from cabal import Distribution.Simple ( defaultMainWithHooks , simpleUserHooks- , UserHooks(runTests, haddockHook)+ , UserHooks(haddockHook) , Args ) @@ -30,26 +26,13 @@ ---------------------------------------------------------------------------------- Cabal setup program with support for 'cabal test' and--- which sets the CPP define '__HADDOCK __' when haddock is run.+-- Cabal setup program 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"+ hooks = simpleUserHooks { haddockHook = haddockHook' } -- Define __HADDOCK__ for CPP when running haddock. haddockHook' ∷ PackageDescription → LocalBuildInfo → UserHooks → HaddockFlags → IO ()
− test.hs
@@ -1,283 +0,0 @@-{-# LANGUAGE CPP- , NoImplicitPrelude- , UnicodeSyntax- , DeriveDataTypeable- #-}--#if MIN_VERSION_base(4,3,0)-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- For block and unblock-#endif--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_ )--#if __GLASGOW_HASKELL__ < 701-import Control.Monad ( (>>), fail )-#endif--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 Prelude ( fromInteger )-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- ]-#ifdef __GLASGOW_HASKELL__- , testGroup "forkOnIO 0" $- [ testCase "wait" $ test_wait (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)- ]-#if MIN_VERSION_base(4,3,0)- , testGroup "forkIOUnmasked" $- [ testCase "wait" $ test_wait (Thread.forkIOUnmasked)- , testCase "unblockedState'" $ test_unblockedState' (Thread.forkIOUnmasked)- , testCase "sync exception" $ test_sync_exception (Thread.forkIOUnmasked)- , testCase "async exception" $ test_async_exception (Thread.forkIOUnmasked)- ]-#endif-#endif- ]- , 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- ]-#ifdef __GLASGOW_HASKELL__- , testGroup "forkOnIO 0" $- [ testCase "wait" $ wrapOnIO_0 test_wait- , 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 nrOfRunning" $ test_group_nrOfRunning (ThreadGroup.forkOnIO 0)- ]-#if MIN_VERSION_base(4,3,0)- , testGroup "forkIOUnmasked" $- [ testCase "wait" $ wrapIOUnmasked test_wait- , testCase "unblockedState'" $ wrapIOUnmasked test_unblockedState'- , testCase "sync exception" $ wrapIOUnmasked test_sync_exception- , testCase "async exception" $ wrapIOUnmasked test_async_exception-- , testCase "group single wait" $ test_group_single_wait ThreadGroup.forkIOUnmasked- , testCase "group nrOfRunning" $ test_group_nrOfRunning ThreadGroup.forkIOUnmasked- ]-#endif-#endif- ]- ]---- Exactly 1 moment. Currently equal to 0.005 seconds.-a_moment ∷ Int-a_moment = 5000-------------------------------------------------------------------------------------- General properties-----------------------------------------------------------------------------------type Fork α = IO α → IO (ThreadId, IO (Result α))--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_unblockedState' ∷ Fork Bool → Assertion-test_unblockedState' fork = do (_, wait) ← block $ 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--#ifdef __GLASGOW_HASKELL__-wrapOnIO_0 ∷ (Fork α → IO β) → IO β-wrapOnIO_0 = wrap $ ThreadGroup.forkOnIO 0--#if MIN_VERSION_base(4,3,0)-wrapIOUnmasked ∷ (Fork α → IO β) → IO β-wrapIOUnmasked = wrap ThreadGroup.forkIOUnmasked-#endif-#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_nrOfRunning ∷ (ThreadGroup → Fork ()) → Assertion-test_group_nrOfRunning doFork = assert $ fmap isJustTrue $ timeout (10 ⋅ a_moment) $ do- tg ← ThreadGroup.new- l ← Lock.newAcquired- replicateM_ (fromInteger n) $ doFork tg $ Lock.acquire l- true ← fmap (≡ n) $ atomically $ ThreadGroup.nrOfRunning tg- 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 = 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 (<$>)----- The End ---------------------------------------------------------------------
threads.cabal view
@@ -1,6 +1,6 @@ name: threads-version: 0.4-cabal-version: >= 1.6+version: 0.4.0.1+cabal-version: >= 1.9.2 build-type: Custom stability: experimental author: Bas van Dijk <v.dijk.bas@gmail.com>@@ -10,6 +10,8 @@ copyright: (c) 2010 Bas van Dijk & Roel van Dijk license: BSD3 license-file: LICENSE+homepage: https://github.com/basvandijk/threads/+bug-reports: https://github.com/basvandijk/threads/issues category: Concurrency synopsis: Fork threads and wait for their result description: This package provides functions to fork threads and@@ -34,24 +36,16 @@ . * GHC specific functionality like @forkOnIO@ and @forkIOUnmasked@. -source-repository head- Type: darcs- Location: http://code.haskell.org/~basvandijk/code/threads-----------------------------------------------------------------------------------flag test- description: Build the testing suite- default: False+extra-source-files: README.markdown -flag hpc- description: Enable program coverage on test executable- default: False+source-repository head+ Type: git+ Location: git://github.com/basvandijk/threads.git ------------------------------------------------------------------------------- library- build-depends: base >= 3 && < 4.4+ build-depends: base >= 3 && < 4.5 , base-unicode-symbols >= 0.1.1 && < 0.3 , stm >= 2.1 && < 2.3 exposed-modules: Control.Concurrent.Thread@@ -61,24 +55,18 @@ ------------------------------------------------------------------------------- -executable test-threads+test-suite test-threads+ type: exitcode-stdio-1.0 main-is: test.hs ghc-options: -Wall -threaded - if flag(test)- build-depends: base >= 3 && < 4.4- , base-unicode-symbols >= 0.1.1 && < 0.3- , stm >= 2.1 && < 2.3- , concurrent-extra >= 0.5.1 && < 0.7- , HUnit >= 1.2.2 && < 1.3- , test-framework >= 0.2.4 && < 0.4- , test-framework-hunit >= 0.2.4 && < 0.3- buildable: True- else- buildable: False-- if flag(hpc)- ghc-options: -fhpc+ build-depends: base >= 3 && < 4.5+ , 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.5+ , test-framework-hunit >= 0.2.4 && < 0.3 -------------------------------------------------------------------------------