threads 0.3.1 → 0.4
raw patch · 4 files changed
+75/−30 lines, 4 files
Files
- Control/Concurrent/Thread.hs +14/−7
- Control/Concurrent/Thread/Group.hs +19/−18
- test.hs +41/−4
- threads.cabal +1/−1
Control/Concurrent/Thread.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax #-}++#if MIN_VERSION_base(4,3,0) {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- For block and unblock+#endif -------------------------------------------------------------------------------- -- |@@ -23,12 +26,12 @@ -- -- @ ----- import qualified Control.Concurrent.Thread as Thread ( 'forkIO', 'unsafeResult' )+-- import qualified Control.Concurrent.Thread as Thread ( 'forkIO', 'result' ) -- -- main = do (tid, wait) <- Thread.'forkIO' $ do x <- someExpensiveComputation -- return x -- doSomethingElse--- x <- Thread.'unsafeResult' =<< 'wait'+-- x <- Thread.'result' =<< 'wait' -- doSomethingWithResult x -- @ --@@ -46,7 +49,7 @@ #endif -- * Results , Result- , unsafeResult+ , result ) where @@ -62,11 +65,15 @@ #if MIN_VERSION_base(4,3,0) import Control.Exception ( block, unblock ) #endif-import Control.Monad ( return, (>>=), fail )+import Control.Monad ( return, (>>=) ) import Data.Either ( Either(..), either ) import Data.Function ( ($) ) import System.IO ( IO ) +#if __GLASGOW_HASKELL__ < 701+import Control.Monad ( fail )+#endif+ #ifdef __GLASGOW_HASKELL__ import qualified GHC.Conc ( forkOnIO ) import Data.Int ( Int )@@ -164,12 +171,12 @@ -- and wasn't catched or the actual value that was returned by the thread. type Result α = Either SomeException α -{-| Unsafely retrieve the actual value from the result.+{-| Retrieve the actual value from the result. When the result is 'SomeException' the exception is thrown. -}-unsafeResult ∷ Result α → IO α-unsafeResult = either throwIO return+result ∷ Result α → IO α+result = either throwIO return -- The End ---------------------------------------------------------------------
Control/Concurrent/Thread/Group.hs view
@@ -3,7 +3,10 @@ , NoImplicitPrelude , UnicodeSyntax #-}++#if MIN_VERSION_base(4,3,0) {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- For block and unblock+#endif -------------------------------------------------------------------------------- -- |@@ -28,10 +31,10 @@ -------------------------------------------------------------------------------- module Control.Concurrent.Thread.Group- ( -- * Groups of threads- ThreadGroup+ ( ThreadGroup , new , nrOfRunning+ , wait -- * Forking threads , forkIO@@ -42,9 +45,6 @@ , forkIOUnmasked #endif #endif-- -- * Waiting- , wait ) where @@ -60,13 +60,19 @@ #if MIN_VERSION_base(4,3,0) import Control.Exception ( block, unblock ) #endif-import Control.Monad ( return, (>>=), (>>), fail, when )+import Control.Monad ( return, (>>=), when ) import Data.Function ( ($) ) import Data.Functor ( fmap )+import Data.Eq ( Eq ) import Data.Typeable ( Typeable )-import Prelude ( ($!), Integer, fromInteger, succ, pred )+import Prelude ( ($!), Integer, succ, pred ) import System.IO ( IO ) +#if __GLASGOW_HASKELL__ < 701+import Prelude ( fromInteger )+import Control.Monad ( (>>), fail )+#endif+ #ifdef __GLASGOW_HASKELL__ import qualified GHC.Conc ( forkOnIO ) import Data.Int ( Int )@@ -119,7 +125,7 @@ * 'wait' blocks as long as the counter is not 0. -}-newtype ThreadGroup = ThreadGroup (TVar Integer) deriving Typeable+newtype ThreadGroup = ThreadGroup (TVar Integer) deriving (Eq, Typeable) -- | Create an empty group of threads. new ∷ IO ThreadGroup@@ -134,7 +140,12 @@ nrOfRunning ∷ ThreadGroup → STM Integer nrOfRunning (ThreadGroup numThreadsTV) = readTVar numThreadsTV +-- | Convenience function which blocks until all threads, that were added to the+-- group have terminated.+wait ∷ ThreadGroup → IO ()+wait tg = atomically $ nrOfRunning tg >>= \n → when (n ≢ 0) retry + -------------------------------------------------------------------------------- -- * Forking threads --------------------------------------------------------------------------------@@ -191,16 +202,6 @@ -- | Strict function composition (∘!) ∷ (β → γ) → (α → β) → (α → γ) f ∘! g = \x → f $! g x-------------------------------------------------------------------------------------- * Waiting------------------------------------------------------------------------------------- | Convenience function which blocks until all threads, that were added to the--- group have terminated.-wait ∷ ThreadGroup → IO ()-wait tg = atomically $ nrOfRunning tg >>= \n → when (n ≢ 0) retry -- The End ---------------------------------------------------------------------
test.hs view
@@ -4,6 +4,10 @@ , DeriveDataTypeable #-} +#if MIN_VERSION_base(4,3,0)+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- For block and unblock+#endif+ module Main where --------------------------------------------------------------------------------@@ -17,7 +21,12 @@ , throwIO , unblock, block, blocked )-import Control.Monad ( return, (>>=), fail, (>>), replicateM_ )+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 )@@ -53,7 +62,7 @@ import Test.Framework.Providers.HUnit ( testCase ) -- from threads:-import Control.Concurrent.Thread ( Result, unsafeResult )+import Control.Concurrent.Thread ( Result, result ) import Control.Concurrent.Thread.Group ( ThreadGroup ) import qualified Control.Concurrent.Thread as Thread@@ -91,7 +100,15 @@ , 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" $@@ -125,7 +142,18 @@ , 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 ] ] @@ -151,12 +179,16 @@ test_blockedState ∷ Fork Bool → Assertion test_blockedState fork = do (_, wait) ← block $ fork $ blocked- wait >>= unsafeResult >>= assert+ wait >>= result >>= assert test_unblockedState ∷ Fork Bool → Assertion test_unblockedState fork = do (_, wait) ← unblock $ fork $ not <$> blocked- wait >>= unsafeResult >>= assert+ 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@@ -197,6 +229,11 @@ #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 β
threads.cabal view
@@ -1,5 +1,5 @@ name: threads-version: 0.3.1+version: 0.4 cabal-version: >= 1.6 build-type: Custom stability: experimental