concurrent-extra 0.7.0.8 → 0.7.0.9

raw patch · 19 files changed

+381/−442 lines, 19 filesdep −base-unicode-symbolsdep ~randomsetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: base-unicode-symbols

Dependency ranges changed: random

API changes (from Hackage documentation)

Files

• Control/Concurrent/Broadcast.hs +41/−40
• Control/Concurrent/Broadcast/Test.hs +2/−7
• Control/Concurrent/Event.hs +15/−18
• Control/Concurrent/Event/Test.hs +30/−32
• Control/Concurrent/Lock.hs +21/−24
• Control/Concurrent/Lock/Test.hs +26/−30
• Control/Concurrent/RLock.hs +51/−56
• Control/Concurrent/RLock/Test.hs +16/−20
• Control/Concurrent/ReadWriteLock.hs +68/−72
• Control/Concurrent/ReadWriteLock/Test.hs +10/−12
• Control/Concurrent/ReadWriteVar.hs +15/−19
• Control/Concurrent/ReadWriteVar/Test.hs +2/−7
• Control/Concurrent/STM/Lock.hs +25/−24
• Control/Concurrent/STM/Lock/Test.hs +26/−30
• Setup.hs +4/−7
• TestUtils.hs +8/−12
• Utils.hs +16/−22
• concurrent-extra.cabal +2/−4
• test.hs +3/−6

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude, UnicodeSyntax #-}+{-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude #-}  #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-}@@ -60,12 +60,12 @@ import Control.Exception          ( onException ) import Data.Eq                    ( Eq ) import Data.Either                ( Either(Left ,Right), either )-import Data.Function              ( ($), const )+import Data.Function              ( ($), (.), const ) import Data.Functor               ( fmap, (<$>) ) import Data.Foldable              ( for_ ) import Data.List                  ( delete, length ) import Data.Maybe                 ( Maybe(Nothing, Just), isNothing )-import Data.Ord                   ( Ord, max )+import Data.Ord                   ( max ) import Data.Typeable              ( Typeable ) import Prelude                    ( Integer, seq ) import System.IO                  ( IO )@@ -73,16 +73,17 @@ #if __GLASGOW_HASKELL__ < 700 import Prelude                    ( fromInteger ) import Control.Monad              ( (>>=), (>>), fail )+import Data.Ord                   ( Ord ) #endif --- from base-unicode-symbols:-import Data.Function.Unicode      ( (∘) )+-- from unbounded-delays:+import Control.Concurrent.Timeout ( timeout )  -- from concurrent-extra (this package): import Utils                      ( purelyModifyMVar, mask_ )-import Control.Concurrent.Timeout ( timeout )  + ------------------------------------------------------------------------------- -- Broadcast -------------------------------------------------------------------------------@@ -96,15 +97,15 @@ * \"Broadcasting @x@\": @'listen'ing@ to the broadcast will return the value @x@ without blocking. -}-newtype Broadcast α = Broadcast {unBroadcast ∷ MVar (Either [MVar α] α)}+newtype Broadcast a = Broadcast {unBroadcast :: MVar (Either [MVar a] a)}     deriving (Eq, Typeable)  -- | @new@ creates a broadcast in the \"silent\" state.-new ∷ IO (Broadcast α)+new :: IO (Broadcast a) new = Broadcast <$> newMVar (Left [])  -- | @newBroadcasting x@ creates a broadcast in the \"broadcasting @x@\" state.-newBroadcasting ∷ α → IO (Broadcast α)+newBroadcasting :: a -> IO (Broadcast a) newBroadcasting x = Broadcast <$> newMVar (Right x)  {-|@@ -116,15 +117,15 @@ * If the broadcast is \"silent\", @listen@ will block until another thread @'broadcast's@ a value to the broadcast. -}-listen ∷ Broadcast α → IO α+listen :: Broadcast a -> IO a listen (Broadcast mv) = mask_ $ do-  mx ← takeMVar mv+  mx <- takeMVar mv   case mx of-    Left ls → do l ← newEmptyMVar-                 putMVar mv $ Left $ l:ls-                 takeMVar l-    Right x → do putMVar mv mx-                 return x+    Left ls -> do l <- newEmptyMVar+                  putMVar mv $ Left $ l:ls+                  takeMVar l+    Right x -> do putMVar mv mx+                  return x  {-| Try to listen to a broadcast; non blocking.@@ -134,8 +135,8 @@  * If the broadcast is \"silent\", @tryListen@ returns 'Nothing' immediately. -}-tryListen ∷ Broadcast α → IO (Maybe α)-tryListen = fmap (either (const Nothing) Just) ∘ readMVar ∘ unBroadcast+tryListen :: Broadcast a -> IO (Maybe a)+tryListen = fmap (either (const Nothing) Just) . readMVar . unBroadcast  {-| Listen to a broadcast if it is available within a given amount of time.@@ -150,24 +151,24 @@  Negative timeouts are treated the same as a timeout of 0 &#x3bc;s. -}-listenTimeout ∷ Broadcast α → Integer → IO (Maybe α)+listenTimeout :: Broadcast a -> Integer -> IO (Maybe a) listenTimeout (Broadcast mv) time = mask_ $ do-  mx ← takeMVar mv+  mx <- takeMVar mv   case mx of-    Left ls → do l ← newEmptyMVar-                 putMVar mv $ Left $ l:ls-                 my ← timeout (max time 0) (takeMVar l)-                      `onException` deleteReader l-                 when (isNothing my) (deleteReader l)-                 return my-    Right x → do putMVar mv mx-                 return $ Just x+    Left ls -> do l <- newEmptyMVar+                  putMVar mv $ Left $ l:ls+                  my <- timeout (max time 0) (takeMVar l)+                         `onException` deleteReader l+                  when (isNothing my) (deleteReader l)+                  return my+    Right x -> do putMVar mv mx+                  return $ Just x     where-      deleteReader l = do mx ← takeMVar mv+      deleteReader l = do mx <- takeMVar mv                           case mx of-                            Left ls → let ls' = delete l ls-                                      in length ls' `seq` putMVar mv (Left ls')-                            Right _ → putMVar mv mx+                            Left ls -> let ls' = delete l ls+                                       in length ls' `seq` putMVar mv (Left ls')+                            Right _ -> putMVar mv mx  {-| Broadcast a value.@@ -177,7 +178,7 @@ If the broadcast was \"silent\" all threads that are @'listen'ing@ to the broadcast will be woken. -}-broadcast ∷ Broadcast α → α → IO ()+broadcast :: Broadcast a -> a -> IO ()  {-| Broadcast a value before becoming \"silent\".@@ -191,21 +192,21 @@   signal b x = 'block' $ 'broadcast' b x >> 'silence' b @ -}-signal ∷ Broadcast α → α → IO ()+signal :: Broadcast a -> a -> IO ()  broadcast b x = broadcastThen (Right x) b x signal    b x = broadcastThen (Left []) b x  -- | Internally used function that performs the actual broadcast in 'broadcast' -- and 'signal' then changes to the given final state.-broadcastThen ∷ Either [MVar α] α → Broadcast α → α → IO ()+broadcastThen :: Either [MVar a] a -> Broadcast a -> a -> IO () broadcastThen finalState (Broadcast mv) x =-    modifyMVar_ mv $ \mx → do+    modifyMVar_ mv $ \mx -> do       case mx of-        Left ls → do for_ ls (`putMVar` x)-                     return finalState-        Right _ → return finalState+        Left ls -> do for_ ls (`putMVar` x)+                      return finalState+        Right _ -> return finalState  -- | Set a broadcast to the \"silent\" state.-silence ∷ Broadcast α → IO ()+silence :: Broadcast a -> IO () silence (Broadcast mv) = purelyModifyMVar mv $ either Left $ const $ Left []

@@ -1,6 +1,4 @@-{-# LANGUAGE NoImplicitPrelude-           , UnicodeSyntax-  #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Control.Concurrent.Broadcast.Test ( tests ) where @@ -12,9 +10,6 @@ -- from base: import Control.Concurrent ( ) --- from base-unicode-symbols:-import Prelude.Unicode       ( )- -- from concurrent-extra: import qualified Control.Concurrent.Broadcast as Broadcast ( ) import TestUtils ( )@@ -33,5 +28,5 @@ -- Tests for Broadcast ------------------------------------------------------------------------------- -tests ∷ [Test]+tests :: [Test] tests = []

@@ -1,7 +1,6 @@ {-# LANGUAGE CPP            , DeriveDataTypeable            , NoImplicitPrelude-           , UnicodeSyntax   #-}  #if __GLASGOW_HASKELL__ >= 704@@ -64,20 +63,18 @@ -- from base: import Data.Bool               ( Bool(..) ) import Data.Eq                 ( Eq )+import Data.Function           ( (.) ) import Data.Functor            ( fmap, (<$>) ) import Data.Maybe              ( isJust ) import Data.Typeable           ( Typeable )  #ifdef __HADDOCK__-import Control.Exception       ( block )+import Control.Exception       ( mask ) #endif  import Prelude                 ( Integer ) import System.IO               ( IO ) --- from base-unicode-symbols:-import Data.Function.Unicode   ( (∘) )- -- from concurrent-extra (this package): import           Control.Concurrent.Broadcast ( Broadcast ) import qualified Control.Concurrent.Broadcast as Broadcast@@ -92,7 +89,7 @@ -------------------------------------------------------------------------------  -- | An event is in one of two possible states: \"set\" or \"cleared\".-newtype Event = Event {evBroadcast ∷ Broadcast ()} deriving (Eq, Typeable)+newtype Event = Event {evBroadcast :: Broadcast ()} deriving (Eq, Typeable)   -------------------------------------------------------------------------------@@ -100,11 +97,11 @@ -------------------------------------------------------------------------------  -- | Create an event in the \"cleared\" state.-new ∷ IO Event+new :: IO Event new = Event <$> Broadcast.new  -- | Create an event in the \"set\" state.-newSet ∷ IO Event+newSet :: IO Event newSet = Event <$> Broadcast.newBroadcasting ()  @@ -121,8 +118,8 @@ (You can also resume a thread that is waiting for an event by throwing an asynchronous exception.) -}-wait ∷ Event → IO ()-wait = Broadcast.listen ∘ evBroadcast+wait :: Event -> IO ()+wait = Broadcast.listen . evBroadcast  {-| Block until the event is 'set' or until a timer expires.@@ -137,7 +134,7 @@  Negative timeouts are treated the same as a timeout of 0 &#x3bc;s. -}-waitTimeout ∷ Event → Integer → IO Bool+waitTimeout :: Event -> Integer -> IO Bool waitTimeout ev time = isJust <$> Broadcast.listenTimeout (evBroadcast ev) time  {-|@@ -147,8 +144,8 @@ Notice that this is only a snapshot of the state. By the time a program reacts on its result it may already be out of date. -}-isSet ∷ Event → IO Bool-isSet = fmap isJust ∘ Broadcast.tryListen ∘ evBroadcast+isSet :: Event -> IO Bool+isSet = fmap isJust . Broadcast.tryListen . evBroadcast   -------------------------------------------------------------------------------@@ -160,7 +157,7 @@ for this event are woken. Threads that 'wait' after the state is changed to \"set\" will not block at all. -}-set ∷ Event → IO ()+set :: Event -> IO () set ev = Broadcast.broadcast (evBroadcast ev) ()  {-|@@ -171,14 +168,14 @@ The semantics of signal are equivalent to the following definition:  @-  signal e = 'block' $ 'set' e >> 'clear' e+  signal e = 'mask' $ 'set' e >> 'clear' e @-}-signal ∷ Event → IO ()+signal :: Event -> IO () signal ev = Broadcast.signal (evBroadcast ev) ()  {-| Changes the state of the event to \"cleared\". Threads that 'wait' after the state is changed to \"cleared\" will block until the state is changed to \"set\". -}-clear ∷ Event → IO ()-clear = Broadcast.silence ∘ evBroadcast+clear :: Event -> IO ()+clear = Broadcast.silence . evBroadcast

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax, ScopedTypeVariables #-}+{-# LANGUAGE CPP, NoImplicitPrelude, ScopedTypeVariables #-}  module Control.Concurrent.Event.Test ( tests ) where @@ -13,16 +13,13 @@ import Data.Function      ( ($) ) import Data.Int           ( Int ) import Data.Bool          ( not )-import Prelude            ( toInteger )+import Prelude            ( toInteger, (*) )  #if __GLASGOW_HASKELL__ < 700 import Prelude            ( fromInteger ) import Control.Monad      ( (>>=), (>>), fail ) #endif --- from base-unicode-symbols:-import Prelude.Unicode ( (⋅) )- -- from concurrent-extra: import qualified Control.Concurrent.Event as Event import TestUtils@@ -41,7 +38,7 @@ -- Tests for Event ------------------------------------------------------------------------------- -tests ∷ [Test]+tests :: [Test] tests = [ testCase "set wait a"    $ test_event_1 1 1         , testCase "set wait b"    $ test_event_1 5 1         , testCase "set wait c"    $ test_event_1 1 5@@ -55,17 +52,17 @@  -- Set an event 's' times then wait for it 'w' times. This should -- terminate within a few moments.-test_event_1 ∷ Int → Int → Assertion-test_event_1 s w = assert $ within (10 ⋅ a_moment) $ do-  e ← Event.new+test_event_1 :: Int -> Int -> Assertion+test_event_1 s w = assert $ within (10 * a_moment) $ do+  e <- Event.new   replicateM_ s $ Event.set  e   replicateM_ w $ Event.wait e -test_event_2 ∷ Assertion-test_event_2 = assert $ within (10 ⋅ a_moment) $ do-  e1 ← Event.new-  e2 ← Event.new-  _ ← forkIO $ do+test_event_2 :: Assertion+test_event_2 = assert $ within (10 * a_moment) $ do+  e1 <- Event.new+  e2 <- Event.new+  _ <- forkIO $ do     Event.wait e1     Event.set  e2   wait_a_moment@@ -73,12 +70,12 @@   Event.wait e2  -- Waking multiple threads with a single Event.-test_event_3 ∷ Int → Assertion-test_event_3 n = assert $ within (10 ⋅ a_moment) $ do-  e1 ← Event.new-  es ← replicateM n $ do-    e2 ← Event.new-    _ ← forkIO $ do+test_event_3 :: Int -> Assertion+test_event_3 n = assert $ within (10 * a_moment) $ do+  e1 <- Event.new+  es <- replicateM n $ do+    e2 <- Event.new+    _ <- forkIO $ do       Event.wait e1       Event.set  e2     return e2@@ -87,22 +84,23 @@   mapM_ Event.wait es  -- Exception handling while waiting for an Event.-test_event_4 ∷ Assertion-test_event_4 = assert $ within (10 ⋅ a_moment) $ do-  e1 ← Event.new-  e2 ← Event.new-  helperId ← forkIO $ catch (Event.wait e1) $ \(_ ∷ ErrorCall) → Event.set e2+test_event_4 :: Assertion+test_event_4 = assert $ within (10 * a_moment) $ do+  e1 <- Event.new+  e2 <- Event.new+  helperId <- forkIO $ Event.wait e1 `catch` \(_ :: ErrorCall) ->+                                                 Event.set e2   wait_a_moment   throwTo helperId $ ErrorCall "Boo!"   Event.wait e2 -test_event_5 ∷ Assertion-test_event_5 = assert $ within (10 ⋅ a_moment) $ do-  e ← Event.new-  notTimedOut ← Event.waitTimeout e $ toInteger a_moment+test_event_5 :: Assertion+test_event_5 = assert $ within (10 * a_moment) $ do+  e <- Event.new+  notTimedOut <- Event.waitTimeout e $ toInteger a_moment   return $ not notTimedOut -test_event_6 ∷ Assertion-test_event_6 = assert $ notWithin (10 ⋅ a_moment) $ do-  e ← Event.new+test_event_6 :: Assertion+test_event_6 = assert $ notWithin (10 * a_moment) $ do+  e <- Event.new   Event.wait e

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude, UnicodeSyntax #-}+{-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude #-}  #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-}@@ -67,13 +67,13 @@                                , isEmptyMVar                                ) import Control.Exception       ( bracket_, onException )-import Control.Monad           ( Monad, return, (>>), when )+import Control.Monad           ( return, (>>), when ) import Data.Bool               ( Bool, not ) #ifdef __HADDOCK__ import Data.Bool               ( Bool(False, True) ) #endif import Data.Eq                 ( Eq )-import Data.Function           ( ($) )+import Data.Function           ( ($), (.) ) import Data.Functor            ( fmap, (<$>) ) import Data.Maybe              ( Maybe(Nothing, Just), isJust ) import Data.Typeable           ( Typeable )@@ -81,12 +81,9 @@ import System.IO               ( IO )  #if __GLASGOW_HASKELL__ < 700-import Control.Monad           ( (>>=), fail )+import Control.Monad           ( Monad, (>>=), fail ) #endif --- from base-unicode-symbols:-import Data.Function.Unicode   ( (∘) )- -- from concurrent-extra (this package): import Utils                   ( mask, mask_ ) @@ -96,7 +93,7 @@ --------------------------------------------------------------------------------  -- | A lock is in one of two states: \"locked\" or \"unlocked\".-newtype Lock = Lock {un ∷ MVar ()} deriving (Eq, Typeable)+newtype Lock = Lock {un :: MVar ()} deriving (Eq, Typeable)   --------------------------------------------------------------------------------@@ -104,11 +101,11 @@ --------------------------------------------------------------------------------  -- | Create a lock in the \"unlocked\" state.-new ∷ IO Lock+new :: IO Lock new = Lock <$> newMVar ()  -- | Create a lock in the \"locked\" state.-newAcquired ∷ IO Lock+newAcquired :: IO Lock newAcquired = Lock <$> newEmptyMVar  @@ -138,8 +135,8 @@ using locks. (Note that this differs from the Python implementation where the wake-up order is undefined.) -}-acquire ∷ Lock → IO ()-acquire = takeMVar ∘ un+acquire :: Lock -> IO ()+acquire = takeMVar . un  {-| A non-blocking 'acquire'.@@ -150,8 +147,8 @@ * When the state is \"locked\" @tryAcquire@ leaves the state unchanged and returns 'False'. -}-tryAcquire ∷ Lock → IO Bool-tryAcquire = fmap isJust ∘ tryTakeMVar ∘ un+tryAcquire :: Lock -> IO Bool+tryAcquire = fmap isJust . tryTakeMVar . un  {-| @release@ changes the state to \"unlocked\" and returns immediately.@@ -161,9 +158,9 @@ If there are any threads blocked on 'acquire' the thread that first called @acquire@ will be woken up. -}-release ∷ Lock → IO ()+release :: Lock -> IO () release (Lock mv) = do-  b ← tryPutMVar mv ()+  b <- tryPutMVar mv ()   when (not b) $ error "Control.Concurrent.Lock.release: Can't release unlocked Lock!"  @@ -178,7 +175,7 @@  Note that: @with = 'liftA2' 'bracket_' 'acquire' 'release'@. -}-with ∷ Lock → IO a → IO a+with :: Lock -> IO a -> IO a with = liftA2 bracket_ acquire release  {-|@@ -188,11 +185,11 @@ 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 = mask $ \restore → do-  acquired ← tryAcquire l+tryWith :: Lock -> IO a -> IO (Maybe a)+tryWith l a = mask $ \restore -> do+  acquired <- tryAcquire l   if acquired-    then do r ← restore a `onException` release l+    then do r <- restore a `onException` release l             release l             return $ Just r     else return Nothing@@ -209,7 +206,7 @@  @wait l = 'block' '$' 'acquire' l '>>' 'release' l@ -}-wait ∷ Lock → IO ()+wait :: Lock -> IO () wait (Lock mv) = mask_ $ takeMVar mv >> putMVar mv ()  @@ -223,5 +220,5 @@ Note that this is only a snapshot of the state. By the time a program reacts on its result it may already be out of date. -}-locked ∷ Lock → IO Bool-locked = isEmptyMVar ∘ un+locked :: Lock -> IO Bool+locked = isEmptyMVar . un

@@ -1,6 +1,5 @@ {-# LANGUAGE CPP            , NoImplicitPrelude-           , UnicodeSyntax            , ScopedTypeVariables   #-} @@ -11,10 +10,11 @@ -------------------------------------------------------------------------------  -- from base:+import Prelude            ( (*) ) import Control.Concurrent ( forkIO ) import Control.Monad      ( return, (>>=), (>>) ) import Data.Bool          ( Bool(False, True), not, (&&) )-import Data.Function      ( ($) )+import Data.Function      ( ($), (.) ) import Data.Functor       ( fmap ) import Data.IORef         ( newIORef, writeIORef, readIORef ) @@ -23,10 +23,6 @@ import Control.Monad      ( fail ) #endif --- from base-unicode-symbols:-import Data.Function.Unicode ( (∘) )-import Prelude.Unicode       ( (⋅) )- -- from concurrent-extra: import qualified Control.Concurrent.Lock as Lock import TestUtils@@ -45,7 +41,7 @@ -- Tests for Lock ------------------------------------------------------------------------------- -tests ∷ [Test]+tests :: [Test] tests = [ testCase "acquire release"    test_lock_1         , testCase "acquire acquire"    test_lock_2         , testCase "new release"        test_lock_3@@ -56,48 +52,48 @@         , testCase "wait"               test_lock_8         ] -test_lock_1 ∷ Assertion+test_lock_1 :: Assertion test_lock_1 = assert $ within a_moment $ do-  l ← Lock.new+  l <- Lock.new   Lock.acquire l   Lock.release l -test_lock_2 ∷ Assertion-test_lock_2 = assert $ notWithin (10 ⋅ a_moment) $ do-  l ← Lock.new+test_lock_2 :: Assertion+test_lock_2 = assert $ notWithin (10 * a_moment) $ do+  l <- Lock.new   Lock.acquire l   Lock.acquire l -test_lock_3 ∷ Assertion+test_lock_3 :: Assertion test_lock_3 = assertException "" $ Lock.new >>= Lock.release -test_lock_4 ∷ Assertion-test_lock_4 = assert $ Lock.new >>= fmap not ∘ Lock.locked+test_lock_4 :: Assertion+test_lock_4 = assert $ Lock.new >>= fmap not . Lock.locked -test_lock_5 ∷ Assertion+test_lock_5 :: Assertion test_lock_5 = assert $ Lock.newAcquired >>= Lock.locked -test_lock_6 ∷ Assertion+test_lock_6 :: Assertion test_lock_6 = assert $ do-  l ← Lock.new+  l <- Lock.new   Lock.acquire l   Lock.release l   fmap not $ Lock.locked l -test_lock_7 ∷ Assertion-test_lock_7 = assert ∘ within (1000 ⋅ a_moment) $ do-  l ← Lock.newAcquired-  _ ← forkIO $ wait_a_moment >> Lock.release l+test_lock_7 :: Assertion+test_lock_7 = assert . within (1000 * a_moment) $ do+  l <- Lock.newAcquired+  _ <- forkIO $ wait_a_moment >> Lock.release l   Lock.acquire l -test_lock_8 ∷ Assertion+test_lock_8 :: Assertion test_lock_8 = assert $ do-  ioRef ← newIORef False-  l ← Lock.newAcquired-  _ ← forkIO $ do wait_a_moment-                  writeIORef ioRef True-                  Lock.release l+  ioRef <- newIORef False+  l <- Lock.newAcquired+  _ <- forkIO $ do wait_a_moment+                   writeIORef ioRef True+                   Lock.release l   Lock.wait l-  set ← readIORef ioRef-  locked ← Lock.locked l+  set <- readIORef ioRef+  locked <- Lock.locked l   return $ set && not locked

@@ -2,7 +2,6 @@            , BangPatterns            , DeriveDataTypeable            , NoImplicitPrelude-           , UnicodeSyntax   #-}  #if __GLASGOW_HASKELL__ >= 704@@ -71,12 +70,13 @@ import Control.Concurrent      ( ThreadId, myThreadId ) import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, readMVar, putMVar ) import Control.Exception       ( bracket_, onException )-import Control.Monad           ( Monad, return, (>>) )+import Control.Monad           ( return, (>>) ) import Data.Bool               ( Bool(False, True), otherwise )-import Data.Eq                 ( Eq )-import Data.Function           ( ($) )+import Data.Eq                 ( Eq, (==) )+import Data.Function           ( ($), (.) ) import Data.Functor            ( fmap, (<$>) ) import Data.Maybe              ( Maybe(Nothing, Just) )+import Data.List               ( (++) ) import Data.Tuple              ( fst ) import Data.Typeable           ( Typeable ) import Prelude                 ( Integer, succ, pred, error )@@ -84,14 +84,9 @@  #if __GLASGOW_HASKELL__ < 700 import Prelude                 ( fromInteger )-import Control.Monad           ( fail, (>>=) )+import Control.Monad           ( Monad, fail, (>>=) ) #endif --- from base-unicode-symbols:-import Data.Eq.Unicode         ( (≡) )-import Data.Function.Unicode   ( (∘) )-import Data.Monoid.Unicode     ( (⊕) )- -- from concurrent-extra (this package): import           Control.Concurrent.Lock ( Lock ) import qualified Control.Concurrent.Lock as Lock@@ -111,7 +106,7 @@  * Its /acquired count/: how many times its owner acquired the lock. -}-newtype RLock = RLock {un ∷ MVar (State, Lock)}+newtype RLock = RLock {un :: MVar (State, Lock)}     deriving (Eq, Typeable)  {-| The state of an 'RLock'.@@ -129,17 +124,17 @@ --------------------------------------------------------------------------------  -- | Create a reentrant lock in the \"unlocked\" state.-new ∷ IO RLock-new = do lock ← Lock.new+new :: IO RLock+new = do lock <- Lock.new          RLock <$> newMVar (Nothing, lock)  {-| Create a reentrant lock in the \"locked\" state (with the current thread as owner and an acquired count of 1). -}-newAcquired ∷ IO RLock-newAcquired = do myTID ← myThreadId-                 lock ← Lock.newAcquired+newAcquired :: IO RLock+newAcquired = do myTID <- myThreadId+                 lock <- Lock.newAcquired                  RLock <$> newMVar (Just (myTID, 1), lock)  @@ -174,19 +169,19 @@ using locks. (Note that this differs from the Python implementation where the wake-up order is undefined.) -}-acquire ∷ RLock → IO ()+acquire :: RLock -> IO () acquire (RLock mv) = do-  myTID ← myThreadId-  mask_ $ let acq = do t@(mb, lock) ← takeMVar mv+  myTID <- myThreadId+  mask_ $ let acq = do t@(mb, lock) <- takeMVar mv                        case mb of-                         Nothing         → do Lock.acquire lock-                                              putMVar mv (Just (myTID, 1), lock)+                         Nothing          -> do Lock.acquire lock+                                                putMVar mv (Just (myTID, 1), lock)                          Just (tid, n)-                           | myTID ≡ tid → let !sn = succ n-                                           in putMVar mv (Just (tid, sn), lock)-                           | otherwise   → do putMVar mv t-                                              Lock.wait lock-                                              acq+                           | myTID == tid -> let !sn = succ n+                                             in putMVar mv (Just (tid, sn), lock)+                           | otherwise    -> do putMVar mv t+                                                Lock.wait lock+                                                acq           in acq  {-|@@ -199,22 +194,22 @@ * When the state is \"locked\" @tryAcquire@ leaves the state unchanged and returns 'False'. -}-tryAcquire ∷ RLock → IO Bool+tryAcquire :: RLock -> IO Bool tryAcquire (RLock mv) = do-  myTID ← myThreadId+  myTID <- myThreadId   mask_ $ do-    t@(mb, lock) ← takeMVar mv+    t@(mb, lock) <- takeMVar mv     case mb of-      Nothing         → do Lock.acquire lock-                           putMVar mv (Just (myTID, 1), lock)-                           return True+      Nothing          -> do Lock.acquire lock+                             putMVar mv (Just (myTID, 1), lock)+                             return True       Just (tid, n)-        | myTID ≡ tid → do let !sn = succ n-                           putMVar mv (Just (tid, sn), lock)-                           return True+        | myTID == tid -> do let !sn = succ n+                             putMVar mv (Just (tid, sn), lock)+                             return True -        | otherwise   → do putMVar mv t-                           return False+        | otherwise    -> do putMVar mv t+                             return False  {-| @release@ decrements the acquired count. When a lock is released with an acquired count of 1 its state is changed to \"unlocked\".@@ -225,22 +220,22 @@ If there are any threads blocked on 'acquire' the thread that first called @acquire@ will be woken up. -}-release ∷ RLock → IO ()+release :: RLock -> IO () release (RLock mv) = do-  myTID ← myThreadId+  myTID <- myThreadId   mask_ $ do-    t@(mb, lock) ← takeMVar mv+    t@(mb, lock) <- takeMVar mv     let err msg = do putMVar mv t-                     error $ "Control.Concurrent.RLock.release: " ⊕ msg+                     error $ "Control.Concurrent.RLock.release: " ++ msg     case mb of-      Nothing → err "Can't release an unacquired RLock!"+      Nothing -> err "Can't release an unacquired RLock!"       Just (tid, n)-        | myTID ≡ tid → if n ≡ 1-                        then do Lock.release lock-                                putMVar mv (Nothing, lock)-                        else let !pn = pred n-                             in putMVar mv (Just (tid, pn), lock)-        | otherwise → err "Calling thread does not own the RLock!"+        | myTID == tid -> if n == 1+                          then do Lock.release lock+                                  putMVar mv (Nothing, lock)+                          else let !pn = pred n+                               in putMVar mv (Just (tid, pn), lock)+        | otherwise -> err "Calling thread does not own the RLock!"   --------------------------------------------------------------------------------@@ -253,7 +248,7 @@  Note that: @with = 'liftA2' 'bracket_' 'acquire' 'release'@. -}-with ∷ RLock → IO α → IO α+with :: RLock -> IO a -> IO a with = liftA2 bracket_ acquire release  {-|@@ -263,11 +258,11 @@ by raising an exception, the lock is released and 'Just' the result of the computation is returned. -}-tryWith ∷ RLock → IO α → IO (Maybe α)-tryWith l a = mask $ \restore → do-  acquired ← tryAcquire l+tryWith :: RLock -> IO a -> IO (Maybe a)+tryWith l a = mask $ \restore -> do+  acquired <- tryAcquire l   if acquired-    then do r ← restore a `onException` release l+    then do r <- restore a `onException` release l             release l             return $ Just r     else return Nothing@@ -284,7 +279,7 @@  @wait l = 'block' '$' 'acquire' l '>>' 'release' l@ -}-wait ∷ RLock → IO ()+wait :: RLock -> IO () wait l = mask_ $ acquire l >> release l  @@ -298,5 +293,5 @@ Note that this is only a snapshot of the state. By the time a program reacts on its result it may already be out of date. -}-state ∷ RLock → IO State-state = fmap fst ∘ readMVar ∘ un+state :: RLock -> IO State+state = fmap fst . readMVar . un

@@ -1,7 +1,6 @@ {-# LANGUAGE CPP            , NoImplicitPrelude-           , UnicodeSyntax-           , ScopedTypeVariables  +           , ScopedTypeVariables   #-}  module Control.Concurrent.RLock.Test ( tests ) where@@ -12,9 +11,10 @@ -------------------------------------------------------------------------------  -- from base:+import Prelude            ( (*) ) import Control.Concurrent ( forkIO, threadDelay ) import Control.Monad      ( replicateM_ )-import Data.Function      ( ($) )+import Data.Function      ( ($), (.) ) import Data.Int           ( Int )  #if __GLASGOW_HASKELL__ < 700@@ -22,10 +22,6 @@ import Control.Monad      ( (>>=), fail, (>>) ) #endif --- from base-unicode-symbols:-import Data.Function.Unicode ( (∘) )-import Prelude.Unicode       ( (⋅) )- -- from concurrent-extra: import qualified Control.Concurrent.Event as Event ( new, set, wait ) import qualified Control.Concurrent.RLock as RLock@@ -45,35 +41,35 @@ -- Tests for RLock ------------------------------------------------------------------------------- -tests ∷ [Test]+tests :: [Test] tests = [ testCase "recursive acquire"  $ test_rlock_1 5         , testCase "conc acquire"       $ test_rlock_2         ] -test_rlock_1 ∷ Int → Assertion-test_rlock_1 n = assert ∘ within (10 ⋅ a_moment) $ do-  l ← RLock.new+test_rlock_1 :: Int -> Assertion+test_rlock_1 n = assert . within (10 * a_moment) $ do+  l <- RLock.new   replicateM_ n $ RLock.acquire l   replicateM_ n $ RLock.release l  -- Tests for bug found by Felipe Lessa.-test_rlock_2 ∷ Assertion-test_rlock_2 = assert ∘ within (20 ⋅ a_moment) $ do-  rl           ← RLock.new-  t1_has_rlock ← Event.new-  t1_done      ← Event.new-  t2_done      ← Event.new+test_rlock_2 :: Assertion+test_rlock_2 = assert . within (20 * a_moment) $ do+  rl           <- RLock.new+  t1_has_rlock <- Event.new+  t1_done      <- Event.new+  t2_done      <- Event.new    -- Thread 1-  _ ← forkIO $ do+  _ <- forkIO $ do     RLock.acquire rl     Event.set t1_has_rlock-    threadDelay $ 10 ⋅ a_moment+    threadDelay $ 10 * a_moment     RLock.release rl     Event.set t1_done    -- Thread 2-  _ ← forkIO $ do+  _ <- forkIO $ do     Event.wait t1_has_rlock     RLock.acquire rl     RLock.release rl

@@ -2,7 +2,6 @@            , DeriveDataTypeable            , NamedFieldPuns            , NoImplicitPrelude-           , UnicodeSyntax   #-}  #if __GLASGOW_HASKELL__ >= 704@@ -78,9 +77,10 @@ import Control.Monad           ( return, (>>) ) import Data.Bool               ( Bool(False, True) ) import Data.Eq                 ( Eq, (==) )-import Data.Function           ( ($), on )+import Data.Function           ( ($), (.), on ) import Data.Int                ( Int ) import Data.Maybe              ( Maybe(Nothing, Just) )+import Data.List               ( (++)) import Data.Typeable           ( Typeable ) import Prelude                 ( String, ($!), succ, pred, error ) import System.IO               ( IO )@@ -90,10 +90,6 @@ import Control.Monad           ( (>>=), fail ) #endif --- from base-unicode-symbols:-import Data.Function.Unicode   ( (∘) )-import Data.Monoid.Unicode     ( (⊕) )- -- from concurrent-extra (this package): import           Control.Concurrent.Lock ( Lock ) import qualified Control.Concurrent.Lock as Lock@@ -116,9 +112,9 @@ * \"Write\": A single thread has acquired write access. Blocks other threads from acquiring both read and write access. -}-data RWLock = RWLock { state     ∷ MVar State-                     , readLock  ∷ Lock-                     , writeLock ∷ Lock+data RWLock = RWLock { state     :: MVar State+                     , readLock  :: Lock+                     , writeLock :: Lock                      } deriving Typeable  instance Eq RWLock where@@ -134,21 +130,21 @@  -- | Create a new 'RWLock' in the \"free\" state; either read or write access -- can be acquired without blocking.-new ∷ IO RWLock+new :: IO RWLock new = liftA3 RWLock (newMVar Free)                     Lock.new                     Lock.new  -- | Create a new 'RWLock' in the \"read\" state; only read can be acquired -- without blocking.-newAcquiredRead ∷ IO RWLock+newAcquiredRead :: IO RWLock newAcquiredRead = liftA3 RWLock (newMVar $ Read 1)                                 Lock.newAcquired                                 Lock.new  -- | Create a new 'RWLock' in the \"write\" state; either acquiring read or -- write will block.-newAcquiredWrite ∷ IO RWLock+newAcquiredWrite :: IO RWLock newAcquiredWrite = liftA3 RWLock (newMVar Write)                                  Lock.new                                  Lock.newAcquired@@ -167,17 +163,17 @@ Implementation note: Throws an exception when more than (maxBound :: Int) simultaneous threads acquire the read lock. But that is unlikely. -}-acquireRead ∷ RWLock → IO ()+acquireRead :: RWLock -> IO () acquireRead (RWLock {state, readLock, writeLock}) = mask_ acqRead     where-      acqRead = do st ← takeMVar state+      acqRead = do st <- takeMVar state                    case st of-                     Free   → do Lock.acquire readLock-                                 putMVar state $ Read 1-                     Read n → putMVar state ∘ Read $! succ n-                     Write  → do putMVar state st-                                 Lock.wait writeLock-                                 acqRead+                     Free   -> do Lock.acquire readLock+                                  putMVar state $ Read 1+                     Read n -> putMVar state . Read $! succ n+                     Write  -> do putMVar state st+                                  Lock.wait writeLock+                                  acqRead  {-| Try to acquire the read lock; non blocking.@@ -185,17 +181,17 @@ Like 'acquireRead', but doesn't block. Returns 'True' if the resulting state is \"read\", 'False' otherwise. -}-tryAcquireRead ∷ RWLock → IO Bool+tryAcquireRead :: RWLock -> IO Bool tryAcquireRead (RWLock {state, readLock}) = mask_ $ do-  st ← takeMVar state+  st <- takeMVar state   case st of-    Free   → do Lock.acquire readLock-                putMVar state $ Read 1-                return True-    Read n → do putMVar state ∘ Read $! succ n-                return True-    Write  → do putMVar state st-                return False+    Free   -> do Lock.acquire readLock+                 putMVar state $ Read 1+                 return True+    Read n -> do putMVar state . Read $! succ n+                 return True+    Write  -> do putMVar state st+                 return False  {-| Release the read lock.@@ -206,22 +202,22 @@ It is an error to release read access to an 'RWLock' which is not in the \"read\" state. -}-releaseRead ∷ RWLock → IO ()+releaseRead :: RWLock -> IO () releaseRead (RWLock {state, readLock}) = mask_ $ do-  st ← takeMVar state+  st <- takeMVar state   case st of-    Read 1 → do Lock.release readLock-                putMVar state Free-    Read n → putMVar state ∘ Read $! pred n-    _ → do putMVar state st-           error $ moduleName ⊕ ".releaseRead: already released"+    Read 1 -> do Lock.release readLock+                 putMVar state Free+    Read n -> putMVar state . Read $! pred n+    _ -> do putMVar state st+            error $ moduleName ++ ".releaseRead: already released"  {-| A convenience function wich first acquires read access and then performs the computation. When the computation terminates, whether normally or by raising an exception, the read lock is released. -}-withRead ∷ RWLock → IO α → IO α+withRead :: RWLock -> IO a -> IO a withRead = liftA2 bracket_ acquireRead releaseRead  {-|@@ -230,11 +226,11 @@ computation terminates, whether normally or by raising an exception, the lock is released and 'Just' the result of the computation is returned. -}-tryWithRead ∷ RWLock → IO α → IO (Maybe α)-tryWithRead l a = mask $ \restore → do-  acquired ← tryAcquireRead l+tryWithRead :: RWLock -> IO a -> IO (Maybe a)+tryWithRead l a = mask $ \restore -> do+  acquired <- tryAcquireRead l   if acquired-    then do r ← restore a `onException` releaseRead l+    then do r <- restore a `onException` releaseRead l             releaseRead l             return $ Just r     else return Nothing@@ -251,7 +247,7 @@  @waitRead l = 'mask_' '$' 'acquireRead' l '>>' 'releaseRead' l@ -}-waitRead ∷ RWLock → IO ()+waitRead :: RWLock -> IO () waitRead l = mask_ $ acquireRead l >> releaseRead l  @@ -266,19 +262,19 @@ @acquireWrite@ terminates without throwing an exception the state of the 'RWLock' will be \"write\". -}-acquireWrite ∷ RWLock → IO ()+acquireWrite :: RWLock -> IO () acquireWrite (RWLock {state, readLock, writeLock}) = mask_ acqWrite     where-      acqWrite = do st ← takeMVar state+      acqWrite = do st <- takeMVar state                     case st of-                      Free   → do Lock.acquire writeLock-                                  putMVar state Write-                      Read _ → do putMVar state st-                                  Lock.wait readLock-                                  acqWrite-                      Write  → do putMVar state st-                                  Lock.wait writeLock-                                  acqWrite+                      Free   -> do Lock.acquire writeLock+                                   putMVar state Write+                      Read _ -> do putMVar state st+                                   Lock.wait readLock+                                   acqWrite+                      Write  -> do putMVar state st+                                   Lock.wait writeLock+                                   acqWrite  {-| Try to acquire the write lock; non blocking.@@ -286,15 +282,15 @@ Like 'acquireWrite', but doesn't block. Returns 'True' if the resulting state is \"write\", 'False' otherwise. -}-tryAcquireWrite ∷ RWLock → IO Bool+tryAcquireWrite :: RWLock -> IO Bool tryAcquireWrite (RWLock {state, writeLock}) = mask_ $ do-  st ← takeMVar state+  st <- takeMVar state   case st of-    Free   → do Lock.acquire writeLock-                putMVar state Write-                return True-    _      → do putMVar state st-                return False+    Free   -> do Lock.acquire writeLock+                 putMVar state Write+                 return True+    _      -> do putMVar state st+                 return False  {-| Release the write lock.@@ -305,21 +301,21 @@ It is an error to release write access to an 'RWLock' which is not in the \"write\" state. -}-releaseWrite ∷ RWLock → IO ()+releaseWrite :: RWLock -> IO () releaseWrite (RWLock {state, writeLock}) = mask_ $ do-  st ← takeMVar state+  st <- takeMVar state   case st of-    Write → do Lock.release writeLock-               putMVar state Free-    _ → do putMVar state st-           error $ moduleName ⊕ ".releaseWrite: already released"+    Write -> do Lock.release writeLock+                putMVar state Free+    _ -> do putMVar state st+            error $ moduleName ++ ".releaseWrite: already released"  {-| A convenience function wich first acquires write access and then performs the computation. When the computation terminates, whether normally or by raising an exception, the write lock is released. -}-withWrite ∷ RWLock → IO α → IO α+withWrite :: RWLock -> IO a -> IO a withWrite = liftA2 bracket_ acquireWrite releaseWrite  {-|@@ -328,11 +324,11 @@ computation terminates, whether normally or by raising an exception, the lock is released and 'Just' the result of the computation is returned. -}-tryWithWrite ∷ RWLock → IO α → IO (Maybe α)-tryWithWrite l a = mask $ \restore → do-  acquired ← tryAcquireWrite l+tryWithWrite :: RWLock -> IO a -> IO (Maybe a)+tryWithWrite l a = mask $ \restore -> do+  acquired <- tryAcquireWrite l   if acquired-    then do r ← restore a `onException` releaseWrite l+    then do r <- restore a `onException` releaseWrite l             releaseWrite l             return $ Just r     else return Nothing@@ -349,8 +345,8 @@  @waitWrite l = 'mask_' '$' 'acquireWrite' l '>>' 'releaseWrite' l@ -}-waitWrite ∷ RWLock → IO ()+waitWrite :: RWLock -> IO () waitWrite l = mask_ $ acquireWrite l >> releaseWrite l -moduleName ∷ String+moduleName :: String moduleName = "Control.Concurrent.ReadWriteLock"

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, NoImplicitPrelude , UnicodeSyntax #-}+{-# LANGUAGE CPP, NoImplicitPrelude #-}  module Control.Concurrent.ReadWriteLock.Test ( tests ) where @@ -8,6 +8,7 @@ -------------------------------------------------------------------------------  -- from base:+import Prelude            ( (*) ) import Control.Monad      ( (>>), (>>=), replicateM_ ) import Control.Concurrent ( forkIO, threadDelay ) import Data.Function      ( ($) )@@ -20,9 +21,6 @@ import Control.Monad      ( (>>=), fail ) #endif --- from base-unicode-symbols:-import Prelude.Unicode    ( (⋅) )- -- from async: import Control.Concurrent.Async ( Concurrently(Concurrently), runConcurrently ) @@ -48,16 +46,16 @@ -- Tests for ReadWriteLock ------------------------------------------------------------------------------- -tests ∷ [Test]+tests :: [Test] tests = [ testCase "test1" test1         , testCase "test2" test2         , testCase "stressTest" stressTest         ] -test1 ∷ Assertion-test1 = assert $ within (10 ⋅ a_moment) $ do+test1 :: Assertion+test1 = assert $ within (10 * a_moment) $ do           -- Create a new read-write-lock (in the "Free" state):-          rwl ← RWLock.new+          rwl <- RWLock.new            -- Put the read-write-lock in the "Write" state:           RWLock.acquireWrite rwl@@ -76,10 +74,10 @@           -- following shouldn't deadlock:           RWLock.acquireWrite rwl -test2 ∷ Assertion-test2 = assert $ within (10 ⋅ a_moment) $ do+test2 :: Assertion+test2 = assert $ within (10 * a_moment) $ do           -- Create a new read-write-lock (in the "Free" state):-          rwl ← RWLock.new+          rwl <- RWLock.new            -- Put the read-write-lock in the "Read" state:           RWLock.acquireRead rwl@@ -99,7 +97,7 @@           RWLock.acquireRead rwl  stressTest :: Assertion-stressTest = assert $ within (500 ⋅ a_moment) $ do+stressTest = assert $ within (500 * a_moment) $ do   lock <- RWLock.new    let randomDelay hi = randomRIO (0, hi) >>= threadDelay

@@ -2,7 +2,6 @@            , DeriveDataTypeable            , NoImplicitPrelude            , TupleSections-           , UnicodeSyntax   #-}  #if __GLASGOW_HASKELL__ >= 704@@ -71,7 +70,7 @@ import Control.Monad       ( (>>=) ) import Data.Bool           ( Bool(..) ) import Data.Eq             ( Eq, (==) )-import Data.Function       ( ($), on )+import Data.Function       ( ($), (.), on ) import Data.Functor        ( fmap  ) import Data.Maybe          ( Maybe(..), isJust ) import Data.IORef          ( IORef, newIORef, readIORef )@@ -82,9 +81,6 @@ import Prelude             ( undefined ) #endif --- from base-unicode-symbols:-import Data.Function.Unicode ( (∘) )- -- from concurrent-extra (this package): import           Control.Concurrent.ReadWriteLock ( RWLock ) import qualified Control.Concurrent.ReadWriteLock as RWLock@@ -97,16 +93,16 @@ -------------------------------------------------------------------------------  -- | Concurrently readable and sequentially writable variable.-data RWVar α = RWVar RWLock (IORef α) deriving Typeable+data RWVar a = RWVar RWLock (IORef a) deriving Typeable -instance Eq (RWVar α) where+instance Eq (RWVar a) where     (==) = (==) `on` rwlock         where           rwlock (RWVar rwl _) = rwl  -- | Create a new 'RWVar'.-new ∷ α → IO (RWVar α)-new = liftA2 RWVar RWLock.new ∘ newIORef+new :: a -> IO (RWVar a)+new = liftA2 RWVar RWLock.new . newIORef  {-| Execute an action that operates on the contents of the 'RWVar'. @@ -117,13 +113,13 @@ If another thread is modifying the contents of the 'RWVar' this function will block until the other thread finishes its action. -}-with ∷ RWVar α → (α → IO β) → IO β+with :: RWVar a -> (a -> IO b) -> IO b with (RWVar l r) f = RWLock.withRead l $ readIORef r >>= f  {-| Like 'with' but doesn't block. Returns 'Just' the result if read access could be acquired without blocking, 'Nothing' otherwise. -}-tryWith ∷ RWVar α → (α → IO β) → IO (Maybe β)+tryWith :: RWVar a -> (a -> IO b) -> IO (Maybe b) tryWith (RWVar l r) f = RWLock.tryWithRead l $ readIORef r >>= f  {-| Modify the contents of an 'RWVar'.@@ -131,29 +127,29 @@ This function needs exclusive write access to the 'RWVar'. Only one thread can modify an 'RWVar' at the same time. All others will block. -}-modify_ ∷ RWVar α → (α → IO α) → IO ()-modify_ (RWVar l r) = RWLock.withWrite l ∘ modifyIORefM_ r+modify_ :: RWVar a -> (a -> IO a) -> IO ()+modify_ (RWVar l r) = RWLock.withWrite l . modifyIORefM_ r  {-| Modify the contents of an 'RWVar' and return an additional value.  Like 'modify_', but allows a value to be returned (β) in addition to the modified value of the 'RWVar'. -}-modify ∷ RWVar α → (α → IO (α, β)) → IO β-modify (RWVar l r) = RWLock.withWrite l ∘ modifyIORefM r+modify :: RWVar a -> (a -> IO (a, b)) -> IO b+modify (RWVar l r) = RWLock.withWrite l . modifyIORefM r  {-| Attempt to modify the contents of an 'RWVar'.  Like 'modify_', but doesn't block. Returns 'True' if the contents could be replaced, 'False' otherwise. -}-tryModify_ ∷ RWVar α → (α → IO α) → IO Bool-tryModify_ (RWVar l r) = fmap isJust ∘ RWLock.tryWithWrite l ∘ modifyIORefM_ r+tryModify_ :: RWVar a -> (a -> IO a) -> IO Bool+tryModify_ (RWVar l r) = fmap isJust . RWLock.tryWithWrite l . modifyIORefM_ r  {-| Attempt to modify the contents of an 'RWVar' and return an additional value.  Like 'modify', but doesn't block. Returns 'Just' the additional value if the contents could be replaced, 'Nothing' otherwise. -}-tryModify ∷ RWVar α → (α → IO (α, β)) → IO (Maybe β)-tryModify (RWVar l r) = RWLock.tryWithWrite l ∘ modifyIORefM r+tryModify :: RWVar a -> (a -> IO (a, b)) -> IO (Maybe b)+tryModify (RWVar l r) = RWLock.tryWithWrite l . modifyIORefM r

@@ -1,6 +1,4 @@-{-# LANGUAGE NoImplicitPrelude-           , UnicodeSyntax-  #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Control.Concurrent.ReadWriteVar.Test ( tests ) where @@ -12,9 +10,6 @@ -- from base: import Control.Concurrent ( ) --- from base-unicode-symbols:-import Prelude.Unicode       ( )- -- from concurrent-extra: import qualified Control.Concurrent.ReadWriteVar as RWVar ( ) import TestUtils ( )@@ -33,5 +28,5 @@ -- Tests for ReadWriteVar ------------------------------------------------------------------------------- -tests ∷ [Test]+tests :: [Test] tests = []

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude, UnicodeSyntax #-}+{-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude #-}  #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Trustworthy #-}@@ -52,7 +52,7 @@ -- from base: import Control.Applicative          ( liftA2 ) import Control.Exception            ( bracket_, onException )-import Control.Monad                ( Monad, return, (>>), when )+import Control.Monad                ( return, (>>), when ) import Data.Bool                    ( Bool, not )  #ifdef __HADDOCK__@@ -60,7 +60,7 @@ #endif  import Data.Eq                      ( Eq )-import Data.Function                ( ($) )+import Data.Function                ( ($), (.) ) import Data.Functor                 ( fmap, (<$>) ) import Data.Maybe                   ( Maybe(Nothing, Just), isJust ) import Data.Typeable                ( Typeable )@@ -71,6 +71,10 @@ import Control.Monad                ( (>>=), fail ) #endif +#if __GLASGOW_HASKELL__ < 700+import Control.Monad                ( Monad )+#endif+ -- from stm: import Control.Concurrent.STM       ( STM, atomically ) @@ -84,9 +88,6 @@                                     , isEmptyTMVar                                     ) --- from base-unicode-symbols:-import Data.Function.Unicode        ( (∘) )- -- from concurrent-extra (this package): import Utils                        ( mask ) @@ -96,7 +97,7 @@ --------------------------------------------------------------------------------  -- | A lock is in one of two states: \"locked\" or \"unlocked\".-newtype Lock = Lock {un ∷ TMVar ()}+newtype Lock = Lock {un :: TMVar ()}     deriving (Typeable, Eq)  @@ -105,11 +106,11 @@ --------------------------------------------------------------------------------  -- | Create a lock in the \"unlocked\" state.-new ∷ STM Lock+new :: STM Lock new = Lock <$> newTMVar ()  -- | Create a lock in the \"locked\" state.-newAcquired ∷ STM Lock+newAcquired :: STM Lock newAcquired = Lock <$> newEmptyTMVar  @@ -122,8 +123,8 @@  * When the state is \"unlocked\" @acquire@ will change the state to \"locked\". -}-acquire ∷ Lock → STM ()-acquire = takeTMVar ∘ un+acquire :: Lock -> STM ()+acquire = takeTMVar . un  {-| A non-blocking 'acquire'.@@ -134,17 +135,17 @@ * When the state is \"locked\" @tryAcquire@ leaves the state unchanged and returns 'False'. -}-tryAcquire ∷ Lock → STM Bool-tryAcquire = fmap isJust ∘ tryTakeTMVar ∘ un+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 -> STM () release (Lock tmv) = do-  b ← tryPutTMVar tmv ()+  b <- tryPutTMVar tmv ()   when (not b) $ error "Control.Concurrent.STM.Lock.release: Can't release unlocked Lock!"  @@ -157,8 +158,8 @@ 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)+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@@ -167,11 +168,11 @@ 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 = mask $ \restore → do-  acquired ← atomically (tryAcquire l)+tryWith :: Lock -> IO a -> IO (Maybe a)+tryWith l a = mask $ \restore -> do+  acquired <- atomically (tryAcquire l)   if acquired-    then do r ← restore a `onException` atomically (release l)+    then do r <- restore a `onException` atomically (release l)             atomically (release l)             return $ Just r     else return Nothing@@ -187,7 +188,7 @@  @wait l = 'acquire' l '>>' 'release' l@ -}-wait ∷ Lock → STM ()+wait :: Lock -> STM () wait (Lock tmv) = takeTMVar tmv >> putTMVar tmv ()  @@ -201,5 +202,5 @@ 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+locked :: Lock -> STM Bool+locked = isEmptyTMVar . un

@@ -1,6 +1,5 @@ {-# LANGUAGE CPP            , NoImplicitPrelude-           , UnicodeSyntax            , ScopedTypeVariables   #-} @@ -11,10 +10,11 @@ -------------------------------------------------------------------------------  -- from base:+import Prelude            ( (*) ) import Control.Concurrent ( forkIO ) import Control.Monad      ( return, (>>=), (>>) ) import Data.Bool          ( Bool(False, True), not, (&&) )-import Data.Function      ( ($) )+import Data.Function      ( ($), (.) ) import Data.Functor       ( fmap ) import Data.IORef         ( newIORef, writeIORef, readIORef ) @@ -23,10 +23,6 @@ import Control.Monad      ( fail ) #endif --- from base-unicode-symbols:-import Data.Function.Unicode ( (∘) )-import Prelude.Unicode       ( (⋅) )- -- from stm: import Control.Concurrent.STM ( atomically ) @@ -48,7 +44,7 @@ -- Tests for Lock ------------------------------------------------------------------------------- -tests ∷ [Test]+tests :: [Test] tests = [ testCase "acquire release"    test_lock_1         , testCase "acquire acquire"    test_lock_2         , testCase "new release"        test_lock_3@@ -59,48 +55,48 @@         , testCase "wait"               test_lock_8         ] -test_lock_1 ∷ Assertion+test_lock_1 :: Assertion test_lock_1 = assert $ within a_moment $ atomically $ do-  l ← Lock.new+  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+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 :: 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_4 :: Assertion+test_lock_4 = assert $ atomically $ Lock.new >>= fmap not . Lock.locked -test_lock_5 ∷ Assertion+test_lock_5 :: Assertion test_lock_5 = assert $ atomically $ Lock.newAcquired >>= Lock.locked -test_lock_6 ∷ Assertion+test_lock_6 :: Assertion test_lock_6 = assert $ atomically $ do-  l ← Lock.new+  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)+test_lock_7 :: Assertion+test_lock_7 = assert . within (10 * a_moment) $ do+  l <- atomically $ Lock.newAcquired+  _ <- forkIO $ wait_a_moment >> atomically (Lock.release l)   atomically $ Lock.acquire l -test_lock_8 ∷ Assertion+test_lock_8 :: Assertion test_lock_8 = assert $ do-  ioRef ← newIORef False-  l ← atomically Lock.newAcquired-  _ ← forkIO $ do wait_a_moment-                  writeIORef ioRef True-                  atomically $ Lock.release l+  ioRef <- newIORef False+  l <- atomically Lock.newAcquired+  _ <- forkIO $ do wait_a_moment+                   writeIORef ioRef True+                   atomically $ Lock.release l   atomically $ Lock.wait l-  set ← readIORef ioRef-  locked ← atomically $ Lock.locked l+  set <- readIORef ioRef+  locked <- atomically $ Lock.locked l   return $ set && not locked

@@ -1,6 +1,6 @@ #! /usr/bin/env runhaskell -{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Main (main) where @@ -28,17 +28,14 @@ -- Cabal setup program which sets the CPP define '__HADDOCK __' when haddock is run. ------------------------------------------------------------------------------- -main ∷ IO ()+main :: IO () main = defaultMainWithHooks hooks   where     hooks = simpleUserHooks { haddockHook = haddockHook' }  -- Define __HADDOCK__ for CPP when running haddock.-haddockHook' ∷ PackageDescription → LocalBuildInfo → UserHooks → HaddockFlags → IO ()+haddockHook' :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO () haddockHook' pkg lbi =-  haddockHook simpleUserHooks pkg (lbi { withPrograms = p })+    haddockHook simpleUserHooks pkg (lbi { withPrograms = p })   where     p = userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] (withPrograms lbi)----- The End ---------------------------------------------------------------------

@@ -1,7 +1,6 @@ {-# LANGUAGE CPP            , NoImplicitPrelude            , ScopedTypeVariables-           , UnicodeSyntax     #-}  module TestUtils where@@ -38,24 +37,21 @@ -------------------------------------------------------------------------------  -- Exactly 1 moment. Currently equal to 0.005 seconds.-a_moment ∷ Int+a_moment :: Int a_moment = 5000 -wait_a_moment ∷ IO ()+wait_a_moment :: IO () wait_a_moment = threadDelay a_moment  -- True if the action 'a' evaluates within 't' μs.-within ∷ Int → IO α → IO Bool+within :: Int -> IO a -> IO Bool within t a = isJust <$> timeout t a -notWithin ∷ Int → IO α → IO Bool+notWithin :: Int -> IO a -> IO Bool notWithin t a = not <$> within t a -assertException ∷ String → IO α → Assertion-assertException errMsg a = do e ← try a+assertException :: String -> IO a -> Assertion+assertException errMsg a = do e <- try a                               case e of-                                Left (_ ∷ SomeException ) → return ()-                                Right _ → assertFailure errMsg----- The End ---------------------------------------------------------------------+                                Left (_ :: SomeException ) -> return ()+                                Right _ -> assertFailure errMsg

@@ -1,9 +1,9 @@-{-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax #-}+{-# LANGUAGE CPP, NoImplicitPrelude #-}  module Utils     ( mask     , mask_-    , (∘!)+    , (.!)     , void     , ifM     , purelyModifyMVar@@ -19,7 +19,7 @@ import Control.Concurrent.MVar ( MVar, takeMVar, putMVar ) import Control.Monad           ( Monad, return, (>>=) ) import Data.Bool               ( Bool )-import Data.Function           ( ($) )+import Data.Function           ( ($), (.) ) import Data.IORef              ( IORef, readIORef, writeIORef ) import Prelude                 ( ($!) ) import System.IO               ( IO )@@ -28,10 +28,7 @@ import Control.Monad           ( (>>), fail ) #endif --- from base-unicode-symbols:-import Data.Function.Unicode   ( (∘) ) - -------------------------------------------------------------------------------- -- Utility functions --------------------------------------------------------------------------------@@ -44,33 +41,30 @@ import Data.Function           ( id ) import Data.Functor            ( Functor, (<$) ) -mask ∷ ((IO α → IO α) → IO β) → IO β-mask io = blocked >>= \b → if b then io id else block $ io unblock+mask :: ((IO a -> IO a) -> IO b) -> IO b+mask io = blocked >>= \b -> if b then io id else block $ io unblock -mask_ ∷ IO α → IO α+mask_ :: IO a -> IO a mask_ = block -void ∷ Functor f ⇒ f α → f ()+void :: (Functor f) => f a -> f () void = (() <$) #endif  -- | Strict function composition.-(∘!) ∷ (β → γ) → (α → β) → (α → γ)-f ∘! g = (f $!) ∘ g+(.!) :: (b -> γ) -> (a -> b) -> (a -> γ)+f .! g = (f $!) . g -ifM ∷ Monad m ⇒ m Bool → m α → m α → m α-ifM c t e = c >>= \b → if b then t else e+ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM c t e = c >>= \b -> if b then t else e -purelyModifyMVar ∷ MVar α → (α → α) → IO ()-purelyModifyMVar mv f = mask_ $ takeMVar mv >>= putMVar mv ∘! f+purelyModifyMVar :: MVar a -> (a -> a) -> IO ()+purelyModifyMVar mv f = mask_ $ takeMVar mv >>= putMVar mv .! f -modifyIORefM ∷ IORef α → (α → IO (α, β)) → IO β-modifyIORefM r f = do (y, z) ← readIORef r >>= f+modifyIORefM :: IORef a -> (a -> IO (a, b)) -> IO b+modifyIORefM r f = do (y, z) <- readIORef r >>= f                       writeIORef r y                       return z -modifyIORefM_ ∷ IORef α → (α → IO α) → IO ()+modifyIORefM_ :: IORef a -> (a -> IO a) -> IO () modifyIORefM_ r f = readIORef r >>= f >>= writeIORef r----- The End ---------------------------------------------------------------------

@@ -1,5 +1,5 @@ name:          concurrent-extra-version:       0.7.0.8+version:       0.7.0.9 cabal-version: >= 1.8 build-type:    Custom stability:     experimental@@ -51,7 +51,6 @@  library   build-depends: base                 >= 3       && < 5-               , base-unicode-symbols >= 0.1.1   && < 0.3                , stm                  >= 2.1.2.1 && < 2.5                , unbounded-delays     >= 0.1     && < 0.2   exposed-modules: Control.Concurrent.Lock@@ -81,11 +80,10 @@   ghc-options: -Wall -threaded    build-depends: base                 >= 3       && < 5-               , base-unicode-symbols >= 0.1.1   && < 0.3                , stm                  >= 2.1.2.1 && < 2.5                , unbounded-delays     >= 0.1     && < 0.2                , HUnit                >= 1.2.2   && < 1.3-               , random               >= 1.0     && < 1.1+               , random               >= 1.0     && < 1.2                , test-framework       >= 0.2.4   && < 0.9                , test-framework-hunit >= 0.2.4   && < 0.4                , async                >= 2.0     && < 2.1

@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Main where @@ -26,10 +26,10 @@ -- Tests ------------------------------------------------------------------------------- -main ∷ IO ()+main :: IO () main = defaultMain tests -tests ∷ [Test]+tests :: [Test] tests = [ testGroup "Pessimistic locking"           [ testGroup "Event"         Event.tests           , testGroup "Lock"          Lock.tests@@ -40,6 +40,3 @@           , testGroup "ReadWriteVar"  RWVar.tests           ]         ]----- The End ---------------------------------------------------------------------