diff --git a/Control/Concurrent/STM/TArray.hs b/Control/Concurrent/STM/TArray.hs --- a/Control/Concurrent/STM/TArray.hs +++ b/Control/Concurrent/STM/TArray.hs @@ -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 diff --git a/Control/Concurrent/STM/TBQueue.hs b/Control/Concurrent/STM/TBQueue.hs --- a/Control/Concurrent/STM/TBQueue.hs +++ b/Control/Concurrent/STM/TBQueue.hs @@ -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 diff --git a/Control/Concurrent/STM/TMVar.hs b/Control/Concurrent/STM/TMVar.hs --- a/Control/Concurrent/STM/TMVar.hs +++ b/Control/Concurrent/STM/TMVar.hs @@ -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 diff --git a/Control/Concurrent/STM/TVar.hs b/Control/Concurrent/STM/TVar.hs --- a/Control/Concurrent/STM/TVar.hs +++ b/Control/Concurrent/STM/TVar.hs @@ -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 #-} diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 diff --git a/stm.cabal b/stm.cabal --- a/stm.cabal +++ b/stm.cabal @@ -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: diff --git a/testsuite/src/Issue17.hs b/testsuite/src/Issue17.hs deleted file mode 100644 --- a/testsuite/src/Issue17.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE CPP #-} - --- see https://github.com/haskell/stm/pull/19 --- --- Test-case contributed by Alexey Kuleshevich --- --- 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" diff --git a/testsuite/src/Main.hs b/testsuite/src/Main.hs --- a/testsuite/src/Main.hs +++ b/testsuite/src/Main.hs @@ -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 diff --git a/testsuite/testsuite.cabal b/testsuite/testsuite.cabal --- a/testsuite/testsuite.cabal +++ b/testsuite/testsuite.cabal @@ -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