concurrency 1.6.1.0 → 1.6.2.0

raw patch · 6 files changed

+904/−2 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.rst +16/−0
• Control/Concurrent/Classy.hs +6/−0
• Control/Concurrent/Classy/BoundedChan.hs +223/−0
• Control/Concurrent/Classy/Lock.hs +246/−0
• Control/Concurrent/Classy/RWLock.hs +408/−0
• concurrency.cabal +5/−2

@@ -7,6 +7,22 @@ .. _PVP: https://pvp.haskell.org/  +1.6.2.0 (2018-11-28)+--------------------++* Git: :tag:`concurrency-1.6.2.0`+* Hackage: :hackage:`concurrency-1.6.2.0`++**Contributors:** :u:`gip` (:pull:`289`).++Added+~~~~~++* (:pull:`289`) The ``Control.Concurrent.Classy.BoundedChan`` module.+* (:pull:`289`) The ``Control.Concurrent.Classy.Lock`` module.+* (:pull:`289`) The ``Control.Concurrent.Classy.RWLock`` module.++ 1.6.1.0 (2018-09-23) -------------------- 

@@ -24,19 +24,25 @@ module Control.Concurrent.Classy   ( module Control.Monad.Conc.Class   , module Control.Concurrent.Classy.Chan+  , module Control.Concurrent.Classy.BoundedChan   , module Control.Concurrent.Classy.CRef   , module Control.Concurrent.Classy.IORef   , module Control.Concurrent.Classy.MVar   , module Control.Concurrent.Classy.STM   , module Control.Concurrent.Classy.QSem   , module Control.Concurrent.Classy.QSemN+  , module Control.Concurrent.Classy.Lock+  , module Control.Concurrent.Classy.RWLock   ) where +import           Control.Concurrent.Classy.BoundedChan import           Control.Concurrent.Classy.Chan import           Control.Concurrent.Classy.CRef import           Control.Concurrent.Classy.IORef+import           Control.Concurrent.Classy.Lock import           Control.Concurrent.Classy.MVar import           Control.Concurrent.Classy.QSem import           Control.Concurrent.Classy.QSemN+import           Control.Concurrent.Classy.RWLock import           Control.Concurrent.Classy.STM import           Control.Monad.Conc.Class

@@ -0,0 +1,223 @@+--------------------------------------------------------------------------------++-- Copyright © 2009, Galois, Inc.+-- Copyright © 2018, DFINITY Stiftung+-- All rights reserved.+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+--+--   * Redistributions of source code must retain the above copyright+--     notice, this list of conditions and the following disclaimer.+--   * Redistributions in binary form must reproduce the above copyright+--     notice, this list of conditions and the following disclaimer in+--     the documentation and/or other materials provided with the+--     distribution.+--   * Neither the name of the Galois, Inc. nor the names of its+--     contributors may be used to endorse or promote products derived+--     from this software without specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS+-- FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+-- COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+-- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+-- BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+-- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+-- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++--------------------------------------------------------------------------------++-- |+-- Module     : Control.Concurrent.Classy.BoundedChan+-- Copyright  : © 2009 Galois Inc.+--            , © 2018 DFINITY Stiftung+-- Maintainer : DFINITY USA Research <team@dfinity.org>+--+-- Implements bounded channels. These channels differ from normal 'Chan's in+-- that they are guaranteed to contain no more than a certain number of+-- elements. This is ideal when you may be writing to a channel faster than+-- you are able to read from it.+--+-- This module supports all the functions of "Control.Concurrent.Chan" except+-- 'unGetChan' and 'dupChan', which are not supported for bounded channels.+--+-- Extra consistency: This version enforces that if thread Alice writes+-- e1 followed by e2 then e1 will be returned by readBoundedChan before e2.+-- Conversely, if thead Bob reads e1 followed by e2 then it was true that+-- writeBoundedChan e1 preceded writeBoundedChan e2.+--+-- Previous versions did not enforce this consistency: if writeBoundedChan were+-- preempted between putMVars or killThread arrived between putMVars then it+-- can fail.  Similarly it might fail if readBoundedChan were stopped after putMVar+-- and before the second takeMVar.  An unlucky pattern of several such deaths+-- might actually break the invariants of the array in an unrecoverable way+-- causing all future reads and writes to block.++--------------------------------------------------------------------------------++module Control.Concurrent.Classy.BoundedChan+  ( BoundedChan+  , newBoundedChan+  , writeBoundedChan+  , trywriteBoundedChan+  , readBoundedChan+  , tryreadBoundedChan+  , isEmptyBoundedChan+  , writeList2BoundedChan+  ) where++--------------------------------------------------------------------------------++import           Control.Monad                  (replicateM)+import           Data.Array                     (Array, listArray, (!))++import qualified Control.Concurrent.Classy.MVar as MVar+import           Control.Monad.Catch            (mask_, onException)+import           Control.Monad.Conc.Class       (MonadConc(MVar))++--------------------------------------------------------------------------------++-- | A 'BoundedChan' is an abstract data type representing a bounded channel.+--+-- @since 1.6.2.0+data BoundedChan m a+  = BoundedChan+    { _size     :: Int+    , _contents :: Array Int (MVar m a)+    , _writePos :: MVar m Int+    , _readPos  :: MVar m Int+    }+  deriving ()++-- TODO: check if the fields of BoundedChan could be strict / unpacked++--------------------------------------------------------------------------------++-- Versions of modifyMVar and withMVar that do not 'restore' the previous mask+-- state when running 'io', with added modification strictness.+-- The lack of 'restore' may make these perform better than the normal version.+-- Moving strictness here makes using them more pleasant.++{-# INLINE modifyMVarMask #-}+modifyMVarMask :: (MonadConc m) => MVar m a -> (a -> m (a, b)) -> m b+modifyMVarMask m callback = mask_ $ do+  a <- MVar.takeMVar m+  (a', b) <- callback a `onException` MVar.putMVar m a+  MVar.putMVar m $! a'+  pure b++{-# INLINE modifyMVarMask_ #-}+modifyMVarMask_ :: (MonadConc m) => MVar m a -> (a -> m a) -> m ()+modifyMVarMask_ m callback =+  mask_ $ do+    a <- MVar.takeMVar m+    a' <- callback a `onException` MVar.putMVar m a+    MVar.putMVar m $! a'++{-# INLINE withMVarMask #-}+withMVarMask :: (MonadConc m) => MVar m a -> (a -> m b) -> m b+withMVarMask m callback =+  mask_ $ do+    a <- MVar.takeMVar m+    b <- callback a `onException` MVar.putMVar m a+    MVar.putMVar m a+    pure b++--------------------------------------------------------------------------------++-- |+-- @newBoundedChan n@ returns a channel than can contain no more than @n@+-- elements.+--+-- @since 1.6.2.0+newBoundedChan :: (MonadConc m) => Int -> m (BoundedChan m a)+newBoundedChan x = do+  entls <- replicateM x MVar.newEmptyMVar+  wpos  <- MVar.newMVar 0+  rpos  <- MVar.newMVar 0+  let entries = listArray (0, x - 1) entls+  pure (BoundedChan x entries wpos rpos)++-- |+-- Write an element to the channel. If the channel is full, this routine will+-- block until it is able to write. Blockers wait in a fair FIFO queue.+--+-- @since 1.6.2.0+writeBoundedChan :: (MonadConc m) => BoundedChan m a -> a -> m ()+writeBoundedChan (BoundedChan size contents wposMV _) x =+  modifyMVarMask_ wposMV $ \wpos -> do+    MVar.putMVar (contents ! wpos) x+    pure (succ wpos `mod` size) -- only advance when putMVar succeeds++-- |+-- A variant of 'writeBoundedChan' which, instead of blocking when the channel is+-- full, simply aborts and does not write the element. Note that this routine+-- can still block while waiting for write access to the channel.+--+-- @since 1.6.2.0+trywriteBoundedChan :: (MonadConc m) => BoundedChan m a -> a -> m Bool+trywriteBoundedChan (BoundedChan size contents wposMV _) x =+  modifyMVarMask wposMV $ \wpos -> do+    success <- MVar.tryPutMVar (contents ! wpos) x+    -- only advance when putMVar succeeds+    let wpos' = if success then succ wpos `mod` size else wpos+    pure (wpos', success)++-- |+-- Read an element from the channel. If the channel is empty, this routine+-- will block until it is able to read. Blockers wait in a fair FIFO queue.+--+-- @since 1.6.2.0+readBoundedChan :: (MonadConc m) => BoundedChan m a -> m a+readBoundedChan (BoundedChan size contents _ rposMV) =+  modifyMVarMask rposMV $ \rpos -> do+    a <- MVar.takeMVar (contents ! rpos)+    pure (succ rpos `mod` size, a) -- only advance when takeMVar succeeds++-- |+-- A variant of 'readBoundedChan' which, instead of blocking when the channel is+-- empty, immediately returns 'Nothing'. Otherwise, 'tryreadBoundedChan' returns+-- @'Just' a@ where @a@ is the element read from the channel. Note that this+-- routine can still block while waiting for read access to the channel.+--+-- @since 1.6.2.0+tryreadBoundedChan :: (MonadConc m) => BoundedChan m a -> m (Maybe a)+tryreadBoundedChan (BoundedChan size contents _ rposMV) =+  modifyMVarMask rposMV $ \rpos -> do+    ma <- MVar.tryTakeMVar (contents ! rpos)+    -- only advance when takeMVar succeeds+    let rpos' = case ma of+                  Just _  -> succ rpos `mod` size+                  Nothing -> rpos+    pure (rpos', ma)++-- |+-- Returns 'True' if the supplied channel is empty.+--+-- NOTE: This may block on an empty channel if there is a blocked reader.+-- NOTE: This function is deprecated.+--+-- @since 1.6.2.0+{-# DEPRECATED isEmptyBoundedChan+               "This isEmptyBoundedChan can block, no non-blocking substitute yet" #-}+isEmptyBoundedChan :: (MonadConc m) => BoundedChan m a -> m Bool+isEmptyBoundedChan (BoundedChan _ contents _ rposMV) =+  withMVarMask rposMV $ \rpos ->+    MVar.isEmptyMVar (contents ! rpos)++-- |+-- Write a list of elements to the channel.+-- If the channel becomes full, this routine will block until it can write.+-- Competing writers may interleave with this one.+--+-- @since 1.6.2.0+writeList2BoundedChan :: (MonadConc m) => BoundedChan m a -> [a] -> m ()+writeList2BoundedChan = mapM_ . writeBoundedChan++--------------------------------------------------------------------------------

@@ -0,0 +1,246 @@+--------------------------------------------------------------------------------++-- Copyright © 2010-2012 Bas van Dijk & Roel van Dijk+-- Copyright © 2018 DFINITY Stiftung+--+-- All rights reserved.+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+--     * Redistributions of source code must retain the above copyright+--       notice, this list of conditions and the following disclaimer.+--+--     * Redistributions in binary form must reproduce the above+--       copyright notice, this list of conditions and the following+--       disclaimer in the documentation and/or other materials provided+--       with the distribution.+--+--     * The names of Bas van Dijk, Roel van Dijk and the names of+--       contributors may NOT be used to endorse or promote products+--       derived from this software without specific prior written+--       permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++--------------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE UndecidableInstances #-}++--------------------------------------------------------------------------------++-- |+-- Module     : Control.Concurrent.Classy.Lock+-- Copyright  : © 2010-2011 Bas van Dijk & Roel van Dijk+--            , © 2018 DFINITY Stiftung+-- Maintainer : DFINITY USA Research <team@dfinity.org>+--+-- This module provides the 'Lock' synchronisation mechanism. It was inspired by+-- the Python and Java @Lock@ objects and should behave in a similar way. See:+--+-- <http://docs.python.org/3.1/library/threading.html#lock-objects>+--+-- and:+--+-- <http://java.sun.com/javase/7/docs/api/java/util/concurrent/locks/Lock.html>+--+-- All functions are /exception safe/. Throwing asynchronous exceptions will not+-- compromise the internal state of a 'Lock'.++--------------------------------------------------------------------------------++module Control.Concurrent.Classy.Lock+  ( -- * @Lock@+    Lock++    -- * Creating locks+  , newLock+  , newAcquired++    -- * Locking and unlocking+  , acquire+  , tryAcquire+  , release++    -- * Convenience functions+  , with+  , tryWith+  , wait++    -- * Querying locks+  , locked+  ) where++--------------------------------------------------------------------------------++import           Control.Applicative            (pure, (<*>))+import           Control.Monad                  (when)+import           Data.Bool                      (Bool, not)+import           Data.Eq                        (Eq((==)))+import           Data.Function                  (($), (.))+import           Data.Functor                   (fmap, (<$>))+import           Data.Maybe                     (Maybe(Just, Nothing), isJust)+import           Data.Typeable                  (Typeable)+import           Prelude                        (error)++import qualified Control.Concurrent.Classy.MVar as MVar+import           Control.Monad.Catch            (bracket_, mask, onException)+import           Control.Monad.Conc.Class       (MonadConc(MVar))++--------------------------------------------------------------------------------++-- | A lock is in one of two states: \"locked\" or \"unlocked\".+--+-- @since 1.6.2.0+newtype Lock m+  = Lock+    { _fromLock :: MVar m ()+    }+  deriving (Typeable)++instance (Eq (MVar m ())) => Eq (Lock m) where+  (==) (Lock a) (Lock b) = a == b++--------------------------------------------------------------------------------++-- | Create a lock in the \"unlocked\" state.+--+-- @since 1.6.2.0+newLock :: (MonadConc m) => m (Lock m)+newLock = Lock <$> MVar.newMVar ()++-- | Create a lock in the \"locked\" state.+--+-- @since 1.6.2.0+newAcquired :: (MonadConc m) => m (Lock m)+newAcquired = Lock <$> MVar.newEmptyMVar++--------------------------------------------------------------------------------++-- |+-- Acquires the 'Lock'. Blocks if another thread has acquired the 'Lock'.+--+-- @acquire@ behaves as follows:+--+-- * When the state is \"unlocked\" @acquire@ changes the state to \"locked\".+--+-- * When the state is \"locked\" @acquire@ /blocks/ until a call to 'release'+--   in another thread wakes the calling thread. Upon awakening it will change+--   the state to \"locked\".+--+-- There are two further important properties of @acquire@:+--+-- * @acquire@ is single-wakeup. That is, if there are multiple threads blocked+--   on @acquire@ and the lock is released, only one thread will be woken up.+--   The runtime guarantees that the woken thread completes its @acquire@+--   operation.+--+-- * When multiple threads are blocked on @acquire@, they are woken up in FIFO+--   order. This is useful for providing fairness properties of abstractions+--   built using locks. Note that this differs from the Python implementation+--   where the wake-up order is undefined.+--+-- @since 1.6.2.0+acquire :: (MonadConc m) => Lock m -> m ()+acquire = MVar.takeMVar . _fromLock++-- |+-- 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'.+--+-- @since 1.6.2.0+tryAcquire :: (MonadConc m) => Lock m -> m Bool+tryAcquire = fmap isJust . MVar.tryTakeMVar . _fromLock++-- |+-- @release@ changes the state to \"unlocked\" and returns immediately.+--+-- Note that it is an error to release a lock in the \"unlocked\" state!+--+-- If there are any threads blocked on 'acquire' the thread that first called+-- @acquire@ will be woken up.+--+-- @since 1.6.2.0+release :: (MonadConc m) => Lock m -> m ()+release (Lock mv) = do+  b <- MVar.tryPutMVar mv ()+  when (not b) $+    error "Control.Concurrent.Classy.Lock.release: cannot release an unlocked Lock!"++--------------------------------------------------------------------------------++-- |+-- A convenience function which first acquires the lock and then performs the+-- computation. When the computation terminates, whether normally or by raising an+-- exception, the lock is released.+--+-- Note that: @with = 'bracket_' '<$>' 'acquire' '<*>' 'release'@.+--+-- @since 1.6.2.0+with :: (MonadConc m) => Lock m -> m a -> m a+with = bracket_ <$> acquire <*> release++-- |+-- A non-blocking 'with'. @tryWith@ is a convenience function which first tries+-- to acquire the lock. If that fails, 'Nothing' is returned. If it succeeds,+-- the computation is performed. When the computation terminates, whether+-- normally or by raising an exception, the lock is released and 'Just' the+-- result of the computation is returned.+--+-- @since 1.6.2.0+tryWith :: (MonadConc m) => Lock m -> m a -> m (Maybe a)+tryWith l a = mask $ \restore -> do+  acquired <- tryAcquire l+  if acquired+    then do r <- restore a `onException` release l+            release l+            pure (Just r)+    else pure Nothing++-- |+-- * When the state is \"locked\", @wait@ /blocks/ until a call to 'release'+--   in another thread changes it to \"unlocked\".+--+-- * @wait@ is multiple-wakeup, so when multiple waiters are blocked on+--   a @Lock@, all of them are woken up at the same time.+--+-- * When the state is \"unlocked\" @wait@ returns immediately.+--+-- @wait@ does not alter the state of the lock.+--+-- @since 1.6.2.0+wait :: (MonadConc m) => Lock m -> m ()+wait (Lock mv) = MVar.readMVar mv++--------------------------------------------------------------------------------++-- |+-- 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.+--+-- @since 1.6.2.0+locked :: (MonadConc m) => Lock m -> m Bool+locked = MVar.isEmptyMVar . _fromLock++--------------------------------------------------------------------------------

@@ -0,0 +1,408 @@+--------------------------------------------------------------------------------++-- Copyright © 2010-2012 Bas van Dijk & Roel van Dijk+-- Copyright © 2018 DFINITY Stiftung+--+-- All rights reserved.+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+--     * Redistributions of source code must retain the above copyright+--       notice, this list of conditions and the following disclaimer.+--+--     * Redistributions in binary form must reproduce the above+--       copyright notice, this list of conditions and the following+--       disclaimer in the documentation and/or other materials provided+--       with the distribution.+--+--     * The names of Bas van Dijk, Roel van Dijk and the names of+--       contributors may NOT be used to endorse or promote products+--       derived from this software without specific prior written+--       permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++-------------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE UndecidableInstances #-}++-------------------------------------------------------------------------------++-- |+-- Module     : Control.Concurrent.Classy.RWLock+-- Copyright  : © 2010-2011 Bas van Dijk & Roel van Dijk+--            , © 2018 DFINITY Stiftung+-- Maintainer : DFINITY USA Research <team@dfinity.org>+--+-- Multiple-reader, single-writer locks. Used to protect shared resources which+-- may be concurrently read, but only sequentially written.+--+-- All functions are /exception safe/. Throwing asynchronous exceptions will not+-- compromise the internal state of an 'RWLock'. This means it is perfectly safe+-- to kill a thread that is blocking on, for example, 'acquireRead'.++-------------------------------------------------------------------------------++module Control.Concurrent.Classy.RWLock+  ( -- * @RWLock@+    RWLock++    -- * Creating locks+  , newRWLock+  , newAcquiredRead+  , newAcquiredWrite++    -- * Read access++    -- ** Blocking+  , acquireRead+  , releaseRead+  , withRead+  , waitRead++    -- ** Non-blocking+  , tryAcquireRead+  , tryWithRead++    -- * Write access++    -- ** Blocking+  , acquireWrite+  , releaseWrite+  , withWrite+  , waitWrite++    -- ** Non-blocking+  , tryAcquireWrite+  , tryWithWrite+  ) where++-------------------------------------------------------------------------------++import           Control.Applicative            (pure, (<*>))+import           Control.Monad                  (Monad, (>>))+import           Data.Bool                      (Bool(False, True))+import           Data.Eq                        (Eq, (==))+import           Data.Function                  (on, ($))+import           Data.Functor                   ((<$>))+import           Data.Int                       (Int)+import           Data.List                      ((++))+import           Data.Maybe                     (Maybe(Just, Nothing))+import           Data.Ord                       (Ord)+import           Data.Typeable                  (Typeable)+import           Prelude                        (String, error, pred, succ)+import           Text.Read                      (Read)+import           Text.Show                      (Show)++import qualified Control.Concurrent.Classy.MVar as MVar+import           Control.Monad.Catch            (bracket_, mask, mask_,+                                                 onException)+import           Control.Monad.Conc.Class       (MonadConc(MVar))++import           Control.Concurrent.Classy.Lock (Lock)+import qualified Control.Concurrent.Classy.Lock as Lock++-------------------------------------------------------------------------------++-- |+-- Multiple-reader, single-writer lock. Is in one of three states:+--+-- * \"Free\": Read or write access can be acquired without blocking.+--+-- * \"Read\": One or more threads have acquired read access.+--   Blocks write access.+--+-- * \"Write\": A single thread has acquired write access.+--   Blocks other threads from acquiring both read and write access.+--+-- @since 1.6.2.0+data RWLock m+  = RWLock+    { _state     :: MVar m State+    , _readLock  :: Lock m+    , _writeLock :: Lock m+    }+  deriving (Typeable)++-- TODO: could the fields of RWLock be strict / unpacked?++instance (Eq (MVar m State)) => Eq (RWLock m) where+  (==) = (==) `on` _state++-------------------------------------------------------------------------------++-- |+-- Internal state of the 'RWLock'.+data State+  = Free+  | Read !Int+  | Write+  deriving (Eq, Ord, Show, Read)++-------------------------------------------------------------------------------++-- |+-- Create a new 'RWLock' in the \"free\" state; either read or write access+-- can be acquired without blocking.+--+-- @since 1.6.2.0+newRWLock :: (MonadConc m) => m (RWLock m)+newRWLock = do+  state <- MVar.newMVar Free+  rlock <- Lock.newLock+  RWLock state rlock <$> Lock.newLock++-- |+-- Create a new 'RWLock' in the \"read\" state; only read can be acquired+-- without blocking.+--+-- @since 1.6.2.0+newAcquiredRead :: (MonadConc m) => m (RWLock m)+newAcquiredRead = do+  state <- MVar.newMVar (Read 1)+  rlock <- Lock.newAcquired+  RWLock state rlock <$> Lock.newLock++-- |+-- Create a new 'RWLock' in the \"write\" state; either acquiring read or+-- write will block.+--+-- @since 1.6.2.0+newAcquiredWrite :: (MonadConc m) => m (RWLock m)+newAcquiredWrite = do+  state <- MVar.newMVar Write+  rlock <- Lock.newLock+  RWLock state rlock <$> Lock.newAcquired++-------------------------------------------------------------------------------++-- |+-- Acquire the read lock.+--+-- Blocks if another thread has acquired write access.+-- If @acquireRead@ terminates without throwing an exception the state of+-- the 'RWLock' will be \"read\".+--+-- Implementation note: throws an exception when more than @'maxBound' :: 'Int'@+-- simultaneous threads acquire the read lock. But that is unlikely.+--+-- @since 1.6.2.0+acquireRead :: (MonadConc m) => RWLock m -> m ()+acquireRead RWLock { _state, _readLock, _writeLock } = mask_ go+  where+    go = do+      st <- MVar.takeMVar _state+      case st of+        Free     -> do Lock.acquire _readLock+                       MVar.putMVar _state $ Read 1+        (Read n) ->    MVar.putMVar _state $ Read (succ n)+        Write    -> do MVar.putMVar _state st+                       Lock.wait _writeLock+                       go++-- |+-- Try to acquire the read lock; non blocking.+--+-- Like 'acquireRead', but doesn't block. Returns 'True' if the resulting+-- state is \"read\", 'False' otherwise.+--+-- @since 1.6.2.0+tryAcquireRead :: (MonadConc m) => RWLock m -> m Bool+tryAcquireRead RWLock { _state, _readLock } = mask_ $ do+  st <- MVar.takeMVar _state+  case st of+    Free   -> do Lock.acquire _readLock+                 MVar.putMVar _state $ Read 1+                 pure True+    Read n -> do MVar.putMVar _state $ Read (succ n)+                 pure True+    Write  -> do MVar.putMVar _state st+                 pure False++-- |+-- Release the read lock.+--+-- If the calling thread was the last one to relinquish read access the state+-- will revert to \"free\".+--+-- It is an error to release read access to an 'RWLock' which is not in+-- the \"read\" state.+--+-- @since 1.6.2.0+releaseRead :: (MonadConc m) => RWLock m -> m ()+releaseRead RWLock { _state, _readLock } = mask_ $ do+  st <- MVar.takeMVar _state+  case st of+    Read 1 -> do Lock.release _readLock+                 MVar.putMVar _state Free+    Read n ->    MVar.putMVar _state $ Read (pred n)+    _      -> do MVar.putMVar _state st+                 throw "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.+--+-- @since 1.6.2.0+withRead :: (MonadConc m) => RWLock m -> m a -> m a+withRead = bracket_ <$> acquireRead <*> releaseRead++-- |+-- A non-blocking 'withRead'. First tries to acquire the lock. If that fails,+-- 'Nothing' is returned. If it succeeds, the computation is performed.+-- When the computation terminates, whether normally or by raising an exception,+-- the lock is released and 'Just' the result of the computation is returned.+--+-- @since 1.6.2.0+tryWithRead :: (MonadConc m) => RWLock m -> m a -> m (Maybe a)+tryWithRead l a = mask $ \restore -> do+  acquired <- tryAcquireRead l+  if acquired+    then do r <- restore a `onException` releaseRead l+            releaseRead l+            pure $ Just r+    else pure Nothing++-- |+-- * When the state is \"write\", @waitRead@ /blocks/ until a call to+--   'releaseWrite' in another thread changes the state to \"free\".+--+-- * When the state is \"free\" or \"read\" @waitRead@ returns immediately.+--+-- @waitRead@ does not alter the state of the lock.+--+-- Note that @waitRead@ is just a convenience function defined as:+--+-- @waitRead l = 'mask_' '$' 'acquireRead' l '>>' 'releaseRead' l@+--+-- @since 1.6.2.0+waitRead :: (MonadConc m) => RWLock m -> m ()+waitRead l = mask_ (acquireRead l >> releaseRead l)++-------------------------------------------------------------------------------++-- |+-- Acquire the write lock.+--+-- Blocks if another thread has acquired either read or write access.+-- If @acquireWrite@ terminates without throwing an exception the state of+-- the 'RWLock' will be \"write\".+--+-- @since 1.6.2.0+acquireWrite :: (MonadConc m) => RWLock m -> m ()+acquireWrite RWLock { _state, _readLock, _writeLock } = mask_ go'+  where+    go' = do+      st <- MVar.takeMVar _state+      case st of+        Free   -> do Lock.acquire _writeLock+                     MVar.putMVar _state Write+        Read _ -> do MVar.putMVar _state st+                     Lock.wait _readLock+                     go'+        Write  -> do MVar.putMVar _state st+                     Lock.wait _writeLock+                     go'++-- |+-- Try to acquire the write lock; non blocking.+--+-- Like 'acquireWrite', but doesn't block.+-- Returns 'True' if the resulting state is \"write\", 'False' otherwise.+--+-- @since 1.6.2.0+tryAcquireWrite :: (MonadConc m) => RWLock m -> m Bool+tryAcquireWrite RWLock { _state, _writeLock } = mask_ $ do+  st <- MVar.takeMVar _state+  case st of+    Free -> do Lock.acquire _writeLock+               MVar.putMVar _state Write+               pure True+    _    -> do MVar.putMVar _state st+               pure False++-- |+-- Release the write lock.+--+-- If @releaseWrite@ terminates without throwing an exception the state+-- will be \"free\".+--+-- It is an error to release write access to an 'RWLock' which is not+-- in the \"write\" state.+--+-- @since 1.6.2.0+releaseWrite :: (MonadConc m) => RWLock m -> m ()+releaseWrite RWLock { _state, _writeLock } = mask_ $ do+  st <- MVar.takeMVar _state+  case st of+    Write -> do Lock.release _writeLock+                MVar.putMVar _state Free+    _     -> do MVar.putMVar _state st+                throw "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.+--+-- @since 1.6.2.0+withWrite :: (MonadConc m) => RWLock m -> m a -> m a+withWrite = bracket_ <$> acquireWrite <*> releaseWrite++-- |+-- A non-blocking 'withWrite'. First tries to acquire the lock. If that fails,+-- 'Nothing' is returned. If it succeeds, the computation is performed.+-- When the computation terminates, whether normally or by raising an exception,+-- the lock is released and 'Just' the result of the computation is returned.+--+-- @since 1.6.2.0+tryWithWrite :: (MonadConc m) => RWLock m -> m a -> m (Maybe a)+tryWithWrite l a = mask $ \restore -> do+  acquired <- tryAcquireWrite l+  if acquired+    then do r <- restore a `onException` releaseWrite l+            releaseWrite l+            pure $ Just r+    else pure Nothing++-- |+-- * When the state is \"write\" or \"read\" @waitWrite@ /blocks/ until a call+--   to 'releaseWrite' or 'releaseRead' in another thread changes the state+--   to \"free\".+--+-- * When the state is \"free\" @waitWrite@ returns immediately.+--+-- @waitWrite@ does not alter the state of the lock.+--+-- Note that @waitWrite@ is just a convenience function defined as:+--+-- @waitWrite l = 'mask_' '$' 'acquireWrite' l '>>' 'releaseWrite' l@+--+-- @since 1.6.2.0+waitWrite :: (MonadConc m) => RWLock m -> m ()+waitWrite l = mask_ (acquireWrite l >> releaseWrite l)++--------------------------------------------------------------------------------++throw :: (Monad m) => String -> String -> m a+throw func msg+  = error ("Control.Concurrent.Classy.RWLock." ++ func ++ ": " ++ msg)++--------------------------------------------------------------------------------

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                concurrency-version:             1.6.1.0+version:             1.6.2.0 synopsis:            Typeclasses, functions, and data types for concurrency and STM.  description:@@ -32,7 +32,7 @@ source-repository this   type:     git   location: https://github.com/barrucadu/dejafu.git-  tag:      concurrency-1.6.1.0+  tag:      concurrency-1.6.2.0  library   exposed-modules:     Control.Monad.Conc.Class@@ -41,11 +41,14 @@                      , Control.Concurrent.Classy                      , Control.Concurrent.Classy.Async                      , Control.Concurrent.Classy.Chan+                     , Control.Concurrent.Classy.BoundedChan                      , Control.Concurrent.Classy.CRef                      , Control.Concurrent.Classy.IORef                      , Control.Concurrent.Classy.MVar                      , Control.Concurrent.Classy.QSem                      , Control.Concurrent.Classy.QSemN+                     , Control.Concurrent.Classy.Lock+                     , Control.Concurrent.Classy.RWLock                      , Control.Concurrent.Classy.STM                      , Control.Concurrent.Classy.STM.TVar                      , Control.Concurrent.Classy.STM.TMVar