diff --git a/Control/Concurrent/Broadcast.hs b/Control/Concurrent/Broadcast.hs --- a/Control/Concurrent/Broadcast.hs +++ b/Control/Concurrent/Broadcast.hs @@ -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 diff --git a/Control/Concurrent/Broadcast/Test.hs b/Control/Concurrent/Broadcast/Test.hs deleted file mode 100644 --- a/Control/Concurrent/Broadcast/Test.hs +++ /dev/null @@ -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 --------------------------------------------------------------------- diff --git a/Control/Concurrent/Event/Test.hs b/Control/Concurrent/Event/Test.hs deleted file mode 100644 --- a/Control/Concurrent/Event/Test.hs +++ /dev/null @@ -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 --------------------------------------------------------------------- diff --git a/Control/Concurrent/Lock.hs b/Control/Concurrent/Lock.hs --- a/Control/Concurrent/Lock.hs +++ b/Control/Concurrent/Lock.hs @@ -76,7 +76,7 @@ import Prelude ( error ) import System.IO ( IO ) -#if __GLASGOW_HASKELL__ < 701 +#if __GLASGOW_HASKELL__ < 700 import Control.Monad ( (>>=), fail ) #endif diff --git a/Control/Concurrent/Lock/Test.hs b/Control/Concurrent/Lock/Test.hs deleted file mode 100644 --- a/Control/Concurrent/Lock/Test.hs +++ /dev/null @@ -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 --------------------------------------------------------------------- diff --git a/Control/Concurrent/RLock.hs b/Control/Concurrent/RLock.hs --- a/Control/Concurrent/RLock.hs +++ b/Control/Concurrent/RLock.hs @@ -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 diff --git a/Control/Concurrent/RLock/Test.hs b/Control/Concurrent/RLock/Test.hs deleted file mode 100644 --- a/Control/Concurrent/RLock/Test.hs +++ /dev/null @@ -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 --------------------------------------------------------------------- diff --git a/Control/Concurrent/ReadWriteLock.hs b/Control/Concurrent/ReadWriteLock.hs --- a/Control/Concurrent/ReadWriteLock.hs +++ b/Control/Concurrent/ReadWriteLock.hs @@ -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 diff --git a/Control/Concurrent/ReadWriteLock/Test.hs b/Control/Concurrent/ReadWriteLock/Test.hs deleted file mode 100644 --- a/Control/Concurrent/ReadWriteLock/Test.hs +++ /dev/null @@ -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 --------------------------------------------------------------------- diff --git a/Control/Concurrent/ReadWriteVar/Test.hs b/Control/Concurrent/ReadWriteVar/Test.hs deleted file mode 100644 --- a/Control/Concurrent/ReadWriteVar/Test.hs +++ /dev/null @@ -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 --------------------------------------------------------------------- diff --git a/Control/Concurrent/STM/Lock.hs b/Control/Concurrent/STM/Lock.hs --- a/Control/Concurrent/STM/Lock.hs +++ b/Control/Concurrent/STM/Lock.hs @@ -63,7 +63,7 @@ import Prelude ( error ) import System.IO ( IO ) -#if __GLASGOW_HASKELL__ < 701 +#if __GLASGOW_HASKELL__ < 700 import Control.Monad ( (>>=), fail ) #endif diff --git a/Control/Concurrent/STM/Lock/Test.hs b/Control/Concurrent/STM/Lock/Test.hs deleted file mode 100644 --- a/Control/Concurrent/STM/Lock/Test.hs +++ /dev/null @@ -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 --------------------------------------------------------------------- diff --git a/Control/Concurrent/Thread/Delay.hs b/Control/Concurrent/Thread/Delay.hs deleted file mode 100644 --- a/Control/Concurrent/Thread/Delay.hs +++ /dev/null @@ -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 --- , Roel van Dijk --- --- 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 --------------------------------------------------------------------- diff --git a/Control/Concurrent/Timeout.hs b/Control/Concurrent/Timeout.hs deleted file mode 100644 --- a/Control/Concurrent/Timeout.hs +++ /dev/null @@ -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 --- , Roel van Dijk --- --- 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 _ = "<>" - -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 --------------------------------------------------------------------- diff --git a/Control/Concurrent/Timeout/Test.hs b/Control/Concurrent/Timeout/Test.hs deleted file mode 100644 --- a/Control/Concurrent/Timeout/Test.hs +++ /dev/null @@ -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 --------------------------------------------------------------------- diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 () diff --git a/TestUtils.hs b/TestUtils.hs deleted file mode 100644 --- a/TestUtils.hs +++ /dev/null @@ -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 --------------------------------------------------------------------- diff --git a/Utils.hs b/Utils.hs --- a/Utils.hs +++ b/Utils.hs @@ -24,7 +24,7 @@ import Prelude ( ($!) ) import System.IO ( IO ) -#if __GLASGOW_HASKELL__ < 701 +#if __GLASGOW_HASKELL__ < 700 import Control.Monad ( (>>), fail ) #endif diff --git a/concurrent-extra.cabal b/concurrent-extra.cabal --- a/concurrent-extra.cabal +++ b/concurrent-extra.cabal @@ -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 @@ -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 ------------------------------------------------------------------------------- diff --git a/test.hs b/test.hs deleted file mode 100644 --- a/test.hs +++ /dev/null @@ -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 ---------------------------------------------------------------------