concurrent-extra 0.5.1 → 0.6
raw patch · 12 files changed
+146/−82 lines, 12 filesdep ~basedep ~stm
Dependency ranges changed: base, stm
Files
- Control/Concurrent/Broadcast.hs +7/−7
- Control/Concurrent/Event.hs +3/−3
- Control/Concurrent/Lock.hs +11/−6
- Control/Concurrent/Lock/Test.hs +18/−3
- Control/Concurrent/RLock.hs +12/−8
- Control/Concurrent/ReadWriteLock.hs +21/−18
- Control/Concurrent/ReadWriteVar.hs +3/−3
- Control/Concurrent/STM/Lock.hs +16/−13
- Control/Concurrent/STM/Lock/Test.hs +18/−3
- Control/Concurrent/Timeout.hs +1/−1
- Utils.hs +24/−4
- concurrent-extra.cabal +12/−13
Control/Concurrent/Broadcast.hs view
@@ -53,7 +53,7 @@ import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar , takeMVar, putMVar, readMVar, modifyMVar_ )-import Control.Exception ( block, onException )+import Control.Exception ( onException ) import Data.Eq ( Eq ) import Data.Either ( Either(Left ,Right), either ) import Data.Function ( ($), const )@@ -69,8 +69,8 @@ -- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) --- from concurrent-extra:-import Utils ( purelyModifyMVar )+-- from concurrent-extra (this package):+import Utils ( purelyModifyMVar, mask_ ) import Control.Concurrent.Timeout ( timeout ) @@ -90,11 +90,11 @@ newtype Broadcast α = Broadcast {unBroadcast ∷ MVar (Either [MVar α] α)} deriving (Eq, Typeable) --- | @new@ Creates a broadcast in the \"silent\" state.+-- | @new@ creates a broadcast in the \"silent\" state. new ∷ IO (Broadcast α) new = Broadcast <$> newMVar (Left []) --- | @newBroadcasting x@ Creates a broadcast in the \"broadcasting @x@\" state.+-- | @newBroadcasting x@ creates a broadcast in the \"broadcasting @x@\" state. newBroadcasting ∷ α → IO (Broadcast α) newBroadcasting x = Broadcast <$> newMVar (Right x) @@ -108,7 +108,7 @@ @'broadcast's@ a value to the broadcast. -} listen ∷ Broadcast α → IO α-listen (Broadcast mv) = block $ do+listen (Broadcast mv) = mask_ $ do mx ← takeMVar mv case mx of Left ls → do l ← newEmptyMVar@@ -142,7 +142,7 @@ Negative timeouts are treated the same as a timeout of 0 μs. -} listenTimeout ∷ Broadcast α → Integer → IO (Maybe α)-listenTimeout (Broadcast mv) time = block $ do+listenTimeout (Broadcast mv) time = mask_ $ do mx ← takeMVar mv case mx of Left ls → do l ← newEmptyMVar
Control/Concurrent/Event.hs view
@@ -57,7 +57,7 @@ -- Imports ------------------------------------------------------------------------------- --- from base+-- from base: import Data.Bool ( Bool(..) ) import Data.Eq ( Eq ) import Data.Functor ( fmap, (<$>) )@@ -69,10 +69,10 @@ import Prelude ( Integer ) import System.IO ( IO ) --- from base-unicode-symbols+-- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) --- from concurrent-extra+-- from concurrent-extra (this package): import Control.Concurrent.Broadcast ( Broadcast ) import qualified Control.Concurrent.Broadcast as Broadcast ( new, newBroadcasting
Control/Concurrent/Lock.hs view
@@ -59,10 +59,10 @@ import Control.Applicative ( liftA2 ) import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar , takeMVar, tryTakeMVar- , tryPutMVar+ , putMVar, tryPutMVar , isEmptyMVar )-import Control.Exception ( block, bracket_, finally )+import Control.Exception ( bracket_, onException ) import Control.Monad ( Monad, return, (>>=), (>>), fail, when ) import Data.Bool ( Bool, not ) #ifdef __HADDOCK__@@ -79,7 +79,10 @@ -- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) +-- from concurrent-extra (this package):+import Utils ( mask, mask_ ) + -------------------------------------------------------------------------------- -- Locks --------------------------------------------------------------------------------@@ -178,10 +181,12 @@ computation is returned. -} tryWith ∷ Lock → IO α → IO (Maybe α)-tryWith l a = block $ do+tryWith l a = mask $ \restore → do acquired ← tryAcquire l if acquired- then Just <$> a `finally` release l+ then do r ← restore a `onException` release l+ release l+ return $ Just r else return Nothing {-|@@ -192,12 +197,12 @@ @wait@ does not alter the state of the lock. -Note that @wait@ is just a convenience function defined as:+Note that @wait@ is just a convenience function we can be defined as: @wait l = 'block' '$' 'acquire' l '>>' 'release' l@ -} wait ∷ Lock → IO ()-wait l = block $ acquire l >> release l+wait (Lock mv) = mask_ $ takeMVar mv >> putMVar mv () --------------------------------------------------------------------------------
Control/Concurrent/Lock/Test.hs view
@@ -11,12 +11,14 @@ -- from base: import Control.Concurrent ( forkIO )-import Control.Monad ( (>>=), fail, (>>) )-import Data.Bool ( not )+import Control.Monad ( return, (>>=), fail, (>>) )+import Data.Bool ( Bool(False, True), not, (&&) ) import Data.Function ( ($) )-import Data.Functor ( fmap )+import Data.Functor ( fmap )+import Data.IORef ( newIORef, writeIORef, readIORef ) import Prelude ( fromInteger ) + -- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) import Prelude.Unicode ( (⋅) )@@ -47,6 +49,7 @@ , 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@@ -82,6 +85,18 @@ 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
@@ -65,7 +65,7 @@ import Control.Applicative ( liftA2 ) import Control.Concurrent ( ThreadId, myThreadId ) import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, readMVar, putMVar )-import Control.Exception ( block, bracket_, finally )+import Control.Exception ( bracket_, onException ) import Control.Monad ( Monad, return, (>>=), fail, (>>) ) import Data.Bool ( Bool(False, True), otherwise ) import Data.Eq ( Eq )@@ -82,12 +82,14 @@ import Data.Function.Unicode ( (∘) ) import Data.Monoid.Unicode ( (⊕) ) --- from concurrent-extra:+-- from concurrent-extra (this package): import Control.Concurrent.Lock ( Lock ) import qualified Control.Concurrent.Lock as Lock ( new, newAcquired, acquire, release, wait ) +import Utils ( mask, mask_ ) + -------------------------------------------------------------------------------- -- Reentrant locks --------------------------------------------------------------------------------@@ -165,7 +167,7 @@ acquire ∷ RLock → IO () acquire (RLock mv) = do myTID ← myThreadId- block $ let acq = do t@(mb, lock) ← takeMVar mv+ mask_ $ let acq = do t@(mb, lock) ← takeMVar mv case mb of Nothing → do Lock.acquire lock putMVar mv (Just (myTID, 1), lock)@@ -190,7 +192,7 @@ tryAcquire ∷ RLock → IO Bool tryAcquire (RLock mv) = do myTID ← myThreadId- block $ do+ mask_ $ do t@(mb, lock) ← takeMVar mv case mb of Nothing → do Lock.acquire lock@@ -216,7 +218,7 @@ release ∷ RLock → IO () release (RLock mv) = do myTID ← myThreadId- block $ do+ mask_ $ do t@(mb, lock) ← takeMVar mv let err msg = do putMVar mv t error $ "Control.Concurrent.RLock.release: " ⊕ msg@@ -252,10 +254,12 @@ computation is returned. -} tryWith ∷ RLock → IO α → IO (Maybe α)-tryWith l a = block $ do+tryWith l a = mask $ \restore → do acquired ← tryAcquire l if acquired- then Just <$> a `finally` release l+ then do r ← restore a `onException` release l+ release l+ return $ Just r else return Nothing {-|@@ -271,7 +275,7 @@ @wait l = 'block' '$' 'acquire' l '>>' 'release' l@ -} wait ∷ RLock → IO ()-wait l = block $ acquire l >> release l+wait l = mask_ $ acquire l >> release l --------------------------------------------------------------------------------
Control/Concurrent/ReadWriteLock.hs view
@@ -66,32 +66,31 @@ -- Imports ------------------------------------------------------------------------------- --- from base+-- from base: import Control.Applicative ( liftA2, liftA3 ) import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, putMVar, swapMVar )-import Control.Exception ( block, bracket_, finally )+import Control.Exception ( bracket_, onException ) import Control.Monad ( return, (>>=), return, fail, (>>), when ) import Data.Bool ( Bool(False, True) ) import Data.Char ( String ) import Data.Eq ( Eq, (==) ) import Data.Function ( ($), on )-import Data.Functor ( (<$>) ) import Data.Int ( Int ) import Data.Maybe ( Maybe(Nothing, Just) ) import Data.Typeable ( Typeable ) import Prelude ( ($!), fromInteger, succ, pred, error ) import System.IO ( IO ) --- from base-unicode-symbols+-- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) import Data.Monoid.Unicode ( (⊕) ) --- from concurrent-extra+-- from concurrent-extra (this package): import Control.Concurrent.Lock ( Lock ) import qualified Control.Concurrent.Lock as Lock ( new, newAcquired, acquire, tryAcquire, release, wait ) -import Utils ( void )+import Utils ( void, mask, mask_ ) -------------------------------------------------------------------------------@@ -160,7 +159,7 @@ simultaneous threads acquire the read lock. But that is unlikely. -} acquireRead ∷ RWLock → IO ()-acquireRead (RWLock {state, readLock, writeLock}) = block acqRead+acquireRead (RWLock {state, readLock, writeLock}) = mask_ acqRead where acqRead = do st ← takeMVar state case st of@@ -178,7 +177,7 @@ \"read\", 'False' otherwise. -} tryAcquireRead ∷ RWLock → IO Bool-tryAcquireRead (RWLock {state, readLock}) = block $ do+tryAcquireRead (RWLock {state, readLock}) = mask_ $ do st ← takeMVar state case st of Free → do Lock.acquire readLock@@ -199,7 +198,7 @@ \"read\" state. -} releaseRead ∷ RWLock → IO ()-releaseRead (RWLock {state, readLock}) = block $ do+releaseRead (RWLock {state, readLock}) = mask_ $ do st ← takeMVar state case st of Read 1 → do Lock.release readLock@@ -223,10 +222,12 @@ released and 'Just' the result of the computation is returned. -} tryWithRead ∷ RWLock → IO α → IO (Maybe α)-tryWithRead l a = block $ do+tryWithRead l a = mask $ \restore → do acquired ← tryAcquireRead l if acquired- then Just <$> a `finally` releaseRead l+ then do r ← restore a `onException` releaseRead l+ releaseRead l+ return $ Just r else return Nothing {-|@@ -242,7 +243,7 @@ @waitRead l = 'block' '$' 'acquireRead' l '>>' 'releaseRead' l@ -} waitRead ∷ RWLock → IO ()-waitRead l = block $ acquireRead l >> releaseRead l+waitRead l = mask_ $ acquireRead l >> releaseRead l -------------------------------------------------------------------------------@@ -257,7 +258,7 @@ 'RWLock' will be \"write\". -} acquireWrite ∷ RWLock → IO ()-acquireWrite (RWLock {state, readLock, writeLock}) = block acqWrite+acquireWrite (RWLock {state, readLock, writeLock}) = mask_ acqWrite where acqWrite = do st ← takeMVar state case st of@@ -277,7 +278,7 @@ \"write\", 'False' otherwise. -} tryAcquireWrite ∷ RWLock → IO Bool-tryAcquireWrite (RWLock {state, writeLock}) = block $ do+tryAcquireWrite (RWLock {state, writeLock}) = mask_ $ do st ← takeMVar state case st of Free → do Lock.acquire writeLock@@ -300,7 +301,7 @@ \"write\" state. -} releaseWrite ∷ RWLock → IO ()-releaseWrite (RWLock {state, writeLock}) = block $ do+releaseWrite (RWLock {state, writeLock}) = mask_ $ do st ← takeMVar state case st of Write → do Lock.release writeLock@@ -323,10 +324,12 @@ released and 'Just' the result of the computation is returned. -} tryWithWrite ∷ RWLock → IO α → IO (Maybe α)-tryWithWrite l a = block $ do+tryWithWrite l a = mask $ \restore → do acquired ← tryAcquireWrite l if acquired- then Just <$> a `finally` releaseWrite l+ then do r ← restore a `onException` releaseWrite l+ releaseWrite l+ return $ Just r else return Nothing {-|@@ -342,7 +345,7 @@ @waitWrite l = 'block' '$' 'acquireWrite' l '>>' 'releaseWrite' l@ -} waitWrite ∷ RWLock → IO ()-waitWrite l = block $ acquireWrite l >> releaseWrite l+waitWrite l = mask_ $ acquireWrite l >> releaseWrite l moduleName ∷ String moduleName = "Control.Concurrent.ReadWriteLock"
Control/Concurrent/ReadWriteVar.hs view
@@ -61,7 +61,7 @@ -- Imports ------------------------------------------------------------------------------- --- from base+-- from base: import Control.Applicative ( liftA2 ) import Control.Monad ( (>>=) ) import Data.Bool ( Bool(..) )@@ -77,10 +77,10 @@ import Prelude ( undefined ) #endif --- from base-unicode-symbols+-- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) --- from concurrent-extra+-- from concurrent-extra (this package): import Control.Concurrent.ReadWriteLock ( RWLock ) import qualified Control.Concurrent.ReadWriteLock as RWLock
Control/Concurrent/STM/Lock.hs view
@@ -47,13 +47,13 @@ -- from base: import Control.Applicative ( liftA2 )-import Control.Exception ( block, bracket_, finally )+import Control.Exception ( bracket_, onException ) import Control.Monad ( Monad, return, (>>=), (>>), fail, when ) import Data.Bool ( Bool, not ) #ifdef __HADDOCK__-import Data.Bool (Bool(False, True))+import Data.Bool ( Bool(False, True) ) #endif--- TODO: import Data.Eq ( Eq )+import Data.Eq ( Eq ) import Data.Function ( ($) ) import Data.Functor ( fmap, (<$>) ) import Data.Maybe ( Maybe(Nothing, Just), isJust )@@ -68,23 +68,24 @@ #endif import Control.Concurrent.STM.TMVar ( TMVar, newTMVar, newEmptyTMVar , takeTMVar, tryTakeTMVar- , tryPutTMVar+ , putTMVar, tryPutTMVar , isEmptyTMVar ) -- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) +-- from concurrent-extra (this package):+import Utils ( mask ) + -------------------------------------------------------------------------------- -- Locks -------------------------------------------------------------------------------- -- | A lock is in one of two states: \"locked\" or \"unlocked\". newtype Lock = Lock {un ∷ TMVar ()}- deriving ( Typeable- -- TODO: , Eq -- I added an Eq instance for TMVar to the HEAD branch of stm.- )+ deriving (Typeable, Eq) --------------------------------------------------------------------------------@@ -130,8 +131,8 @@ Note that it is an error to release a lock in the \"unlocked\" state! -} release ∷ Lock → STM ()-release (Lock mv) = do- b ← tryPutTMVar mv ()+release (Lock tmv) = do+ b ← tryPutTMVar tmv () when (not b) $ error "Control.Concurrent.STM.Lock.release: Can't release unlocked Lock!" @@ -155,10 +156,12 @@ computation is returned. -} tryWith ∷ Lock → IO α → IO (Maybe α)-tryWith l a = block $ do+tryWith l a = mask $ \restore → do acquired ← atomically (tryAcquire l) if acquired- then Just <$> a `finally` atomically (release l)+ then do r ← restore a `onException` atomically (release l)+ atomically (release l)+ return $ Just r else return Nothing {-|@@ -168,12 +171,12 @@ @wait@ does not alter the state of the lock. -Note that @wait@ is just a convenience function defined as:+Note that @wait@ is just a convenience function which can be defined as: @wait l = 'acquire' l '>>' 'release' l@ -} wait ∷ Lock → STM ()-wait l = acquire l >> release l+wait (Lock tmv) = takeTMVar tmv >> putTMVar tmv () --------------------------------------------------------------------------------
Control/Concurrent/STM/Lock/Test.hs view
@@ -11,10 +11,11 @@ -- from base: import Control.Concurrent ( forkIO )-import Control.Monad ( (>>=), fail, (>>) )-import Data.Bool ( not )+import Control.Monad ( return, (>>=), fail, (>>) )+import Data.Bool ( Bool(False, True), not, (&&) ) import Data.Function ( ($) )-import Data.Functor ( fmap )+import Data.Functor ( fmap )+import Data.IORef ( newIORef, writeIORef, readIORef ) import Prelude ( fromInteger ) -- from base-unicode-symbols:@@ -50,6 +51,7 @@ , 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@@ -85,6 +87,19 @@ 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/Timeout.hs view
@@ -47,7 +47,7 @@ -- from base-unicode-symbols: import Data.Eq.Unicode ( (≡) ) --- from concurrent-extra:+-- from concurrent-extra (this package): import Control.Concurrent.Thread.Delay ( delay )
Utils.hs view
@@ -1,6 +1,15 @@-{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-}+{-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax #-} -module Utils where+module Utils+ ( mask+ , mask_+ , (∘!)+ , void+ , ifM+ , purelyModifyMVar+ , modifyIORefM+ , modifyIORefM_+ ) where -------------------------------------------------------------------------------- -- Imports@@ -8,7 +17,6 @@ -- from base: import Control.Concurrent.MVar ( MVar, takeMVar, putMVar )-import Control.Exception ( block ) import Control.Monad ( Monad, return, (>>=), (>>), fail ) import Data.Bool ( Bool ) import Data.Function ( ($) )@@ -25,6 +33,18 @@ -- Utility functions -------------------------------------------------------------------------------- +#if MIN_VERSION_base(4,3,0)+import Control.Exception ( mask, mask_ )+#else+import Control.Exception ( blocked, block, unblock )++mask ∷ ((IO α → IO α) → IO β) → IO β+mask io = blocked >>= \b → if b then io id else block $ io unblock++mask_ ∷ IO α → IO α+mask_ = block+#endif+ -- | Strict function composition. (∘!) ∷ (β → γ) → (α → β) → (α → γ) f ∘! g = (f $!) ∘ g@@ -36,7 +56,7 @@ ifM c t e = c >>= \b → if b then t else e purelyModifyMVar ∷ MVar α → (α → α) → IO ()-purelyModifyMVar mv f = block $ takeMVar mv >>= putMVar mv ∘! f+purelyModifyMVar mv f = mask_ $ takeMVar mv >>= putMVar mv ∘! f modifyIORefM ∷ IORef α → (α → IO (α, β)) → IO β modifyIORefM r f = do (y, z) ← readIORef r >>= f
concurrent-extra.cabal view
@@ -1,5 +1,5 @@ name: concurrent-extra-version: 0.5.1+version: 0.6 cabal-version: >= 1.6 build-type: Custom stability: experimental@@ -20,7 +20,6 @@ . * @Event@: Wake multiple threads by signalling an event. .- * @Lock@: Enforce exclusive access to a resource. Also known as a binary semaphore or mutex. The package additionally provides an alternative that works in the @STM@ monad.@@ -67,9 +66,9 @@ ------------------------------------------------------------------------------- library- build-depends: base >= 3 && < 4.3- , base-unicode-symbols >= 0.1.1 && < 0.3- , stm >= 2.1 && < 2.2+ build-depends: base >= 3 && < 4.4+ , base-unicode-symbols >= 0.1.1 && < 0.3+ , stm >= 2.1.2.1 && < 2.3 exposed-modules: Control.Concurrent.Lock , Control.Concurrent.STM.Lock , Control.Concurrent.RLock@@ -102,14 +101,14 @@ ghc-options: -Wall if flag(test)- build-depends: base >= 3 && < 4.3- , base-unicode-symbols >= 0.1.1 && < 0.3- , stm >= 2.1 && < 2.2- , HUnit >= 1.2.2 && < 1.3- , QuickCheck >= 2.1.0 && < 2.2- , test-framework >= 0.2.4 && < 0.4- , test-framework-hunit >= 0.2.4 && < 0.3- , test-framework-quickcheck2 >= 0.2.4 && < 0.3+ 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+ , QuickCheck >= 2.1.0 && < 2.2+ , test-framework >= 0.2.4 && < 0.4+ , test-framework-hunit >= 0.2.4 && < 0.3+ , test-framework-quickcheck2 >= 0.2.4 && < 0.3 buildable: True else buildable: False