├── .gitignore
├── default.nix
├── concurrent-extra.nix
├── Control
    └── Concurrent
    │   ├── Broadcast
    │       └── Test.hs
    │   ├── ReadWriteVar
    │       └── Test.hs
    │   ├── RLock
    │       └── Test.hs
    │   ├── Lock
    │       └── Test.hs
    │   ├── STM
    │       ├── Lock
    │       │   └── Test.hs
    │       └── Lock.hs
    │   ├── Event
    │       └── Test.hs
    │   ├── ReadWriteLock
    │       └── Test.hs
    │   ├── ReadWriteVar.hs
    │   ├── Event.hs
    │   ├── Broadcast.hs
    │   ├── Lock.hs
    │   ├── RLock.hs
    │   └── ReadWriteLock.hs
├── README.markdown
├── LICENSE
├── test.hs
├── TestUtils.hs
├── Utils.hs
└── concurrent-extra.cabal


/.gitignore:
--------------------------------------------------------------------------------
1 | dist
2 | /dist-newstyle/
3 | 


--------------------------------------------------------------------------------
/default.nix:
--------------------------------------------------------------------------------
 1 | { nixpkgs ? import <nixpkgs> {}, compiler ? "default" }:
 2 | 
 3 | let
 4 | 
 5 |   inherit (nixpkgs) pkgs;
 6 | 
 7 |   haskellPackages = if compiler == "default"
 8 |                        then pkgs.haskellPackages
 9 |                        else pkgs.haskell.packages.${compiler};
10 | 
11 |   drv = haskellPackages.callPackage (import ./concurrent-extra.nix) {};
12 | 
13 | in
14 | 
15 |   if pkgs.lib.inNixShell then drv.env else drv
16 | 


--------------------------------------------------------------------------------
/concurrent-extra.nix:
--------------------------------------------------------------------------------
 1 | { mkDerivation, async, base, HUnit, random, stdenv, stm
 2 | , test-framework, test-framework-hunit, unbounded-delays
 3 | }:
 4 | mkDerivation {
 5 |   pname = "concurrent-extra";
 6 |   version = "0.7.0.9";
 7 |   src = ./.;
 8 |   libraryHaskellDepends = [ base stm unbounded-delays ];
 9 |   testHaskellDepends = [
10 |     async base HUnit random stm test-framework test-framework-hunit
11 |     unbounded-delays
12 |   ];
13 |   homepage = "https://github.com/basvandijk/concurrent-extra";
14 |   description = "Extra concurrency primitives";
15 |   license = stdenv.lib.licenses.bsd3;
16 | }
17 | 


--------------------------------------------------------------------------------
/Control/Concurrent/Broadcast/Test.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE NoImplicitPrelude #-}
 2 | 
 3 | module Control.Concurrent.Broadcast.Test ( tests ) where
 4 | 
 5 | 
 6 | -------------------------------------------------------------------------------
 7 | -- Imports
 8 | -------------------------------------------------------------------------------
 9 | 
10 | -- from base:
11 | import Control.Concurrent ( )
12 | 
13 | -- from concurrent-extra:
14 | import qualified Control.Concurrent.Broadcast as Broadcast ( )
15 | import TestUtils ( )
16 | 
17 | -- from HUnit:
18 | import Test.HUnit (  )
19 | 
20 | -- from test-framework:
21 | import Test.Framework  ( Test )
22 | 
23 | -- from test-framework-hunit:
24 | import Test.Framework.Providers.HUnit ( )
25 | 
26 | 
27 | -------------------------------------------------------------------------------
28 | -- Tests for Broadcast
29 | -------------------------------------------------------------------------------
30 | 
31 | tests :: [Test]
32 | tests = []
33 | 


--------------------------------------------------------------------------------
/Control/Concurrent/ReadWriteVar/Test.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE NoImplicitPrelude #-}
 2 | 
 3 | module Control.Concurrent.ReadWriteVar.Test ( tests ) where
 4 | 
 5 | 
 6 | -------------------------------------------------------------------------------
 7 | -- Imports
 8 | -------------------------------------------------------------------------------
 9 | 
10 | -- from base:
11 | import Control.Concurrent ( )
12 | 
13 | -- from concurrent-extra:
14 | import qualified Control.Concurrent.ReadWriteVar as RWVar ( )
15 | import TestUtils ( )
16 | 
17 | -- from HUnit:
18 | import Test.HUnit (  )
19 | 
20 | -- from test-framework:
21 | import Test.Framework  ( Test )
22 | 
23 | -- from test-framework-hunit:
24 | import Test.Framework.Providers.HUnit ( )
25 | 
26 | 
27 | -------------------------------------------------------------------------------
28 | -- Tests for ReadWriteVar
29 | -------------------------------------------------------------------------------
30 | 
31 | tests :: [Test]
32 | tests = []
33 | 


--------------------------------------------------------------------------------
/README.markdown:
--------------------------------------------------------------------------------
 1 | The `concurrent-extra` package offers among other things the following
 2 | selection of synchronisation primitives:
 3 | 
 4 | * `Broadcast`: Wake multiple threads by broadcasting a value.
 5 | 
 6 | * `Event`: Wake multiple threads by signalling an event.
 7 | 
 8 | * `Lock`: Enforce exclusive access to a resource. Also known as a
 9 |   binary semaphore or mutex. The package additionally provides an
10 |   alternative that works in the `STM` monad.
11 | 
12 | * `RLock`: A lock which can be acquired multiple times by the same
13 |   thread. Also known as a reentrant mutex.
14 | 
15 | * `ReadWriteLock`: Multiple-reader, single-writer locks. Used to
16 |   protect shared resources which may be concurrently read, but only
17 |   sequentially written.
18 | 
19 | * `ReadWriteVar`: Concurrent read, sequential write variables.
20 | 
21 | Please consult the API documentation of the individual modules for
22 | more detailed information.
23 | 
24 | This package was inspired by the concurrency libraries of
25 | [Java](http://download.oracle.com/javase/6/docs/technotes/guides/concurrency/index.html)
26 | and [Python](http://docs.python.org/py3k/library/threading.html).
27 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2010-2012 Bas van Dijk & Roel van Dijk
 2 | 
 3 | All rights reserved.
 4 | 
 5 | Redistribution and use in source and binary forms, with or without
 6 | modification, are permitted provided that the following conditions are
 7 | met:
 8 | 
 9 |     * Redistributions of source code must retain the above copyright
10 |       notice, this list of conditions and the following disclaimer.
11 | 
12 |     * Redistributions in binary form must reproduce the above
13 |       copyright notice, this list of conditions and the following
14 |       disclaimer in the documentation and/or other materials provided
15 |       with the distribution.
16 | 
17 |     * The names of Bas van Dijk, Roel van Dijk and the names of
18 |       contributors may NOT be used to endorse or promote products
19 |       derived from this software without specific prior written
20 |       permission.
21 | 
22 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
23 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
24 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
25 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
26 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
27 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
28 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
29 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
30 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
31 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
32 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
33 | 


--------------------------------------------------------------------------------
/test.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE NoImplicitPrelude #-}
 2 | 
 3 | module Main where
 4 | 
 5 | -------------------------------------------------------------------------------
 6 | -- Imports
 7 | -------------------------------------------------------------------------------
 8 | 
 9 | -- from base:
10 | import System.IO ( IO )
11 | 
12 | -- from concurrent-extra:
13 | import qualified Control.Concurrent.Event.Test         as Event     ( tests )
14 | import qualified Control.Concurrent.Lock.Test          as Lock      ( tests )
15 | import qualified Control.Concurrent.STM.Lock.Test      as STM.Lock  ( tests )
16 | import qualified Control.Concurrent.RLock.Test         as RLock     ( tests )
17 | import qualified Control.Concurrent.Broadcast.Test     as Broadcast ( tests )
18 | import qualified Control.Concurrent.ReadWriteLock.Test as RWLock    ( tests )
19 | import qualified Control.Concurrent.ReadWriteVar.Test  as RWVar     ( tests )
20 | 
21 | -- from test-framework:
22 | import Test.Framework ( Test, defaultMain, testGroup )
23 | 
24 | 
25 | -------------------------------------------------------------------------------
26 | -- Tests
27 | -------------------------------------------------------------------------------
28 | 
29 | main :: IO ()
30 | main = defaultMain tests
31 | 
32 | tests :: [Test]
33 | tests = [ testGroup "Pessimistic locking"
34 |           [ testGroup "Event"         Event.tests
35 |           , testGroup "Lock"          Lock.tests
36 |           , testGroup "STM.Lock"      STM.Lock.tests
37 |           , testGroup "RLock"         RLock.tests
38 |           , testGroup "Broadcast"     Broadcast.tests
39 |           , testGroup "ReadWriteLock" RWLock.tests
40 |           , testGroup "ReadWriteVar"  RWVar.tests
41 |           ]
42 |         ]
43 | 


--------------------------------------------------------------------------------
/TestUtils.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE CPP
 2 |            , NoImplicitPrelude
 3 |            , ScopedTypeVariables
 4 |   #-}
 5 | 
 6 | module TestUtils where
 7 | 
 8 | 
 9 | -------------------------------------------------------------------------------
10 | -- Imports
11 | -------------------------------------------------------------------------------
12 | 
13 | -- from base:
14 | import Control.Applicative ( (<$>) )
15 | import Control.Concurrent  ( threadDelay )
16 | import Control.Exception   ( try, SomeException )
17 | import Control.Monad       ( return )
18 | import Data.Bool           ( Bool, not )
19 | import Data.Either         ( Either(Left, Right) )
20 | import Data.Int            ( Int )
21 | import Data.Maybe          ( isJust )
22 | import Prelude             ( String )
23 | import System.IO           ( IO )
24 | import System.Timeout      ( timeout )
25 | 
26 | #if __GLASGOW_HASKELL__ < 700
27 | import Prelude             ( fromInteger )
28 | import Control.Monad       ( (>>=), fail )
29 | #endif
30 | 
31 | -- from HUnit:
32 | import Test.HUnit          ( Assertion, assertFailure )
33 | 
34 | 
35 | -------------------------------------------------------------------------------
36 | -- Utilities for testing
37 | -------------------------------------------------------------------------------
38 | 
39 | -- Exactly 1 moment. Currently equal to 0.005 seconds.
40 | a_moment :: Int
41 | a_moment = 5000
42 | 
43 | wait_a_moment :: IO ()
44 | wait_a_moment = threadDelay a_moment
45 | 
46 | -- True if the action 'a' evaluates within 't' μs.
47 | within :: Int -> IO a -> IO Bool
48 | within t a = isJust <$> timeout t a
49 | 
50 | notWithin :: Int -> IO a -> IO Bool
51 | notWithin t a = not <$> within t a
52 | 
53 | assertException :: String -> IO a -> Assertion
54 | assertException errMsg a = do e <- try a
55 |                               case e of
56 |                                 Left (_ :: SomeException ) -> return ()
57 |                                 Right _ -> assertFailure errMsg
58 | 


--------------------------------------------------------------------------------
/Utils.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE CPP, NoImplicitPrelude #-}
 2 | 
 3 | module Utils
 4 |     ( mask
 5 |     , mask_
 6 |     , (.!)
 7 |     , void
 8 |     , ifM
 9 |     , purelyModifyMVar
10 |     , modifyIORefM
11 |     , modifyIORefM_
12 |     ) where
13 | 
14 | --------------------------------------------------------------------------------
15 | -- Imports
16 | --------------------------------------------------------------------------------
17 | 
18 | -- from base:
19 | import Control.Concurrent.MVar ( MVar, takeMVar, putMVar )
20 | import Control.Monad           ( Monad, return, (>>=) )
21 | import Data.Bool               ( Bool )
22 | import Data.Function           ( ($), (.) )
23 | import Data.IORef              ( IORef, readIORef, writeIORef )
24 | import Prelude                 ( ($!) )
25 | import System.IO               ( IO )
26 | 
27 | #if __GLASGOW_HASKELL__ < 700
28 | import Control.Monad           ( (>>), fail )
29 | #endif
30 | 
31 | 
32 | --------------------------------------------------------------------------------
33 | -- Utility functions
34 | --------------------------------------------------------------------------------
35 | 
36 | #if MIN_VERSION_base(4,3,0)
37 | import Control.Exception       ( mask, mask_ )
38 | import Control.Monad           ( void )
39 | #else
40 | import Control.Exception       ( blocked, block, unblock )
41 | import Data.Function           ( id )
42 | import Data.Functor            ( Functor, (<$) )
43 | 
44 | mask :: ((IO a -> IO a) -> IO b) -> IO b
45 | mask io = blocked >>= \b -> if b then io id else block $ io unblock
46 | 
47 | mask_ :: IO a -> IO a
48 | mask_ = block
49 | 
50 | void :: (Functor f) => f a -> f ()
51 | void = (() <$)
52 | #endif
53 | 
54 | -- | Strict function composition.
55 | (.!) :: (b -> γ) -> (a -> b) -> (a -> γ)
56 | f .! g = (f $!) . g
57 | 
58 | ifM :: Monad m => m Bool -> m a -> m a -> m a
59 | ifM c t e = c >>= \b -> if b then t else e
60 | 
61 | purelyModifyMVar :: MVar a -> (a -> a) -> IO ()
62 | purelyModifyMVar mv f = mask_ $ takeMVar mv >>= putMVar mv .! f
63 | 
64 | modifyIORefM :: IORef a -> (a -> IO (a, b)) -> IO b
65 | modifyIORefM r f = do (y, z) <- readIORef r >>= f
66 |                       writeIORef r y
67 |                       return z
68 | 
69 | modifyIORefM_ :: IORef a -> (a -> IO a) -> IO ()
70 | modifyIORefM_ r f = readIORef r >>= f >>= writeIORef r
71 | 


--------------------------------------------------------------------------------
/Control/Concurrent/RLock/Test.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE CPP
 2 |            , NoImplicitPrelude
 3 |            , ScopedTypeVariables
 4 |   #-}
 5 | 
 6 | module Control.Concurrent.RLock.Test ( tests ) where
 7 | 
 8 | 
 9 | -------------------------------------------------------------------------------
10 | -- Imports
11 | -------------------------------------------------------------------------------
12 | 
13 | -- from base:
14 | import Prelude            ( (*) )
15 | import Control.Concurrent ( forkIO, threadDelay )
16 | import Control.Monad      ( replicateM_ )
17 | import Data.Function      ( ($), (.) )
18 | import Data.Int           ( Int )
19 | 
20 | #if __GLASGOW_HASKELL__ < 700
21 | import Prelude            ( fromInteger )
22 | import Control.Monad      ( (>>=), fail, (>>) )
23 | #endif
24 | 
25 | -- from concurrent-extra:
26 | import qualified Control.Concurrent.Event as Event ( new, set, wait )
27 | import qualified Control.Concurrent.RLock as RLock
28 | import TestUtils
29 | 
30 | -- from HUnit:
31 | import Test.HUnit ( Assertion, assert )
32 | 
33 | -- from test-framework:
34 | import Test.Framework  ( Test )
35 | 
36 | -- from test-framework-hunit:
37 | import Test.Framework.Providers.HUnit ( testCase )
38 | 
39 | 
40 | -------------------------------------------------------------------------------
41 | -- Tests for RLock
42 | -------------------------------------------------------------------------------
43 | 
44 | tests :: [Test]
45 | tests = [ testCase "recursive acquire"  $ test_rlock_1 5
46 |         , testCase "conc acquire"       $ test_rlock_2
47 |         ]
48 | 
49 | test_rlock_1 :: Int -> Assertion
50 | test_rlock_1 n = assert . within (10 * a_moment) $ do
51 |   l <- RLock.new
52 |   replicateM_ n $ RLock.acquire l
53 |   replicateM_ n $ RLock.release l
54 | 
55 | -- Tests for bug found by Felipe Lessa.
56 | test_rlock_2 :: Assertion
57 | test_rlock_2 = assert . within (20 * a_moment) $ do
58 |   rl           <- RLock.new
59 |   t1_has_rlock <- Event.new
60 |   t1_done      <- Event.new
61 |   t2_done      <- Event.new
62 | 
63 |   -- Thread 1
64 |   _ <- forkIO $ do
65 |     RLock.acquire rl
66 |     Event.set t1_has_rlock
67 |     threadDelay $ 10 * a_moment
68 |     RLock.release rl
69 |     Event.set t1_done
70 | 
71 |   -- Thread 2
72 |   _ <- forkIO $ do
73 |     Event.wait t1_has_rlock
74 |     RLock.acquire rl
75 |     RLock.release rl
76 |     Event.set t2_done
77 | 
78 |   Event.wait t1_done
79 |   Event.wait t2_done
80 | 


--------------------------------------------------------------------------------
/Control/Concurrent/Lock/Test.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP
  2 |            , NoImplicitPrelude
  3 |            , ScopedTypeVariables
  4 |   #-}
  5 | 
  6 | module Control.Concurrent.Lock.Test ( tests ) where
  7 | 
  8 | -------------------------------------------------------------------------------
  9 | -- Imports
 10 | -------------------------------------------------------------------------------
 11 | 
 12 | -- from base:
 13 | import Prelude            ( (*) )
 14 | import Control.Concurrent ( forkIO )
 15 | import Control.Monad      ( return, (>>=), (>>) )
 16 | import Data.Bool          ( Bool(False, True), not, (&&) )
 17 | import Data.Function      ( ($), (.) )
 18 | import Data.Functor       ( fmap )
 19 | import Data.IORef         ( newIORef, writeIORef, readIORef )
 20 | 
 21 | #if __GLASGOW_HASKELL__ < 700
 22 | import Prelude            ( fromInteger )
 23 | import Control.Monad      ( fail )
 24 | #endif
 25 | 
 26 | -- from concurrent-extra:
 27 | import qualified Control.Concurrent.Lock as Lock
 28 | import TestUtils
 29 | 
 30 | -- from HUnit:
 31 | import Test.HUnit ( Assertion, assert )
 32 | 
 33 | -- from test-framework:
 34 | import Test.Framework  ( Test )
 35 | 
 36 | -- from test-framework-hunit:
 37 | import Test.Framework.Providers.HUnit ( testCase )
 38 | 
 39 | 
 40 | -------------------------------------------------------------------------------
 41 | -- Tests for Lock
 42 | -------------------------------------------------------------------------------
 43 | 
 44 | tests :: [Test]
 45 | tests = [ testCase "acquire release"    test_lock_1
 46 |         , testCase "acquire acquire"    test_lock_2
 47 |         , testCase "new release"        test_lock_3
 48 |         , testCase "new unlocked"       test_lock_4
 49 |         , testCase "newAcquired locked" test_lock_5
 50 |         , testCase "acq rel unlocked"   test_lock_6
 51 |         , testCase "conc release"       test_lock_7
 52 |         , testCase "wait"               test_lock_8
 53 |         ]
 54 | 
 55 | test_lock_1 :: Assertion
 56 | test_lock_1 = assert $ within a_moment $ do
 57 |   l <- Lock.new
 58 |   Lock.acquire l
 59 |   Lock.release l
 60 | 
 61 | test_lock_2 :: Assertion
 62 | test_lock_2 = assert $ notWithin (10 * a_moment) $ do
 63 |   l <- Lock.new
 64 |   Lock.acquire l
 65 |   Lock.acquire l
 66 | 
 67 | test_lock_3 :: Assertion
 68 | test_lock_3 = assertException "" $ Lock.new >>= Lock.release
 69 | 
 70 | test_lock_4 :: Assertion
 71 | test_lock_4 = assert $ Lock.new >>= fmap not . Lock.locked
 72 | 
 73 | test_lock_5 :: Assertion
 74 | test_lock_5 = assert $ Lock.newAcquired >>= Lock.locked
 75 | 
 76 | test_lock_6 :: Assertion
 77 | test_lock_6 = assert $ do
 78 |   l <- Lock.new
 79 |   Lock.acquire l
 80 |   Lock.release l
 81 |   fmap not $ Lock.locked l
 82 | 
 83 | test_lock_7 :: Assertion
 84 | test_lock_7 = assert . within (1000 * a_moment) $ do
 85 |   l <- Lock.newAcquired
 86 |   _ <- forkIO $ wait_a_moment >> Lock.release l
 87 |   Lock.acquire l
 88 | 
 89 | test_lock_8 :: Assertion
 90 | test_lock_8 = assert $ do
 91 |   ioRef <- newIORef False
 92 |   l <- Lock.newAcquired
 93 |   _ <- forkIO $ do wait_a_moment
 94 |                    writeIORef ioRef True
 95 |                    Lock.release l
 96 |   Lock.wait l
 97 |   set <- readIORef ioRef
 98 |   locked <- Lock.locked l
 99 |   return $ set && not locked
100 | 


--------------------------------------------------------------------------------
/Control/Concurrent/STM/Lock/Test.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP
  2 |            , NoImplicitPrelude
  3 |            , ScopedTypeVariables
  4 |   #-}
  5 | 
  6 | module Control.Concurrent.STM.Lock.Test ( tests ) where
  7 | 
  8 | -------------------------------------------------------------------------------
  9 | -- Imports
 10 | -------------------------------------------------------------------------------
 11 | 
 12 | -- from base:
 13 | import Prelude            ( (*) )
 14 | import Control.Concurrent ( forkIO )
 15 | import Control.Monad      ( return, (>>=), (>>) )
 16 | import Data.Bool          ( Bool(False, True), not, (&&) )
 17 | import Data.Function      ( ($), (.) )
 18 | import Data.Functor       ( fmap )
 19 | import Data.IORef         ( newIORef, writeIORef, readIORef )
 20 | 
 21 | #if __GLASGOW_HASKELL__ < 700
 22 | import Prelude            ( fromInteger )
 23 | import Control.Monad      ( fail )
 24 | #endif
 25 | 
 26 | -- from stm:
 27 | import Control.Concurrent.STM ( atomically )
 28 | 
 29 | -- from concurrent-extra:
 30 | import qualified Control.Concurrent.STM.Lock as Lock
 31 | import TestUtils
 32 | 
 33 | -- from HUnit:
 34 | import Test.HUnit ( Assertion, assert )
 35 | 
 36 | -- from test-framework:
 37 | import Test.Framework  ( Test )
 38 | 
 39 | -- from test-framework-hunit:
 40 | import Test.Framework.Providers.HUnit ( testCase )
 41 | 
 42 | 
 43 | -------------------------------------------------------------------------------
 44 | -- Tests for Lock
 45 | -------------------------------------------------------------------------------
 46 | 
 47 | tests :: [Test]
 48 | tests = [ testCase "acquire release"    test_lock_1
 49 |         , testCase "acquire acquire"    test_lock_2
 50 |         , testCase "new release"        test_lock_3
 51 |         , testCase "new unlocked"       test_lock_4
 52 |         , testCase "newAcquired locked" test_lock_5
 53 |         , testCase "acq rel unlocked"   test_lock_6
 54 |         , testCase "conc release"       test_lock_7
 55 |         , testCase "wait"               test_lock_8
 56 |         ]
 57 | 
 58 | test_lock_1 :: Assertion
 59 | test_lock_1 = assert $ within a_moment $ atomically $ do
 60 |   l <- Lock.new
 61 |   Lock.acquire l
 62 |   Lock.release l
 63 | 
 64 | test_lock_2 :: Assertion
 65 | test_lock_2 = assert $ notWithin (10 * a_moment) $ atomically $ do
 66 |   l <- Lock.new
 67 |   Lock.acquire l
 68 |   Lock.acquire l
 69 | 
 70 | test_lock_3 :: Assertion
 71 | test_lock_3 = assertException "" $ atomically $ Lock.new >>= Lock.release
 72 | 
 73 | test_lock_4 :: Assertion
 74 | test_lock_4 = assert $ atomically $ Lock.new >>= fmap not . Lock.locked
 75 | 
 76 | test_lock_5 :: Assertion
 77 | test_lock_5 = assert $ atomically $ Lock.newAcquired >>= Lock.locked
 78 | 
 79 | test_lock_6 :: Assertion
 80 | test_lock_6 = assert $ atomically $ do
 81 |   l <- Lock.new
 82 |   Lock.acquire l
 83 |   Lock.release l
 84 |   fmap not $ Lock.locked l
 85 | 
 86 | test_lock_7 :: Assertion
 87 | test_lock_7 = assert . within (10 * a_moment) $ do
 88 |   l <- atomically $ Lock.newAcquired
 89 |   _ <- forkIO $ wait_a_moment >> atomically (Lock.release l)
 90 |   atomically $ Lock.acquire l
 91 | 
 92 | test_lock_8 :: Assertion
 93 | test_lock_8 = assert $ do
 94 |   ioRef <- newIORef False
 95 |   l <- atomically Lock.newAcquired
 96 |   _ <- forkIO $ do wait_a_moment
 97 |                    writeIORef ioRef True
 98 |                    atomically $ Lock.release l
 99 |   atomically $ Lock.wait l
100 |   set <- readIORef ioRef
101 |   locked <- atomically $ Lock.locked l
102 |   return $ set && not locked
103 | 


--------------------------------------------------------------------------------
/Control/Concurrent/Event/Test.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP, NoImplicitPrelude, ScopedTypeVariables #-}
  2 | 
  3 | module Control.Concurrent.Event.Test ( tests ) where
  4 | 
  5 | -------------------------------------------------------------------------------
  6 | -- Imports
  7 | -------------------------------------------------------------------------------
  8 | 
  9 | -- from base:
 10 | import Control.Exception  ( catch, throwTo, ErrorCall(..) )
 11 | import Control.Concurrent ( forkIO )
 12 | import Control.Monad      ( return, mapM_, replicateM, replicateM_ )
 13 | import Data.Function      ( ($) )
 14 | import Data.Int           ( Int )
 15 | import Data.Bool          ( not )
 16 | import Prelude            ( toInteger, (*) )
 17 | 
 18 | #if __GLASGOW_HASKELL__ < 700
 19 | import Prelude            ( fromInteger )
 20 | import Control.Monad      ( (>>=), (>>), fail )
 21 | #endif
 22 | 
 23 | -- from concurrent-extra:
 24 | import qualified Control.Concurrent.Event as Event
 25 | import TestUtils
 26 | 
 27 | -- from HUnit:
 28 | import Test.HUnit ( Assertion, assert )
 29 | 
 30 | -- from test-framework:
 31 | import Test.Framework  ( Test )
 32 | 
 33 | -- from test-framework-hunit:
 34 | import Test.Framework.Providers.HUnit ( testCase )
 35 | 
 36 | 
 37 | -------------------------------------------------------------------------------
 38 | -- Tests for Event
 39 | -------------------------------------------------------------------------------
 40 | 
 41 | tests :: [Test]
 42 | tests = [ testCase "set wait a"    $ test_event_1 1 1
 43 |         , testCase "set wait b"    $ test_event_1 5 1
 44 |         , testCase "set wait c"    $ test_event_1 1 5
 45 |         , testCase "set wait d"    $ test_event_1 5 5
 46 |         , testCase "conc set wait" $ test_event_2
 47 |         , testCase "multi wake"    $ test_event_3 10
 48 |         , testCase "exception"     $ test_event_4
 49 |         , testCase "wait timeout"  $ test_event_5
 50 |         , testCase "wait blocks"   $ test_event_6
 51 |         ]
 52 | 
 53 | -- Set an event 's' times then wait for it 'w' times. This should
 54 | -- terminate within a few moments.
 55 | test_event_1 :: Int -> Int -> Assertion
 56 | test_event_1 s w = assert $ within (10 * a_moment) $ do
 57 |   e <- Event.new
 58 |   replicateM_ s $ Event.set  e
 59 |   replicateM_ w $ Event.wait e
 60 | 
 61 | test_event_2 :: Assertion
 62 | test_event_2 = assert $ within (10 * a_moment) $ do
 63 |   e1 <- Event.new
 64 |   e2 <- Event.new
 65 |   _ <- forkIO $ do
 66 |     Event.wait e1
 67 |     Event.set  e2
 68 |   wait_a_moment
 69 |   Event.set  e1
 70 |   Event.wait e2
 71 | 
 72 | -- Waking multiple threads with a single Event.
 73 | test_event_3 :: Int -> Assertion
 74 | test_event_3 n = assert $ within (10 * a_moment) $ do
 75 |   e1 <- Event.new
 76 |   es <- replicateM n $ do
 77 |     e2 <- Event.new
 78 |     _ <- forkIO $ do
 79 |       Event.wait e1
 80 |       Event.set  e2
 81 |     return e2
 82 |   wait_a_moment
 83 |   Event.set e1
 84 |   mapM_ Event.wait es
 85 | 
 86 | -- Exception handling while waiting for an Event.
 87 | test_event_4 :: Assertion
 88 | test_event_4 = assert $ within (10 * a_moment) $ do
 89 |   e1 <- Event.new
 90 |   e2 <- Event.new
 91 |   helperId <- forkIO $ Event.wait e1 `catch` \(_ :: ErrorCall) ->
 92 |                                                  Event.set e2
 93 |   wait_a_moment
 94 |   throwTo helperId $ ErrorCall "Boo!"
 95 |   Event.wait e2
 96 | 
 97 | test_event_5 :: Assertion
 98 | test_event_5 = assert $ within (10 * a_moment) $ do
 99 |   e <- Event.new
100 |   notTimedOut <- Event.waitTimeout e $ toInteger a_moment
101 |   return $ not notTimedOut
102 | 
103 | test_event_6 :: Assertion
104 | test_event_6 = assert $ notWithin (10 * a_moment) $ do
105 |   e <- Event.new
106 |   Event.wait e
107 | 


--------------------------------------------------------------------------------
/concurrent-extra.cabal:
--------------------------------------------------------------------------------
 1 | name:          concurrent-extra
 2 | version:       0.7.0.12
 3 | cabal-version: >= 1.8
 4 | build-type:    Simple
 5 | stability:     experimental
 6 | author:        Bas van Dijk <v.dijk.bas@gmail.com>
 7 |                Roel van Dijk <vandijk.roel@gmail.com>
 8 | maintainer:    Bas van Dijk <v.dijk.bas@gmail.com>
 9 |                Roel van Dijk <vandijk.roel@gmail.com>
10 | copyright:     (c) 2010-2012 Bas van Dijk & Roel van Dijk
11 | license:       BSD3
12 | license-file:  LICENSE
13 | homepage:      https://github.com/basvandijk/concurrent-extra
14 | bug-reports:   https://github.com/basvandijk/concurrent-extra/issues
15 | category:      Concurrency
16 | synopsis:      Extra concurrency primitives
17 | description:
18 |   The @concurrent-extra@ package offers among other things the
19 |   following selection of synchronisation primitives:
20 |   .
21 |   * @Broadcast@: Wake multiple threads by broadcasting a value.
22 |   .
23 |   * @Event@: Wake multiple threads by signalling an event.
24 |   .
25 |   * @Lock@: Enforce exclusive access to a resource. Also known as a
26 |     binary semaphore or mutex. The package additionally provides an
27 |     alternative that works in the @STM@ monad.
28 |   .
29 |   * @RLock@: A lock which can be acquired multiple times by the same
30 |     thread. Also known as a reentrant mutex.
31 |   .
32 |   * @ReadWriteLock@: Multiple-reader, single-writer locks. Used to
33 |     protect shared resources which may be concurrently read, but only
34 |     sequentially written.
35 |   .
36 |   * @ReadWriteVar@: Concurrent read, sequential write variables.
37 |   .
38 |   Please consult the API documentation of the individual modules for
39 |   more detailed information.
40 |   .
41 |   This package was inspired by the concurrency libraries of Java and
42 |   Python.
43 | 
44 | extra-source-files: README.markdown
45 | 
46 | source-repository head
47 |   Type: git
48 |   Location: git://github.com/basvandijk/concurrent-extra.git
49 | 
50 | -------------------------------------------------------------------------------
51 | 
52 | library
53 |   build-depends: base             >= 3 && < 5
54 |                , stm              >= 2.1.2.1
55 |                , unbounded-delays >= 0.1
56 |   exposed-modules: Control.Concurrent.Lock
57 |                  , Control.Concurrent.STM.Lock
58 |                  , Control.Concurrent.RLock
59 |                  , Control.Concurrent.Event
60 |                  , Control.Concurrent.Broadcast
61 |                  , Control.Concurrent.ReadWriteLock
62 |                  , Control.Concurrent.ReadWriteVar
63 |   other-modules: Utils
64 |   ghc-options: -Wall
65 | 
66 | -------------------------------------------------------------------------------
67 | 
68 | test-suite test-concurrent-extra
69 |   type:    exitcode-stdio-1.0
70 |   main-is: test.hs
71 |   other-modules: Control.Concurrent.Event.Test
72 |                , Control.Concurrent.Lock.Test
73 |                , Control.Concurrent.STM.Lock.Test
74 |                , Control.Concurrent.RLock.Test
75 |                , Control.Concurrent.Broadcast.Test
76 |                , Control.Concurrent.ReadWriteLock.Test
77 |                , Control.Concurrent.ReadWriteVar.Test
78 |                , TestUtils
79 | 
80 |   ghc-options: -Wall -threaded
81 | 
82 |   build-depends: base                 >= 3 && < 5
83 |                , stm                  >= 2.1.2.1
84 |                , unbounded-delays     >= 0.1
85 |                , HUnit                >= 1.2.2
86 |                , random               >= 1.0
87 |                , test-framework       >= 0.2.4
88 |                , test-framework-hunit >= 0.2.4
89 |                , async                >= 2.0
90 | 
91 | -------------------------------------------------------------------------------
92 | 


--------------------------------------------------------------------------------
/Control/Concurrent/ReadWriteLock/Test.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP, NoImplicitPrelude #-}
  2 | 
  3 | module Control.Concurrent.ReadWriteLock.Test ( tests ) where
  4 | 
  5 | 
  6 | -------------------------------------------------------------------------------
  7 | -- Imports
  8 | -------------------------------------------------------------------------------
  9 | 
 10 | -- from base:
 11 | import Prelude            ( (*) )
 12 | import Control.Monad      ( (>>), (>>=), replicateM_ )
 13 | import Control.Concurrent ( forkIO, threadDelay )
 14 | import Data.Function      ( ($) )
 15 | import Data.Foldable      ( sequenceA_ )
 16 | import Data.List          ( map, replicate, (++) )
 17 | import System.Random      ( randomRIO )
 18 | 
 19 | #if __GLASGOW_HASKELL__ < 700
 20 | import Prelude            ( fromInteger )
 21 | import Control.Monad      ( (>>=), fail )
 22 | #endif
 23 | 
 24 | -- from async:
 25 | import Control.Concurrent.Async ( Concurrently(Concurrently), runConcurrently )
 26 | 
 27 | -- from concurrent-extra:
 28 | import qualified Control.Concurrent.ReadWriteLock as RWLock
 29 |     ( new, acquireWrite, acquireRead, releaseWrite, releaseRead, withRead, withWrite  )
 30 | 
 31 | import TestUtils ( within, a_moment )
 32 | 
 33 | import Utils ( void )
 34 | 
 35 | -- from HUnit:
 36 | import Test.HUnit ( Assertion, assert )
 37 | 
 38 | -- from test-framework:
 39 | import Test.Framework  ( Test )
 40 | 
 41 | -- from test-framework-hunit:
 42 | import Test.Framework.Providers.HUnit ( testCase )
 43 | 
 44 | 
 45 | -------------------------------------------------------------------------------
 46 | -- Tests for ReadWriteLock
 47 | -------------------------------------------------------------------------------
 48 | 
 49 | tests :: [Test]
 50 | tests = [ testCase "test1" test1
 51 |         , testCase "test2" test2
 52 |         , testCase "stressTest" stressTest
 53 |         ]
 54 | 
 55 | test1 :: Assertion
 56 | test1 = assert $ within (10 * a_moment) $ do
 57 |           -- Create a new read-write-lock (in the "Free" state):
 58 |           rwl <- RWLock.new
 59 | 
 60 |           -- Put the read-write-lock in the "Write" state:
 61 |           RWLock.acquireWrite rwl
 62 | 
 63 |           -- Fork a thread that releases the write-lock after a moment:
 64 |           void $ forkIO $ threadDelay a_moment >> RWLock.releaseWrite rwl
 65 | 
 66 |           -- This blocks until the write-lock is released in the above thread.
 67 |           RWLock.acquireRead rwl
 68 | 
 69 |           -- Release the read-lock so that the read-write-lock can either be
 70 |           -- acquired again by 'acquireRead' or 'acquireWrite':
 71 |           RWLock.releaseRead rwl
 72 | 
 73 |           -- The read-write-lock should now be in the "Free" state so the
 74 |           -- following shouldn't deadlock:
 75 |           RWLock.acquireWrite rwl
 76 | 
 77 | test2 :: Assertion
 78 | test2 = assert $ within (10 * a_moment) $ do
 79 |           -- Create a new read-write-lock (in the "Free" state):
 80 |           rwl <- RWLock.new
 81 | 
 82 |           -- Put the read-write-lock in the "Read" state:
 83 |           RWLock.acquireRead rwl
 84 | 
 85 |           -- Fork a thread that releases the read-lock after a moment:
 86 |           void $ forkIO $ threadDelay a_moment >> RWLock.releaseRead rwl
 87 | 
 88 |           -- This blocks until the read-lock is released in the above thread.
 89 |           RWLock.acquireWrite rwl
 90 | 
 91 |           -- Release the write-lock so that the read-write-lock can either be
 92 |           -- acquired again by 'acquireRead' or 'acquireWrite':
 93 |           RWLock.releaseWrite rwl
 94 | 
 95 |           -- The read-write-lock should now be in the "Free" state so the
 96 |           -- following shouldn't deadlock:
 97 |           RWLock.acquireRead rwl
 98 | 
 99 | stressTest :: Assertion
100 | stressTest = assert $ within (500 * a_moment) $ do
101 |   lock <- RWLock.new
102 | 
103 |   let randomDelay hi = randomRIO (0, hi) >>= threadDelay
104 | 
105 |       reader = replicateM_ 500 $ do
106 |         randomDelay 100
107 |         RWLock.withRead lock $ randomDelay 10
108 | 
109 |       writer = replicateM_ 500 $ do
110 |         randomDelay 100
111 |         RWLock.withWrite lock $ randomDelay 10
112 | 
113 |   runConcurrently $ sequenceA_ $ map Concurrently $
114 |     replicate 10 reader ++ replicate 10 writer
115 | 


--------------------------------------------------------------------------------
/Control/Concurrent/ReadWriteVar.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP
  2 |            , DeriveDataTypeable
  3 |            , NoImplicitPrelude
  4 |            , TupleSections
  5 |   #-}
  6 | 
  7 | #if __GLASGOW_HASKELL__ >= 704
  8 | {-# LANGUAGE Safe #-}
  9 | #endif
 10 | 
 11 | -------------------------------------------------------------------------------
 12 | -- |
 13 | -- Module     : Control.Concurrent.ReadWriteVar
 14 | -- Copyright  : 2010—2011 Bas van Dijk & Roel van Dijk
 15 | -- License    : BSD3 (see the file LICENSE)
 16 | -- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>
 17 | --            , Roel van Dijk <vandijk.roel@gmail.com>
 18 | --
 19 | -- Concurrent read, sequential write variables. Comparable to an 'IORef' with
 20 | -- more advanced synchronization mechanisms. The value stored inside the 'RWVar'
 21 | -- can be read and used by multiple threads at the same time. Concurrent
 22 | -- computations inside a 'with' \"block\" observe the same value.
 23 | --
 24 | -- Observing and changing the contents of an 'RWVar' are mutually
 25 | -- exclusive. The 'with' function will block if 'modify' is active and
 26 | -- vice-versa. Furthermore 'with' is fully sequential and will also
 27 | -- block on concurrent calls of 'modify'.
 28 | --
 29 | -- The following are guaranteed deadlocks:
 30 | --
 31 | -- * @'modify_' v '$' 'const' '$' 'with' v '$' 'const' 'undefined'@
 32 | --
 33 | -- * @'with' v '$' 'const' '$' 'modify_' v '$' 'const' 'undefined'@
 34 | --
 35 | -- * @'modify_' v '$' 'const' '$' 'modify_' v '$' 'const' 'undefined'@
 36 | --
 37 | -- All functions are /exception safe/. Throwing asynchronous exceptions will not
 38 | -- compromise the internal state of an 'RWVar'. This also means that threads
 39 | -- blocking on 'with' or 'modify' and friends can still be unblocked by throwing
 40 | -- an asynchronous exception.
 41 | --
 42 | -- This module is designed to be imported qualified. We suggest importing it
 43 | -- like:
 44 | --
 45 | -- @
 46 | -- import           Control.Concurrent.ReadWriteVar        ( RWVar )
 47 | -- import qualified Control.Concurrent.ReadWriteVar as RWV ( ... )
 48 | -- @
 49 | --
 50 | -------------------------------------------------------------------------------
 51 | 
 52 | module Control.Concurrent.ReadWriteVar
 53 |   ( RWVar
 54 |   , new
 55 |   , with
 56 |   , tryWith
 57 |   , modify_
 58 |   , modify
 59 |   , tryModify_
 60 |   , tryModify
 61 |   ) where
 62 | 
 63 | 
 64 | -------------------------------------------------------------------------------
 65 | -- Imports
 66 | -------------------------------------------------------------------------------
 67 | 
 68 | -- from base:
 69 | import Control.Applicative ( liftA2 )
 70 | import Control.Monad       ( (>>=) )
 71 | import Data.Bool           ( Bool(..) )
 72 | import Data.Eq             ( Eq, (==) )
 73 | import Data.Function       ( ($), (.), on )
 74 | import Data.Functor        ( fmap  )
 75 | import Data.Maybe          ( Maybe(..), isJust )
 76 | import Data.IORef          ( IORef, newIORef, readIORef )
 77 | import Data.Typeable       ( Typeable )
 78 | import System.IO           ( IO )
 79 | #ifdef __HADDOCK_VERSION__
 80 | import Data.Function       ( const )
 81 | import Prelude             ( undefined )
 82 | #endif
 83 | 
 84 | -- from concurrent-extra (this package):
 85 | import           Control.Concurrent.ReadWriteLock ( RWLock )
 86 | import qualified Control.Concurrent.ReadWriteLock as RWLock
 87 | 
 88 | import Utils ( modifyIORefM, modifyIORefM_ )
 89 | 
 90 | 
 91 | -------------------------------------------------------------------------------
 92 | -- Read-Write Variables: concurrent read, sequential write
 93 | -------------------------------------------------------------------------------
 94 | 
 95 | -- | Concurrently readable and sequentially writable variable.
 96 | data RWVar a = RWVar RWLock (IORef a) deriving Typeable
 97 | 
 98 | instance Eq (RWVar a) where
 99 |     (==) = (==) `on` rwlock
100 |         where
101 |           rwlock (RWVar rwl _) = rwl
102 | 
103 | -- | Create a new 'RWVar'.
104 | new :: a -> IO (RWVar a)
105 | new = liftA2 RWVar RWLock.new . newIORef
106 | 
107 | {-| Execute an action that operates on the contents of the 'RWVar'.
108 | 
109 | The action is guaranteed to have a consistent view of the stored value. Any
110 | function that attempts to 'modify' the contents will block until the action is
111 | completed.
112 | 
113 | If another thread is modifying the contents of the 'RWVar' this function will
114 | block until the other thread finishes its action.
115 | -}
116 | with :: RWVar a -> (a -> IO b) -> IO b
117 | with (RWVar l r) f = RWLock.withRead l $ readIORef r >>= f
118 | 
119 | {-| Like 'with' but doesn't block. Returns 'Just' the result if read access
120 | could be acquired without blocking, 'Nothing' otherwise.
121 | -}
122 | tryWith :: RWVar a -> (a -> IO b) -> IO (Maybe b)
123 | tryWith (RWVar l r) f = RWLock.tryWithRead l $ readIORef r >>= f
124 | 
125 | {-| Modify the contents of an 'RWVar'.
126 | 
127 | This function needs exclusive write access to the 'RWVar'. Only one thread can
128 | modify an 'RWVar' at the same time. All others will block.
129 | -}
130 | modify_ :: RWVar a -> (a -> IO a) -> IO ()
131 | modify_ (RWVar l r) = RWLock.withWrite l . modifyIORefM_ r
132 | 
133 | {-| Modify the contents of an 'RWVar' and return an additional value.
134 | 
135 | Like 'modify_', but allows a value to be returned (&#x3b2;) in addition to the
136 | modified value of the 'RWVar'.
137 | -}
138 | modify :: RWVar a -> (a -> IO (a, b)) -> IO b
139 | modify (RWVar l r) = RWLock.withWrite l . modifyIORefM r
140 | 
141 | {-| Attempt to modify the contents of an 'RWVar'.
142 | 
143 | Like 'modify_', but doesn't block. Returns 'True' if the contents could be
144 | replaced, 'False' otherwise.
145 | -}
146 | tryModify_ :: RWVar a -> (a -> IO a) -> IO Bool
147 | tryModify_ (RWVar l r) = fmap isJust . RWLock.tryWithWrite l . modifyIORefM_ r
148 | 
149 | {-| Attempt to modify the contents of an 'RWVar' and return an additional value.
150 | 
151 | Like 'modify', but doesn't block. Returns 'Just' the additional value if the
152 | contents could be replaced, 'Nothing' otherwise.
153 | -}
154 | tryModify :: RWVar a -> (a -> IO (a, b)) -> IO (Maybe b)
155 | tryModify (RWVar l r) = RWLock.tryWithWrite l . modifyIORefM r
156 | 


--------------------------------------------------------------------------------
/Control/Concurrent/Event.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP
  2 |            , DeriveDataTypeable
  3 |            , NoImplicitPrelude
  4 |   #-}
  5 | 
  6 | #if __GLASGOW_HASKELL__ >= 704
  7 | {-# LANGUAGE Safe #-}
  8 | #endif
  9 | 
 10 | -------------------------------------------------------------------------------
 11 | -- |
 12 | -- Module     : Control.Concurrent.Event
 13 | -- Copyright  : (c) 2010-2011 Bas van Dijk & Roel van Dijk
 14 | -- License    : BSD3 (see the file LICENSE)
 15 | -- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>
 16 | --            , Roel van Dijk <vandijk.roel@gmail.com>
 17 | --
 18 | -- An Event is a simple mechanism for communication between threads: one thread
 19 | -- signals an event and other threads wait for it.
 20 | --
 21 | -- An event has a state which is either \"set\" or \"cleared\". This state can
 22 | -- be changed with the corresponding functions 'set' and 'clear'. The 'wait'
 23 | -- function blocks until the state is \"set\". An important property of setting
 24 | -- an event is that /all/ threads waiting for it are woken.
 25 | --
 26 | -- It was inspired by the Python @Event@ object. See:
 27 | --
 28 | -- <http://docs.python.org/3.1/library/threading.html#event-objects>
 29 | --
 30 | -- This module is designed to be imported qualified. We suggest importing it
 31 | -- like:
 32 | --
 33 | -- @
 34 | -- import           Control.Concurrent.Event          ( Event )
 35 | -- import qualified Control.Concurrent.Event as Event ( ... )
 36 | -- @
 37 | --
 38 | -------------------------------------------------------------------------------
 39 | 
 40 | module Control.Concurrent.Event
 41 |   ( Event
 42 | 
 43 |     -- * Creating events
 44 |   , new
 45 |   , newSet
 46 | 
 47 |     -- * Waiting for events
 48 |   , wait
 49 |   , waitTimeout
 50 |   , isSet
 51 | 
 52 |     -- * Setting events
 53 |   , set
 54 |   , signal
 55 |   , clear
 56 |   ) where
 57 | 
 58 | 
 59 | -------------------------------------------------------------------------------
 60 | -- Imports
 61 | -------------------------------------------------------------------------------
 62 | 
 63 | -- from base:
 64 | import Data.Bool               ( Bool(..) )
 65 | import Data.Eq                 ( Eq )
 66 | import Data.Function           ( (.) )
 67 | import Data.Functor            ( fmap, (<$>) )
 68 | import Data.Maybe              ( isJust )
 69 | import Data.Typeable           ( Typeable )
 70 | 
 71 | #ifdef __HADDOCK_VERSION__
 72 | import Control.Exception       ( mask )
 73 | #endif
 74 | 
 75 | import Prelude                 ( Integer )
 76 | import System.IO               ( IO )
 77 | 
 78 | -- from concurrent-extra (this package):
 79 | import           Control.Concurrent.Broadcast ( Broadcast )
 80 | import qualified Control.Concurrent.Broadcast as Broadcast
 81 |                                ( new, newBroadcasting
 82 |                                , listen, tryListen, listenTimeout
 83 |                                , broadcast, signal, silence
 84 |                                )
 85 | 
 86 | 
 87 | -------------------------------------------------------------------------------
 88 | -- Events
 89 | -------------------------------------------------------------------------------
 90 | 
 91 | -- | An event is in one of two possible states: \"set\" or \"cleared\".
 92 | newtype Event = Event {evBroadcast :: Broadcast ()} deriving (Eq, Typeable)
 93 | 
 94 | 
 95 | -------------------------------------------------------------------------------
 96 | -- Creating events
 97 | -------------------------------------------------------------------------------
 98 | 
 99 | -- | Create an event in the \"cleared\" state.
100 | new :: IO Event
101 | new = Event <$> Broadcast.new
102 | 
103 | -- | Create an event in the \"set\" state.
104 | newSet :: IO Event
105 | newSet = Event <$> Broadcast.newBroadcasting ()
106 | 
107 | 
108 | -------------------------------------------------------------------------------
109 | -- Waiting for events
110 | -------------------------------------------------------------------------------
111 | 
112 | {-|
113 | Block until the event is 'set'.
114 | 
115 | If the state of the event is already \"set\" this function will return
116 | immediately. Otherwise it will block until another thread calls 'set'.
117 | 
118 | (You can also resume a thread that is waiting for an event by throwing an
119 | asynchronous exception.)
120 | -}
121 | wait :: Event -> IO ()
122 | wait = Broadcast.listen . evBroadcast
123 | 
124 | {-|
125 | Block until the event is 'set' or until a timer expires.
126 | 
127 | Like 'wait', but with a timeout. A return value of 'False' indicates a timeout
128 | occurred.
129 | 
130 | The timeout is specified in microseconds.
131 | 
132 | If the event is \"cleared\" and a timeout of 0 &#x3bc;s is specified the
133 | function returns 'False' without blocking.
134 | 
135 | Negative timeouts are treated the same as a timeout of 0 &#x3bc;s.
136 | -}
137 | waitTimeout :: Event -> Integer -> IO Bool
138 | waitTimeout ev time = isJust <$> Broadcast.listenTimeout (evBroadcast ev) time
139 | 
140 | {-|
141 | Returns 'True' if the state of the event is \"set\" and 'False' if the state
142 | is \"cleared\".
143 | 
144 | Notice that this is only a snapshot of the state. By the time a program reacts
145 | on its result it may already be out of date.
146 | -}
147 | isSet :: Event -> IO Bool
148 | isSet = fmap isJust . Broadcast.tryListen . evBroadcast
149 | 
150 | 
151 | -------------------------------------------------------------------------------
152 | -- Setting events
153 | -------------------------------------------------------------------------------
154 | 
155 | {-|
156 | Changes the state of the event to \"set\". All threads that where waiting
157 | for this event are woken. Threads that 'wait' after the state is changed to
158 | \"set\" will not block at all.
159 | -}
160 | set :: Event -> IO ()
161 | set ev = Broadcast.broadcast (evBroadcast ev) ()
162 | 
163 | {-|
164 | Changes the state to \"cleared\" after all threads that where waiting for this
165 | event are woken. Threads that 'wait' after a @signal@ will block until the event
166 | is 'set' again.
167 | 
168 | The semantics of signal are equivalent to the following definition:
169 | 
170 | @
171 |   signal e = 'mask' $ 'set' e >> 'clear' e
172 | @-}
173 | signal :: Event -> IO ()
174 | signal ev = Broadcast.signal (evBroadcast ev) ()
175 | 
176 | {-|
177 | Changes the state of the event to \"cleared\". Threads that 'wait' after the
178 | state is changed to \"cleared\" will block until the state is changed to \"set\".
179 | -}
180 | clear :: Event -> IO ()
181 | clear = Broadcast.silence . evBroadcast
182 | 


--------------------------------------------------------------------------------
/Control/Concurrent/STM/Lock.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude #-}
  2 | 
  3 | #if __GLASGOW_HASKELL__ >= 800
  4 | {-# LANGUAGE Safe #-}
  5 | #elif __GLASGOW_HASKELL__ >= 704
  6 | {-# LANGUAGE Trustworthy #-}
  7 | #endif
  8 | 
  9 | --------------------------------------------------------------------------------
 10 | -- |
 11 | -- Module     : Control.Concurrent.STM.Lock
 12 | -- Copyright  : (c) 2010-2011 Bas van Dijk & Roel van Dijk
 13 | -- License    : BSD3 (see the file LICENSE)
 14 | -- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>
 15 | --            , Roel van Dijk <vandijk.roel@gmail.com>
 16 | --
 17 | -- This module provides an 'STM' version of @Control.Concurrent.Lock@.
 18 | --
 19 | -- This module is intended to be imported qualified. We suggest importing it like:
 20 | --
 21 | -- @
 22 | -- import           Control.Concurrent.STM.Lock         ( Lock )
 23 | -- import qualified Control.Concurrent.STM.Lock as Lock ( ... )
 24 | -- @
 25 | --
 26 | --------------------------------------------------------------------------------
 27 | 
 28 | module Control.Concurrent.STM.Lock
 29 |     ( Lock
 30 | 
 31 |       -- * Creating locks
 32 |     , new
 33 |     , newAcquired
 34 | 
 35 |       -- * Locking and unlocking
 36 |     , acquire
 37 |     , tryAcquire
 38 |     , release
 39 | 
 40 |       -- * Convenience functions
 41 |     , with
 42 |     , tryWith
 43 |     , wait
 44 | 
 45 |       -- * Querying locks
 46 |     , locked
 47 |     ) where
 48 | 
 49 | 
 50 | --------------------------------------------------------------------------------
 51 | -- Imports
 52 | --------------------------------------------------------------------------------
 53 | 
 54 | -- from base:
 55 | import Control.Applicative          ( liftA2 )
 56 | import Control.Exception            ( bracket_, onException )
 57 | import Control.Monad                ( return, when )
 58 | import Data.Bool                    ( Bool, not )
 59 | 
 60 | #ifdef __HADDOCK_VERSION__
 61 | import Data.Bool                    ( Bool(False, True) )
 62 | #endif
 63 | 
 64 | import Data.Eq                      ( Eq )
 65 | import Data.Function                ( ($), (.) )
 66 | import Data.Functor                 ( fmap, (<$>) )
 67 | import Data.Maybe                   ( Maybe(Nothing, Just), isJust )
 68 | import Data.Typeable                ( Typeable )
 69 | import Prelude                      ( error )
 70 | import System.IO                    ( IO )
 71 | 
 72 | #if __GLASGOW_HASKELL__ < 700
 73 | import Control.Monad                ( (>>=), fail )
 74 | #endif
 75 | 
 76 | #if __GLASGOW_HASKELL__ < 700
 77 | import Control.Monad                ( Monad )
 78 | #endif
 79 | 
 80 | -- from stm:
 81 | import Control.Concurrent.STM       ( STM, atomically )
 82 | 
 83 | #ifdef __HADDOCK_VERSION__
 84 | import Control.Concurrent.STM       ( retry )
 85 | #endif
 86 | 
 87 | import Control.Concurrent.STM.TMVar ( TMVar, newTMVar, newEmptyTMVar
 88 |                                     , takeTMVar, tryTakeTMVar
 89 |                                     , tryPutTMVar, readTMVar, isEmptyTMVar
 90 |                                     )
 91 | 
 92 | -- from concurrent-extra (this package):
 93 | import Utils                        ( mask )
 94 | 
 95 | 
 96 | --------------------------------------------------------------------------------
 97 | -- Locks
 98 | --------------------------------------------------------------------------------
 99 | 
100 | -- | A lock is in one of two states: \"locked\" or \"unlocked\".
101 | newtype Lock = Lock {un :: TMVar ()}
102 |     deriving (Typeable, Eq)
103 | 
104 | 
105 | --------------------------------------------------------------------------------
106 | -- Creating locks
107 | --------------------------------------------------------------------------------
108 | 
109 | -- | Create a lock in the \"unlocked\" state.
110 | new :: STM Lock
111 | new = Lock <$> newTMVar ()
112 | 
113 | -- | Create a lock in the \"locked\" state.
114 | newAcquired :: STM Lock
115 | newAcquired = Lock <$> newEmptyTMVar
116 | 
117 | 
118 | --------------------------------------------------------------------------------
119 | -- Locking and unlocking
120 | --------------------------------------------------------------------------------
121 | 
122 | {-|
123 | * When the state is \"locked\" @acquire@ will 'retry' the transaction.
124 | 
125 | * When the state is \"unlocked\" @acquire@ will change the state to \"locked\".
126 | -}
127 | acquire :: Lock -> STM ()
128 | acquire = takeTMVar . un
129 | 
130 | {-|
131 | A non-blocking 'acquire'.
132 | 
133 | * When the state is \"unlocked\" @tryAcquire@ changes the state to \"locked\"
134 | and returns 'True'.
135 | 
136 | * When the state is \"locked\" @tryAcquire@ leaves the state unchanged and
137 | returns 'False'.
138 | -}
139 | tryAcquire :: Lock -> STM Bool
140 | tryAcquire = fmap isJust . tryTakeTMVar . un
141 | 
142 | {-|
143 | @release@ changes the state to \"unlocked\" and returns immediately.
144 | 
145 | Note that it is an error to release a lock in the \"unlocked\" state!
146 | -}
147 | release :: Lock -> STM ()
148 | release (Lock tmv) = do
149 |   b <- tryPutTMVar tmv ()
150 |   when (not b) $ error "Control.Concurrent.STM.Lock.release: Can't release unlocked Lock!"
151 | 
152 | 
153 | --------------------------------------------------------------------------------
154 | -- Convenience functions
155 | --------------------------------------------------------------------------------
156 | 
157 | {-|
158 | A convenience function which first acquires the lock and then performs the
159 | computation. When the computation terminates, whether normally or by raising an
160 | exception, the lock is released.
161 | -}
162 | with :: Lock -> IO a -> IO a
163 | with = liftA2 bracket_ (atomically . acquire) (atomically . release)
164 | 
165 | {-|
166 | A non-blocking 'with'. @tryWith@ is a convenience function which first tries to
167 | acquire the lock. If that fails, 'Nothing' is returned. If it succeeds, the
168 | computation is performed. When the computation terminates, whether normally or
169 | by raising an exception, the lock is released and 'Just' the result of the
170 | computation is returned.
171 | -}
172 | tryWith :: Lock -> IO a -> IO (Maybe a)
173 | tryWith l a = mask $ \restore -> do
174 |   acquired <- atomically (tryAcquire l)
175 |   if acquired
176 |     then do r <- restore a `onException` atomically (release l)
177 |             atomically (release l)
178 |             return $ Just r
179 |     else return Nothing
180 | 
181 | {-|
182 | * When the state is \"locked\", @wait@ will 'retry' the transaction
183 | 
184 | * When the state is \"unlocked\" @wait@ returns immediately.
185 | 
186 | @wait@ does not alter the state of the lock.
187 | 
188 | Note that @wait@ is just a convenience function which can be defined as:
189 | 
190 | @wait l = 'acquire' l '>>' 'release' l@
191 | -}
192 | wait :: Lock -> STM ()
193 | wait (Lock tmv) = readTMVar tmv
194 | 
195 | 
196 | --------------------------------------------------------------------------------
197 | -- Querying locks
198 | --------------------------------------------------------------------------------
199 | 
200 | {-|
201 | Determines if the lock is in the \"locked\" state.
202 | 
203 | Note that this is only a snapshot of the state. By the time a program reacts
204 | on its result it may already be out of date.
205 | -}
206 | locked :: Lock -> STM Bool
207 | locked = isEmptyTMVar . un
208 | 


--------------------------------------------------------------------------------
/Control/Concurrent/Broadcast.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude #-}
  2 | 
  3 | #if __GLASGOW_HASKELL__ >= 704
  4 | {-# LANGUAGE Safe #-}
  5 | #endif
  6 | 
  7 | -------------------------------------------------------------------------------
  8 | -- |
  9 | -- Module     : Control.Concurrent.Broadcast
 10 | -- Copyright  : (c) 2010-2011 Bas van Dijk & Roel van Dijk
 11 | -- License    : BSD3 (see the file LICENSE)
 12 | -- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>
 13 | --            , Roel van Dijk <vandijk.roel@gmail.com>
 14 | --
 15 | -- A 'Broadcast' is a mechanism for communication between threads. Multiple
 16 | -- @'listen'ers@ wait until a broadcaster @'broadcast's@ a value. The listeners
 17 | -- block until the value is received. When the broadcaster broadcasts a value
 18 | -- all listeners are woken.
 19 | --
 20 | -- All functions are /exception safe/. Throwing asynchronous exceptions will not
 21 | -- compromise the internal state of a broadcast.
 22 | --
 23 | -- This module is designed to be imported qualified. We suggest importing it
 24 | -- like:
 25 | --
 26 | -- @
 27 | -- import           Control.Concurrent.Broadcast              ( Broadcast )
 28 | -- import qualified Control.Concurrent.Broadcast as Broadcast ( ... )
 29 | -- @
 30 | -------------------------------------------------------------------------------
 31 | 
 32 | module Control.Concurrent.Broadcast
 33 |   ( Broadcast
 34 | 
 35 |     -- * Creating broadcasts
 36 |   , new
 37 |   , newBroadcasting
 38 | 
 39 |     -- * Listening to broadcasts
 40 |   , listen
 41 |   , tryListen
 42 |   , listenTimeout
 43 | 
 44 |     -- * Broadcasting
 45 |   , broadcast
 46 |   , signal
 47 |   , silence
 48 |   ) where
 49 | 
 50 | 
 51 | -------------------------------------------------------------------------------
 52 | -- Imports
 53 | -------------------------------------------------------------------------------
 54 | 
 55 | -- from base:
 56 | import Control.Monad              ( return, when )
 57 | import Control.Concurrent.MVar    ( MVar, newMVar, newEmptyMVar
 58 |                                   , takeMVar, putMVar, readMVar, modifyMVar_
 59 |                                   )
 60 | import Control.Exception          ( onException )
 61 | import Data.Eq                    ( Eq )
 62 | import Data.Either                ( Either(Left ,Right), either )
 63 | import Data.Function              ( ($), (.), const )
 64 | import Data.Functor               ( fmap, (<$>) )
 65 | import Data.Foldable              ( for_ )
 66 | import Data.List                  ( delete, length )
 67 | import Data.Maybe                 ( Maybe(Nothing, Just), isNothing )
 68 | import Data.Ord                   ( max )
 69 | import Data.Typeable              ( Typeable )
 70 | import Prelude                    ( Integer, seq )
 71 | import System.IO                  ( IO )
 72 | 
 73 | #if __GLASGOW_HASKELL__ < 700
 74 | import Prelude                    ( fromInteger )
 75 | import Control.Monad              ( (>>=), (>>), fail )
 76 | import Data.Ord                   ( Ord )
 77 | #endif
 78 | 
 79 | -- from unbounded-delays:
 80 | import Control.Concurrent.Timeout ( timeout )
 81 | 
 82 | -- from concurrent-extra (this package):
 83 | import Utils                      ( purelyModifyMVar, mask_ )
 84 | 
 85 | 
 86 | 
 87 | -------------------------------------------------------------------------------
 88 | -- Broadcast
 89 | -------------------------------------------------------------------------------
 90 | 
 91 | {-|
 92 | A broadcast is in one of two possible states:
 93 | 
 94 | * \"Silent\": @'listen'ing@ to the broadcast will block until a value is
 95 | @'broadcast'ed@.
 96 | 
 97 | * \"Broadcasting @x@\": @'listen'ing@ to the broadcast will return the value @x@
 98 | without blocking.
 99 | -}
100 | newtype Broadcast a = Broadcast {unBroadcast :: MVar (Either [MVar a] a)}
101 |     deriving (Eq, Typeable)
102 | 
103 | -- | @new@ creates a broadcast in the \"silent\" state.
104 | new :: IO (Broadcast a)
105 | new = Broadcast <$> newMVar (Left [])
106 | 
107 | -- | @newBroadcasting x@ creates a broadcast in the \"broadcasting @x@\" state.
108 | newBroadcasting :: a -> IO (Broadcast a)
109 | newBroadcasting x = Broadcast <$> newMVar (Right x)
110 | 
111 | {-|
112 | Listen to a broadcast.
113 | 
114 | * If the broadcast is \"broadcasting @x@\", @listen@ will return @x@
115 | immediately.
116 | 
117 | * If the broadcast is \"silent\", @listen@ will block until another thread
118 | @'broadcast's@ a value to the broadcast.
119 | -}
120 | listen :: Broadcast a -> IO a
121 | listen (Broadcast mv) = mask_ $ do
122 |   mx <- takeMVar mv
123 |   case mx of
124 |     Left ls -> do l <- newEmptyMVar
125 |                   putMVar mv $ Left $ l:ls
126 |                   takeMVar l
127 |     Right x -> do putMVar mv mx
128 |                   return x
129 | 
130 | {-|
131 | Try to listen to a broadcast; non blocking.
132 | 
133 | * If the broadcast is \"broadcasting @x@\", @tryListen@ will return 'Just' @x@
134 | immediately.
135 | 
136 | * If the broadcast is \"silent\", @tryListen@ returns 'Nothing' immediately.
137 | -}
138 | tryListen :: Broadcast a -> IO (Maybe a)
139 | tryListen = fmap (either (const Nothing) Just) . readMVar . unBroadcast
140 | 
141 | {-|
142 | Listen to a broadcast if it is available within a given amount of time.
143 | 
144 | Like 'listen', but with a timeout. A return value of 'Nothing' indicates a
145 | timeout occurred.
146 | 
147 | The timeout is specified in microseconds.
148 | 
149 | If the broadcast is \"silent\" and a timeout of 0 &#x3bc;s is specified the
150 | function returns 'Nothing' without blocking.
151 | 
152 | Negative timeouts are treated the same as a timeout of 0 &#x3bc;s.
153 | -}
154 | listenTimeout :: Broadcast a -> Integer -> IO (Maybe a)
155 | listenTimeout (Broadcast mv) time = mask_ $ do
156 |   mx <- takeMVar mv
157 |   case mx of
158 |     Left ls -> do l <- newEmptyMVar
159 |                   putMVar mv $ Left $ l:ls
160 |                   my <- timeout (max time 0) (takeMVar l)
161 |                          `onException` deleteReader l
162 |                   when (isNothing my) (deleteReader l)
163 |                   return my
164 |     Right x -> do putMVar mv mx
165 |                   return $ Just x
166 |     where
167 |       deleteReader l = do mx <- takeMVar mv
168 |                           case mx of
169 |                             Left ls -> let ls' = delete l ls
170 |                                        in length ls' `seq` putMVar mv (Left ls')
171 |                             Right _ -> putMVar mv mx
172 | 
173 | {-|
174 | Broadcast a value.
175 | 
176 | @broadcast b x@ changes the state of the broadcast @b@ to \"broadcasting @x@\".
177 | 
178 | If the broadcast was \"silent\" all threads that are @'listen'ing@ to the
179 | broadcast will be woken.
180 | -}
181 | broadcast :: Broadcast a -> a -> IO ()
182 | 
183 | {-|
184 | Broadcast a value before becoming \"silent\".
185 | 
186 | The state of the broadcast is changed to \"silent\" after all threads that are
187 | @'listen'ing@ to the broadcast are woken and resume with the signalled value.
188 | 
189 | The semantics of signal are equivalent to the following definition:
190 | 
191 | @
192 |   signal b x = 'block' $ 'broadcast' b x >> 'silence' b
193 | @
194 | -}
195 | signal :: Broadcast a -> a -> IO ()
196 | 
197 | broadcast b x = broadcastThen (Right x) b x
198 | signal    b x = broadcastThen (Left []) b x
199 | 
200 | -- | Internally used function that performs the actual broadcast in 'broadcast'
201 | -- and 'signal' then changes to the given final state.
202 | broadcastThen :: Either [MVar a] a -> Broadcast a -> a -> IO ()
203 | broadcastThen finalState (Broadcast mv) x =
204 |     modifyMVar_ mv $ \mx -> do
205 |       case mx of
206 |         Left ls -> do for_ ls (`putMVar` x)
207 |                       return finalState
208 |         Right _ -> return finalState
209 | 
210 | -- | Set a broadcast to the \"silent\" state.
211 | silence :: Broadcast a -> IO ()
212 | silence (Broadcast mv) = purelyModifyMVar mv $ either Left $ const $ Left []
213 | 


--------------------------------------------------------------------------------
/Control/Concurrent/Lock.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude #-}
  2 | 
  3 | #if __GLASGOW_HASKELL__ >= 704
  4 | {-# LANGUAGE Safe #-}
  5 | #endif
  6 | 
  7 | --------------------------------------------------------------------------------
  8 | -- |
  9 | -- Module     : Control.Concurrent.Lock
 10 | -- Copyright  : (c) 2010-2011 Bas van Dijk & Roel van Dijk
 11 | -- License    : BSD3 (see the file LICENSE)
 12 | -- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>
 13 | --            , Roel van Dijk <vandijk.roel@gmail.com>
 14 | --
 15 | -- This module provides the 'Lock' synchronisation mechanism. It was inspired by
 16 | -- the Python and Java @Lock@ objects and should behave in a similar way. See:
 17 | --
 18 | -- <http://docs.python.org/3.1/library/threading.html#lock-objects>
 19 | --
 20 | -- and:
 21 | --
 22 | -- <http://java.sun.com/javase/7/docs/api/java/util/concurrent/locks/Lock.html>
 23 | --
 24 | -- All functions are /exception safe/. Throwing asynchronous exceptions will not
 25 | -- compromise the internal state of a 'Lock'.
 26 | --
 27 | -- This module is intended to be imported qualified. We suggest importing it like:
 28 | --
 29 | -- @
 30 | -- import           Control.Concurrent.Lock         ( Lock )
 31 | -- import qualified Control.Concurrent.Lock as Lock ( ... )
 32 | -- @
 33 | --
 34 | --------------------------------------------------------------------------------
 35 | 
 36 | module Control.Concurrent.Lock
 37 |     ( Lock
 38 | 
 39 |       -- * Creating locks
 40 |     , new
 41 |     , newAcquired
 42 | 
 43 |       -- * Locking and unlocking
 44 |     , acquire
 45 |     , tryAcquire
 46 |     , release
 47 | 
 48 |       -- * Convenience functions
 49 |     , with
 50 |     , tryWith
 51 |     , wait
 52 | 
 53 |       -- * Querying locks
 54 |     , locked
 55 |     ) where
 56 | 
 57 | 
 58 | --------------------------------------------------------------------------------
 59 | -- Imports
 60 | --------------------------------------------------------------------------------
 61 | 
 62 | -- from base:
 63 | import Control.Applicative     ( liftA2 )
 64 | import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar
 65 |                                , takeMVar, tryTakeMVar
 66 |                                , tryPutMVar, readMVar, isEmptyMVar
 67 |                                )
 68 | import Control.Exception       ( bracket_, onException )
 69 | import Control.Monad           ( return, when )
 70 | import Data.Bool               ( Bool, not )
 71 | #ifdef __HADDOCK_VERSION__
 72 | import Data.Bool               ( Bool(False, True) )
 73 | #endif
 74 | import Data.Eq                 ( Eq )
 75 | import Data.Function           ( ($), (.) )
 76 | import Data.Functor            ( fmap, (<$>) )
 77 | import Data.Maybe              ( Maybe(Nothing, Just), isJust )
 78 | import Data.Typeable           ( Typeable )
 79 | import Prelude                 ( error )
 80 | import System.IO               ( IO )
 81 | 
 82 | #if __GLASGOW_HASKELL__ < 700
 83 | import Control.Monad           ( Monad, (>>=), fail )
 84 | #endif
 85 | 
 86 | -- from concurrent-extra (this package):
 87 | import Utils                   ( mask )
 88 | 
 89 | 
 90 | --------------------------------------------------------------------------------
 91 | -- Locks
 92 | --------------------------------------------------------------------------------
 93 | 
 94 | -- | A lock is in one of two states: \"locked\" or \"unlocked\".
 95 | newtype Lock = Lock {un :: MVar ()} deriving (Eq, Typeable)
 96 | 
 97 | 
 98 | --------------------------------------------------------------------------------
 99 | -- Creating locks
100 | --------------------------------------------------------------------------------
101 | 
102 | -- | Create a lock in the \"unlocked\" state.
103 | new :: IO Lock
104 | new = Lock <$> newMVar ()
105 | 
106 | -- | Create a lock in the \"locked\" state.
107 | newAcquired :: IO Lock
108 | newAcquired = Lock <$> newEmptyMVar
109 | 
110 | 
111 | --------------------------------------------------------------------------------
112 | -- Locking and unlocking
113 | --------------------------------------------------------------------------------
114 | 
115 | {-|
116 | Acquires the 'Lock'. Blocks if another thread has acquired the 'Lock'.
117 | 
118 | @acquire@ behaves as follows:
119 | 
120 | * When the state is \"unlocked\" @acquire@ changes the state to \"locked\".
121 | 
122 | * When the state is \"locked\" @acquire@ /blocks/ until a call to 'release' in
123 | another thread wakes the calling thread. Upon awakening it will change the state
124 | to \"locked\".
125 | 
126 | There are two further important properties of @acquire@:
127 | 
128 | * @acquire@ is single-wakeup. That is, if there are multiple threads blocked on
129 | @acquire@ and the lock is released, only one thread will be woken up. The
130 | runtime guarantees that the woken thread completes its @acquire@ operation.
131 | 
132 | * When multiple threads are blocked on @acquire@, they are woken up in FIFO
133 | order. This is useful for providing fairness properties of abstractions built
134 | using locks. (Note that this differs from the Python implementation where the
135 | wake-up order is undefined.)
136 | -}
137 | acquire :: Lock -> IO ()
138 | acquire = takeMVar . un
139 | 
140 | {-|
141 | A non-blocking 'acquire'.
142 | 
143 | * When the state is \"unlocked\" @tryAcquire@ changes the state to \"locked\"
144 | and returns 'True'.
145 | 
146 | * When the state is \"locked\" @tryAcquire@ leaves the state unchanged and
147 | returns 'False'.
148 | -}
149 | tryAcquire :: Lock -> IO Bool
150 | tryAcquire = fmap isJust . tryTakeMVar . un
151 | 
152 | {-|
153 | @release@ changes the state to \"unlocked\" and returns immediately.
154 | 
155 | Note that it is an error to release a lock in the \"unlocked\" state!
156 | 
157 | If there are any threads blocked on 'acquire' the thread that first called
158 | @acquire@ will be woken up.
159 | -}
160 | release :: Lock -> IO ()
161 | release (Lock mv) = do
162 |   b <- tryPutMVar mv ()
163 |   when (not b) $ error "Control.Concurrent.Lock.release: Can't release unlocked Lock!"
164 | 
165 | 
166 | --------------------------------------------------------------------------------
167 | -- Convenience functions
168 | --------------------------------------------------------------------------------
169 | 
170 | {-|
171 | A convenience function which first acquires the lock and then performs the
172 | computation. When the computation terminates, whether normally or by raising an
173 | exception, the lock is released.
174 | 
175 | Note that: @with = 'liftA2' 'bracket_' 'acquire' 'release'@.
176 | -}
177 | with :: Lock -> IO a -> IO a
178 | with = liftA2 bracket_ acquire release
179 | 
180 | {-|
181 | A non-blocking 'with'. @tryWith@ is a convenience function which first tries to
182 | acquire the lock. If that fails, 'Nothing' is returned. If it succeeds, the
183 | computation is performed. When the computation terminates, whether normally or
184 | by raising an exception, the lock is released and 'Just' the result of the
185 | computation is returned.
186 | -}
187 | tryWith :: Lock -> IO a -> IO (Maybe a)
188 | tryWith l a = mask $ \restore -> do
189 |   acquired <- tryAcquire l
190 |   if acquired
191 |     then do r <- restore a `onException` release l
192 |             release l
193 |             return $ Just r
194 |     else return Nothing
195 | 
196 | {-|
197 | * When the state is \"locked\", @wait@ /blocks/ until a call to 'release' in
198 | another thread changes it to \"unlocked\".
199 | 
200 | * @wait@ is multiple-wakeup, so when multiple waiters are blocked on a @Lock@,
201 |   all of them are woken up at the same time.
202 | 
203 | * When the state is \"unlocked\" @wait@ returns immediately.
204 | 
205 | @wait@ does not alter the state of the lock.
206 | -}
207 | wait :: Lock -> IO ()
208 | wait (Lock mv) = readMVar mv
209 | 
210 | 
211 | --------------------------------------------------------------------------------
212 | -- Querying locks
213 | --------------------------------------------------------------------------------
214 | 
215 | {-|
216 | Determines if the lock is in the \"locked\" state.
217 | 
218 | Note that this is only a snapshot of the state. By the time a program reacts
219 | on its result it may already be out of date.
220 | -}
221 | locked :: Lock -> IO Bool
222 | locked = isEmptyMVar . un
223 | 


--------------------------------------------------------------------------------
/Control/Concurrent/RLock.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP
  2 |            , BangPatterns
  3 |            , DeriveDataTypeable
  4 |            , NoImplicitPrelude
  5 |   #-}
  6 | 
  7 | #if __GLASGOW_HASKELL__ >= 704
  8 | {-# LANGUAGE Safe #-}
  9 | #endif
 10 | 
 11 | --------------------------------------------------------------------------------
 12 | -- |
 13 | -- Module     : Control.Concurrent.RLock
 14 | -- Copyright  : (c) 2010-2011 Bas van Dijk & Roel van Dijk
 15 | -- License    : BSD3 (see the file LICENSE)
 16 | -- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>
 17 | --            , Roel van Dijk <vandijk.roel@gmail.com>
 18 | --
 19 | -- This module provides the 'RLock' synchronisation mechanism. It was inspired
 20 | -- by the Python @RLock@ and Java @ReentrantLock@ objects and should behave in a
 21 | -- similar way. See:
 22 | --
 23 | -- <http://docs.python.org/3.1/library/threading.html#rlock-objects>
 24 | --
 25 | -- and:
 26 | --
 27 | -- <http://java.sun.com/javase/7/docs/api/java/util/concurrent/locks/ReentrantLock.html>
 28 | --
 29 | -- All functions are /exception safe/. Throwing asynchronous exceptions will not
 30 | -- compromise the internal state of an 'RLock'.
 31 | --
 32 | -- This module is intended to be imported qualified. We suggest importing it like:
 33 | --
 34 | -- @
 35 | -- import           Control.Concurrent.RLock          ( RLock )
 36 | -- import qualified Control.Concurrent.RLock as RLock ( ... )
 37 | -- @
 38 | --
 39 | --------------------------------------------------------------------------------
 40 | 
 41 | module Control.Concurrent.RLock
 42 |     ( RLock
 43 | 
 44 |       -- * Creating reentrant locks
 45 |     , new
 46 |     , newAcquired
 47 | 
 48 |       -- * Locking and unlocking
 49 |     , acquire
 50 |     , tryAcquire
 51 |     , release
 52 | 
 53 |       -- * Convenience functions
 54 |     , with
 55 |     , tryWith
 56 |     , wait
 57 | 
 58 |       -- * Querying reentrant locks
 59 |     , State
 60 |     , state
 61 |     ) where
 62 | 
 63 | 
 64 | --------------------------------------------------------------------------------
 65 | -- Imports
 66 | --------------------------------------------------------------------------------
 67 | 
 68 | -- from base:
 69 | import Control.Applicative     ( liftA2 )
 70 | import Control.Concurrent      ( ThreadId, myThreadId )
 71 | import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, readMVar, putMVar )
 72 | import Control.Exception       ( bracket_, onException )
 73 | import Control.Monad           ( return, (>>) )
 74 | import Data.Bool               ( Bool(False, True), otherwise )
 75 | import Data.Eq                 ( Eq, (==) )
 76 | import Data.Function           ( ($), (.) )
 77 | import Data.Functor            ( fmap, (<$>) )
 78 | import Data.Maybe              ( Maybe(Nothing, Just) )
 79 | import Data.List               ( (++) )
 80 | import Data.Tuple              ( fst )
 81 | import Data.Typeable           ( Typeable )
 82 | import Prelude                 ( Integer, succ, pred, error )
 83 | import System.IO               ( IO )
 84 | 
 85 | #if __GLASGOW_HASKELL__ < 700
 86 | import Prelude                 ( fromInteger )
 87 | import Control.Monad           ( Monad, fail, (>>=) )
 88 | #endif
 89 | 
 90 | -- from concurrent-extra (this package):
 91 | import           Control.Concurrent.Lock ( Lock )
 92 | import qualified Control.Concurrent.Lock as Lock
 93 |     ( new, newAcquired, acquire, release, wait )
 94 | 
 95 | import Utils ( mask, mask_ )
 96 | 
 97 | 
 98 | --------------------------------------------------------------------------------
 99 | -- Reentrant locks
100 | --------------------------------------------------------------------------------
101 | 
102 | {-| A reentrant lock is in one of two states: \"locked\" or \"unlocked\". When
103 | the lock is in the \"locked\" state it has two additional properties:
104 | 
105 | * Its /owner/: the thread that acquired the lock.
106 | 
107 | * Its /acquired count/: how many times its owner acquired the lock.
108 | -}
109 | newtype RLock = RLock {un :: MVar (State, Lock)}
110 |     deriving (Eq, Typeable)
111 | 
112 | {-| The state of an 'RLock'.
113 | 
114 | * 'Nothing' indicates an \"unlocked\" state.
115 | 
116 | * @'Just' (tid, n)@ indicates a \"locked\" state where the thread identified by
117 | @tid@ acquired the lock @n@ times.
118 | -}
119 | type State = Maybe (ThreadId, Integer)
120 | 
121 | 
122 | --------------------------------------------------------------------------------
123 | -- * Creating reentrant locks
124 | --------------------------------------------------------------------------------
125 | 
126 | -- | Create a reentrant lock in the \"unlocked\" state.
127 | new :: IO RLock
128 | new = do lock <- Lock.new
129 |          RLock <$> newMVar (Nothing, lock)
130 | 
131 | {-|
132 | Create a reentrant lock in the \"locked\" state (with the current thread as
133 | owner and an acquired count of 1).
134 | -}
135 | newAcquired :: IO RLock
136 | newAcquired = do myTID <- myThreadId
137 |                  lock <- Lock.newAcquired
138 |                  RLock <$> newMVar (Just (myTID, 1), lock)
139 | 
140 | 
141 | --------------------------------------------------------------------------------
142 | -- * Locking and unlocking
143 | --------------------------------------------------------------------------------
144 | 
145 | {-|
146 | Acquires the 'RLock'. Blocks if another thread has acquired the 'RLock'.
147 | 
148 | @acquire@ behaves as follows:
149 | 
150 | * When the state is \"unlocked\", @acquire@ changes the state to \"locked\"
151 | with the current thread as owner and an acquired count of 1.
152 | 
153 | * When the state is \"locked\" and the current thread owns the lock @acquire@
154 | only increments the acquired count.
155 | 
156 | * When the state is \"locked\" and the current thread does not own the lock
157 | @acquire@ /blocks/ until the owner releases the lock. If the thread that called
158 | @acquire@ is woken upon release of the lock it will take ownership and change
159 | the state to \"locked\" with an acquired count of 1.
160 | 
161 | There are two further important properties of @acquire@:
162 | 
163 | * @acquire@ is single-wakeup. That is, if there are multiple threads blocked on
164 | @acquire@, and the lock is released, only one thread will be woken up. The
165 | runtime guarantees that the woken thread completes its @acquire@ operation.
166 | 
167 | * When multiple threads are blocked on @acquire@ they are woken up in FIFO
168 | order. This is useful for providing fairness properties of abstractions built
169 | using locks. (Note that this differs from the Python implementation where the
170 | wake-up order is undefined.)
171 | -}
172 | acquire :: RLock -> IO ()
173 | acquire (RLock mv) = do
174 |   myTID <- myThreadId
175 |   mask_ $ let acq = do t@(mb, lock) <- takeMVar mv
176 |                        case mb of
177 |                          Nothing          -> do Lock.acquire lock
178 |                                                 putMVar mv (Just (myTID, 1), lock)
179 |                          Just (tid, n)
180 |                            | myTID == tid -> let !sn = succ n
181 |                                              in putMVar mv (Just (tid, sn), lock)
182 |                            | otherwise    -> do putMVar mv t
183 |                                                 Lock.wait lock
184 |                                                 acq
185 |           in acq
186 | 
187 | {-|
188 | A non-blocking 'acquire'.
189 | 
190 | * When the state is \"unlocked\" @tryAcquire@ changes the state to \"locked\"
191 | (with the current thread as owner and an acquired count of 1) and returns
192 | 'True'.
193 | 
194 | * When the state is \"locked\" @tryAcquire@ leaves the state unchanged and
195 | returns 'False'.
196 | -}
197 | tryAcquire :: RLock -> IO Bool
198 | tryAcquire (RLock mv) = do
199 |   myTID <- myThreadId
200 |   mask_ $ do
201 |     t@(mb, lock) <- takeMVar mv
202 |     case mb of
203 |       Nothing          -> do Lock.acquire lock
204 |                              putMVar mv (Just (myTID, 1), lock)
205 |                              return True
206 |       Just (tid, n)
207 |         | myTID == tid -> do let !sn = succ n
208 |                              putMVar mv (Just (tid, sn), lock)
209 |                              return True
210 | 
211 |         | otherwise    -> do putMVar mv t
212 |                              return False
213 | 
214 | {-| @release@ decrements the acquired count. When a lock is released with an
215 | acquired count of 1 its state is changed to \"unlocked\".
216 | 
217 | Note that it is both an error to release a lock in the \"unlocked\" state and to
218 | release a lock that is not owned by the current thread.
219 | 
220 | If there are any threads blocked on 'acquire' the thread that first called
221 | @acquire@ will be woken up.
222 | -}
223 | release :: RLock -> IO ()
224 | release (RLock mv) = do
225 |   myTID <- myThreadId
226 |   mask_ $ do
227 |     t@(mb, lock) <- takeMVar mv
228 |     let err msg = do putMVar mv t
229 |                      error $ "Control.Concurrent.RLock.release: " ++ msg
230 |     case mb of
231 |       Nothing -> err "Can't release an unacquired RLock!"
232 |       Just (tid, n)
233 |         | myTID == tid -> if n == 1
234 |                           then do Lock.release lock
235 |                                   putMVar mv (Nothing, lock)
236 |                           else let !pn = pred n
237 |                                in putMVar mv (Just (tid, pn), lock)
238 |         | otherwise -> err "Calling thread does not own the RLock!"
239 | 
240 | 
241 | --------------------------------------------------------------------------------
242 | -- * Convenience functions
243 | --------------------------------------------------------------------------------
244 | 
245 | {-| A convenience function which first acquires the lock and then
246 | performs the computation. When the computation terminates, whether
247 | normally or by raising an exception, the lock is released.
248 | 
249 | Note that: @with = 'liftA2' 'bracket_' 'acquire' 'release'@.
250 | -}
251 | with :: RLock -> IO a -> IO a
252 | with = liftA2 bracket_ acquire release
253 | 
254 | {-|
255 | A non-blocking 'with'. @tryWith@ is a convenience function which first tries to
256 | acquire the lock. If that fails, 'Nothing' is returned. If it succeeds, the
257 | computation is performed. When the computation terminates, whether normally or
258 | by raising an exception, the lock is released and 'Just' the result of the
259 | computation is returned.
260 | -}
261 | tryWith :: RLock -> IO a -> IO (Maybe a)
262 | tryWith l a = mask $ \restore -> do
263 |   acquired <- tryAcquire l
264 |   if acquired
265 |     then do r <- restore a `onException` release l
266 |             release l
267 |             return $ Just r
268 |     else return Nothing
269 | 
270 | {-|
271 | * When the state is \"locked\" @wait@ /blocks/ until a call to 'release' in
272 | another thread changes it to \"unlocked\".
273 | 
274 | * When the state is \"unlocked\" @wait@ returns immediately.
275 | 
276 | @wait@ does not alter the state of the lock.
277 | 
278 | Note that @wait@ is just a convenience function defined as:
279 | 
280 | @wait l = 'block' '$' 'acquire' l '>>' 'release' l@
281 | -}
282 | wait :: RLock -> IO ()
283 | wait l = mask_ $ acquire l >> release l
284 | 
285 | 
286 | --------------------------------------------------------------------------------
287 | -- * Querying reentrant locks
288 | --------------------------------------------------------------------------------
289 | 
290 | {-|
291 | Determine the state of the reentrant lock.
292 | 
293 | Note that this is only a snapshot of the state. By the time a program reacts on
294 | its result it may already be out of date.
295 | -}
296 | state :: RLock -> IO State
297 | state = fmap fst . readMVar . un
298 | 


--------------------------------------------------------------------------------
/Control/Concurrent/ReadWriteLock.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP
  2 |            , DeriveDataTypeable
  3 |            , NamedFieldPuns
  4 |            , NoImplicitPrelude
  5 |   #-}
  6 | 
  7 | #if __GLASGOW_HASKELL__ >= 704
  8 | {-# LANGUAGE Safe #-}
  9 | #endif
 10 | 
 11 | -------------------------------------------------------------------------------
 12 | -- |
 13 | -- Module     : Control.Concurrent.ReadWriteLock
 14 | -- Copyright  : (c) 2010-2011 Bas van Dijk & Roel van Dijk
 15 | -- License    : BSD3 (see the file LICENSE)
 16 | -- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>
 17 | --            , Roel van Dijk <vandijk.roel@gmail.com>
 18 | --
 19 | -- Multiple-reader, single-writer locks. Used to protect shared resources which
 20 | -- may be concurrently read, but only sequentially written.
 21 | --
 22 | -- All functions are /exception safe/. Throwing asynchronous exceptions will not
 23 | -- compromise the internal state of an 'RWLock'. This means it is perfectly safe
 24 | -- to kill a thread that is blocking on, for example, 'acquireRead'.
 25 | --
 26 | -- See also Java's version:
 27 | -- <http://java.sun.com/javase/7/docs/api/java/util/concurrent/locks/ReadWriteLock.html>
 28 | --
 29 | -- This module is designed to be imported qualified. We suggest importing it
 30 | -- like:
 31 | --
 32 | -- @
 33 | -- import           Control.Concurrent.ReadWriteLock        ( RWLock )
 34 | -- import qualified Control.Concurrent.ReadWriteLock as RWL ( ... )
 35 | -- @
 36 | --
 37 | -------------------------------------------------------------------------------
 38 | 
 39 | module Control.Concurrent.ReadWriteLock
 40 |   ( RWLock
 41 | 
 42 |     -- *Creating Read-Write Locks
 43 |   , new
 44 |   , newAcquiredRead
 45 |   , newAcquiredWrite
 46 | 
 47 |     -- *Read access
 48 |     -- **Blocking
 49 |   , acquireRead
 50 |   , releaseRead
 51 |   , withRead
 52 |   , waitRead
 53 |     -- **Non-blocking
 54 |   , tryAcquireRead
 55 |   , tryWithRead
 56 | 
 57 |     -- *Write access
 58 |     -- **Blocking
 59 |   , acquireWrite
 60 |   , releaseWrite
 61 |   , withWrite
 62 |   , waitWrite
 63 |     -- **Non-blocking
 64 |   , tryAcquireWrite
 65 |   , tryWithWrite
 66 |   ) where
 67 | 
 68 | 
 69 | -------------------------------------------------------------------------------
 70 | -- Imports
 71 | -------------------------------------------------------------------------------
 72 | 
 73 | -- from base:
 74 | import Control.Applicative     ( liftA2, liftA3 )
 75 | import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, putMVar )
 76 | import Control.Exception       ( bracket_, onException )
 77 | import Control.Monad           ( return, (>>) )
 78 | import Data.Bool               ( Bool(False, True) )
 79 | import Data.Eq                 ( Eq, (==) )
 80 | import Data.Function           ( ($), (.), on )
 81 | import Data.Int                ( Int )
 82 | import Data.Maybe              ( Maybe(Nothing, Just) )
 83 | import Data.List               ( (++))
 84 | import Data.Typeable           ( Typeable )
 85 | import Prelude                 ( String, ($!), succ, pred, error )
 86 | import System.IO               ( IO )
 87 | 
 88 | #if __GLASGOW_HASKELL__ < 700
 89 | import Prelude                 ( fromInteger )
 90 | import Control.Monad           ( (>>=), fail )
 91 | #endif
 92 | 
 93 | -- from concurrent-extra (this package):
 94 | import           Control.Concurrent.Lock ( Lock )
 95 | import qualified Control.Concurrent.Lock as Lock
 96 |     ( new, newAcquired, acquire, release, wait )
 97 | 
 98 | import Utils ( mask, mask_ )
 99 | 
100 | 
101 | -------------------------------------------------------------------------------
102 | -- Read Write Lock
103 | -------------------------------------------------------------------------------
104 | 
105 | {-|
106 | Multiple-reader, single-writer lock. Is in one of three states:
107 | 
108 | * \"Free\": Read or write access can be acquired without blocking.
109 | 
110 | * \"Read\": One or more threads have acquired read access. Blocks write access.
111 | 
112 | * \"Write\": A single thread has acquired write access. Blocks other threads
113 | from acquiring both read and write access.
114 | -}
115 | data RWLock = RWLock { state     :: MVar State
116 |                      , readLock  :: Lock
117 |                      , writeLock :: Lock
118 |                      } deriving Typeable
119 | 
120 | instance Eq RWLock where
121 |     (==) = (==) `on` state
122 | 
123 | -- | Internal state of the 'RWLock'.
124 | data State = Free | Read Int | Write
125 | 
126 | 
127 | -------------------------------------------------------------------------------
128 | -- * Creating Read-Write Locks
129 | -------------------------------------------------------------------------------
130 | 
131 | -- | Create a new 'RWLock' in the \"free\" state; either read or write access
132 | -- can be acquired without blocking.
133 | new :: IO RWLock
134 | new = liftA3 RWLock (newMVar Free)
135 |                     Lock.new
136 |                     Lock.new
137 | 
138 | -- | Create a new 'RWLock' in the \"read\" state; only read can be acquired
139 | -- without blocking.
140 | newAcquiredRead :: IO RWLock
141 | newAcquiredRead = liftA3 RWLock (newMVar $ Read 1)
142 |                                 Lock.newAcquired
143 |                                 Lock.new
144 | 
145 | -- | Create a new 'RWLock' in the \"write\" state; either acquiring read or
146 | -- write will block.
147 | newAcquiredWrite :: IO RWLock
148 | newAcquiredWrite = liftA3 RWLock (newMVar Write)
149 |                                  Lock.new
150 |                                  Lock.newAcquired
151 | 
152 | 
153 | -------------------------------------------------------------------------------
154 | -- * Read access
155 | -------------------------------------------------------------------------------
156 | 
157 | {-|
158 | Acquire the read lock.
159 | 
160 | Blocks if another thread has acquired write access. If @acquireRead@ terminates
161 | without throwing an exception the state of the 'RWLock' will be \"read\".
162 | 
163 | Implementation note: Throws an exception when more than (maxBound :: Int)
164 | simultaneous threads acquire the read lock. But that is unlikely.
165 | -}
166 | acquireRead :: RWLock -> IO ()
167 | acquireRead (RWLock {state, readLock, writeLock}) = mask_ acqRead
168 |     where
169 |       acqRead = do st <- takeMVar state
170 |                    case st of
171 |                      Free   -> do Lock.acquire readLock
172 |                                   putMVar state $ Read 1
173 |                      Read n -> putMVar state . Read $! succ n
174 |                      Write  -> do putMVar state st
175 |                                   Lock.wait writeLock
176 |                                   acqRead
177 | 
178 | {-|
179 | Try to acquire the read lock; non blocking.
180 | 
181 | Like 'acquireRead', but doesn't block. Returns 'True' if the resulting state is
182 | \"read\", 'False' otherwise.
183 | -}
184 | tryAcquireRead :: RWLock -> IO Bool
185 | tryAcquireRead (RWLock {state, readLock}) = mask_ $ do
186 |   st <- takeMVar state
187 |   case st of
188 |     Free   -> do Lock.acquire readLock
189 |                  putMVar state $ Read 1
190 |                  return True
191 |     Read n -> do putMVar state . Read $! succ n
192 |                  return True
193 |     Write  -> do putMVar state st
194 |                  return False
195 | 
196 | {-|
197 | Release the read lock.
198 | 
199 | If the calling thread was the last one to relinquish read access the state will
200 | revert to \"free\".
201 | 
202 | It is an error to release read access to an 'RWLock' which is not in the
203 | \"read\" state.
204 | -}
205 | releaseRead :: RWLock -> IO ()
206 | releaseRead (RWLock {state, readLock}) = mask_ $ do
207 |   st <- takeMVar state
208 |   case st of
209 |     Read 1 -> do Lock.release readLock
210 |                  putMVar state Free
211 |     Read n -> putMVar state . Read $! pred n
212 |     _ -> do putMVar state st
213 |             error $ moduleName ++ ".releaseRead: already released"
214 | 
215 | {-|
216 | A convenience function wich first acquires read access and then performs the
217 | computation. When the computation terminates, whether normally or by raising an
218 | exception, the read lock is released.
219 | -}
220 | withRead :: RWLock -> IO a -> IO a
221 | withRead = liftA2 bracket_ acquireRead releaseRead
222 | 
223 | {-|
224 | A non-blocking 'withRead'. First tries to acquire the lock. If that fails,
225 | 'Nothing' is returned. If it succeeds, the computation is performed. When the
226 | computation terminates, whether normally or by raising an exception, the lock is
227 | released and 'Just' the result of the computation is returned.
228 | -}
229 | tryWithRead :: RWLock -> IO a -> IO (Maybe a)
230 | tryWithRead l a = mask $ \restore -> do
231 |   acquired <- tryAcquireRead l
232 |   if acquired
233 |     then do r <- restore a `onException` releaseRead l
234 |             releaseRead l
235 |             return $ Just r
236 |     else return Nothing
237 | 
238 | {-|
239 | * When the state is \"write\", @waitRead@ /blocks/ until a call to
240 | 'releaseWrite' in another thread changes the state to \"free\".
241 | 
242 | * When the state is \"free\" or \"read\" @waitRead@ returns immediately.
243 | 
244 | @waitRead@ does not alter the state of the lock.
245 | 
246 | Note that @waitRead@ is just a convenience function defined as:
247 | 
248 | @waitRead l = 'mask_' '$' 'acquireRead' l '>>' 'releaseRead' l@
249 | -}
250 | waitRead :: RWLock -> IO ()
251 | waitRead l = mask_ $ acquireRead l >> releaseRead l
252 | 
253 | 
254 | -------------------------------------------------------------------------------
255 | -- *Write access
256 | -------------------------------------------------------------------------------
257 | 
258 | {-|
259 | Acquire the write lock.
260 | 
261 | Blocks if another thread has acquired either read or write access. If
262 | @acquireWrite@ terminates without throwing an exception the state of the
263 | 'RWLock' will be \"write\".
264 | -}
265 | acquireWrite :: RWLock -> IO ()
266 | acquireWrite (RWLock {state, readLock, writeLock}) = mask_ acqWrite
267 |     where
268 |       acqWrite = do st <- takeMVar state
269 |                     case st of
270 |                       Free   -> do Lock.acquire writeLock
271 |                                    putMVar state Write
272 |                       Read _ -> do putMVar state st
273 |                                    Lock.wait readLock
274 |                                    acqWrite
275 |                       Write  -> do putMVar state st
276 |                                    Lock.wait writeLock
277 |                                    acqWrite
278 | 
279 | {-|
280 | Try to acquire the write lock; non blocking.
281 | 
282 | Like 'acquireWrite', but doesn't block. Returns 'True' if the resulting state is
283 | \"write\", 'False' otherwise.
284 | -}
285 | tryAcquireWrite :: RWLock -> IO Bool
286 | tryAcquireWrite (RWLock {state, writeLock}) = mask_ $ do
287 |   st <- takeMVar state
288 |   case st of
289 |     Free   -> do Lock.acquire writeLock
290 |                  putMVar state Write
291 |                  return True
292 |     _      -> do putMVar state st
293 |                  return False
294 | 
295 | {-|
296 | Release the write lock.
297 | 
298 | If @releaseWrite@ terminates without throwing an exception the state will be
299 | \"free\".
300 | 
301 | It is an error to release write access to an 'RWLock' which is not in the
302 | \"write\" state.
303 | -}
304 | releaseWrite :: RWLock -> IO ()
305 | releaseWrite (RWLock {state, writeLock}) = mask_ $ do
306 |   st <- takeMVar state
307 |   case st of
308 |     Write -> do Lock.release writeLock
309 |                 putMVar state Free
310 |     _ -> do putMVar state st
311 |             error $ moduleName ++ ".releaseWrite: already released"
312 | 
313 | {-|
314 | A convenience function wich first acquires write access and then performs
315 | the computation. When the computation terminates, whether normally or by raising
316 | an exception, the write lock is released.
317 | -}
318 | withWrite :: RWLock -> IO a -> IO a
319 | withWrite = liftA2 bracket_ acquireWrite releaseWrite
320 | 
321 | {-|
322 | A non-blocking 'withWrite'. First tries to acquire the lock. If that fails,
323 | 'Nothing' is returned. If it succeeds, the computation is performed. When the
324 | computation terminates, whether normally or by raising an exception, the lock is
325 | released and 'Just' the result of the computation is returned.
326 | -}
327 | tryWithWrite :: RWLock -> IO a -> IO (Maybe a)
328 | tryWithWrite l a = mask $ \restore -> do
329 |   acquired <- tryAcquireWrite l
330 |   if acquired
331 |     then do r <- restore a `onException` releaseWrite l
332 |             releaseWrite l
333 |             return $ Just r
334 |     else return Nothing
335 | 
336 | {-|
337 | * When the state is \"write\" or \"read\" @waitWrite@ /blocks/ until a call to
338 | 'releaseWrite' or 'releaseRead' in another thread changes the state to \"free\".
339 | 
340 | * When the state is \"free\" @waitWrite@ returns immediately.
341 | 
342 | @waitWrite@ does not alter the state of the lock.
343 | 
344 | Note that @waitWrite@ is just a convenience function defined as:
345 | 
346 | @waitWrite l = 'mask_' '$' 'acquireWrite' l '>>' 'releaseWrite' l@
347 | -}
348 | waitWrite :: RWLock -> IO ()
349 | waitWrite l = mask_ $ acquireWrite l >> releaseWrite l
350 | 
351 | moduleName :: String
352 | moduleName = "Control.Concurrent.ReadWriteLock"
353 | 


--------------------------------------------------------------------------------