concurrent-extra-0.7.0.12/0000755000000000000000000000000013252301656013433 5ustar0000000000000000concurrent-extra-0.7.0.12/Setup.hs0000644000000000000000000000005613252301656015070 0ustar0000000000000000import Distribution.Simple main = defaultMain concurrent-extra-0.7.0.12/LICENSE0000644000000000000000000000302213252301656014435 0ustar0000000000000000Copyright (c) 2010-2012 Bas van Dijk & Roel van Dijk All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * The names of Bas van Dijk, Roel van Dijk and the names of contributors may NOT be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. concurrent-extra-0.7.0.12/README.markdown0000644000000000000000000000203513252301656016134 0ustar0000000000000000The `concurrent-extra` package offers among other things the following selection of synchronisation primitives: * `Broadcast`: Wake multiple threads by broadcasting a value. * `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. * `RLock`: A lock which can be acquired multiple times by the same thread. Also known as a reentrant mutex. * `ReadWriteLock`: Multiple-reader, single-writer locks. Used to protect shared resources which may be concurrently read, but only sequentially written. * `ReadWriteVar`: Concurrent read, sequential write variables. Please consult the API documentation of the individual modules for more detailed information. This package was inspired by the concurrency libraries of [Java](http://download.oracle.com/javase/6/docs/technotes/guides/concurrency/index.html) and [Python](http://docs.python.org/py3k/library/threading.html). concurrent-extra-0.7.0.12/test.hs0000644000000000000000000000303713252301656014751 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} 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 ] ] concurrent-extra-0.7.0.12/concurrent-extra.cabal0000644000000000000000000000647213252301656017733 0ustar0000000000000000name: concurrent-extra version: 0.7.0.12 cabal-version: >= 1.8 build-type: Simple stability: experimental author: Bas van Dijk Roel van Dijk maintainer: Bas van Dijk Roel van Dijk copyright: (c) 2010-2012 Bas van Dijk & Roel van Dijk license: BSD3 license-file: LICENSE homepage: https://github.com/basvandijk/concurrent-extra bug-reports: https://github.com/basvandijk/concurrent-extra/issues category: Concurrency synopsis: Extra concurrency primitives description: The @concurrent-extra@ package offers among other things the following selection of synchronisation primitives: . * @Broadcast@: Wake multiple threads by broadcasting a value. . * @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. . * @RLock@: A lock which can be acquired multiple times by the same thread. Also known as a reentrant mutex. . * @ReadWriteLock@: Multiple-reader, single-writer locks. Used to protect shared resources which may be concurrently read, but only sequentially written. . * @ReadWriteVar@: Concurrent read, sequential write variables. . Please consult the API documentation of the individual modules for more detailed information. . This package was inspired by the concurrency libraries of Java and Python. extra-source-files: README.markdown source-repository head Type: git Location: git://github.com/basvandijk/concurrent-extra.git ------------------------------------------------------------------------------- library build-depends: base >= 3 && < 5 , stm >= 2.1.2.1 , unbounded-delays >= 0.1 exposed-modules: Control.Concurrent.Lock , Control.Concurrent.STM.Lock , Control.Concurrent.RLock , Control.Concurrent.Event , Control.Concurrent.Broadcast , Control.Concurrent.ReadWriteLock , Control.Concurrent.ReadWriteVar other-modules: Utils ghc-options: -Wall ------------------------------------------------------------------------------- test-suite test-concurrent-extra type: exitcode-stdio-1.0 main-is: test.hs other-modules: Control.Concurrent.Event.Test , Control.Concurrent.Lock.Test , Control.Concurrent.STM.Lock.Test , Control.Concurrent.RLock.Test , Control.Concurrent.Broadcast.Test , Control.Concurrent.ReadWriteLock.Test , Control.Concurrent.ReadWriteVar.Test , TestUtils ghc-options: -Wall -threaded build-depends: base >= 3 && < 5 , stm >= 2.1.2.1 , unbounded-delays >= 0.1 , HUnit >= 1.2.2 , random >= 1.0 , test-framework >= 0.2.4 , test-framework-hunit >= 0.2.4 , async >= 2.0 ------------------------------------------------------------------------------- concurrent-extra-0.7.0.12/Utils.hs0000644000000000000000000000376013252301656015075 0ustar0000000000000000{-# LANGUAGE CPP, NoImplicitPrelude #-} module Utils ( mask , mask_ , (.!) , void , ifM , purelyModifyMVar , modifyIORefM , modifyIORefM_ ) where -------------------------------------------------------------------------------- -- Imports -------------------------------------------------------------------------------- -- from base: import Control.Concurrent.MVar ( MVar, takeMVar, putMVar ) import Control.Monad ( Monad, return, (>>=) ) import Data.Bool ( Bool ) import Data.Function ( ($), (.) ) import Data.IORef ( IORef, readIORef, writeIORef ) import Prelude ( ($!) ) import System.IO ( IO ) #if __GLASGOW_HASKELL__ < 700 import Control.Monad ( (>>), fail ) #endif -------------------------------------------------------------------------------- -- Utility functions -------------------------------------------------------------------------------- #if MIN_VERSION_base(4,3,0) import Control.Exception ( mask, mask_ ) import Control.Monad ( void ) #else import Control.Exception ( blocked, block, unblock ) import Data.Function ( id ) import Data.Functor ( Functor, (<$) ) mask :: ((IO a -> IO a) -> IO b) -> IO b mask io = blocked >>= \b -> if b then io id else block $ io unblock mask_ :: IO a -> IO a mask_ = block void :: (Functor f) => f a -> f () void = (() <$) #endif -- | Strict function composition. (.!) :: (b -> γ) -> (a -> b) -> (a -> γ) f .! g = (f $!) . g ifM :: Monad m => m Bool -> m a -> m a -> m a ifM c t e = c >>= \b -> if b then t else e purelyModifyMVar :: MVar a -> (a -> a) -> IO () purelyModifyMVar mv f = mask_ $ takeMVar mv >>= putMVar mv .! f modifyIORefM :: IORef a -> (a -> IO (a, b)) -> IO b modifyIORefM r f = do (y, z) <- readIORef r >>= f writeIORef r y return z modifyIORefM_ :: IORef a -> (a -> IO a) -> IO () modifyIORefM_ r f = readIORef r >>= f >>= writeIORef r concurrent-extra-0.7.0.12/TestUtils.hs0000644000000000000000000000330613252301656015731 0ustar0000000000000000{-# LANGUAGE CPP , NoImplicitPrelude , ScopedTypeVariables #-} 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 a -> IO Bool within t a = isJust <$> timeout t a notWithin :: Int -> IO a -> IO Bool notWithin t a = not <$> within t a assertException :: String -> IO a -> Assertion assertException errMsg a = do e <- try a case e of Left (_ :: SomeException ) -> return () Right _ -> assertFailure errMsg concurrent-extra-0.7.0.12/Control/0000755000000000000000000000000013252301656015053 5ustar0000000000000000concurrent-extra-0.7.0.12/Control/Concurrent/0000755000000000000000000000000013252301656017175 5ustar0000000000000000concurrent-extra-0.7.0.12/Control/Concurrent/ReadWriteLock.hs0000644000000000000000000002650613252301656022241 0ustar0000000000000000{-# LANGUAGE CPP , DeriveDataTypeable , NamedFieldPuns , NoImplicitPrelude #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #endif ------------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.ReadWriteLock -- Copyright : (c) 2010-2011 Bas van Dijk & Roel van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk -- , Roel van Dijk -- -- Multiple-reader, single-writer locks. Used to protect shared resources which -- may be concurrently read, but only sequentially written. -- -- All functions are /exception safe/. Throwing asynchronous exceptions will not -- compromise the internal state of an 'RWLock'. This means it is perfectly safe -- to kill a thread that is blocking on, for example, 'acquireRead'. -- -- See also Java's version: -- -- -- This module is designed to be imported qualified. We suggest importing it -- like: -- -- @ -- import Control.Concurrent.ReadWriteLock ( RWLock ) -- import qualified Control.Concurrent.ReadWriteLock as RWL ( ... ) -- @ -- ------------------------------------------------------------------------------- module Control.Concurrent.ReadWriteLock ( RWLock -- *Creating Read-Write Locks , new , newAcquiredRead , newAcquiredWrite -- *Read access -- **Blocking , acquireRead , releaseRead , withRead , waitRead -- **Non-blocking , tryAcquireRead , tryWithRead -- *Write access -- **Blocking , acquireWrite , releaseWrite , withWrite , waitWrite -- **Non-blocking , tryAcquireWrite , tryWithWrite ) where ------------------------------------------------------------------------------- -- Imports ------------------------------------------------------------------------------- -- from base: import Control.Applicative ( liftA2, liftA3 ) import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, putMVar ) import Control.Exception ( bracket_, onException ) import Control.Monad ( return, (>>) ) import Data.Bool ( Bool(False, True) ) import Data.Eq ( Eq, (==) ) import Data.Function ( ($), (.), on ) import Data.Int ( Int ) import Data.Maybe ( Maybe(Nothing, Just) ) import Data.List ( (++)) import Data.Typeable ( Typeable ) import Prelude ( String, ($!), succ, pred, error ) import System.IO ( IO ) #if __GLASGOW_HASKELL__ < 700 import Prelude ( fromInteger ) import Control.Monad ( (>>=), fail ) #endif -- 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_ ) ------------------------------------------------------------------------------- -- Read Write Lock ------------------------------------------------------------------------------- {-| Multiple-reader, single-writer lock. Is in one of three states: * \"Free\": Read or write access can be acquired without blocking. * \"Read\": One or more threads have acquired read access. Blocks write access. * \"Write\": A single thread has acquired write access. Blocks other threads from acquiring both read and write access. -} data RWLock = RWLock { state :: MVar State , readLock :: Lock , writeLock :: Lock } deriving Typeable instance Eq RWLock where (==) = (==) `on` state -- | Internal state of the 'RWLock'. data State = Free | Read Int | Write ------------------------------------------------------------------------------- -- * Creating Read-Write Locks ------------------------------------------------------------------------------- -- | Create a new 'RWLock' in the \"free\" state; either read or write access -- can be acquired without blocking. new :: IO RWLock new = liftA3 RWLock (newMVar Free) Lock.new Lock.new -- | Create a new 'RWLock' in the \"read\" state; only read can be acquired -- without blocking. newAcquiredRead :: IO RWLock newAcquiredRead = liftA3 RWLock (newMVar $ Read 1) Lock.newAcquired Lock.new -- | Create a new 'RWLock' in the \"write\" state; either acquiring read or -- write will block. newAcquiredWrite :: IO RWLock newAcquiredWrite = liftA3 RWLock (newMVar Write) Lock.new Lock.newAcquired ------------------------------------------------------------------------------- -- * Read access ------------------------------------------------------------------------------- {-| Acquire the read lock. Blocks if another thread has acquired write access. If @acquireRead@ terminates without throwing an exception the state of the 'RWLock' will be \"read\". Implementation note: Throws an exception when more than (maxBound :: Int) simultaneous threads acquire the read lock. But that is unlikely. -} acquireRead :: RWLock -> IO () acquireRead (RWLock {state, readLock, writeLock}) = mask_ acqRead where acqRead = do st <- takeMVar state case st of Free -> do Lock.acquire readLock putMVar state $ Read 1 Read n -> putMVar state . Read $! succ n Write -> do putMVar state st Lock.wait writeLock acqRead {-| Try to acquire the read lock; non blocking. Like 'acquireRead', but doesn't block. Returns 'True' if the resulting state is \"read\", 'False' otherwise. -} tryAcquireRead :: RWLock -> IO Bool tryAcquireRead (RWLock {state, readLock}) = mask_ $ do st <- takeMVar state case st of Free -> do Lock.acquire readLock putMVar state $ Read 1 return True Read n -> do putMVar state . Read $! succ n return True Write -> do putMVar state st return False {-| Release the read lock. If the calling thread was the last one to relinquish read access the state will revert to \"free\". It is an error to release read access to an 'RWLock' which is not in the \"read\" state. -} releaseRead :: RWLock -> IO () releaseRead (RWLock {state, readLock}) = mask_ $ do st <- takeMVar state case st of Read 1 -> do Lock.release readLock putMVar state Free Read n -> putMVar state . Read $! pred n _ -> do putMVar state st error $ moduleName ++ ".releaseRead: already released" {-| A convenience function wich first acquires read access and then performs the computation. When the computation terminates, whether normally or by raising an exception, the read lock is released. -} withRead :: RWLock -> IO a -> IO a withRead = liftA2 bracket_ acquireRead releaseRead {-| A non-blocking 'withRead'. First tries to acquire the lock. If that fails, 'Nothing' is returned. If it succeeds, the computation is performed. When the computation terminates, whether normally or by raising an exception, the lock is released and 'Just' the result of the computation is returned. -} tryWithRead :: RWLock -> IO a -> IO (Maybe a) tryWithRead l a = mask $ \restore -> do acquired <- tryAcquireRead l if acquired then do r <- restore a `onException` releaseRead l releaseRead l return $ Just r else return Nothing {-| * When the state is \"write\", @waitRead@ /blocks/ until a call to 'releaseWrite' in another thread changes the state to \"free\". * When the state is \"free\" or \"read\" @waitRead@ returns immediately. @waitRead@ does not alter the state of the lock. Note that @waitRead@ is just a convenience function defined as: @waitRead l = 'mask_' '$' 'acquireRead' l '>>' 'releaseRead' l@ -} waitRead :: RWLock -> IO () waitRead l = mask_ $ acquireRead l >> releaseRead l ------------------------------------------------------------------------------- -- *Write access ------------------------------------------------------------------------------- {-| Acquire the write lock. Blocks if another thread has acquired either read or write access. If @acquireWrite@ terminates without throwing an exception the state of the 'RWLock' will be \"write\". -} acquireWrite :: RWLock -> IO () acquireWrite (RWLock {state, readLock, writeLock}) = mask_ acqWrite where acqWrite = do st <- takeMVar state case st of Free -> do Lock.acquire writeLock putMVar state Write Read _ -> do putMVar state st Lock.wait readLock acqWrite Write -> do putMVar state st Lock.wait writeLock acqWrite {-| Try to acquire the write lock; non blocking. Like 'acquireWrite', but doesn't block. Returns 'True' if the resulting state is \"write\", 'False' otherwise. -} tryAcquireWrite :: RWLock -> IO Bool tryAcquireWrite (RWLock {state, writeLock}) = mask_ $ do st <- takeMVar state case st of Free -> do Lock.acquire writeLock putMVar state Write return True _ -> do putMVar state st return False {-| Release the write lock. If @releaseWrite@ terminates without throwing an exception the state will be \"free\". It is an error to release write access to an 'RWLock' which is not in the \"write\" state. -} releaseWrite :: RWLock -> IO () releaseWrite (RWLock {state, writeLock}) = mask_ $ do st <- takeMVar state case st of Write -> do Lock.release writeLock putMVar state Free _ -> do putMVar state st error $ moduleName ++ ".releaseWrite: already released" {-| A convenience function wich first acquires write access and then performs the computation. When the computation terminates, whether normally or by raising an exception, the write lock is released. -} withWrite :: RWLock -> IO a -> IO a withWrite = liftA2 bracket_ acquireWrite releaseWrite {-| A non-blocking 'withWrite'. First tries to acquire the lock. If that fails, 'Nothing' is returned. If it succeeds, the computation is performed. When the computation terminates, whether normally or by raising an exception, the lock is released and 'Just' the result of the computation is returned. -} tryWithWrite :: RWLock -> IO a -> IO (Maybe a) tryWithWrite l a = mask $ \restore -> do acquired <- tryAcquireWrite l if acquired then do r <- restore a `onException` releaseWrite l releaseWrite l return $ Just r else return Nothing {-| * When the state is \"write\" or \"read\" @waitWrite@ /blocks/ until a call to 'releaseWrite' or 'releaseRead' in another thread changes the state to \"free\". * When the state is \"free\" @waitWrite@ returns immediately. @waitWrite@ does not alter the state of the lock. Note that @waitWrite@ is just a convenience function defined as: @waitWrite l = 'mask_' '$' 'acquireWrite' l '>>' 'releaseWrite' l@ -} waitWrite :: RWLock -> IO () waitWrite l = mask_ $ acquireWrite l >> releaseWrite l moduleName :: String moduleName = "Control.Concurrent.ReadWriteLock" concurrent-extra-0.7.0.12/Control/Concurrent/Event.hs0000644000000000000000000001300713252301656020613 0ustar0000000000000000{-# LANGUAGE CPP , DeriveDataTypeable , NoImplicitPrelude #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #endif ------------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.Event -- Copyright : (c) 2010-2011 Bas van Dijk & Roel van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk -- , Roel van Dijk -- -- An Event is a simple mechanism for communication between threads: one thread -- signals an event and other threads wait for it. -- -- An event has a state which is either \"set\" or \"cleared\". This state can -- be changed with the corresponding functions 'set' and 'clear'. The 'wait' -- function blocks until the state is \"set\". An important property of setting -- an event is that /all/ threads waiting for it are woken. -- -- It was inspired by the Python @Event@ object. See: -- -- -- -- This module is designed to be imported qualified. We suggest importing it -- like: -- -- @ -- import Control.Concurrent.Event ( Event ) -- import qualified Control.Concurrent.Event as Event ( ... ) -- @ -- ------------------------------------------------------------------------------- module Control.Concurrent.Event ( Event -- * Creating events , new , newSet -- * Waiting for events , wait , waitTimeout , isSet -- * Setting events , set , signal , clear ) where ------------------------------------------------------------------------------- -- Imports ------------------------------------------------------------------------------- -- from base: import Data.Bool ( Bool(..) ) import Data.Eq ( Eq ) import Data.Function ( (.) ) import Data.Functor ( fmap, (<$>) ) import Data.Maybe ( isJust ) import Data.Typeable ( Typeable ) #ifdef __HADDOCK_VERSION__ import Control.Exception ( mask ) #endif import Prelude ( Integer ) import System.IO ( IO ) -- from concurrent-extra (this package): import Control.Concurrent.Broadcast ( Broadcast ) import qualified Control.Concurrent.Broadcast as Broadcast ( new, newBroadcasting , listen, tryListen, listenTimeout , broadcast, signal, silence ) ------------------------------------------------------------------------------- -- Events ------------------------------------------------------------------------------- -- | An event is in one of two possible states: \"set\" or \"cleared\". newtype Event = Event {evBroadcast :: Broadcast ()} deriving (Eq, Typeable) ------------------------------------------------------------------------------- -- Creating events ------------------------------------------------------------------------------- -- | Create an event in the \"cleared\" state. new :: IO Event new = Event <$> Broadcast.new -- | Create an event in the \"set\" state. newSet :: IO Event newSet = Event <$> Broadcast.newBroadcasting () ------------------------------------------------------------------------------- -- Waiting for events ------------------------------------------------------------------------------- {-| Block until the event is 'set'. If the state of the event is already \"set\" this function will return immediately. Otherwise it will block until another thread calls 'set'. (You can also resume a thread that is waiting for an event by throwing an asynchronous exception.) -} wait :: Event -> IO () wait = Broadcast.listen . evBroadcast {-| Block until the event is 'set' or until a timer expires. Like 'wait', but with a timeout. A return value of 'False' indicates a timeout occurred. The timeout is specified in microseconds. If the event is \"cleared\" and a timeout of 0 μs is specified the function returns 'False' without blocking. Negative timeouts are treated the same as a timeout of 0 μs. -} waitTimeout :: Event -> Integer -> IO Bool waitTimeout ev time = isJust <$> Broadcast.listenTimeout (evBroadcast ev) time {-| Returns 'True' if the state of the event is \"set\" and 'False' if the state is \"cleared\". Notice that this is only a snapshot of the state. By the time a program reacts on its result it may already be out of date. -} isSet :: Event -> IO Bool isSet = fmap isJust . Broadcast.tryListen . evBroadcast ------------------------------------------------------------------------------- -- Setting events ------------------------------------------------------------------------------- {-| Changes the state of the event to \"set\". All threads that where waiting for this event are woken. Threads that 'wait' after the state is changed to \"set\" will not block at all. -} set :: Event -> IO () set ev = Broadcast.broadcast (evBroadcast ev) () {-| Changes the state to \"cleared\" after all threads that where waiting for this event are woken. Threads that 'wait' after a @signal@ will block until the event is 'set' again. The semantics of signal are equivalent to the following definition: @ signal e = 'mask' $ 'set' e >> 'clear' e @-} signal :: Event -> IO () signal ev = Broadcast.signal (evBroadcast ev) () {-| Changes the state of the event to \"cleared\". Threads that 'wait' after the state is changed to \"cleared\" will block until the state is changed to \"set\". -} clear :: Event -> IO () clear = Broadcast.silence . evBroadcast concurrent-extra-0.7.0.12/Control/Concurrent/Lock.hs0000644000000000000000000001576613252301656020440 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #endif -------------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.Lock -- Copyright : (c) 2010-2011 Bas van Dijk & Roel van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk -- , Roel van Dijk -- -- This module provides the 'Lock' synchronisation mechanism. It was inspired by -- the Python and Java @Lock@ objects and should behave in a similar way. See: -- -- -- -- and: -- -- -- -- All functions are /exception safe/. Throwing asynchronous exceptions will not -- compromise the internal state of a 'Lock'. -- -- This module is intended to be imported qualified. We suggest importing it like: -- -- @ -- import Control.Concurrent.Lock ( Lock ) -- import qualified Control.Concurrent.Lock as Lock ( ... ) -- @ -- -------------------------------------------------------------------------------- module Control.Concurrent.Lock ( Lock -- * Creating locks , new , newAcquired -- * Locking and unlocking , acquire , tryAcquire , release -- * Convenience functions , with , tryWith , wait -- * Querying locks , locked ) where -------------------------------------------------------------------------------- -- Imports -------------------------------------------------------------------------------- -- from base: import Control.Applicative ( liftA2 ) import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar , takeMVar, tryTakeMVar , tryPutMVar, readMVar, isEmptyMVar ) import Control.Exception ( bracket_, onException ) import Control.Monad ( return, when ) import Data.Bool ( Bool, not ) #ifdef __HADDOCK_VERSION__ import Data.Bool ( Bool(False, True) ) #endif import Data.Eq ( Eq ) import Data.Function ( ($), (.) ) import Data.Functor ( fmap, (<$>) ) import Data.Maybe ( Maybe(Nothing, Just), isJust ) import Data.Typeable ( Typeable ) import Prelude ( error ) import System.IO ( IO ) #if __GLASGOW_HASKELL__ < 700 import Control.Monad ( Monad, (>>=), fail ) #endif -- from concurrent-extra (this package): import Utils ( mask ) -------------------------------------------------------------------------------- -- Locks -------------------------------------------------------------------------------- -- | A lock is in one of two states: \"locked\" or \"unlocked\". newtype Lock = Lock {un :: MVar ()} deriving (Eq, Typeable) -------------------------------------------------------------------------------- -- Creating locks -------------------------------------------------------------------------------- -- | Create a lock in the \"unlocked\" state. new :: IO Lock new = Lock <$> newMVar () -- | Create a lock in the \"locked\" state. newAcquired :: IO Lock newAcquired = Lock <$> newEmptyMVar -------------------------------------------------------------------------------- -- Locking and unlocking -------------------------------------------------------------------------------- {-| Acquires the 'Lock'. Blocks if another thread has acquired the 'Lock'. @acquire@ behaves as follows: * When the state is \"unlocked\" @acquire@ changes the state to \"locked\". * When the state is \"locked\" @acquire@ /blocks/ until a call to 'release' in another thread wakes the calling thread. Upon awakening it will change the state to \"locked\". There are two further important properties of @acquire@: * @acquire@ is single-wakeup. That is, if there are multiple threads blocked on @acquire@ and the lock is released, only one thread will be woken up. The runtime guarantees that the woken thread completes its @acquire@ operation. * When multiple threads are blocked on @acquire@, they are woken up in FIFO order. This is useful for providing fairness properties of abstractions built using locks. (Note that this differs from the Python implementation where the wake-up order is undefined.) -} acquire :: Lock -> IO () acquire = takeMVar . un {-| A non-blocking 'acquire'. * When the state is \"unlocked\" @tryAcquire@ changes the state to \"locked\" and returns 'True'. * When the state is \"locked\" @tryAcquire@ leaves the state unchanged and returns 'False'. -} tryAcquire :: Lock -> IO Bool tryAcquire = fmap isJust . tryTakeMVar . un {-| @release@ changes the state to \"unlocked\" and returns immediately. Note that it is an error to release a lock in the \"unlocked\" state! If there are any threads blocked on 'acquire' the thread that first called @acquire@ will be woken up. -} release :: Lock -> IO () release (Lock mv) = do b <- tryPutMVar mv () when (not b) $ error "Control.Concurrent.Lock.release: Can't release unlocked Lock!" -------------------------------------------------------------------------------- -- Convenience functions -------------------------------------------------------------------------------- {-| A convenience function which first acquires the lock and then performs the computation. When the computation terminates, whether normally or by raising an exception, the lock is released. Note that: @with = 'liftA2' 'bracket_' 'acquire' 'release'@. -} with :: Lock -> IO a -> IO a with = liftA2 bracket_ acquire release {-| A non-blocking 'with'. @tryWith@ is a convenience function which first tries to acquire the lock. If that fails, 'Nothing' is returned. If it succeeds, the computation is performed. When the computation terminates, whether normally or by raising an exception, the lock is released and 'Just' the result of the computation is returned. -} tryWith :: Lock -> IO a -> IO (Maybe a) tryWith l a = mask $ \restore -> do acquired <- tryAcquire l if acquired then do r <- restore a `onException` release l release l return $ Just r else return Nothing {-| * When the state is \"locked\", @wait@ /blocks/ until a call to 'release' in another thread changes it to \"unlocked\". * @wait@ is multiple-wakeup, so when multiple waiters are blocked on a @Lock@, all of them are woken up at the same time. * When the state is \"unlocked\" @wait@ returns immediately. @wait@ does not alter the state of the lock. -} wait :: Lock -> IO () wait (Lock mv) = readMVar mv -------------------------------------------------------------------------------- -- Querying locks -------------------------------------------------------------------------------- {-| Determines if the lock is in the \"locked\" state. Note that this is only a snapshot of the state. By the time a program reacts on its result it may already be out of date. -} locked :: Lock -> IO Bool locked = isEmptyMVar . un concurrent-extra-0.7.0.12/Control/Concurrent/Broadcast.hs0000644000000000000000000001542313252301656021440 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #endif ------------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.Broadcast -- Copyright : (c) 2010-2011 Bas van Dijk & Roel van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk -- , Roel van Dijk -- -- A 'Broadcast' is a mechanism for communication between threads. Multiple -- @'listen'ers@ wait until a broadcaster @'broadcast's@ a value. The listeners -- block until the value is received. When the broadcaster broadcasts a value -- all listeners are woken. -- -- All functions are /exception safe/. Throwing asynchronous exceptions will not -- compromise the internal state of a broadcast. -- -- This module is designed to be imported qualified. We suggest importing it -- like: -- -- @ -- import Control.Concurrent.Broadcast ( Broadcast ) -- import qualified Control.Concurrent.Broadcast as Broadcast ( ... ) -- @ ------------------------------------------------------------------------------- module Control.Concurrent.Broadcast ( Broadcast -- * Creating broadcasts , new , newBroadcasting -- * Listening to broadcasts , listen , tryListen , listenTimeout -- * Broadcasting , broadcast , signal , silence ) where ------------------------------------------------------------------------------- -- Imports ------------------------------------------------------------------------------- -- from base: import Control.Monad ( return, when ) import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar , takeMVar, putMVar, readMVar, modifyMVar_ ) import Control.Exception ( onException ) import Data.Eq ( Eq ) import Data.Either ( Either(Left ,Right), either ) import Data.Function ( ($), (.), const ) import Data.Functor ( fmap, (<$>) ) import Data.Foldable ( for_ ) import Data.List ( delete, length ) import Data.Maybe ( Maybe(Nothing, Just), isNothing ) import Data.Ord ( max ) import Data.Typeable ( Typeable ) import Prelude ( Integer, seq ) import System.IO ( IO ) #if __GLASGOW_HASKELL__ < 700 import Prelude ( fromInteger ) import Control.Monad ( (>>=), (>>), fail ) import Data.Ord ( Ord ) #endif -- from unbounded-delays: import Control.Concurrent.Timeout ( timeout ) -- from concurrent-extra (this package): import Utils ( purelyModifyMVar, mask_ ) ------------------------------------------------------------------------------- -- Broadcast ------------------------------------------------------------------------------- {-| A broadcast is in one of two possible states: * \"Silent\": @'listen'ing@ to the broadcast will block until a value is @'broadcast'ed@. * \"Broadcasting @x@\": @'listen'ing@ to the broadcast will return the value @x@ without blocking. -} newtype Broadcast a = Broadcast {unBroadcast :: MVar (Either [MVar a] a)} deriving (Eq, Typeable) -- | @new@ creates a broadcast in the \"silent\" state. new :: IO (Broadcast a) new = Broadcast <$> newMVar (Left []) -- | @newBroadcasting x@ creates a broadcast in the \"broadcasting @x@\" state. newBroadcasting :: a -> IO (Broadcast a) newBroadcasting x = Broadcast <$> newMVar (Right x) {-| Listen to a broadcast. * If the broadcast is \"broadcasting @x@\", @listen@ will return @x@ immediately. * If the broadcast is \"silent\", @listen@ will block until another thread @'broadcast's@ a value to the broadcast. -} listen :: Broadcast a -> IO a listen (Broadcast mv) = mask_ $ do mx <- takeMVar mv case mx of Left ls -> do l <- newEmptyMVar putMVar mv $ Left $ l:ls takeMVar l Right x -> do putMVar mv mx return x {-| Try to listen to a broadcast; non blocking. * If the broadcast is \"broadcasting @x@\", @tryListen@ will return 'Just' @x@ immediately. * If the broadcast is \"silent\", @tryListen@ returns 'Nothing' immediately. -} tryListen :: Broadcast a -> IO (Maybe a) tryListen = fmap (either (const Nothing) Just) . readMVar . unBroadcast {-| Listen to a broadcast if it is available within a given amount of time. Like 'listen', but with a timeout. A return value of 'Nothing' indicates a timeout occurred. The timeout is specified in microseconds. If the broadcast is \"silent\" and a timeout of 0 μs is specified the function returns 'Nothing' without blocking. Negative timeouts are treated the same as a timeout of 0 μs. -} listenTimeout :: Broadcast a -> Integer -> IO (Maybe a) listenTimeout (Broadcast mv) time = mask_ $ do mx <- takeMVar mv case mx of Left ls -> do l <- newEmptyMVar putMVar mv $ Left $ l:ls my <- timeout (max time 0) (takeMVar l) `onException` deleteReader l when (isNothing my) (deleteReader l) return my Right x -> do putMVar mv mx return $ Just x where deleteReader l = do mx <- takeMVar mv case mx of Left ls -> let ls' = delete l ls in length ls' `seq` putMVar mv (Left ls') Right _ -> putMVar mv mx {-| Broadcast a value. @broadcast b x@ changes the state of the broadcast @b@ to \"broadcasting @x@\". If the broadcast was \"silent\" all threads that are @'listen'ing@ to the broadcast will be woken. -} broadcast :: Broadcast a -> a -> IO () {-| Broadcast a value before becoming \"silent\". The state of the broadcast is changed to \"silent\" after all threads that are @'listen'ing@ to the broadcast are woken and resume with the signalled value. The semantics of signal are equivalent to the following definition: @ signal b x = 'block' $ 'broadcast' b x >> 'silence' b @ -} signal :: Broadcast a -> a -> IO () broadcast b x = broadcastThen (Right x) b x signal b x = broadcastThen (Left []) b x -- | Internally used function that performs the actual broadcast in 'broadcast' -- and 'signal' then changes to the given final state. broadcastThen :: Either [MVar a] a -> Broadcast a -> a -> IO () broadcastThen finalState (Broadcast mv) x = modifyMVar_ mv $ \mx -> do case mx of Left ls -> do for_ ls (`putMVar` x) return finalState Right _ -> return finalState -- | Set a broadcast to the \"silent\" state. silence :: Broadcast a -> IO () silence (Broadcast mv) = purelyModifyMVar mv $ either Left $ const $ Left [] concurrent-extra-0.7.0.12/Control/Concurrent/RLock.hs0000644000000000000000000002375613252301656020560 0ustar0000000000000000{-# LANGUAGE CPP , BangPatterns , DeriveDataTypeable , NoImplicitPrelude #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #endif -------------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.RLock -- Copyright : (c) 2010-2011 Bas van Dijk & Roel van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk -- , Roel van Dijk -- -- This module provides the 'RLock' synchronisation mechanism. It was inspired -- by the Python @RLock@ and Java @ReentrantLock@ objects and should behave in a -- similar way. See: -- -- -- -- and: -- -- -- -- All functions are /exception safe/. Throwing asynchronous exceptions will not -- compromise the internal state of an 'RLock'. -- -- This module is intended to be imported qualified. We suggest importing it like: -- -- @ -- import Control.Concurrent.RLock ( RLock ) -- import qualified Control.Concurrent.RLock as RLock ( ... ) -- @ -- -------------------------------------------------------------------------------- module Control.Concurrent.RLock ( RLock -- * Creating reentrant locks , new , newAcquired -- * Locking and unlocking , acquire , tryAcquire , release -- * Convenience functions , with , tryWith , wait -- * Querying reentrant locks , State , state ) where -------------------------------------------------------------------------------- -- Imports -------------------------------------------------------------------------------- -- from base: import Control.Applicative ( liftA2 ) import Control.Concurrent ( ThreadId, myThreadId ) import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, readMVar, putMVar ) import Control.Exception ( bracket_, onException ) import Control.Monad ( return, (>>) ) import Data.Bool ( Bool(False, True), otherwise ) import Data.Eq ( Eq, (==) ) import Data.Function ( ($), (.) ) import Data.Functor ( fmap, (<$>) ) import Data.Maybe ( Maybe(Nothing, Just) ) import Data.List ( (++) ) import Data.Tuple ( fst ) import Data.Typeable ( Typeable ) import Prelude ( Integer, succ, pred, error ) import System.IO ( IO ) #if __GLASGOW_HASKELL__ < 700 import Prelude ( fromInteger ) import Control.Monad ( Monad, fail, (>>=) ) #endif -- 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 -------------------------------------------------------------------------------- {-| A reentrant lock is in one of two states: \"locked\" or \"unlocked\". When the lock is in the \"locked\" state it has two additional properties: * Its /owner/: the thread that acquired the lock. * Its /acquired count/: how many times its owner acquired the lock. -} newtype RLock = RLock {un :: MVar (State, Lock)} deriving (Eq, Typeable) {-| The state of an 'RLock'. * 'Nothing' indicates an \"unlocked\" state. * @'Just' (tid, n)@ indicates a \"locked\" state where the thread identified by @tid@ acquired the lock @n@ times. -} type State = Maybe (ThreadId, Integer) -------------------------------------------------------------------------------- -- * Creating reentrant locks -------------------------------------------------------------------------------- -- | Create a reentrant lock in the \"unlocked\" state. new :: IO RLock new = do lock <- Lock.new RLock <$> newMVar (Nothing, lock) {-| Create a reentrant lock in the \"locked\" state (with the current thread as owner and an acquired count of 1). -} newAcquired :: IO RLock newAcquired = do myTID <- myThreadId lock <- Lock.newAcquired RLock <$> newMVar (Just (myTID, 1), lock) -------------------------------------------------------------------------------- -- * Locking and unlocking -------------------------------------------------------------------------------- {-| Acquires the 'RLock'. Blocks if another thread has acquired the 'RLock'. @acquire@ behaves as follows: * When the state is \"unlocked\", @acquire@ changes the state to \"locked\" with the current thread as owner and an acquired count of 1. * When the state is \"locked\" and the current thread owns the lock @acquire@ only increments the acquired count. * When the state is \"locked\" and the current thread does not own the lock @acquire@ /blocks/ until the owner releases the lock. If the thread that called @acquire@ is woken upon release of the lock it will take ownership and change the state to \"locked\" with an acquired count of 1. There are two further important properties of @acquire@: * @acquire@ is single-wakeup. That is, if there are multiple threads blocked on @acquire@, and the lock is released, only one thread will be woken up. The runtime guarantees that the woken thread completes its @acquire@ operation. * When multiple threads are blocked on @acquire@ they are woken up in FIFO order. This is useful for providing fairness properties of abstractions built using locks. (Note that this differs from the Python implementation where the wake-up order is undefined.) -} acquire :: RLock -> IO () acquire (RLock mv) = do myTID <- myThreadId mask_ $ let acq = do t@(mb, lock) <- takeMVar mv case mb of Nothing -> do Lock.acquire lock putMVar mv (Just (myTID, 1), lock) Just (tid, n) | myTID == tid -> let !sn = succ n in putMVar mv (Just (tid, sn), lock) | otherwise -> do putMVar mv t Lock.wait lock acq in acq {-| A non-blocking 'acquire'. * When the state is \"unlocked\" @tryAcquire@ changes the state to \"locked\" (with the current thread as owner and an acquired count of 1) and returns 'True'. * When the state is \"locked\" @tryAcquire@ leaves the state unchanged and returns 'False'. -} tryAcquire :: RLock -> IO Bool tryAcquire (RLock mv) = do myTID <- myThreadId mask_ $ do t@(mb, lock) <- takeMVar mv case mb of Nothing -> do Lock.acquire lock putMVar mv (Just (myTID, 1), lock) return True Just (tid, n) | myTID == tid -> do let !sn = succ n putMVar mv (Just (tid, sn), lock) return True | otherwise -> do putMVar mv t return False {-| @release@ decrements the acquired count. When a lock is released with an acquired count of 1 its state is changed to \"unlocked\". Note that it is both an error to release a lock in the \"unlocked\" state and to release a lock that is not owned by the current thread. If there are any threads blocked on 'acquire' the thread that first called @acquire@ will be woken up. -} release :: RLock -> IO () release (RLock mv) = do myTID <- myThreadId mask_ $ do t@(mb, lock) <- takeMVar mv let err msg = do putMVar mv t error $ "Control.Concurrent.RLock.release: " ++ msg case mb of Nothing -> err "Can't release an unacquired RLock!" Just (tid, n) | myTID == tid -> if n == 1 then do Lock.release lock putMVar mv (Nothing, lock) else let !pn = pred n in putMVar mv (Just (tid, pn), lock) | otherwise -> err "Calling thread does not own the RLock!" -------------------------------------------------------------------------------- -- * Convenience functions -------------------------------------------------------------------------------- {-| A convenience function which first acquires the lock and then performs the computation. When the computation terminates, whether normally or by raising an exception, the lock is released. Note that: @with = 'liftA2' 'bracket_' 'acquire' 'release'@. -} with :: RLock -> IO a -> IO a with = liftA2 bracket_ acquire release {-| A non-blocking 'with'. @tryWith@ is a convenience function which first tries to acquire the lock. If that fails, 'Nothing' is returned. If it succeeds, the computation is performed. When the computation terminates, whether normally or by raising an exception, the lock is released and 'Just' the result of the computation is returned. -} tryWith :: RLock -> IO a -> IO (Maybe a) tryWith l a = mask $ \restore -> do acquired <- tryAcquire l if acquired then do r <- restore a `onException` release l release l return $ Just r else return Nothing {-| * When the state is \"locked\" @wait@ /blocks/ until a call to 'release' in another thread changes it to \"unlocked\". * When the state is \"unlocked\" @wait@ returns immediately. @wait@ does not alter the state of the lock. Note that @wait@ is just a convenience function defined as: @wait l = 'block' '$' 'acquire' l '>>' 'release' l@ -} wait :: RLock -> IO () wait l = mask_ $ acquire l >> release l -------------------------------------------------------------------------------- -- * Querying reentrant locks -------------------------------------------------------------------------------- {-| Determine the state of the reentrant lock. Note that this is only a snapshot of the state. By the time a program reacts on its result it may already be out of date. -} state :: RLock -> IO State state = fmap fst . readMVar . un concurrent-extra-0.7.0.12/Control/Concurrent/ReadWriteVar.hs0000644000000000000000000001250013252301656022066 0ustar0000000000000000{-# LANGUAGE CPP , DeriveDataTypeable , NoImplicitPrelude , TupleSections #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #endif ------------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.ReadWriteVar -- Copyright : 2010—2011 Bas van Dijk & Roel van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk -- , Roel van Dijk -- -- Concurrent read, sequential write variables. Comparable to an 'IORef' with -- more advanced synchronization mechanisms. The value stored inside the 'RWVar' -- can be read and used by multiple threads at the same time. Concurrent -- computations inside a 'with' \"block\" observe the same value. -- -- Observing and changing the contents of an 'RWVar' are mutually -- exclusive. The 'with' function will block if 'modify' is active and -- vice-versa. Furthermore 'with' is fully sequential and will also -- block on concurrent calls of 'modify'. -- -- The following are guaranteed deadlocks: -- -- * @'modify_' v '$' 'const' '$' 'with' v '$' 'const' 'undefined'@ -- -- * @'with' v '$' 'const' '$' 'modify_' v '$' 'const' 'undefined'@ -- -- * @'modify_' v '$' 'const' '$' 'modify_' v '$' 'const' 'undefined'@ -- -- All functions are /exception safe/. Throwing asynchronous exceptions will not -- compromise the internal state of an 'RWVar'. This also means that threads -- blocking on 'with' or 'modify' and friends can still be unblocked by throwing -- an asynchronous exception. -- -- This module is designed to be imported qualified. We suggest importing it -- like: -- -- @ -- import Control.Concurrent.ReadWriteVar ( RWVar ) -- import qualified Control.Concurrent.ReadWriteVar as RWV ( ... ) -- @ -- ------------------------------------------------------------------------------- module Control.Concurrent.ReadWriteVar ( RWVar , new , with , tryWith , modify_ , modify , tryModify_ , tryModify ) where ------------------------------------------------------------------------------- -- Imports ------------------------------------------------------------------------------- -- from base: import Control.Applicative ( liftA2 ) import Control.Monad ( (>>=) ) import Data.Bool ( Bool(..) ) import Data.Eq ( Eq, (==) ) import Data.Function ( ($), (.), on ) import Data.Functor ( fmap ) import Data.Maybe ( Maybe(..), isJust ) import Data.IORef ( IORef, newIORef, readIORef ) import Data.Typeable ( Typeable ) import System.IO ( IO ) #ifdef __HADDOCK_VERSION__ import Data.Function ( const ) import Prelude ( undefined ) #endif -- from concurrent-extra (this package): import Control.Concurrent.ReadWriteLock ( RWLock ) import qualified Control.Concurrent.ReadWriteLock as RWLock import Utils ( modifyIORefM, modifyIORefM_ ) ------------------------------------------------------------------------------- -- Read-Write Variables: concurrent read, sequential write ------------------------------------------------------------------------------- -- | Concurrently readable and sequentially writable variable. data RWVar a = RWVar RWLock (IORef a) deriving Typeable instance Eq (RWVar a) where (==) = (==) `on` rwlock where rwlock (RWVar rwl _) = rwl -- | Create a new 'RWVar'. new :: a -> IO (RWVar a) new = liftA2 RWVar RWLock.new . newIORef {-| Execute an action that operates on the contents of the 'RWVar'. The action is guaranteed to have a consistent view of the stored value. Any function that attempts to 'modify' the contents will block until the action is completed. If another thread is modifying the contents of the 'RWVar' this function will block until the other thread finishes its action. -} with :: RWVar a -> (a -> IO b) -> IO b with (RWVar l r) f = RWLock.withRead l $ readIORef r >>= f {-| Like 'with' but doesn't block. Returns 'Just' the result if read access could be acquired without blocking, 'Nothing' otherwise. -} tryWith :: RWVar a -> (a -> IO b) -> IO (Maybe b) tryWith (RWVar l r) f = RWLock.tryWithRead l $ readIORef r >>= f {-| Modify the contents of an 'RWVar'. This function needs exclusive write access to the 'RWVar'. Only one thread can modify an 'RWVar' at the same time. All others will block. -} modify_ :: RWVar a -> (a -> IO a) -> IO () modify_ (RWVar l r) = RWLock.withWrite l . modifyIORefM_ r {-| Modify the contents of an 'RWVar' and return an additional value. Like 'modify_', but allows a value to be returned (β) in addition to the modified value of the 'RWVar'. -} modify :: RWVar a -> (a -> IO (a, b)) -> IO b modify (RWVar l r) = RWLock.withWrite l . modifyIORefM r {-| Attempt to modify the contents of an 'RWVar'. Like 'modify_', but doesn't block. Returns 'True' if the contents could be replaced, 'False' otherwise. -} tryModify_ :: RWVar a -> (a -> IO a) -> IO Bool tryModify_ (RWVar l r) = fmap isJust . RWLock.tryWithWrite l . modifyIORefM_ r {-| Attempt to modify the contents of an 'RWVar' and return an additional value. Like 'modify', but doesn't block. Returns 'Just' the additional value if the contents could be replaced, 'Nothing' otherwise. -} tryModify :: RWVar a -> (a -> IO (a, b)) -> IO (Maybe b) tryModify (RWVar l r) = RWLock.tryWithWrite l . modifyIORefM r concurrent-extra-0.7.0.12/Control/Concurrent/ReadWriteLock/0000755000000000000000000000000013252301656021674 5ustar0000000000000000concurrent-extra-0.7.0.12/Control/Concurrent/ReadWriteLock/Test.hs0000644000000000000000000000720313252301656023151 0ustar0000000000000000{-# LANGUAGE CPP, NoImplicitPrelude #-} module Control.Concurrent.ReadWriteLock.Test ( tests ) where ------------------------------------------------------------------------------- -- Imports ------------------------------------------------------------------------------- -- from base: import Prelude ( (*) ) import Control.Monad ( (>>), (>>=), replicateM_ ) import Control.Concurrent ( forkIO, threadDelay ) import Data.Function ( ($) ) import Data.Foldable ( sequenceA_ ) import Data.List ( map, replicate, (++) ) import System.Random ( randomRIO ) #if __GLASGOW_HASKELL__ < 700 import Prelude ( fromInteger ) import Control.Monad ( (>>=), fail ) #endif -- from async: import Control.Concurrent.Async ( Concurrently(Concurrently), runConcurrently ) -- from concurrent-extra: import qualified Control.Concurrent.ReadWriteLock as RWLock ( new, acquireWrite, acquireRead, releaseWrite, releaseRead, withRead, withWrite ) 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 , testCase "stressTest" stressTest ] 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 stressTest :: Assertion stressTest = assert $ within (500 * a_moment) $ do lock <- RWLock.new let randomDelay hi = randomRIO (0, hi) >>= threadDelay reader = replicateM_ 500 $ do randomDelay 100 RWLock.withRead lock $ randomDelay 10 writer = replicateM_ 500 $ do randomDelay 100 RWLock.withWrite lock $ randomDelay 10 runConcurrently $ sequenceA_ $ map Concurrently $ replicate 10 reader ++ replicate 10 writer concurrent-extra-0.7.0.12/Control/Concurrent/RLock/0000755000000000000000000000000013252301656020207 5ustar0000000000000000concurrent-extra-0.7.0.12/Control/Concurrent/RLock/Test.hs0000644000000000000000000000402213252301656021460 0ustar0000000000000000{-# LANGUAGE CPP , NoImplicitPrelude , ScopedTypeVariables #-} module Control.Concurrent.RLock.Test ( tests ) where ------------------------------------------------------------------------------- -- Imports ------------------------------------------------------------------------------- -- from base: import Prelude ( (*) ) 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 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 concurrent-extra-0.7.0.12/Control/Concurrent/ReadWriteVar/0000755000000000000000000000000013252301656021534 5ustar0000000000000000concurrent-extra-0.7.0.12/Control/Concurrent/ReadWriteVar/Test.hs0000644000000000000000000000145113252301656023010 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} module Control.Concurrent.ReadWriteVar.Test ( tests ) where ------------------------------------------------------------------------------- -- Imports ------------------------------------------------------------------------------- -- from base: import Control.Concurrent ( ) -- 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 = [] concurrent-extra-0.7.0.12/Control/Concurrent/Event/0000755000000000000000000000000013252301656020256 5ustar0000000000000000concurrent-extra-0.7.0.12/Control/Concurrent/Event/Test.hs0000644000000000000000000000616713252301656021543 0ustar0000000000000000{-# LANGUAGE CPP, NoImplicitPrelude, 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 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 $ Event.wait e1 `catch` \(_ :: 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 concurrent-extra-0.7.0.12/Control/Concurrent/Broadcast/0000755000000000000000000000000013252301656021077 5ustar0000000000000000concurrent-extra-0.7.0.12/Control/Concurrent/Broadcast/Test.hs0000644000000000000000000000144413252301656022355 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} module Control.Concurrent.Broadcast.Test ( tests ) where ------------------------------------------------------------------------------- -- Imports ------------------------------------------------------------------------------- -- from base: import Control.Concurrent ( ) -- 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 = [] concurrent-extra-0.7.0.12/Control/Concurrent/STM/0000755000000000000000000000000013252301656017640 5ustar0000000000000000concurrent-extra-0.7.0.12/Control/Concurrent/STM/Lock.hs0000644000000000000000000001422713252301656021072 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Trustworthy #-} #endif -------------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.STM.Lock -- Copyright : (c) 2010-2011 Bas van Dijk & Roel van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk -- , Roel van Dijk -- -- This module provides an 'STM' version of @Control.Concurrent.Lock@. -- -- This module is intended to be imported qualified. We suggest importing it like: -- -- @ -- import Control.Concurrent.STM.Lock ( Lock ) -- import qualified Control.Concurrent.STM.Lock as Lock ( ... ) -- @ -- -------------------------------------------------------------------------------- module Control.Concurrent.STM.Lock ( Lock -- * Creating locks , new , newAcquired -- * Locking and unlocking , acquire , tryAcquire , release -- * Convenience functions , with , tryWith , wait -- * Querying locks , locked ) where -------------------------------------------------------------------------------- -- Imports -------------------------------------------------------------------------------- -- from base: import Control.Applicative ( liftA2 ) import Control.Exception ( bracket_, onException ) import Control.Monad ( return, when ) import Data.Bool ( Bool, not ) #ifdef __HADDOCK_VERSION__ import Data.Bool ( Bool(False, True) ) #endif import Data.Eq ( Eq ) import Data.Function ( ($), (.) ) import Data.Functor ( fmap, (<$>) ) import Data.Maybe ( Maybe(Nothing, Just), isJust ) import Data.Typeable ( Typeable ) import Prelude ( error ) import System.IO ( IO ) #if __GLASGOW_HASKELL__ < 700 import Control.Monad ( (>>=), fail ) #endif #if __GLASGOW_HASKELL__ < 700 import Control.Monad ( Monad ) #endif -- from stm: import Control.Concurrent.STM ( STM, atomically ) #ifdef __HADDOCK_VERSION__ import Control.Concurrent.STM ( retry ) #endif import Control.Concurrent.STM.TMVar ( TMVar, newTMVar, newEmptyTMVar , takeTMVar, tryTakeTMVar , tryPutTMVar, readTMVar, isEmptyTMVar ) -- 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, Eq) -------------------------------------------------------------------------------- -- Creating locks -------------------------------------------------------------------------------- -- | Create a lock in the \"unlocked\" state. new :: STM Lock new = Lock <$> newTMVar () -- | Create a lock in the \"locked\" state. newAcquired :: STM Lock newAcquired = Lock <$> newEmptyTMVar -------------------------------------------------------------------------------- -- Locking and unlocking -------------------------------------------------------------------------------- {-| * When the state is \"locked\" @acquire@ will 'retry' the transaction. * When the state is \"unlocked\" @acquire@ will change the state to \"locked\". -} acquire :: Lock -> STM () acquire = takeTMVar . un {-| A non-blocking 'acquire'. * When the state is \"unlocked\" @tryAcquire@ changes the state to \"locked\" and returns 'True'. * When the state is \"locked\" @tryAcquire@ leaves the state unchanged and returns 'False'. -} tryAcquire :: Lock -> STM Bool tryAcquire = fmap isJust . tryTakeTMVar . un {-| @release@ changes the state to \"unlocked\" and returns immediately. Note that it is an error to release a lock in the \"unlocked\" state! -} release :: Lock -> STM () release (Lock tmv) = do b <- tryPutTMVar tmv () when (not b) $ error "Control.Concurrent.STM.Lock.release: Can't release unlocked Lock!" -------------------------------------------------------------------------------- -- Convenience functions -------------------------------------------------------------------------------- {-| A convenience function which first acquires the lock and then performs the computation. When the computation terminates, whether normally or by raising an exception, the lock is released. -} with :: Lock -> IO a -> IO a with = liftA2 bracket_ (atomically . acquire) (atomically . release) {-| A non-blocking 'with'. @tryWith@ is a convenience function which first tries to acquire the lock. If that fails, 'Nothing' is returned. If it succeeds, the computation is performed. When the computation terminates, whether normally or by raising an exception, the lock is released and 'Just' the result of the computation is returned. -} tryWith :: Lock -> IO a -> IO (Maybe a) tryWith l a = mask $ \restore -> do acquired <- atomically (tryAcquire l) if acquired then do r <- restore a `onException` atomically (release l) atomically (release l) return $ Just r else return Nothing {-| * When the state is \"locked\", @wait@ will 'retry' the transaction * When the state is \"unlocked\" @wait@ returns immediately. @wait@ does not alter the state of the lock. Note that @wait@ is just a convenience function which can be defined as: @wait l = 'acquire' l '>>' 'release' l@ -} wait :: Lock -> STM () wait (Lock tmv) = readTMVar tmv -------------------------------------------------------------------------------- -- Querying locks -------------------------------------------------------------------------------- {-| Determines if the lock is in the \"locked\" state. Note that this is only a snapshot of the state. By the time a program reacts on its result it may already be out of date. -} locked :: Lock -> STM Bool locked = isEmptyTMVar . un concurrent-extra-0.7.0.12/Control/Concurrent/STM/Lock/0000755000000000000000000000000013252301656020530 5ustar0000000000000000concurrent-extra-0.7.0.12/Control/Concurrent/STM/Lock/Test.hs0000644000000000000000000000567613252301656022021 0ustar0000000000000000{-# LANGUAGE CPP , NoImplicitPrelude , ScopedTypeVariables #-} module Control.Concurrent.STM.Lock.Test ( tests ) where ------------------------------------------------------------------------------- -- Imports ------------------------------------------------------------------------------- -- from base: import Prelude ( (*) ) 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 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 concurrent-extra-0.7.0.12/Control/Concurrent/Lock/0000755000000000000000000000000013252301656020065 5ustar0000000000000000concurrent-extra-0.7.0.12/Control/Concurrent/Lock/Test.hs0000644000000000000000000000532613252301656021346 0ustar0000000000000000{-# LANGUAGE CPP , NoImplicitPrelude , ScopedTypeVariables #-} module Control.Concurrent.Lock.Test ( tests ) where ------------------------------------------------------------------------------- -- Imports ------------------------------------------------------------------------------- -- from base: import Prelude ( (*) ) 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 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 (1000 * 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