concurrent-extra 0.7.0.1 → 0.7.0.2

raw patch · 17 files changed

+676/−25 lines, 17 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Control/Concurrent/Broadcast.hs +0/−3
• Control/Concurrent/Broadcast/Test.hs +37/−0
• Control/Concurrent/Event.hs +0/−3
• Control/Concurrent/Event/Test.hs +108/−0
• Control/Concurrent/Lock.hs +0/−3
• Control/Concurrent/Lock/Test.hs +103/−0
• Control/Concurrent/RLock.hs +0/−3
• Control/Concurrent/RLock/Test.hs +83/−0
• Control/Concurrent/ReadWriteLock.hs +0/−3
• Control/Concurrent/ReadWriteLock/Test.hs +92/−0
• Control/Concurrent/ReadWriteVar.hs +0/−3
• Control/Concurrent/ReadWriteVar/Test.hs +37/−0
• Control/Concurrent/STM/Lock.hs +0/−3
• Control/Concurrent/STM/Lock/Test.hs +106/−0
• TestUtils.hs +61/−0
• concurrent-extra.cabal +4/−4
• test.hs +45/−0

@@ -205,6 +205,3 @@ -- | Set a broadcast to the \"silent\" state. silence ∷ Broadcast α → IO () silence (Broadcast mv) = purelyModifyMVar mv $ either Left $ const $ Left []----- The End ---------------------------------------------------------------------

@@ -0,0 +1,37 @@+{-# 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 = []

@@ -178,6 +178,3 @@ -} clear ∷ Event → IO () clear = Broadcast.silence ∘ evBroadcast----- The End ---------------------------------------------------------------------

@@ -0,0 +1,108 @@+{-# 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 Data.Bool          ( not )+import Prelude            ( toInteger )++#if __GLASGOW_HASKELL__ < 700+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+  notTimedOut ← Event.waitTimeout e $ toInteger a_moment+  return $ not notTimedOut++test_event_6 ∷ Assertion+test_event_6 = assert $ notWithin (10 ⋅ a_moment) $ do+  e ← Event.new+  Event.wait e

@@ -221,6 +221,3 @@ -} locked ∷ Lock → IO Bool locked = isEmptyMVar ∘ un----- The End ---------------------------------------------------------------------

@@ -0,0 +1,103 @@+{-# 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__ < 700+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

@@ -296,6 +296,3 @@ -} state ∷ RLock → IO State state = fmap fst ∘ readMVar ∘ un----- The End ---------------------------------------------------------------------

@@ -0,0 +1,83 @@+{-# 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__ < 700+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

@@ -354,6 +354,3 @@  moduleName ∷ String moduleName = "Control.Concurrent.ReadWriteLock"----- The End --------------------------------------------------------------------

@@ -0,0 +1,92 @@+{-# 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__ < 700+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

@@ -153,6 +153,3 @@ -} tryModify ∷ RWVar α → (α → IO (α, β)) → IO (Maybe β) tryModify (RWVar l r) = RWLock.tryWithWrite l ∘ modifyIORefM r----- The End --------------------------------------------------------------------

@@ -0,0 +1,37 @@+{-# 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 = []

@@ -199,6 +199,3 @@ -} locked ∷ Lock → STM Bool locked = isEmptyTMVar ∘ un----- The End ---------------------------------------------------------------------

@@ -0,0 +1,106 @@+{-# 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__ < 700+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

@@ -0,0 +1,61 @@+{-# 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.Either         ( Either(Left, Right) )+import Data.Int            ( Int )+import Data.Maybe          ( isJust )+import Prelude             ( String )+import System.IO           ( IO )+import System.Timeout      ( timeout )++#if __GLASGOW_HASKELL__ < 700+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 ---------------------------------------------------------------------

@@ -1,5 +1,5 @@ name:          concurrent-extra-version:       0.7.0.1+version:       0.7.0.2 cabal-version: >= 1.8 build-type:    Custom stability:     experimental@@ -10,7 +10,7 @@ copyright:     (c) 2010-2011 Bas van Dijk & Roel van Dijk license:       BSD3 license-file:  LICENSE-homepage:      https://github.com/basvandijk/concurrent-extra/+homepage:      https://github.com/basvandijk/concurrent-extra bug-reports:   https://github.com/basvandijk/concurrent-extra/issues category:      Concurrency synopsis:      Extra concurrency primitives@@ -50,7 +50,7 @@ -------------------------------------------------------------------------------  library-  build-depends: base                 >= 3       && < 4.5+  build-depends: base                 >= 3       && < 4.6                , base-unicode-symbols >= 0.1.1   && < 0.3                , stm                  >= 2.1.2.1 && < 2.3                , unbounded-delays     >= 0.1     && < 0.2@@ -80,7 +80,7 @@    ghc-options: -Wall -  build-depends: base                 >= 3       && < 4.5+  build-depends: base                 >= 3       && < 4.6                , base-unicode-symbols >= 0.1.1   && < 0.3                , stm                  >= 2.1.2.1 && < 2.3                , unbounded-delays     >= 0.1     && < 0.2

@@ -0,0 +1,45 @@+{-# 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 )++-- 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+          ]+        ]+++-- The End ---------------------------------------------------------------------