concurrent-extra 0.6.0.1 → 0.7
raw patch · 20 files changed
+26/−1002 lines, 20 filesdep +unbounded-delayssetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: unbounded-delays
API changes (from Hackage documentation)
- Control.Concurrent.Thread.Delay: delay :: Integer -> IO ()
- Control.Concurrent.Timeout: instance Eq Timeout
- Control.Concurrent.Timeout: instance Exception Timeout
- Control.Concurrent.Timeout: instance Show Timeout
- Control.Concurrent.Timeout: instance Typeable Timeout
- Control.Concurrent.Timeout: timeout :: Integer -> IO α -> IO (Maybe α)
Files
- Control/Concurrent/Broadcast.hs +3/−3
- Control/Concurrent/Broadcast/Test.hs +0/−40
- Control/Concurrent/Event/Test.hs +0/−109
- Control/Concurrent/Lock.hs +1/−1
- Control/Concurrent/Lock/Test.hs +0/−106
- Control/Concurrent/RLock.hs +1/−1
- Control/Concurrent/RLock/Test.hs +0/−86
- Control/Concurrent/ReadWriteLock.hs +3/−3
- Control/Concurrent/ReadWriteLock/Test.hs +0/−95
- Control/Concurrent/ReadWriteVar/Test.hs +0/−40
- Control/Concurrent/STM/Lock.hs +1/−1
- Control/Concurrent/STM/Lock/Test.hs +0/−110
- Control/Concurrent/Thread/Delay.hs +0/−58
- Control/Concurrent/Timeout.hs +0/−121
- Control/Concurrent/Timeout/Test.hs +0/−55
- Setup.hs +4/−22
- TestUtils.hs +0/−61
- Utils.hs +1/−1
- concurrent-extra.cabal +12/−42
- test.hs +0/−47
Control/Concurrent/Broadcast.hs view
@@ -66,7 +66,7 @@ import Prelude ( Integer, seq ) import System.IO ( IO ) -#if __GLASGOW_HASKELL__ < 701+#if __GLASGOW_HASKELL__ < 700 import Prelude ( fromInteger ) import Control.Monad ( (>>=), (>>), fail ) #endif@@ -156,8 +156,8 @@ `onException` deleteReader l when (isNothing my) (deleteReader l) return my- Right x → do putMVar mv mx- return $ Just x+ Right x → do putMVar mv mx+ return $ Just x where deleteReader l = do mx ← takeMVar mv case mx of
− Control/Concurrent/Broadcast/Test.hs
@@ -1,40 +0,0 @@-{-# LANGUAGE NoImplicitPrelude- , UnicodeSyntax- #-}--module Control.Concurrent.Broadcast.Test ( tests ) where------------------------------------------------------------------------------------- Imports------------------------------------------------------------------------------------ from base:-import Control.Concurrent ( )---- from base-unicode-symbols:-import Prelude.Unicode ( )---- from concurrent-extra:-import qualified Control.Concurrent.Broadcast as Broadcast ( )-import TestUtils ( )---- from HUnit:-import Test.HUnit ( )---- from test-framework:-import Test.Framework ( Test )---- from test-framework-hunit:-import Test.Framework.Providers.HUnit ( )------------------------------------------------------------------------------------- Tests for Broadcast----------------------------------------------------------------------------------tests ∷ [Test]-tests = []----- The End ---------------------------------------------------------------------
− Control/Concurrent/Event/Test.hs
@@ -1,109 +0,0 @@-{-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax, ScopedTypeVariables #-}--module Control.Concurrent.Event.Test ( tests ) where------------------------------------------------------------------------------------ Imports------------------------------------------------------------------------------------ from base:-import Control.Exception ( catch, throwTo, ErrorCall(..) )-import Control.Concurrent ( forkIO )-import Control.Monad ( return, mapM_, replicateM, replicateM_ )-import Data.Function ( ($) )-import Data.Int ( Int )-import Prelude ( toInteger )--#if __GLASGOW_HASKELL__ < 701-import Prelude ( fromInteger )-import Control.Monad ( (>>=), (>>), fail )-#endif---- from base-unicode-symbols:-import Prelude.Unicode ( (⋅) )---- from concurrent-extra:-import qualified Control.Concurrent.Event as Event-import TestUtils---- 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 Event----------------------------------------------------------------------------------tests ∷ [Test]-tests = [ testCase "set wait a" $ test_event_1 1 1- , testCase "set wait b" $ test_event_1 5 1- , testCase "set wait c" $ test_event_1 1 5- , testCase "set wait d" $ test_event_1 5 5- , testCase "conc set wait" $ test_event_2- , testCase "multi wake" $ test_event_3 10- , testCase "exception" $ test_event_4- , testCase "wait timeout" $ test_event_5- , testCase "wait blocks" $ test_event_6- ]---- Set an event 's' times then wait for it 'w' times. This should--- terminate within a few moments.-test_event_1 ∷ Int → Int → Assertion-test_event_1 s w = assert $ within (10 ⋅ a_moment) $ do- e ← Event.new- replicateM_ s $ Event.set e- replicateM_ w $ Event.wait e--test_event_2 ∷ Assertion-test_event_2 = assert $ within (10 ⋅ a_moment) $ do- e1 ← Event.new- e2 ← Event.new- _ ← forkIO $ do- Event.wait e1- Event.set e2- wait_a_moment- Event.set e1- Event.wait e2---- Waking multiple threads with a single Event.-test_event_3 ∷ Int → Assertion-test_event_3 n = assert $ within (10 ⋅ a_moment) $ do- e1 ← Event.new- es ← replicateM n $ do- e2 ← Event.new- _ ← forkIO $ do- Event.wait e1- Event.set e2- return e2- wait_a_moment- Event.set e1- mapM_ Event.wait es---- Exception handling while waiting for an Event.-test_event_4 ∷ Assertion-test_event_4 = assert $ within (10 ⋅ a_moment) $ do- e1 ← Event.new- e2 ← Event.new- helperId ← forkIO $ catch (Event.wait e1) $ \(_ ∷ ErrorCall) → Event.set e2- wait_a_moment- throwTo helperId $ ErrorCall "Boo!"- Event.wait e2--test_event_5 ∷ Assertion-test_event_5 = assert $ within (10 ⋅ a_moment) $ do- e ← Event.new- Event.waitTimeout e $ toInteger a_moment--test_event_6 ∷ Assertion-test_event_6 = assert $ notWithin (10 ⋅ a_moment) $ do- e ← Event.new- Event.wait e----- The End ---------------------------------------------------------------------
Control/Concurrent/Lock.hs view
@@ -76,7 +76,7 @@ import Prelude ( error ) import System.IO ( IO ) -#if __GLASGOW_HASKELL__ < 701+#if __GLASGOW_HASKELL__ < 700 import Control.Monad ( (>>=), fail ) #endif
− Control/Concurrent/Lock/Test.hs
@@ -1,106 +0,0 @@-{-# LANGUAGE CPP- , NoImplicitPrelude- , UnicodeSyntax- , ScopedTypeVariables- #-}--module Control.Concurrent.Lock.Test ( tests ) where------------------------------------------------------------------------------------ Imports------------------------------------------------------------------------------------ from base:-import Control.Concurrent ( forkIO )-import Control.Monad ( return, (>>=), (>>) )-import Data.Bool ( Bool(False, True), not, (&&) )-import Data.Function ( ($) )-import Data.Functor ( fmap )-import Data.IORef ( newIORef, writeIORef, readIORef )--#if __GLASGOW_HASKELL__ < 701-import Prelude ( fromInteger )-import Control.Monad ( fail )-#endif---- from base-unicode-symbols:-import Data.Function.Unicode ( (∘) )-import Prelude.Unicode ( (⋅) )---- from concurrent-extra:-import qualified Control.Concurrent.Lock as Lock-import TestUtils---- 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 Lock----------------------------------------------------------------------------------tests ∷ [Test]-tests = [ testCase "acquire release" test_lock_1- , testCase "acquire acquire" test_lock_2- , testCase "new release" test_lock_3- , testCase "new unlocked" test_lock_4- , testCase "newAcquired locked" test_lock_5- , testCase "acq rel unlocked" test_lock_6- , testCase "conc release" test_lock_7- , testCase "wait" test_lock_8- ]--test_lock_1 ∷ Assertion-test_lock_1 = assert $ within a_moment $ do- l ← Lock.new- Lock.acquire l- Lock.release l--test_lock_2 ∷ Assertion-test_lock_2 = assert $ notWithin (10 ⋅ a_moment) $ do- l ← Lock.new- Lock.acquire l- Lock.acquire l--test_lock_3 ∷ Assertion-test_lock_3 = assertException "" $ Lock.new >>= Lock.release--test_lock_4 ∷ Assertion-test_lock_4 = assert $ Lock.new >>= fmap not ∘ Lock.locked--test_lock_5 ∷ Assertion-test_lock_5 = assert $ Lock.newAcquired >>= Lock.locked--test_lock_6 ∷ Assertion-test_lock_6 = assert $ do- l ← Lock.new- Lock.acquire l- Lock.release l- fmap not $ Lock.locked l--test_lock_7 ∷ Assertion-test_lock_7 = assert ∘ within (10 ⋅ a_moment) $ do- l ← Lock.newAcquired- _ ← forkIO $ wait_a_moment >> Lock.release l- Lock.acquire l--test_lock_8 ∷ Assertion-test_lock_8 = assert $ do- ioRef ← newIORef False- l ← Lock.newAcquired- _ ← forkIO $ do wait_a_moment- writeIORef ioRef True- Lock.release l- Lock.wait l- set ← readIORef ioRef- locked ← Lock.locked l- return $ set && not locked----- The End ---------------------------------------------------------------------
Control/Concurrent/RLock.hs view
@@ -78,7 +78,7 @@ import Prelude ( Integer, succ, pred, error ) import System.IO ( IO ) -#if __GLASGOW_HASKELL__ < 701+#if __GLASGOW_HASKELL__ < 700 import Prelude ( fromInteger ) import Control.Monad ( fail, (>>=) ) #endif
− Control/Concurrent/RLock/Test.hs
@@ -1,86 +0,0 @@-{-# LANGUAGE CPP- , NoImplicitPrelude- , UnicodeSyntax- , ScopedTypeVariables - #-}--module Control.Concurrent.RLock.Test ( tests ) where------------------------------------------------------------------------------------- Imports------------------------------------------------------------------------------------ from base:-import Control.Concurrent ( forkIO, threadDelay )-import Control.Monad ( replicateM_ )-import Data.Function ( ($) )-import Data.Int ( Int )--#if __GLASGOW_HASKELL__ < 701-import Prelude ( fromInteger )-import Control.Monad ( (>>=), fail, (>>) )-#endif---- from base-unicode-symbols:-import Data.Function.Unicode ( (∘) )-import Prelude.Unicode ( (⋅) )---- from concurrent-extra:-import qualified Control.Concurrent.Event as Event ( new, set, wait )-import qualified Control.Concurrent.RLock as RLock-import TestUtils---- 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 RLock----------------------------------------------------------------------------------tests ∷ [Test]-tests = [ testCase "recursive acquire" $ test_rlock_1 5- , testCase "conc acquire" $ test_rlock_2- ]--test_rlock_1 ∷ Int → Assertion-test_rlock_1 n = assert ∘ within (10 ⋅ a_moment) $ do- l ← RLock.new- replicateM_ n $ RLock.acquire l- replicateM_ n $ RLock.release l---- Tests for bug found by Felipe Lessa.-test_rlock_2 ∷ Assertion-test_rlock_2 = assert ∘ within (20 ⋅ a_moment) $ do- rl ← RLock.new- t1_has_rlock ← Event.new- t1_done ← Event.new- t2_done ← Event.new-- -- Thread 1- _ ← forkIO $ do- RLock.acquire rl- Event.set t1_has_rlock- threadDelay $ 10 ⋅ a_moment- RLock.release rl- Event.set t1_done-- -- Thread 2- _ ← forkIO $ do- Event.wait t1_has_rlock- RLock.acquire rl- RLock.release rl- Event.set t2_done-- Event.wait t1_done- Event.wait t2_done----- The End ---------------------------------------------------------------------
Control/Concurrent/ReadWriteLock.hs view
@@ -82,7 +82,7 @@ import Prelude ( ($!), succ, pred, error ) import System.IO ( IO ) -#if __GLASGOW_HASKELL__ < 701+#if __GLASGOW_HASKELL__ < 700 import Prelude ( fromInteger ) import Control.Monad ( (>>=), fail ) #endif@@ -246,7 +246,7 @@ Note that @waitRead@ is just a convenience function defined as: -@waitRead l = 'block' '$' 'acquireRead' l '>>' 'releaseRead' l@+@waitRead l = 'mask_' '$' 'acquireRead' l '>>' 'releaseRead' l@ -} waitRead ∷ RWLock → IO () waitRead l = mask_ $ acquireRead l >> releaseRead l@@ -348,7 +348,7 @@ Note that @waitWrite@ is just a convenience function defined as: -@waitWrite l = 'block' '$' 'acquireWrite' l '>>' 'releaseWrite' l@+@waitWrite l = 'mask_' '$' 'acquireWrite' l '>>' 'releaseWrite' l@ -} waitWrite ∷ RWLock → IO () waitWrite l = mask_ $ acquireWrite l >> releaseWrite l
− Control/Concurrent/ReadWriteLock/Test.hs
@@ -1,95 +0,0 @@-{-# LANGUAGE CPP, NoImplicitPrelude , UnicodeSyntax #-}--module Control.Concurrent.ReadWriteLock.Test ( tests ) where------------------------------------------------------------------------------------- Imports------------------------------------------------------------------------------------ from base:-import Control.Monad ( (>>) )-import Control.Concurrent ( forkIO, threadDelay )-import Data.Function ( ($) )--#if __GLASGOW_HASKELL__ < 701-import Prelude ( fromInteger )-import Control.Monad ( (>>=), fail )-#endif---- from base-unicode-symbols:-import Prelude.Unicode ( (⋅) )---- from concurrent-extra:-import qualified Control.Concurrent.ReadWriteLock as RWLock- ( new, acquireWrite, acquireRead, releaseWrite, releaseRead )--import TestUtils ( within, a_moment )--import Utils ( void )---- 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 ReadWriteLock----------------------------------------------------------------------------------tests ∷ [Test]-tests = [ testCase "test1" test1- , testCase "test2" test2- ]--test1 ∷ Assertion-test1 = assert $ within (10 ⋅ a_moment) $ do- -- Create a new read-write-lock (in the "Free" state):- rwl ← RWLock.new-- -- Put the read-write-lock in the "Write" state:- RWLock.acquireWrite rwl-- -- Fork a thread that releases the write-lock after a moment:- void $ forkIO $ threadDelay a_moment >> RWLock.releaseWrite rwl-- -- This blocks until the write-lock is released in the above thread.- RWLock.acquireRead rwl-- -- Release the read-lock so that the read-write-lock can either be- -- acquired again by 'acquireRead' or 'acquireWrite':- RWLock.releaseRead rwl-- -- The read-write-lock should now be in the "Free" state so the- -- following shouldn't deadlock:- RWLock.acquireWrite rwl--test2 ∷ Assertion-test2 = assert $ within (10 ⋅ a_moment) $ do- -- Create a new read-write-lock (in the "Free" state):- rwl ← RWLock.new-- -- Put the read-write-lock in the "Read" state:- RWLock.acquireRead rwl-- -- Fork a thread that releases the read-lock after a moment:- void $ forkIO $ threadDelay a_moment >> RWLock.releaseRead rwl-- -- This blocks until the read-lock is released in the above thread.- RWLock.acquireWrite rwl-- -- Release the write-lock so that the read-write-lock can either be- -- acquired again by 'acquireRead' or 'acquireWrite':- RWLock.releaseWrite rwl-- -- The read-write-lock should now be in the "Free" state so the- -- following shouldn't deadlock:- RWLock.acquireRead rwl----- The End ---------------------------------------------------------------------
− Control/Concurrent/ReadWriteVar/Test.hs
@@ -1,40 +0,0 @@-{-# LANGUAGE NoImplicitPrelude- , UnicodeSyntax- #-}--module Control.Concurrent.ReadWriteVar.Test ( tests ) where------------------------------------------------------------------------------------- Imports------------------------------------------------------------------------------------ from base:-import Control.Concurrent ( )---- from base-unicode-symbols:-import Prelude.Unicode ( )---- from concurrent-extra:-import qualified Control.Concurrent.ReadWriteVar as RWVar ( )-import TestUtils ( )---- from HUnit:-import Test.HUnit ( )---- from test-framework:-import Test.Framework ( Test )---- from test-framework-hunit:-import Test.Framework.Providers.HUnit ( )------------------------------------------------------------------------------------- Tests for ReadWriteVar----------------------------------------------------------------------------------tests ∷ [Test]-tests = []----- The End ---------------------------------------------------------------------
Control/Concurrent/STM/Lock.hs view
@@ -63,7 +63,7 @@ import Prelude ( error ) import System.IO ( IO ) -#if __GLASGOW_HASKELL__ < 701+#if __GLASGOW_HASKELL__ < 700 import Control.Monad ( (>>=), fail ) #endif
− Control/Concurrent/STM/Lock/Test.hs
@@ -1,110 +0,0 @@-{-# LANGUAGE CPP- , NoImplicitPrelude- , UnicodeSyntax- , ScopedTypeVariables- #-}--module Control.Concurrent.STM.Lock.Test ( tests ) where------------------------------------------------------------------------------------ Imports------------------------------------------------------------------------------------ from base:-import Control.Concurrent ( forkIO )-import Control.Monad ( return, (>>=), (>>) )-import Data.Bool ( Bool(False, True), not, (&&) )-import Data.Function ( ($) )-import Data.Functor ( fmap )-import Data.IORef ( newIORef, writeIORef, readIORef )--#if __GLASGOW_HASKELL__ < 701-import Prelude ( fromInteger )-import Control.Monad ( fail )-#endif---- from base-unicode-symbols:-import Data.Function.Unicode ( (∘) )-import Prelude.Unicode ( (⋅) )---- from stm:-import Control.Concurrent.STM ( atomically )---- from concurrent-extra:-import qualified Control.Concurrent.STM.Lock as Lock-import TestUtils---- 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 Lock----------------------------------------------------------------------------------tests ∷ [Test]-tests = [ testCase "acquire release" test_lock_1- , testCase "acquire acquire" test_lock_2- , testCase "new release" test_lock_3- , testCase "new unlocked" test_lock_4- , testCase "newAcquired locked" test_lock_5- , testCase "acq rel unlocked" test_lock_6- , testCase "conc release" test_lock_7- , testCase "wait" test_lock_8- ]--test_lock_1 ∷ Assertion-test_lock_1 = assert $ within a_moment $ atomically $ do- l ← Lock.new- Lock.acquire l- Lock.release l--test_lock_2 ∷ Assertion-test_lock_2 = assert $ notWithin (10 ⋅ a_moment) $ atomically $ do- l ← Lock.new- Lock.acquire l- Lock.acquire l--test_lock_3 ∷ Assertion-test_lock_3 = assertException "" $ atomically $ Lock.new >>= Lock.release--test_lock_4 ∷ Assertion-test_lock_4 = assert $ atomically $ Lock.new >>= fmap not ∘ Lock.locked--test_lock_5 ∷ Assertion-test_lock_5 = assert $ atomically $ Lock.newAcquired >>= Lock.locked--test_lock_6 ∷ Assertion-test_lock_6 = assert $ atomically $ do- l ← Lock.new- Lock.acquire l- Lock.release l- fmap not $ Lock.locked l--test_lock_7 ∷ Assertion-test_lock_7 = assert ∘ within (10 ⋅ a_moment) $ do- l ← atomically $ Lock.newAcquired- _ ← forkIO $ wait_a_moment >> atomically (Lock.release l)- atomically $ Lock.acquire l--test_lock_8 ∷ Assertion-test_lock_8 = assert $ do- ioRef ← newIORef False- l ← atomically Lock.newAcquired- _ ← forkIO $ do wait_a_moment- writeIORef ioRef True- atomically $ Lock.release l- atomically $ Lock.wait l- set ← readIORef ioRef- locked ← atomically $ Lock.locked l- return $ set && not locked------ The End ---------------------------------------------------------------------
− Control/Concurrent/Thread/Delay.hs
@@ -1,58 +0,0 @@-{-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax #-}------------------------------------------------------------------------------------ |--- Module : Control.Concurrent.Thread.Delay--- 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>------ Arbitrarily long thread delays.----------------------------------------------------------------------------------module Control.Concurrent.Thread.Delay ( delay ) where------------------------------------------------------------------------------------- Imports------------------------------------------------------------------------------------ from base:-import Control.Concurrent ( threadDelay )-import Control.Monad ( when )-import Data.Function ( ($) )-import Data.Int ( Int )-import Data.Ord ( min )-import Prelude ( Integer, toInteger, fromInteger, maxBound, (-) )-import System.IO ( IO )--#if __GLASGOW_HASKELL__ < 701-import Control.Monad ( (>>) )-#endif---- from base-unicode-symbols:-import Data.Eq.Unicode ( (≢) )------------------------------------------------------------------------------------- Delay----------------------------------------------------------------------------------{-|-Like 'threadDelay', but not bounded by an 'Int'.--Suspends the current thread for a given number of microseconds (GHC only).--There is no guarantee that the thread will be rescheduled promptly when the-delay has expired, but the thread will never continue to run earlier than-specified.--}-delay ∷ Integer → IO ()-delay time = do- let maxWait = min time $ toInteger (maxBound ∷ Int)- threadDelay $ fromInteger maxWait- when (maxWait ≢ time) $ delay (time - maxWait)----- The End ---------------------------------------------------------------------
− Control/Concurrent/Timeout.hs
@@ -1,121 +0,0 @@-{-# LANGUAGE CPP- , DeriveDataTypeable- , NoImplicitPrelude- , UnicodeSyntax- #-}------------------------------------------------------------------------------------ |--- Module : Control.Concurrent.Timeout--- 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>------ Wait arbitrarily long for an IO computation to finish.----------------------------------------------------------------------------------module Control.Concurrent.Timeout ( timeout ) where------------------------------------------------------------------------------------- Imports------------------------------------------------------------------------------------ from base:-import Control.Concurrent ( forkIO, myThreadId, throwTo, killThread )-import Control.Exception ( Exception, bracket, handleJust )-import Control.Monad ( return, (>>) )-import Data.Bool ( otherwise )-import Data.Eq ( Eq )-import Data.Functor ( fmap )-import Data.Maybe ( Maybe(Nothing, Just) )-import Data.Ord ( (<) )-import Data.Typeable ( Typeable )-import Data.Unique ( Unique, newUnique )-import Prelude ( Integer )-import System.IO ( IO )-import Text.Show ( Show, show )--#if __GLASGOW_HASKELL__ < 701-import Prelude ( fromInteger )-import Control.Monad ( (>>=), fail )-#endif--#ifdef __HADDOCK__-import Data.Int ( Int )-import System.IO ( hGetBuf, hPutBuf, hWaitForInput )-import qualified System.Timeout ( timeout )-#endif---- from base-unicode-symbols:-import Data.Eq.Unicode ( (≡) )---- from concurrent-extra (this package):-import Control.Concurrent.Thread.Delay ( delay )------------------------------------------------------------------------------------- Long delays and timeouts----------------------------------------------------------------------------------{--The following code was mostly copied from the module System.Timeout in the-package base-4.2.0.0.--(c) The University of Glasgow 2007--}--data Timeout = Timeout Unique deriving (Eq, Typeable)--instance Show Timeout where- show _ = "<<timeout>>"--instance Exception Timeout--{-|-Like 'System.Timeout.timeout', but not bounded by an 'Int'.--Wrap an 'IO' computation to time out and return 'Nothing' in case no result is-available within @n@ microseconds (@1\/10^6@ seconds). In case a result is-available before the timeout expires, 'Just' @a@ is returned. A negative timeout-interval means \"wait indefinitely\".--The design of this combinator was guided by the objective that @timeout n f@-should behave exactly the same as @f@ as long as @f@ doesn't time out. This-means that @f@ has the same 'myThreadId' it would have without the timeout-wrapper. Any exceptions @f@ might throw cancel the timeout and propagate further-up. It also possible for @f@ to receive exceptions thrown to it by another-thread.--A tricky implementation detail is the question of how to abort an 'IO'-computation. This combinator relies on asynchronous exceptions internally. The-technique works very well for computations executing inside of the Haskell-runtime system, but it doesn't work at all for non-Haskell code. Foreign-function calls, for example, cannot be timed out with this combinator simply-because an arbitrary C function cannot receive asynchronous exceptions. When-@timeout@ is used to wrap an FFI call that blocks, no timeout event can be-delivered until the FFI call returns, which pretty much negates the purpose of-the combinator. In practice, however, this limitation is less severe than it may-sound. Standard I\/O functions like 'System.IO.hGetBuf', 'System.IO.hPutBuf',-Network.Socket.accept, or 'System.IO.hWaitForInput' appear to be blocking, but-they really don't because the runtime system uses scheduling mechanisms like-@select(2)@ to perform asynchronous I\/O, so it is possible to interrupt-standard socket I\/O or file I\/O using this combinator.--}-timeout ∷ Integer → IO α → IO (Maybe α)-timeout n f- | n < 0 = fmap Just f- | n ≡ 0 = return Nothing- | otherwise = do- pid ← myThreadId- ex ← fmap Timeout newUnique- handleJust (\e → if e ≡ ex then Just () else Nothing)- (\_ → return Nothing)- (bracket (forkIO (delay n >> throwTo pid ex))- (killThread)- (\_ → fmap Just f)- )----- The End ---------------------------------------------------------------------
− Control/Concurrent/Timeout/Test.hs
@@ -1,55 +0,0 @@-{-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax #-}--module Control.Concurrent.Timeout.Test ( tests ) where------------------------------------------------------------------------------------- Imports------------------------------------------------------------------------------------ from base:-import Control.Concurrent ( forkIO, killThread )-import Data.Function ( ($) )-import Prelude ( toInteger )--#if __GLASGOW_HASKELL__ < 701-import Prelude ( fromInteger )-import Control.Monad ( (>>=), fail, (>>) )-#endif---- from base-unicode-symbols:-import Prelude.Unicode ( (⋅) )---- from concurrent-extra:-import qualified Control.Concurrent.Lock as Lock-import Control.Concurrent.Timeout ( timeout )-import TestUtils ( a_moment, within )-import Utils ( void, mask_ )---- 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 timeout----------------------------------------------------------------------------------tests ∷ [Test]-tests = [ testCase "timeout exception" test_timeout_exception ]--test_timeout_exception ∷ Assertion-test_timeout_exception = assert $ within (10 ⋅ a_moment) $ do- l ← Lock.newAcquired- tid ← mask_ $ forkIO $- void $ timeout (toInteger $ 1000 ⋅ a_moment) $ Lock.acquire l- killThread tid- Lock.release l----- The End ---------------------------------------------------------------------
Setup.hs view
@@ -10,17 +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)- , Args+ , UserHooks(haddockHook) ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )@@ -30,26 +25,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-concurrent-extra"- </> "test-concurrent-extra"+ hooks = simpleUserHooks { haddockHook = haddockHook' } -- Define __HADDOCK__ for CPP when running haddock. haddockHook' ∷ PackageDescription → LocalBuildInfo → UserHooks → HaddockFlags → IO ()
− TestUtils.hs
@@ -1,61 +0,0 @@-{-# LANGUAGE CPP- , 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 )-import Data.Bool ( Bool, not )-import Data.Char ( String )-import Data.Either ( Either(Left, Right) )-import Data.Int ( Int )-import Data.Maybe ( isJust )-import System.IO ( IO )-import System.Timeout ( timeout )--#if __GLASGOW_HASKELL__ < 701-import Prelude ( fromInteger )-import Control.Monad ( (>>=), fail )-#endif---- 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
@@ -24,7 +24,7 @@ import Prelude ( ($!) ) import System.IO ( IO ) -#if __GLASGOW_HASKELL__ < 701+#if __GLASGOW_HASKELL__ < 700 import Control.Monad ( (>>), fail ) #endif
concurrent-extra.cabal view
@@ -1,6 +1,6 @@ name: concurrent-extra-version: 0.6.0.1-cabal-version: >= 1.6+version: 0.7+cabal-version: >= 1.8 build-type: Custom stability: experimental author: Bas van Dijk <v.dijk.bas@gmail.com>@@ -33,12 +33,6 @@ . * @ReadWriteVar@: Concurrent read, sequential write variables. .- Besides these synchronisation primitives the package also provides:- .- * @Thread.Delay@: Arbitrarily long thread delays.- .- * @Timeout@: Wait arbitrarily long for an IO computation to finish.- . Please consult the API documentation of the individual modules for more detailed information. .@@ -51,24 +45,11 @@ ------------------------------------------------------------------------------- -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.4 , base-unicode-symbols >= 0.1.1 && < 0.3 , stm >= 2.1.2.1 && < 2.3+ , unbounded-delays >= 0.1 && < 0.2 exposed-modules: Control.Concurrent.Lock , Control.Concurrent.STM.Lock , Control.Concurrent.RLock@@ -76,17 +57,13 @@ , Control.Concurrent.Broadcast , Control.Concurrent.ReadWriteLock , Control.Concurrent.ReadWriteVar- , Control.Concurrent.Thread.Delay- , Control.Concurrent.Timeout other-modules: Utils ghc-options: -Wall - if flag(nolib)- buildable: False- ------------------------------------------------------------------------------- -executable test-concurrent-extra+test-suite test-concurrent-extra+ type: exitcode-stdio-1.0 main-is: test.hs other-modules: Control.Concurrent.Event.Test , Control.Concurrent.Lock.Test@@ -95,23 +72,16 @@ , Control.Concurrent.Broadcast.Test , Control.Concurrent.ReadWriteLock.Test , Control.Concurrent.ReadWriteVar.Test- , Control.Concurrent.Timeout.Test , TestUtils ghc-options: -Wall - if flag(test)- build-depends: base >= 3 && < 4.4- , base-unicode-symbols >= 0.1.1 && < 0.3- , stm >= 2.1.2.1 && < 2.3- , 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.4+ , base-unicode-symbols >= 0.1.1 && < 0.3+ , stm >= 2.1.2.1 && < 2.3+ , unbounded-delays >= 0.1 && < 0.2+ , HUnit >= 1.2.2 && < 1.3+ , test-framework >= 0.2.4 && < 0.4+ , test-framework-hunit >= 0.2.4 && < 0.3 -------------------------------------------------------------------------------
− test.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-}--module Main where------------------------------------------------------------------------------------ Imports------------------------------------------------------------------------------------ from base:-import System.IO ( IO )---- from concurrent-extra:-import qualified Control.Concurrent.Event.Test as Event ( tests )-import qualified Control.Concurrent.Lock.Test as Lock ( tests )-import qualified Control.Concurrent.STM.Lock.Test as STM.Lock ( tests )-import qualified Control.Concurrent.RLock.Test as RLock ( tests )-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.Timeout.Test as Timeout ( tests )---- from test-framework:-import Test.Framework ( Test, defaultMain, testGroup )------------------------------------------------------------------------------------- Tests----------------------------------------------------------------------------------main ∷ IO ()-main = defaultMain tests--tests ∷ [Test]-tests = [ testGroup "Pessimistic locking"- [ testGroup "Event" Event.tests- , testGroup "Lock" Lock.tests- , testGroup "STM.Lock" STM.Lock.tests- , testGroup "RLock" RLock.tests- , testGroup "Broadcast" Broadcast.tests- , testGroup "ReadWriteLock" RWLock.tests- , testGroup "ReadWriteVar" RWVar.tests- ]- , testGroup "Timeout" Timeout.tests- ]----- The End ---------------------------------------------------------------------