concurrent-extra 0.5 → 0.5.1

raw patch · 6 files changed

+299/−5 lines, 6 filesdep +stmdep ~test-frameworkPVP ok

version bump matches the API change (PVP)

Dependencies added: stm

Dependency ranges changed: test-framework

API changes (from Hackage documentation)

Files

• Control/Concurrent/Lock.hs +4/−1
• Control/Concurrent/STM/Lock.hs +193/−0
• Control/Concurrent/STM/Lock/Test.hs +90/−0
• LICENSE +1/−1
• concurrent-extra.cabal +9/−3
• test.hs +2/−0

@@ -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, (<$>) )

@@ -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 <v.dijk.bas@gmail.com>+--            , Roel van Dijk <vandijk.roel@gmail.com>+--+-- 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 ---------------------------------------------------------------------

@@ -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 ---------------------------------------------------------------------

@@ -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. 

@@ -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

@@ -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