diff --git a/Control/Concurrent/Lock.hs b/Control/Concurrent/Lock.hs --- a/Control/Concurrent/Lock.hs +++ b/Control/Concurrent/Lock.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude, UnicodeSyntax #-} +{-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude, UnicodeSyntax #-} -------------------------------------------------------------------------------- -- | @@ -65,6 +65,9 @@ import Control.Exception ( block, bracket_, finally ) import Control.Monad ( Monad, return, (>>=), (>>), fail, when ) import Data.Bool ( Bool, not ) +#ifdef __HADDOCK__ +import Data.Bool ( Bool(False, True) ) +#endif import Data.Eq ( Eq ) import Data.Function ( ($) ) import Data.Functor ( fmap, (<$>) ) diff --git a/Control/Concurrent/STM/Lock.hs b/Control/Concurrent/STM/Lock.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/STM/Lock.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude, UnicodeSyntax #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.STM.Lock +-- Copyright : (c) 2010 Bas van Dijk & Roel van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- , Roel van Dijk +-- +-- This module provides an 'STM' version of @Control.Concurrent.Lock@. +-- +-- This module is intended to be imported qualified. We suggest importing it like: +-- +-- @ +-- import Control.Concurrent.STM.Lock ( Lock ) +-- import qualified Control.Concurrent.STM.Lock as Lock ( ... ) +-- @ +-- +-------------------------------------------------------------------------------- + +module Control.Concurrent.STM.Lock + ( Lock + + -- * Creating locks + , new + , newAcquired + + -- * Locking and unlocking + , acquire + , tryAcquire + , release + + -- * Convenience functions + , with + , tryWith + , wait + + -- * Querying locks + , locked + ) where + + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Control.Applicative ( liftA2 ) +import Control.Exception ( block, bracket_, finally ) +import Control.Monad ( Monad, return, (>>=), (>>), fail, when ) +import Data.Bool ( Bool, not ) +#ifdef __HADDOCK__ +import Data.Bool (Bool(False, True)) +#endif +-- TODO: import Data.Eq ( Eq ) +import Data.Function ( ($) ) +import Data.Functor ( fmap, (<$>) ) +import Data.Maybe ( Maybe(Nothing, Just), isJust ) +import Data.Typeable ( Typeable ) +import Prelude ( error ) +import System.IO ( IO ) + +-- from stm: +import Control.Concurrent.STM ( STM, atomically ) +#ifdef __HADDOCK__ +import Control.Concurrent.STM ( retry ) +#endif +import Control.Concurrent.STM.TMVar ( TMVar, newTMVar, newEmptyTMVar + , takeTMVar, tryTakeTMVar + , tryPutTMVar + , isEmptyTMVar + ) + +-- from base-unicode-symbols: +import Data.Function.Unicode ( (∘) ) + + +-------------------------------------------------------------------------------- +-- Locks +-------------------------------------------------------------------------------- + +-- | A lock is in one of two states: \"locked\" or \"unlocked\". +newtype Lock = Lock {un ∷ TMVar ()} + deriving ( Typeable + -- TODO: , Eq -- I added an Eq instance for TMVar to the HEAD branch of stm. + ) + + +-------------------------------------------------------------------------------- +-- Creating locks +-------------------------------------------------------------------------------- + +-- | Create a lock in the \"unlocked\" state. +new ∷ STM Lock +new = Lock <$> newTMVar () + +-- | Create a lock in the \"locked\" state. +newAcquired ∷ STM Lock +newAcquired = Lock <$> newEmptyTMVar + + +-------------------------------------------------------------------------------- +-- Locking and unlocking +-------------------------------------------------------------------------------- + +{-| +* When the state is \"locked\" @acquire@ will 'retry' the transaction. + +* When the state is \"unlocked\" @acquire@ will change the state to \"locked\". +-} +acquire ∷ Lock → STM () +acquire = takeTMVar ∘ un + +{-| +A non-blocking 'acquire'. + +* When the state is \"unlocked\" @tryAcquire@ changes the state to \"locked\" +and returns 'True'. + +* When the state is \"locked\" @tryAcquire@ leaves the state unchanged and +returns 'False'. +-} +tryAcquire ∷ Lock → STM Bool +tryAcquire = fmap isJust ∘ tryTakeTMVar ∘ un + +{-| +@release@ changes the state to \"unlocked\" and returns immediately. + +Note that it is an error to release a lock in the \"unlocked\" state! +-} +release ∷ Lock → STM () +release (Lock mv) = do + b ← tryPutTMVar mv () + when (not b) $ error "Control.Concurrent.STM.Lock.release: Can't release unlocked Lock!" + + +-------------------------------------------------------------------------------- +-- Convenience functions +-------------------------------------------------------------------------------- + +{-| +A convenience function which first acquires the lock and then performs the +computation. When the computation terminates, whether normally or by raising an +exception, the lock is released. +-} +with ∷ Lock → IO a → IO a +with = liftA2 bracket_ (atomically ∘ acquire) (atomically ∘ release) + +{-| +A non-blocking 'with'. @tryWith@ is a convenience function which first tries to +acquire the lock. If that fails, 'Nothing' is returned. If it succeeds, the +computation is performed. When the computation terminates, whether normally or +by raising an exception, the lock is released and 'Just' the result of the +computation is returned. +-} +tryWith ∷ Lock → IO α → IO (Maybe α) +tryWith l a = block $ do + acquired ← atomically (tryAcquire l) + if acquired + then Just <$> a `finally` atomically (release l) + else return Nothing + +{-| +* When the state is \"locked\", @wait@ will 'retry' the transaction + +* When the state is \"unlocked\" @wait@ returns immediately. + +@wait@ does not alter the state of the lock. + +Note that @wait@ is just a convenience function defined as: + +@wait l = 'acquire' l '>>' 'release' l@ +-} +wait ∷ Lock → STM () +wait l = acquire l >> release l + + +-------------------------------------------------------------------------------- +-- Querying locks +-------------------------------------------------------------------------------- + +{-| +Determines if the lock is in the \"locked\" state. + +Note that this is only a snapshot of the state. By the time a program reacts +on its result it may already be out of date. +-} +locked ∷ Lock → STM Bool +locked = isEmptyTMVar ∘ un + + +-- The End --------------------------------------------------------------------- diff --git a/Control/Concurrent/STM/Lock/Test.hs b/Control/Concurrent/STM/Lock/Test.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/STM/Lock/Test.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE NoImplicitPrelude + , UnicodeSyntax + , ScopedTypeVariables + #-} + +module Control.Concurrent.STM.Lock.Test ( tests ) where + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +-- from base: +import Control.Concurrent ( forkIO ) +import Control.Monad ( (>>=), fail, (>>) ) +import Data.Bool ( not ) +import Data.Function ( ($) ) +import Data.Functor ( fmap ) +import Prelude ( fromInteger ) + +-- from base-unicode-symbols: +import Data.Function.Unicode ( (∘) ) +import Prelude.Unicode ( (⋅) ) + +-- from stm: +import Control.Concurrent.STM ( atomically ) + +-- from concurrent-extra: +import qualified Control.Concurrent.STM.Lock as Lock +import TestUtils + +-- from HUnit: +import Test.HUnit ( Assertion, assert ) + +-- from test-framework: +import Test.Framework ( Test ) + +-- from test-framework-hunit: +import Test.Framework.Providers.HUnit ( testCase ) + + +------------------------------------------------------------------------------- +-- Tests for Lock +------------------------------------------------------------------------------- + +tests ∷ [Test] +tests = [ testCase "acquire release" test_lock_1 + , testCase "acquire acquire" test_lock_2 + , testCase "new release" test_lock_3 + , testCase "new unlocked" test_lock_4 + , testCase "newAcquired locked" test_lock_5 + , testCase "acq rel unlocked" test_lock_6 + , testCase "conc release" test_lock_7 + ] + +test_lock_1 ∷ Assertion +test_lock_1 = assert $ within a_moment $ atomically $ do + l ← Lock.new + Lock.acquire l + Lock.release l + +test_lock_2 ∷ Assertion +test_lock_2 = assert $ notWithin (10 ⋅ a_moment) $ atomically $ do + l ← Lock.new + Lock.acquire l + Lock.acquire l + +test_lock_3 ∷ Assertion +test_lock_3 = assertException "" $ atomically $ Lock.new >>= Lock.release + +test_lock_4 ∷ Assertion +test_lock_4 = assert $ atomically $ Lock.new >>= fmap not ∘ Lock.locked + +test_lock_5 ∷ Assertion +test_lock_5 = assert $ atomically $ Lock.newAcquired >>= Lock.locked + +test_lock_6 ∷ Assertion +test_lock_6 = assert $ atomically $ do + l ← Lock.new + Lock.acquire l + Lock.release l + fmap not $ Lock.locked l + +test_lock_7 ∷ Assertion +test_lock_7 = assert ∘ within (10 ⋅ a_moment) $ do + l ← atomically $ Lock.newAcquired + _ ← forkIO $ wait_a_moment >> atomically (Lock.release l) + atomically $ Lock.acquire l + + +-- The End --------------------------------------------------------------------- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2009 Bas van Dijk & Roel van Dijk +Copyright (c) 2010 Bas van Dijk & Roel van Dijk All rights reserved. diff --git a/concurrent-extra.cabal b/concurrent-extra.cabal --- a/concurrent-extra.cabal +++ b/concurrent-extra.cabal @@ -1,5 +1,5 @@ name: concurrent-extra -version: 0.5 +version: 0.5.1 cabal-version: >= 1.6 build-type: Custom stability: experimental @@ -20,8 +20,10 @@ . * @Event@: Wake multiple threads by signalling an event. . + * @Lock@: Enforce exclusive access to a resource. Also known as a - binary semaphore or mutex. + binary semaphore or mutex. The package additionally provides an + alternative that works in the @STM@ monad. . * @RLock@: A lock which can be acquired multiple times by the same thread. Also known as a reentrant mutex. @@ -67,7 +69,9 @@ library build-depends: base >= 3 && < 4.3 , base-unicode-symbols >= 0.1.1 && < 0.3 + , stm >= 2.1 && < 2.2 exposed-modules: Control.Concurrent.Lock + , Control.Concurrent.STM.Lock , Control.Concurrent.RLock , Control.Concurrent.Event , Control.Concurrent.Broadcast @@ -87,6 +91,7 @@ main-is: test.hs other-modules: Control.Concurrent.Event.Test , Control.Concurrent.Lock.Test + , Control.Concurrent.STM.Lock.Test , Control.Concurrent.RLock.Test , Control.Concurrent.Broadcast.Test , Control.Concurrent.ReadWriteLock.Test @@ -99,9 +104,10 @@ if flag(test) build-depends: base >= 3 && < 4.3 , base-unicode-symbols >= 0.1.1 && < 0.3 + , stm >= 2.1 && < 2.2 , HUnit >= 1.2.2 && < 1.3 , QuickCheck >= 2.1.0 && < 2.2 - , test-framework >= 0.2.4 && < 0.3 + , test-framework >= 0.2.4 && < 0.4 , test-framework-hunit >= 0.2.4 && < 0.3 , test-framework-quickcheck2 >= 0.2.4 && < 0.3 buildable: True diff --git a/test.hs b/test.hs --- a/test.hs +++ b/test.hs @@ -12,6 +12,7 @@ -- from concurrent-extra: import qualified Control.Concurrent.Event.Test as Event ( tests ) import qualified Control.Concurrent.Lock.Test as Lock ( tests ) +import qualified Control.Concurrent.STM.Lock.Test as STM.Lock ( tests ) import qualified Control.Concurrent.RLock.Test as RLock ( tests ) import qualified Control.Concurrent.Broadcast.Test as Broadcast ( tests ) import qualified Control.Concurrent.ReadWriteLock.Test as RWLock ( tests ) @@ -33,6 +34,7 @@ tests = [ testGroup "Pessimistic locking" [ testGroup "Event" Event.tests , testGroup "Lock" Lock.tests + , testGroup "STM.Lock" STM.Lock.tests , testGroup "RLock" RLock.tests , testGroup "Broadcast" Broadcast.tests , testGroup "ReadWriteLock" RWLock.tests