concurrent-extra 0.4 → 0.5

raw patch · 7 files changed

+36/−441 lines, 7 filesdep ~base-unicode-symbolsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base-unicode-symbols

API changes (from Hackage documentation)

Files

• Control/Concurrent/Broadcast.hs +16/−11
• Control/Concurrent/Thread.hs +0/−320
• Control/Concurrent/Thread/Test.hs +0/−87
• Control/Concurrent/Timeout/Test.hs +5/−6
• Utils.hs +8/−7
• concurrent-extra.cabal +7/−8
• test.hs +0/−2

@@ -49,7 +49,7 @@ -------------------------------------------------------------------------------  -- from base:-import Control.Monad           ( (>>=), (>>), return, forM_, fail, when )+import Control.Monad           ( (>>=), (>>), return, fail, when ) import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar                                , takeMVar, putMVar, readMVar, modifyMVar_                                )@@ -58,6 +58,7 @@ import Data.Either             ( Either(Left ,Right), either ) import Data.Function           ( ($), const ) import Data.Functor            ( fmap, (<$>) )+import Data.Foldable           ( for_ ) import Data.List               ( delete, length ) import Data.Maybe              ( Maybe(Nothing, Just), isNothing ) import Data.Ord                ( Ord, max )@@ -168,11 +169,7 @@ broadcast will be woken. -} broadcast ∷ Broadcast α → α → IO ()-broadcast (Broadcast mv) x = modifyMVar_ mv $ \mx → do-                               case mx of-                                 Left ls → do forM_ ls (`putMVar` x)-                                              return $ Right x-                                 Right _ → return $ Right x+ {-| Broadcast a value before becoming \"silent\". @@ -186,11 +183,19 @@ @ -} signal ∷ Broadcast α → α → IO ()-signal (Broadcast mv) x = modifyMVar_ mv $ \mx → do-                            case mx of-                              Left ls → do forM_ ls (`putMVar` x)-                                           return $ Left []-                              Right _ → return $ Left []++broadcast b x = broadcastThen (Right x) b x+signal    b x = broadcastThen (Left []) b x++-- | Internally used function that performs the actual broadcast in 'broadcast'+-- and 'signal' then changes to the given final state.+broadcastThen ∷ Either [MVar α] α → Broadcast α → α → IO ()+broadcastThen finalState (Broadcast mv) x =+    modifyMVar_ mv $ \mx → do+      case mx of+        Left ls → do for_ ls (`putMVar` x)+                     return finalState+        Right _ → return finalState  -- | Set a broadcast to the \"silent\" state. silence ∷ Broadcast α → IO ()

@@ -1,320 +0,0 @@-{-# LANGUAGE CPP, DeriveDataTypeable, 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.------ Inspired by: <http://hackage.haskell.org/package/threadmanager>------ This module re-implements several 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_--    -- ** Waiting with a timeout-  , waitTimeout-  , waitTimeout_-  , unsafeWaitTimeout-  , unsafeWaitTimeout_--    -- * Quering thread status-  , isRunning--    -- * Convenience functions-  , throwTo-  , killThread-  , killThreadTimeout-  ) where------------------------------------------------------------------------------------- Imports------------------------------------------------------------------------------------ from base:-import Control.Exception ( Exception, SomeException-                         , AsyncException(ThreadKilled)-                         , try, blocked, block, unblock-                         )-#ifdef __HADDOCK__-import Control.Exception ( BlockedIndefinitelyOnMVar, BlockedIndefinitelyOnSTM )-#endif-import Control.Monad     ( return, (>>=), fail, (>>) )-import Data.Bool         ( Bool(..) )-import Data.Eq           ( Eq, (==) )-import Data.Either       ( Either(..), either )-import Data.Function     ( ($), on )-import Data.Functor      ( fmap, (<$>) )-import Data.Maybe        ( Maybe(..), maybe, isNothing, isJust )-import Data.Ord          ( Ord, compare )-import Data.Typeable     ( Typeable )-import Prelude           ( Integer )-import System.IO         ( IO )-import Text.Show         ( Show, show )--import qualified Control.Concurrent as Conc-    ( ThreadId, forkIO, forkOS, throwTo )---- from base-unicode-symbols:-import Data.Function.Unicode ( (∘) )---- from concurrent-extra:-import           Control.Concurrent.Broadcast ( Broadcast )-import qualified Control.Concurrent.Broadcast as Broadcast-    ( new, broadcast, listen, tryListen, listenTimeout )--import Utils ( void, ifM, throwInner )------------------------------------------------------------------------------------- Threads----------------------------------------------------------------------------------{-|-A @'ThreadId' &#x3B1;@ is an abstract type representing a handle to a thread-that is executing or has executed a computation of type @'IO' &#x3B1;@.--@'ThreadId' &#x3B1;@ is an instance of 'Eq', 'Ord' and 'Show', where the 'Ord'-instance implements an arbitrary total ordering over 'ThreadId's. 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.--}-data ThreadId α = ThreadId-    { stopped  ∷ Broadcast (Either SomeException α)-    , threadId ∷ Conc.ThreadId -- ^ Extract the underlying 'Conc.ThreadId'-                               -- (@Conctrol.Concurrent.ThreadId@).-    } deriving Typeable--instance Eq (ThreadId α) where-    (==) = (==) `on` threadId--instance Ord (ThreadId α) where-    compare = compare `on` threadId--instance Show (ThreadId α) where-    show = show ∘ 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').--The newly created thread has an exception handler that discards the exceptions-'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', and 'ThreadKilled'. All-other exceptions are recorded in the 'ThreadId' and can be retrieved using-'wait'.--}-forkIO ∷ IO α → IO (ThreadId α)-forkIO = fork Conc.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 Conc.forkOS--{-|-Internally used function which generalises 'forkIO' and 'forkOS'. Parametrised-by the function which does the actual forking.--}-fork ∷ (IO () → IO Conc.ThreadId) → IO α → IO (ThreadId α)-fork doFork a = do-  stop ← Broadcast.new-  let broadcastToStop = Broadcast.broadcast stop-  tid ← ifM blocked (        doFork $ try          a  >>= broadcastToStop)-                    (block $ doFork $ try (unblock a) >>= broadcastToStop)-  return $ ThreadId stop tid------------------------------------------------------------------------------------- * 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 = Broadcast.listen ∘ stopped---- | 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_ = void ∘ unsafeWait----- ** Waiting with a timeout--{-|-Block until the given thread is terminated or until a timer expires.--* Returns 'Nothing' if a timeout occurred.--* Returns 'Just' the result 'wait' would return when the thread finished within-the specified time.--The timeout is specified in microseconds.--}-waitTimeout ∷ ThreadId α → Integer → IO (Maybe (Either SomeException α))-waitTimeout = Broadcast.listenTimeout ∘ stopped---- | Like 'waitTimeout' but will ignore the value returned by the thread.--- Returns 'False' when a timeout occurred and 'True' otherwise.-waitTimeout_ ∷ ThreadId α → Integer → IO Bool-waitTimeout_ tid t = isJust <$> waitTimeout tid t--{-|-Like 'waitTimeout' but will rethrow the exception that was thrown in the-thread. Returns 'Nothing' if a timeout occured or 'Just' the value returned from-the target thread.--}-unsafeWaitTimeout ∷ ThreadId α → Integer → IO (Maybe α)-unsafeWaitTimeout tid t = waitTimeout tid t >>= maybe (return Nothing)-                                                      (either throwInner-                                                              (return ∘ Just))---- | Like 'unsafeWaitTimeout' in that it will rethrow the exception that was--- thrown in the thread but it will ignore the value returned by the thread.--- Returns 'False' when a timeout occurred and 'True' otherwise.-unsafeWaitTimeout_ ∷ ThreadId α → Integer → IO Bool-unsafeWaitTimeout_ tid t = isJust <$> unsafeWaitTimeout tid t------------------------------------------------------------------------------------- * Quering thread status----------------------------------------------------------------------------------{-|-Returns 'True' if the given thread is currently running.--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 ∘ Broadcast.tryListen ∘ stopped------------------------------------------------------------------------------------- * 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 = Conc.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'.--This function blocks until the target thread is terminated. It is a no-op if the-target thread has already completed.--}-killThread ∷ ThreadId α → IO ()-killThread tid = throwTo tid ThreadKilled >> wait_ tid--{-|-Like 'killThread' but with a timeout. Returns 'True' if the target thread was-terminated within the given amount of time, 'False' otherwise.--The timeout is specified in microseconds.--Note that even when a timeout occurs, the target thread can still terminate at a-later time as a direct result of calling this function.--}-killThreadTimeout ∷ ThreadId α → Integer → IO Bool-killThreadTimeout tid time = throwTo tid ThreadKilled >> waitTimeout_ tid time----- The End ---------------------------------------------------------------------

@@ -1,87 +0,0 @@-{-# LANGUAGE NoImplicitPrelude-           , UnicodeSyntax-  #-}--module Control.Concurrent.Thread.Test ( tests ) where------------------------------------------------------------------------------------- Imports------------------------------------------------------------------------------------ from base:-import Control.Concurrent ( threadDelay )-import Control.Exception  ( unblock, block, blocked )-import Control.Monad      ( return, (>>=), fail, (>>) )-import Data.Bool          ( Bool(False, True), not )-import Data.Function      ( ($), id )-import Data.Functor       ( fmap  )-import Data.IORef         ( newIORef, readIORef, writeIORef )-import Data.Maybe         ( maybe )-import Prelude            ( fromInteger, toInteger )-import System.Timeout     ( timeout )---- from base-unicode-symbols:-import Prelude.Unicode       ( (⋅) )---- from concurrent-extra:-import qualified Control.Concurrent.Lock   as Lock-import qualified Control.Concurrent.Thread as Thread-import TestUtils ( a_moment, within )---- from HUnit:-import Test.HUnit ( Assertion, assert )---- from test-framework:-import Test.Framework ( Test )---- from test-framework-hunit:-import Test.Framework.Providers.HUnit ( testCase )------------------------------------------------------------------------------------- Tests for Thread----------------------------------------------------------------------------------tests ∷ [Test]-tests = [ testCase "wait"           test_wait-        , testCase "waitTimeout"    test_waitTimeout-        , testCase "isRunning"      test_isRunning-        , testCase "blockedState"   test_blockedState-        , testCase "unblockedState" test_unblockedState-        ]--test_wait ∷ Assertion-test_wait = assert $ fmap (maybe False id) $ timeout (10 ⋅ a_moment) $ do-  r ← newIORef False-  tid ← Thread.forkIO $ do-    threadDelay $ 2 ⋅ a_moment-    writeIORef r True-  _ ← Thread.wait tid-  readIORef r--test_waitTimeout ∷ Assertion-test_waitTimeout = assert $ within (10 ⋅ a_moment) $ do-  l ← Lock.newAcquired-  tid ← Thread.forkIO $ Lock.acquire l-  _ ← Thread.waitTimeout tid (toInteger $ 5 ⋅ a_moment)-  Lock.release l--test_isRunning ∷ Assertion-test_isRunning = assert $ fmap (maybe False id) $ timeout (10 ⋅ a_moment) $ do-  l ← Lock.newAcquired-  tid ← Thread.forkIO $ Lock.acquire l-  r ← Thread.isRunning tid-  Lock.release l-  return r--test_blockedState ∷ Assertion-test_blockedState = (block $ Thread.forkIO $ blocked) >>=-                    Thread.unsafeWait >>= assert--test_unblockedState ∷ Assertion-test_unblockedState = (unblock $ Thread.forkIO $ fmap not $ blocked) >>=-                      Thread.unsafeWait >>= assert----- The End ---------------------------------------------------------------------

@@ -10,7 +10,7 @@ -------------------------------------------------------------------------------  -- from base:-import Control.Concurrent ( )+import Control.Concurrent ( forkIO, killThread ) import Control.Exception  ( block ) import Control.Monad      ( (>>=), fail, (>>) ) import Data.Function      ( ($) )@@ -21,9 +21,9 @@  -- from concurrent-extra: import qualified Control.Concurrent.Lock   as Lock-import qualified Control.Concurrent.Thread as Thread import Control.Concurrent.Timeout ( timeout ) import TestUtils ( a_moment, within )+import Utils ( void )  -- from HUnit: import Test.HUnit ( Assertion, assert )@@ -45,10 +45,9 @@ test_timeout_exception ∷ Assertion test_timeout_exception = assert $ within (10 ⋅ a_moment) $ do   l ← Lock.newAcquired-  tid ← block $ Thread.forkIO-                $ timeout (toInteger $ 1000 ⋅ a_moment)-                  $ Lock.acquire l-  Thread.killThread tid+  tid ← block $ forkIO $+          void $ timeout (toInteger $ 1000 ⋅ a_moment) $ Lock.acquire l+  killThread tid   Lock.release l  

@@ -8,12 +8,13 @@  -- from base: import Control.Concurrent.MVar ( MVar, takeMVar, putMVar )-import Control.Exception       ( SomeException(SomeException), block, throwIO )+import Control.Exception       ( block ) import Control.Monad           ( Monad, return, (>>=), (>>), fail ) import Data.Bool               ( Bool ) import Data.Function           ( ($) ) import Data.Functor            ( Functor, (<$) ) import Data.IORef              ( IORef, readIORef, writeIORef )+import Prelude                 ( ($!) ) import System.IO               ( IO )  -- from base-unicode-symbols:@@ -24,21 +25,21 @@ -- Utility functions -------------------------------------------------------------------------------- +-- | Strict function composition.+(∘!) ∷ (β → γ) → (α → β) → (α → γ)+f ∘! g = (f $!) ∘ g+ 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 -throwInner ∷ SomeException → IO α-throwInner (SomeException e) = throwIO e- purelyModifyMVar ∷ MVar α → (α → α) → IO ()-purelyModifyMVar mv f = block $ takeMVar mv >>= putMVar mv ∘ f+purelyModifyMVar mv f = block $ takeMVar mv >>= putMVar mv ∘! f  modifyIORefM ∷ IORef α → (α → IO (α, β)) → IO β-modifyIORefM r f = do x ← readIORef r-                      (y, z) ← f x+modifyIORefM r f = do (y, z) ← readIORef r >>= f                       writeIORef r y                       return z 

@@ -1,5 +1,5 @@ name:          concurrent-extra-version:       0.4+version:       0.5 cabal-version: >= 1.6 build-type:    Custom stability:     experimental@@ -34,9 +34,6 @@   .   Besides these synchronisation primitives the package also provides:   .-  * @Thread@: Threads extended with the ability to wait for their-    termination.-  .   * @Thread.Delay@: Arbitrarily long thread delays.   .   * @Timeout@: Wait arbitrarily long for an IO computation to finish.@@ -69,14 +66,13 @@  library   build-depends: base                 >= 3     && < 4.3-               , base-unicode-symbols >= 0.1.1 && < 0.2+               , base-unicode-symbols >= 0.1.1 && < 0.3   exposed-modules: Control.Concurrent.Lock                  , Control.Concurrent.RLock                  , Control.Concurrent.Event                  , Control.Concurrent.Broadcast                  , Control.Concurrent.ReadWriteLock                  , Control.Concurrent.ReadWriteVar-                 , Control.Concurrent.Thread                  , Control.Concurrent.Thread.Delay                  , Control.Concurrent.Timeout   other-modules: Utils@@ -95,14 +91,15 @@                , Control.Concurrent.Broadcast.Test                , Control.Concurrent.ReadWriteLock.Test                , Control.Concurrent.ReadWriteVar.Test-               , Control.Concurrent.Thread.Test                , Control.Concurrent.Timeout.Test                , TestUtils    ghc-options: -Wall    if flag(test)-    build-depends: HUnit                      >= 1.2.2 && < 1.3+    build-depends: base                       >= 3     && < 4.3+                 , base-unicode-symbols       >= 0.1.1 && < 0.3+                 , 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@@ -113,3 +110,5 @@    if flag(hpc)     ghc-options: -fhpc++-------------------------------------------------------------------------------

@@ -16,7 +16,6 @@ import qualified Control.Concurrent.Broadcast.Test     as Broadcast ( tests ) import qualified Control.Concurrent.ReadWriteLock.Test as RWLock    ( tests ) import qualified Control.Concurrent.ReadWriteVar.Test  as RWVar     ( tests )-import qualified Control.Concurrent.Thread.Test        as Thread    ( tests ) import qualified Control.Concurrent.Timeout.Test       as Timeout   ( tests )  -- from test-framework:@@ -38,7 +37,6 @@           , testGroup "Broadcast"     Broadcast.tests           , testGroup "ReadWriteLock" RWLock.tests           , testGroup "ReadWriteVar"  RWVar.tests-          , testGroup "Thread"        Thread.tests           ]         , testGroup "Timeout" Timeout.tests         ]