stm 2.5.1.0 → 2.5.2.0
raw patch · 9 files changed
+258/−270 lines, 9 filesdep ~base
Dependency ranges changed: base
Files
- Control/Concurrent/STM/TArray.hs +87/−22
- Control/Concurrent/STM/TBQueue.hs +152/−164
- Control/Concurrent/STM/TMVar.hs +3/−1
- Control/Concurrent/STM/TVar.hs +2/−2
- changelog.md +9/−0
- stm.cabal +3/−3
- testsuite/src/Issue17.hs +0/−73
- testsuite/src/Main.hs +0/−2
- testsuite/testsuite.cabal +2/−3
Control/Concurrent/STM/TArray.hs view
@@ -4,17 +4,23 @@ {-# LANGUAGE Trustworthy #-} #endif +#define HAS_UNLIFTED_ARRAY defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 904++#if HAS_UNLIFTED_ARRAY+{-# LANGUAGE MagicHash, UnboxedTuples #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.STM.TArray -- Copyright : (c) The University of Glasgow 2005 -- License : BSD-style (see the file libraries/base/LICENSE)--- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : non-portable (requires STM) ----- TArrays: transactional arrays, for use in the STM monad+-- TArrays: transactional arrays, for use in the STM monad. -- ----------------------------------------------------------------------------- @@ -22,41 +28,99 @@ TArray ) where -import Data.Array (Array, bounds)-import Data.Array.Base (listArray, arrEleBottom, unsafeAt, MArray(..),- IArray(numElements))-import Data.Ix (rangeSize)+import Control.Monad.STM (STM, atomically) import Data.Typeable (Typeable)-import Control.Concurrent.STM.TVar (TVar, newTVar, readTVar, writeTVar)-#ifdef __GLASGOW_HASKELL__-import GHC.Conc (STM)+#if HAS_UNLIFTED_ARRAY+import Control.Concurrent.STM.TVar (readTVar, readTVarIO, writeTVar)+import Data.Array.Base (safeRangeSize, MArray(..))+import Data.Ix (Ix)+import GHC.Conc (STM(..), TVar(..))+import GHC.Exts+import GHC.IO (IO(..)) #else-import Control.Sequential.STM (STM)+import Control.Concurrent.STM.TVar (TVar, newTVar, newTVarIO, readTVar, readTVarIO, writeTVar)+import Data.Array (Array, bounds, listArray)+import Data.Array.Base (safeRangeSize, unsafeAt, MArray(..), IArray(numElements)) #endif --- |TArray is a transactional array, supporting the usual 'MArray'+-- | 'TArray' is a transactional array, supporting the usual 'MArray' -- interface for mutable arrays. ----- It is currently implemented as @Array ix (TVar e)@,--- but it may be replaced by a more efficient implementation in the future--- (the interface will remain the same, however).---+-- It is conceptually implemented as @Array i (TVar e)@.+#if HAS_UNLIFTED_ARRAY+data TArray i e = TArray+ !i -- lower bound+ !i -- upper bound+ !Int -- size+ (Array# (TVar# RealWorld e))+ deriving (Typeable)++instance (Eq i, Eq e) => Eq (TArray i e) where+ (TArray l1 u1 n1 arr1#) == (TArray l2 u2 n2 arr2#) =+ -- each `TArray` has its own `TVar`s, so it's sufficient to compare the first one+ if n1 == 0 then n2 == 0 else l1 == l2 && u1 == u2 && isTrue# (sameTVar# (unsafeFirstT arr1#) (unsafeFirstT arr2#))+ where+ unsafeFirstT :: Array# (TVar# RealWorld e) -> TVar# RealWorld e+ unsafeFirstT arr# = case indexArray# arr# 0# of (# e #) -> e++newTArray# :: Ix i => (i, i) -> e -> State# RealWorld -> (# State# RealWorld, TArray i e #)+newTArray# b@(l, u) e = \s1# ->+ case safeRangeSize b of+ n@(I# n#) -> case newTVar# e s1# of+ (# s2#, initial_tvar# #) -> case newArray# n# initial_tvar# s2# of+ (# s3#, marr# #) ->+ let go i# = \s4# -> case newTVar# e s4# of+ (# s5#, tvar# #) -> case writeArray# marr# i# tvar# s5# of+ s6# -> if isTrue# (i# ==# n# -# 1#) then s6# else go (i# +# 1#) s6#+ in case unsafeFreezeArray# marr# (if n <= 1 then s3# else go 1# s3#) of+ (# s7#, arr# #) -> (# s7#, TArray l u n arr# #)++instance MArray TArray e STM where+ getBounds (TArray l u _ _) = return (l, u)+ getNumElements (TArray _ _ n _) = return n+ newArray b e = STM $ newTArray# b e+ unsafeRead (TArray _ _ _ arr#) (I# i#) = case indexArray# arr# i# of+ (# tvar# #) -> readTVar (TVar tvar#)+ unsafeWrite (TArray _ _ _ arr#) (I# i#) e = case indexArray# arr# i# of+ (# tvar# #) -> writeTVar (TVar tvar#) e++-- | Writes are slow in `IO`.+instance MArray TArray e IO where+ getBounds (TArray l u _ _) = return (l, u)+ getNumElements (TArray _ _ n _) = return n+ newArray b e = IO $ newTArray# b e+ unsafeRead (TArray _ _ _ arr#) (I# i#) = case indexArray# arr# i# of+ (# tvar# #) -> readTVarIO (TVar tvar#)+ unsafeWrite (TArray _ _ _ arr#) (I# i#) e = case indexArray# arr# i# of+ (# tvar# #) -> atomically $ writeTVar (TVar tvar#) e+#else newtype TArray i e = TArray (Array i (TVar e)) deriving (Eq, Typeable) instance MArray TArray e STM where getBounds (TArray a) = return (bounds a)+ getNumElements (TArray a) = return (numElements a) newArray b e = do- a <- rep (rangeSize b) (newTVar e)- return $ TArray (listArray b a)- newArray_ b = do- a <- rep (rangeSize b) (newTVar arrEleBottom)+ a <- rep (safeRangeSize b) (newTVar e) return $ TArray (listArray b a) unsafeRead (TArray a) i = readTVar $ unsafeAt a i unsafeWrite (TArray a) i e = writeTVar (unsafeAt a i) e++ {-# INLINE newArray #-}++-- | Writes are slow in `IO`.+instance MArray TArray e IO where+ getBounds (TArray a) = return (bounds a) getNumElements (TArray a) = return (numElements a)+ newArray b e = do+ a <- rep (safeRangeSize b) (newTVarIO e)+ return $ TArray (listArray b a)+ unsafeRead (TArray a) i = readTVarIO $ unsafeAt a i+ unsafeWrite (TArray a) i e = atomically $ writeTVar (unsafeAt a i) e --- | Like 'replicateM' but uses an accumulator to prevent stack overflows.--- Unlike 'replicateM' the returned list is in reversed order.+ {-# INLINE newArray #-}++-- | Like 'replicateM', but uses an accumulator to prevent stack overflows.+-- Unlike 'replicateM', the returned list is in reversed order. -- This doesn't matter though since this function is only used to create -- arrays with identical elements. rep :: Monad m => Int -> m a -> m [a]@@ -65,4 +129,5 @@ go 0 xs = return xs go i xs = do x <- m- go (i-1) (x:xs)+ go (i - 1) (x : xs)+#endif
Control/Concurrent/STM/TBQueue.hs view
@@ -1,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}@@ -18,225 +19,212 @@ -- -- 'TBQueue' is a bounded version of 'TQueue'. The queue has a maximum -- capacity set when it is created. If the queue already contains the--- maximum number of elements, then 'writeTBQueue' blocks until an+-- maximum number of elements, then 'writeTBQueue' retries until an -- element is removed from the queue. ----- The implementation is based on the traditional purely-functional--- queue representation that uses two lists to obtain amortised /O(1)/+-- The implementation is based on an array to obtain /O(1)/ -- enqueue and dequeue operations. -- -- @since 2.4 ----------------------------------------------------------------------------- module Control.Concurrent.STM.TBQueue (- -- * TBQueue- TBQueue,- newTBQueue,- newTBQueueIO,- readTBQueue,- tryReadTBQueue,- flushTBQueue,- peekTBQueue,- tryPeekTBQueue,- writeTBQueue,- unGetTBQueue,- lengthTBQueue,- isEmptyTBQueue,- isFullTBQueue,+ -- * TBQueue+ TBQueue,+ newTBQueue,+ newTBQueueIO,+ readTBQueue,+ tryReadTBQueue,+ flushTBQueue,+ peekTBQueue,+ tryPeekTBQueue,+ writeTBQueue,+ unGetTBQueue,+ lengthTBQueue,+ isEmptyTBQueue,+ isFullTBQueue,+ capacityTBQueue, ) where -import Control.Monad (unless)-import Data.Typeable (Typeable)-import GHC.Conc (STM, TVar, newTVar, newTVarIO, orElse,- readTVar, retry, writeTVar)-import Numeric.Natural (Natural)-import Prelude hiding (read)+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (pure)+#endif+import Data.Array.Base+import Data.Maybe (isJust, isNothing)+import Data.Typeable (Typeable)+import GHC.Conc+import Numeric.Natural (Natural)+import Prelude hiding (read) +import Control.Concurrent.STM.TArray+ -- | 'TBQueue' is an abstract type representing a bounded FIFO channel. -- -- @since 2.4 data TBQueue a- = TBQueue {-# UNPACK #-} !(TVar Natural) -- CR: read capacity- {-# UNPACK #-} !(TVar [a]) -- R: elements waiting to be read- {-# UNPACK #-} !(TVar Natural) -- CW: write capacity- {-# UNPACK #-} !(TVar [a]) -- W: elements written (head is most recent)- !(Natural) -- CAP: initial capacity+ = TBQueue {-# UNPACK #-} !(TVar Int) -- read index+ {-# UNPACK #-} !(TVar Int) -- write index+ {-# UNPACK #-} !(TArray Int (Maybe a)) -- elements+ {-# UNPACK #-} !Int -- initial capacity deriving Typeable instance Eq (TBQueue a) where- TBQueue a _ _ _ _ == TBQueue b _ _ _ _ = a == b+ -- each `TBQueue` has its own `TVar`s, so it's sufficient to compare the first one+ TBQueue a _ _ _ == TBQueue b _ _ _ = a == b --- Total channel capacity remaining is CR + CW. Reads only need to--- access CR, writes usually need to access only CW but sometimes need--- CR. So in the common case we avoid contention between CR and CW.------ - when removing an element from R:--- CR := CR + 1------ - when adding an element to W:--- if CW is non-zero--- then CW := CW - 1--- then if CR is non-zero--- then CW := CR - 1; CR := 0--- else **FULL**+-- incMod x cap == (x + 1) `mod` cap+incMod :: Int -> Int -> Int+incMod x cap = let y = x + 1 in if y == cap then 0 else y +-- decMod x cap = (x - 1) `mod` cap+decMod :: Int -> Int -> Int+decMod x cap = if x == 0 then cap - 1 else x - 1+ -- | Builds and returns a new instance of 'TBQueue'. newTBQueue :: Natural -- ^ maximum number of elements the queue can hold -> STM (TBQueue a)-newTBQueue size = do- read <- newTVar []- write <- newTVar []- rsize <- newTVar 0- wsize <- newTVar size- return (TBQueue rsize read wsize write size)+newTBQueue cap+ | cap <= 0 = error "capacity has to be greater than 0"+ | cap > fromIntegral (maxBound :: Int) = error "capacity is too big"+ | otherwise = do+ rindex <- newTVar 0+ windex <- newTVar 0+ elements <- newArray (0, cap' - 1) Nothing+ pure (TBQueue rindex windex elements cap')+ where+ cap' = fromIntegral cap --- |@IO@ version of 'newTBQueue'. This is useful for creating top-level+-- | @IO@ version of 'newTBQueue'. This is useful for creating top-level -- 'TBQueue's using 'System.IO.Unsafe.unsafePerformIO', because using -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't -- possible. newTBQueueIO :: Natural -> IO (TBQueue a)-newTBQueueIO size = do- read <- newTVarIO []- write <- newTVarIO []- rsize <- newTVarIO 0- wsize <- newTVarIO size- return (TBQueue rsize read wsize write size)+newTBQueueIO cap+ | cap <= 0 = error "capacity has to be greater than 0"+ | cap > fromIntegral (maxBound :: Int) = error "capacity is too big"+ | otherwise = do+ rindex <- newTVarIO 0+ windex <- newTVarIO 0+ elements <- newArray (0, cap' - 1) Nothing+ pure (TBQueue rindex windex elements cap')+ where+ cap' = fromIntegral cap --- |Write a value to a 'TBQueue'; blocks if the queue is full.+-- | Write a value to a 'TBQueue'; retries if the queue is full. writeTBQueue :: TBQueue a -> a -> STM ()-writeTBQueue (TBQueue rsize _read wsize write _size) a = do- w <- readTVar wsize- if (w > 0)- then do writeTVar wsize $! w - 1- else do- r <- readTVar rsize- if (r > 0)- then do writeTVar rsize 0- writeTVar wsize $! r - 1- else retry- listend <- readTVar write- writeTVar write (a:listend)+writeTBQueue (TBQueue _ windex elements cap) a = do+ w <- readTVar windex+ ele <- unsafeRead elements w+ case ele of+ Nothing -> unsafeWrite elements w (Just a)+ Just _ -> retry+ writeTVar windex $! incMod w cap --- |Read the next value from the 'TBQueue'.+-- | Read the next value from the 'TBQueue'; retries if the queue is empty. readTBQueue :: TBQueue a -> STM a-readTBQueue (TBQueue rsize read _wsize write _size) = do- xs <- readTVar read- r <- readTVar rsize- writeTVar rsize $! r + 1- case xs of- (x:xs') -> do- writeTVar read xs'- return x- [] -> do- ys <- readTVar write- case ys of- [] -> retry- _ -> do- -- NB. lazy: we want the transaction to be- -- short, otherwise it will conflict- let ~(z,zs) = case reverse ys of- z':zs' -> (z',zs')- _ -> error "readTBQueue: impossible"- writeTVar write []- writeTVar read zs- return z+readTBQueue (TBQueue rindex _ elements cap) = do+ r <- readTVar rindex+ ele <- unsafeRead elements r+ a <- case ele of+ Nothing -> retry+ Just a -> do+ unsafeWrite elements r Nothing+ pure a+ writeTVar rindex $! incMod r cap+ pure a -- | A version of 'readTBQueue' which does not retry. Instead it -- returns @Nothing@ if no value is available. tryReadTBQueue :: TBQueue a -> STM (Maybe a)-tryReadTBQueue c = fmap Just (readTBQueue c) `orElse` return Nothing+tryReadTBQueue q = fmap Just (readTBQueue q) `orElse` pure Nothing -- | Efficiently read the entire contents of a 'TBQueue' into a list. This -- function never retries. -- -- @since 2.4.5-flushTBQueue :: TBQueue a -> STM [a]-flushTBQueue (TBQueue rsize read wsize write size) = do- xs <- readTVar read- ys <- readTVar write- if null xs && null ys- then return []- else do- unless (null xs) $ writeTVar read []- unless (null ys) $ writeTVar write []- writeTVar rsize 0- writeTVar wsize size- return (xs ++ reverse ys)+flushTBQueue :: forall a. TBQueue a -> STM [a]+flushTBQueue (TBQueue _rindex windex elements cap) = do+ w <- readTVar windex+ go (decMod w cap) []+ where+ go :: Int -> [a] -> STM [a]+ go i acc = do+ ele <- unsafeRead elements i+ case ele of+ Nothing -> pure acc+ Just a -> do+ unsafeWrite elements i Nothing+ go (decMod i cap) (a : acc) -- | Get the next value from the @TBQueue@ without removing it,--- retrying if the channel is empty.+-- retrying if the queue is empty. peekTBQueue :: TBQueue a -> STM a-peekTBQueue (TBQueue _ read _ write _) = do- xs <- readTVar read- case xs of- (x:_) -> return x- [] -> do- ys <- readTVar write- case ys of- [] -> retry- _ -> do- let (z:zs) = reverse ys -- NB. lazy: we want the transaction to be- -- short, otherwise it will conflict- writeTVar write []- writeTVar read (z:zs)- return z+peekTBQueue (TBQueue rindex _ elements _) = do+ r <- readTVar rindex+ ele <- unsafeRead elements r+ case ele of+ Nothing -> retry+ Just a -> pure a -- | A version of 'peekTBQueue' which does not retry. Instead it -- returns @Nothing@ if no value is available. tryPeekTBQueue :: TBQueue a -> STM (Maybe a)-tryPeekTBQueue c = do- m <- tryReadTBQueue c- case m of- Nothing -> return Nothing- Just x -> do- unGetTBQueue c x- return m+tryPeekTBQueue q = fmap Just (peekTBQueue q) `orElse` pure Nothing --- |Put a data item back onto a channel, where it will be the next item read.--- Blocks if the queue is full.+-- | Put a data item back onto a channel, where it will be the next item read.+-- Retries if the queue is full. unGetTBQueue :: TBQueue a -> a -> STM ()-unGetTBQueue (TBQueue rsize read wsize _write _size) a = do- r <- readTVar rsize- if (r > 0)- then do writeTVar rsize $! r - 1- else do- w <- readTVar wsize- if (w > 0)- then writeTVar wsize $! w - 1- else retry- xs <- readTVar read- writeTVar read (a:xs)+unGetTBQueue (TBQueue rindex _ elements cap) a = do+ r <- readTVar rindex+ ele <- unsafeRead elements r+ case ele of+ Nothing -> unsafeWrite elements r (Just a)+ Just _ -> retry+ writeTVar rindex $! decMod r cap --- |Return the length of a 'TBQueue'.+-- | Return the length of a 'TBQueue'. -- -- @since 2.5.0.0 lengthTBQueue :: TBQueue a -> STM Natural-lengthTBQueue (TBQueue rsize _read wsize _write size) = do- r <- readTVar rsize- w <- readTVar wsize- return $! size - r - w+lengthTBQueue (TBQueue rindex windex elements cap) = do+ r <- readTVar rindex+ w <- readTVar windex+ if w == r then do+ -- length is 0 or cap+ ele <- unsafeRead elements r+ case ele of+ Nothing -> pure 0+ Just _ -> pure $! fromIntegral cap+ else do+ let len' = w - r+ pure $! fromIntegral (if len' < 0 then len' + cap else len') --- |Returns 'True' if the supplied 'TBQueue' is empty.+-- | Returns 'True' if the supplied 'TBQueue' is empty. isEmptyTBQueue :: TBQueue a -> STM Bool-isEmptyTBQueue (TBQueue _rsize read _wsize write _size) = do- xs <- readTVar read- case xs of- (_:_) -> return False- [] -> do ys <- readTVar write- case ys of- [] -> return True- _ -> return False+isEmptyTBQueue (TBQueue rindex windex elements _) = do+ r <- readTVar rindex+ w <- readTVar windex+ if w == r then do+ ele <- unsafeRead elements r+ pure $! isNothing ele+ else+ pure False --- |Returns 'True' if the supplied 'TBQueue' is full.+-- | Returns 'True' if the supplied 'TBQueue' is full. -- -- @since 2.4.3 isFullTBQueue :: TBQueue a -> STM Bool-isFullTBQueue (TBQueue rsize _read wsize _write _size) = do- w <- readTVar wsize- if (w > 0)- then return False- else do- r <- readTVar rsize- if (r > 0)- then return False- else return True+isFullTBQueue (TBQueue rindex windex elements _) = do+ r <- readTVar rindex+ w <- readTVar windex+ if w == r then do+ ele <- unsafeRead elements r+ pure $! isJust ele+ else+ pure False++-- | The maximum number of elements the queue can hold.+--+-- @since TODO+capacityTBQueue :: TBQueue a -> Natural+capacityTBQueue (TBQueue _ _ _ cap) = fromIntegral cap
Control/Concurrent/STM/TMVar.hs view
@@ -151,8 +151,10 @@ -- | Non-blocking write of a new value to a 'TMVar' -- Puts if empty. Replaces if populated.+--+-- @since 2.5.1 writeTMVar :: TMVar a -> a -> STM ()-writeTMVar t new = tryTakeTMVar t >> putTMVar t new+writeTMVar (TMVar t) new = writeTVar t (Just new) -- |Check whether a given 'TMVar' is empty. isEmptyTMVar :: TMVar a -> STM Bool
Control/Concurrent/STM/TVar.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}+{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}@@ -73,7 +73,7 @@ stateTVar :: TVar s -> (s -> (a, s)) -> STM a stateTVar var f = do s <- readTVar var- let (a, s') = f s -- since we destructure this, we are strict in f+ let !(a, s') = f s writeTVar var s' return a {-# INLINE stateTVar #-}
changelog.md view
@@ -1,5 +1,14 @@ # Changelog for [`stm` package](http://hackage.haskell.org/package/stm) +## 2.5.2.0 *September 2023*++ * Fix strictness of `stateTVar` ([#30](https://github.com/haskell/stm/ssues/30))+ * Rewrite `TBQueue` to use a more-efficient array-based representation ([#65](https://github.com/haskell/stm/issues/65))+ * `newTBQueue 0` now fails as one would expect ([#28](https://github.com/haskell/stm/issues/28))+ * Add `capacityTBQueue` ([#61](https://github.com/haskell/stm/issues/61))+ * Add `MArray TArray e IO` instance+ * Use unlifted `Array#` for `TArray` ([#66](https://github.com/haskell/stm/pull/66))+ ## 2.5.1.0 *Aug 2022* * Teach `flushTBQueue` to only flush queue when necessary
stm.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: stm-version: 2.5.1.0+version: 2.5.2.0 -- don't forget to update changelog.md file! license: BSD3@@ -11,7 +11,7 @@ synopsis: Software Transactional Memory category: Concurrency build-type: Simple-tested-with: GHC==8.10.*, GHC==8.8.*, GHC==8.6.*, GHC==8.4.*, GHC==8.2.*, GHC==8.0.*, GHC==7.10.*, GHC==7.8.*, GHC==7.6.*, GHC==7.4.*, GHC==7.2.*+tested-with: GHC==9.6.2, GHC==9.4.7, GHC==9.2.8, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2 description: Software Transactional Memory, or STM, is an abstraction for concurrent communication. The main benefits of STM are@@ -53,7 +53,7 @@ build-depends: semigroups >=0.18.6 && <0.21 build-depends:- base >= 4.4 && < 4.18,+ base >= 4.4 && < 4.20, array >= 0.3 && < 0.6 exposed-modules:
− testsuite/src/Issue17.hs
@@ -1,73 +0,0 @@-{-# LANGUAGE CPP #-}---- see https://github.com/haskell/stm/pull/19------ Test-case contributed by Alexey Kuleshevich <alexey@kukeshevi.ch>------ This bug is observable in all versions with TBQueue from `stm-2.4` to--- `stm-2.4.5.1` inclusive.--module Issue17 (main) where--import Control.Concurrent.STM-import Test.HUnit.Base (assertBool, assertEqual)--main :: IO ()-main = do- -- New queue capacity is set to 0- queueIO <- newTBQueueIO 0- assertNoCapacityTBQueue queueIO-- -- Same as above, except created within STM- queueSTM <- atomically $ newTBQueue 0- assertNoCapacityTBQueue queueSTM--#if !MIN_VERSION_stm(2,5,0)- -- NB: below are expected failures-- -- New queue capacity is set to a negative numer- queueIO' <- newTBQueueIO (-1 :: Int)- assertNoCapacityTBQueue queueIO'-- -- Same as above, except created within STM and different negative number- queueSTM' <- atomically $ newTBQueue (minBound :: Int)- assertNoCapacityTBQueue queueSTM'-#endif--assertNoCapacityTBQueue :: TBQueue Int -> IO ()-assertNoCapacityTBQueue queue = do- assertEmptyTBQueue queue- assertFullTBQueue queue-- -- Attempt to write into the queue.- eValWrite <- atomically $ orElse (fmap Left (writeTBQueue queue 217))- (fmap Right (tryReadTBQueue queue))- assertEqual "Expected queue with no capacity: writeTBQueue" eValWrite (Right Nothing)- eValUnGet <- atomically $ orElse (fmap Left (unGetTBQueue queue 218))- (fmap Right (tryReadTBQueue queue))- assertEqual "Expected queue with no capacity: unGetTBQueue" eValUnGet (Right Nothing)-- -- Make sure that attempt to write didn't affect the queue- assertEmptyTBQueue queue- assertFullTBQueue queue---assertEmptyTBQueue :: TBQueue Int -> IO ()-assertEmptyTBQueue queue = do- atomically (isEmptyTBQueue queue) >>=- assertBool "Expected empty: isEmptyTBQueue should return True"-- atomically (tryReadTBQueue queue) >>=- assertEqual "Expected empty: tryReadTBQueue should return Nothing" Nothing-- atomically (tryPeekTBQueue queue) >>=- assertEqual "Expected empty: tryPeekTBQueue should return Nothing" Nothing-- atomically (flushTBQueue queue) >>=- assertEqual "Expected empty: flushTBQueue should return []" []---assertFullTBQueue :: TBQueue Int -> IO ()-assertFullTBQueue queue = do- atomically (isFullTBQueue queue) >>=- assertBool "Expected full: isFullTBQueue shoule return True"
testsuite/src/Main.hs view
@@ -6,7 +6,6 @@ import Test.Framework.Providers.HUnit import qualified Issue9-import qualified Issue17 import qualified Stm052 import qualified Stm064 import qualified Stm065@@ -19,7 +18,6 @@ tests = [ testGroup "regression" [ testCase "issue #9" Issue9.main- , testCase "issue #17" Issue17.main , testCase "stm052" Stm052.main , testCase "stm064" Stm064.main , testCase "stm065" Stm065.main
testsuite/testsuite.cabal view
@@ -6,7 +6,7 @@ category: Testing license: BSD-3-Clause maintainer: hvr@gnu.org-tested-with: GHC==8.8.*, GHC==8.6.*, GHC==8.4.*, GHC==8.2.*, GHC==8.0.*, GHC==7.10.*, GHC==7.8.*, GHC==7.6.*, GHC==7.4.*, GHC==7.2.*, GHC==7.0.*+tested-with: GHC==9.6.2, GHC==9.4.7, GHC==9.2.8, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2 description: This testsuite is intended to be compatible with different versions of `stm` (via use of @CPP@ if needed) in order to more easily@@ -20,7 +20,6 @@ main-is: Main.hs other-modules: Issue9- Issue17 Stm052 Stm064 Stm065@@ -36,7 +35,7 @@ -- build-depends:- , base >= 4.3 && < 4.17+ , base >= 4.4 && < 4.20 , test-framework ^>= 0.8.2.0 , test-framework-hunit ^>= 0.3.0.2 , HUnit ^>= 1.6.0.0