mutable-containers (empty) → 0.1.0.0
raw patch · 11 files changed
+808/−0 lines, 11 filesdep +QuickCheckdep +basedep +containerssetup-changed
Dependencies added: QuickCheck, base, containers, criterion, hspec, mono-traversable, mutable-containers, primitive, vector
Files
- Data/Mutable/Class.hs +251/−0
- Data/Mutable/DList.hs +97/−0
- Data/Mutable/Deque.hs +107/−0
- Data/Mutable/SRef.hs +50/−0
- Data/Mutable/URef.hs +51/−0
- LICENSE +20/−0
- README.md +7/−0
- Setup.hs +2/−0
- bench/bench.hs +35/−0
- mutable-containers.cabal +54/−0
- test/Spec.hs +134/−0
+ Data/Mutable/Class.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+-- | Various typeclasses for mutable containers.+module Data.Mutable.Class+ where++import Control.Monad.Primitive+import Data.IORef+import Data.STRef+import Data.Primitive.MutVar+import Data.Monoid+import Data.MonoTraversable (Element)+import qualified Data.Sequences as Seqs++class MutableContainer c where+ type MCState c++instance MutableContainer (IORef a) where+ type MCState (IORef a) = PrimState IO+instance MutableContainer (STRef s a) where+ type MCState (STRef s a) = s+instance MutableContainer (MutVar s a) where+ type MCState (MutVar s a) = s++class MutableContainer c => MutableRef c where+ type RefElement c+ newRef :: (PrimMonad m, PrimState m ~ MCState c)+ => RefElement c+ -> m c+ readRef :: (PrimMonad m, PrimState m ~ MCState c)+ => c+ -> m (RefElement c)+ writeRef :: (PrimMonad m, PrimState m ~ MCState c)+ => c+ -> RefElement c+ -> m ()+ modifyRef :: (PrimMonad m, PrimState m ~ MCState c)+ => c+ -> (RefElement c -> RefElement c)+ -> m ()+ modifyRef' :: (PrimMonad m, PrimState m ~ MCState c)+ => c+ -> (RefElement c -> RefElement c)+ -> m ()++instance MutableRef (IORef a) where+ type RefElement (IORef a) = a+ newRef = primToPrim . newIORef+ {-# INLINE newRef #-}+ readRef = primToPrim . readIORef+ {-# INLINE readRef #-}+ writeRef c = primToPrim . writeIORef c+ {-# INLINE writeRef #-}+ modifyRef c = primToPrim . modifyIORef c+ {-# INLINE modifyRef #-}+ modifyRef' c = primToPrim . modifyIORef' c+ {-# INLINE modifyRef' #-}+instance MutableRef (STRef s a) where+ type RefElement (STRef s a) = a+ newRef = primToPrim . newSTRef+ {-# INLINE newRef #-}+ readRef = primToPrim . readSTRef+ {-# INLINE readRef #-}+ writeRef c = primToPrim . writeSTRef c+ {-# INLINE writeRef #-}+ modifyRef c = primToPrim . modifySTRef c+ {-# INLINE modifyRef #-}+ modifyRef' c = primToPrim . modifySTRef' c+ {-# INLINE modifyRef' #-}+instance MutableRef (MutVar s a) where+ type RefElement (MutVar s a) = a+ newRef = newMutVar+ {-# INLINE newRef #-}+ readRef = readMutVar+ {-# INLINE readRef #-}+ writeRef = writeMutVar+ {-# INLINE writeRef #-}+ modifyRef = modifyMutVar+ {-# INLINE modifyRef #-}+ modifyRef' = modifyMutVar'+ {-# INLINE modifyRef' #-}++class MutableRef c => MutableAtomicRef c where+ atomicModifyRef+ :: (PrimMonad m, PrimState m ~ MCState c)+ => c+ -> (RefElement c -> (RefElement c, a))+ -> m a+ atomicModifyRef'+ :: (PrimMonad m, PrimState m ~ MCState c)+ => c+ -> (RefElement c -> (RefElement c, a))+ -> m a+instance MutableAtomicRef (IORef a) where+ atomicModifyRef c = primToPrim . atomicModifyIORef c+ {-# INLINE atomicModifyRef #-}+ atomicModifyRef' c = primToPrim . atomicModifyIORef' c+ {-# INLINE atomicModifyRef' #-}+instance MutableAtomicRef (MutVar s a) where+ atomicModifyRef = atomicModifyMutVar+ {-# INLINE atomicModifyRef #-}+ atomicModifyRef' = atomicModifyMutVar'+ {-# INLINE atomicModifyRef' #-}++class MutableContainer c => MutableCollection c where+ type CollElement c+ newColl :: (PrimMonad m, PrimState m ~ MCState c)+ => m c+instance Monoid w => MutableCollection (IORef w) where+ type CollElement (IORef w) = Element w+ newColl = newRef mempty+ {-# INLINE newColl #-}+instance Monoid w => MutableCollection (STRef s w) where+ type CollElement (STRef s w) = Element w+ newColl = newRef mempty+ {-# INLINE newColl #-}+instance Monoid w => MutableCollection (MutVar s w) where+ type CollElement (MutVar s w) = Element w+ newColl = newRef mempty+ {-# INLINE newColl #-}++class MutableCollection c => MutablePopFront c where+ popFront :: (PrimMonad m, PrimState m ~ MCState c)+ => c+ -> m (Maybe (CollElement c))+popFrontRef+ :: ( PrimMonad m+ , PrimState m ~ MCState c+ , MutableRef c+ , CollElement c ~ Element (RefElement c)+ , Seqs.IsSequence (RefElement c)+ )+ => c+ -> m (Maybe (CollElement c))+popFrontRef c = do+ l <- readRef c+ case Seqs.uncons l of+ Nothing -> return Nothing+ Just (x, xs) -> do+ writeRef c xs+ return (Just x)+{-# INLINE popFrontRef #-}+instance Seqs.IsSequence a => MutablePopFront (IORef a) where+ popFront = popFrontRef+ {-# INLINE popFront #-}+instance Seqs.IsSequence a => MutablePopFront (STRef s a) where+ popFront = popFrontRef+ {-# INLINE popFront #-}+instance Seqs.IsSequence a => MutablePopFront (MutVar s a) where+ popFront = popFrontRef+ {-# INLINE popFront #-}++class MutableCollection c => MutablePushFront c where+ pushFront :: (PrimMonad m, PrimState m ~ MCState c)+ => c+ -> CollElement c+ -> m ()+pushFrontRef+ :: ( PrimMonad m+ , PrimState m ~ MCState c+ , MutableRef c+ , CollElement c ~ Element (RefElement c)+ , Seqs.IsSequence (RefElement c)+ )+ => c+ -> CollElement c+ -> m ()+pushFrontRef c e = modifyRef' c (Seqs.cons e)+{-# INLINE pushFrontRef #-}+instance Seqs.IsSequence a => MutablePushFront (IORef a) where+ pushFront = pushFrontRef+ {-# INLINE pushFront #-}+instance Seqs.IsSequence a => MutablePushFront (STRef s a) where+ pushFront = pushFrontRef+ {-# INLINE pushFront #-}+instance Seqs.IsSequence a => MutablePushFront (MutVar s a) where+ pushFront = pushFrontRef+ {-# INLINE pushFront #-}++class MutableCollection c => MutablePopBack c where+ popBack :: (PrimMonad m, PrimState m ~ MCState c)+ => c+ -> m (Maybe (CollElement c))+popBackRef+ :: ( PrimMonad m+ , PrimState m ~ MCState c+ , MutableRef c+ , CollElement c ~ Element (RefElement c)+ , Seqs.IsSequence (RefElement c)+ )+ => c+ -> m (Maybe (CollElement c))+popBackRef c = do+ l <- readRef c+ case Seqs.unsnoc l of+ Nothing -> return Nothing+ Just (xs, x) -> do+ writeRef c xs+ return (Just x)+{-# INLINE popBackRef #-}+instance Seqs.IsSequence a => MutablePopBack (IORef a) where+ popBack = popBackRef+ {-# INLINE popBack #-}+instance Seqs.IsSequence a => MutablePopBack (STRef s a) where+ popBack = popBackRef+ {-# INLINE popBack #-}+instance Seqs.IsSequence a => MutablePopBack (MutVar s a) where+ popBack = popBackRef+ {-# INLINE popBack #-}++class MutableCollection c => MutablePushBack c where+ pushBack :: (PrimMonad m, PrimState m ~ MCState c)+ => c+ -> CollElement c+ -> m ()+pushBackRef+ :: ( PrimMonad m+ , PrimState m ~ MCState c+ , MutableRef c+ , CollElement c ~ Element (RefElement c)+ , Seqs.IsSequence (RefElement c)+ )+ => c+ -> CollElement c+ -> m ()+pushBackRef c e = modifyRef' c (`Seqs.snoc` e)+{-# INLINE pushBackRef #-}+instance Seqs.IsSequence a => MutablePushBack (IORef a) where+ pushBack = pushBackRef+ {-# INLINE pushBack #-}+instance Seqs.IsSequence a => MutablePushBack (STRef s a) where+ pushBack = pushBackRef+ {-# INLINE pushBack #-}+instance Seqs.IsSequence a => MutablePushBack (MutVar s a) where+ pushBack = pushBackRef+ {-# INLINE pushBack #-}++type MutableQueue c = (MutablePopFront c, MutablePushBack c)+type MutableStack c = (MutablePopFront c, MutablePushFront c)+type MutableDeque c = (MutableQueue c, MutablePushFront c, MutablePopBack c)++asIORef :: IORef a -> IORef a+asIORef = id++asSTRef :: STRef s a -> STRef s a+asSTRef = id++asMutVar :: MutVar s a -> MutVar s a+asMutVar = id
+ Data/Mutable/DList.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE TypeFamilies #-}+-- | Doubly-linked list+module Data.Mutable.DList+ ( DList+ , asDList+ , module Data.Mutable.Class+ ) where++import Data.Mutable.Class+import Data.Primitive.MutVar++data Node s a = Node+ a+ (MutVar s (Maybe (Node s a))) -- previous+ (MutVar s (Maybe (Node s a))) -- next++data DList s a = DList (MutVar s (Maybe (Node s a))) (MutVar s (Maybe (Node s a)))++asDList :: DList s a -> DList s a+asDList = id+{-# INLINE asDList #-}++instance MutableContainer (DList s a) where+ type MCState (DList s a) = s+instance MutableCollection (DList s a) where+ type CollElement (DList s a) = a+ newColl = do+ x <- newRef $! Nothing+ y <- newRef $! Nothing+ return $! DList x y+ {-# INLINE newColl #-}+instance MutablePopFront (DList s a) where+ popFront (DList frontRef backRef) = do+ mfront <- readRef frontRef+ case mfront of+ Nothing -> return Nothing+ Just (Node val _ nextRef) -> do+ mnext <- readRef nextRef+ case mnext of+ Nothing -> do+ writeRef frontRef $! Nothing+ writeRef backRef $! Nothing+ Just next@(Node _ prevRef _) -> do+ writeRef prevRef $! Nothing+ writeRef frontRef $! Just next+ return $ Just val+ {-# INLINE popFront #-}+instance MutablePopBack (DList s a) where+ popBack (DList frontRef backRef) = do+ mback <- readRef backRef+ case mback of+ Nothing -> return Nothing+ Just (Node val prevRef _) -> do+ mprev <- readRef prevRef+ case mprev of+ Nothing -> do+ writeRef frontRef $! Nothing+ writeRef backRef $! Nothing+ Just prev@(Node _ _ nextRef) -> do+ writeRef nextRef $! Nothing+ writeRef backRef (Just prev)+ return $ Just val+ {-# INLINE popBack #-}+instance MutablePushFront (DList s a) where+ pushFront (DList frontRef backRef) val = do+ mfront <- readRef frontRef+ case mfront of+ Nothing -> do+ prevRef <- newRef $! Nothing+ nextRef <- newRef $! Nothing+ let node = Just $ Node val prevRef nextRef+ writeRef frontRef node+ writeRef backRef node+ Just front@(Node _ prevRef _) -> do+ prevRefNew <- newRef $! Nothing+ nextRef <- newRef $ Just front+ let node = Just $ Node val prevRefNew nextRef+ writeRef prevRef node+ writeRef frontRef node+ {-# INLINE pushFront #-}+instance MutablePushBack (DList s a) where+ pushBack (DList frontRef backRef) val = do+ mback <- readRef backRef+ case mback of+ Nothing -> do+ prevRef <- newRef $! Nothing+ nextRef <- newRef $! Nothing+ let node = Just $! Node val prevRef nextRef+ writeRef frontRef $! node+ writeRef backRef $! node+ Just back@(Node _ _ nextRef) -> do+ nextRefNew <- newRef $! Nothing+ prevRef <- newRef $! Just back+ let node = Just $! Node val prevRef nextRefNew+ writeRef nextRef $! node+ writeRef backRef $! node+ {-# INLINE pushBack #-}
+ Data/Mutable/Deque.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE TypeFamilies #-}+module Data.Mutable.Deque+ ( Deque+ , asUDeque+ , asSDeque+ , module Data.Mutable.Class+ ) where++import Data.Mutable.Class+import qualified Data.Vector.Generic.Mutable as V+import Control.Monad+import Control.Monad.Primitive (PrimState, PrimMonad)+import Data.Primitive.MutVar (MutVar)+import qualified Data.Vector.Unboxed.Mutable as U+import qualified Data.Vector.Storable.Mutable as S++data DequeState v s a = DequeState+ (v s a)+ {-# UNPACK #-} !Int -- start+ {-# UNPACK #-} !Int -- size++newtype Deque v s a = Deque (MutVar s (DequeState v s a))++asUDeque :: Deque U.MVector s a -> Deque U.MVector s a+asUDeque = id++asSDeque :: Deque S.MVector s a -> Deque S.MVector s a+asSDeque = id++instance MutableContainer (Deque v s a) where+ type MCState (Deque v s a) = s+instance V.MVector v a => MutableCollection (Deque v s a) where+ type CollElement (Deque v s a) = a+ newColl = do+ v <- V.new baseSize+ liftM Deque $ newRef (DequeState v 0 0)+ where+ baseSize = 32+ {-# INLINE newColl #-}+instance V.MVector v a => MutablePopFront (Deque v s a) where+ popFront (Deque var) = do+ DequeState v start size <- readRef var+ if size == 0+ then return Nothing+ else do+ x <- V.unsafeRead v (start `mod` V.length v)+ writeRef var $! DequeState v (start + 1) (size - 1)+ return $! Just x+ {-# INLINE popFront #-}+instance V.MVector v a => MutablePopBack (Deque v s a) where+ popBack (Deque var) = do+ DequeState v start size <- readRef var+ if size == 0+ then return Nothing+ else do+ let size' = size - 1+ end = (start + size') `mod` V.length v+ x <- V.unsafeRead v end+ writeRef var $! DequeState v start size'+ return $! Just x+ {-# INLINE popBack #-}+instance V.MVector v a => MutablePushFront (Deque v s a) where+ pushFront (Deque var) x = do+ DequeState v start size <- readRef var+ inner v start size+ where+ inner v start size = do+ if size >= V.length v+ then newVector v start size inner+ else do+ let size' = size + 1+ start' = (start - 1) `mod` V.length v+ V.unsafeWrite v start' x+ writeRef var $! DequeState v start' size'+ {-# INLINE pushFront #-}+instance V.MVector v a => MutablePushBack (Deque v s a) where+ pushBack (Deque var) x = do+ DequeState v start size <- readRef var+ inner v start size+ where+ inner v start size = do+ if size >= V.length v+ then newVector v start size inner+ else do+ let end = (start + size) `mod` V.length v+ V.unsafeWrite v end x+ writeRef var $! DequeState v start (size + 1)+ {-# INLINE pushBack #-}++newVector :: (PrimMonad m, V.MVector v a)+ => v (PrimState m) a+ -> Int+ -> Int+ -> (v (PrimState m) a -> Int -> Int -> m b)+ -> m b+newVector v start size f = do+ v' <- V.unsafeNew (V.length v * 2)+ let size1 = V.length v - size2+ size2 = start `mod` V.length v+ V.unsafeCopy+ (V.unsafeTake size1 v')+ (V.unsafeDrop start v)+ V.unsafeCopy+ (V.unsafeSlice size1 size2 v')+ (V.unsafeTake size2 v)+ f v' 0 size+{-# INLINE newVector #-}
+ Data/Mutable/SRef.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE TypeFamilies #-}+-- | Use 1-length mutable storable vectors for mutable references.+--+-- Motivated by: <http://stackoverflow.com/questions/27261813/why-is-my-little-stref-int-require-allocating-gigabytes> and ArrayRef.+module Data.Mutable.SRef+ ( -- * Types+ SRef+ , IOSRef+ -- * Functions+ , asSRef+ , MutableRef (..)+ ) where++import Data.Mutable.Class+import Control.Monad.Primitive (PrimMonad, PrimState)+import Control.Monad.ST (ST)+import Control.Monad (liftM)+import qualified Data.Vector.Storable.Mutable as VS+import qualified Data.Vector.Mutable as VB+import qualified Data.Vector.Generic.Mutable as V++-- | A storable vector reference, supporting any monad.+newtype SRef s a = SRef (VS.MVector s a)++asSRef :: SRef s a -> SRef s a+asSRef x = x+{-# INLINE asSRef #-}++-- | A storable IO vector reference.+type IOSRef = SRef (PrimState IO)++instance MutableContainer (SRef s a) where+ type MCState (SRef s a) = s+instance VS.Storable a => MutableRef (SRef s a) where+ type RefElement (SRef s a) = a++ newRef = liftM SRef . V.replicate 1+ {-# INLINE newRef#-}++ readRef (SRef v) = V.unsafeRead v 0+ {-# INLINE readRef #-}++ writeRef (SRef v) = V.unsafeWrite v 0+ {-# INLINE writeRef #-}++ modifyRef (SRef v) f = V.unsafeRead v 0 >>= V.unsafeWrite v 0 . f+ {-# INLINE modifyRef #-}++ modifyRef' = modifyRef+ {-# INLINE modifyRef' #-}
+ Data/Mutable/URef.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE TypeFamilies #-}+-- | Use 1-length mutable unboxed vectors for mutable references.+--+-- Motivated by: <http://stackoverflow.com/questions/27261813/why-is-my-little-stref-int-require-allocating-gigabytes> and ArrayRef.+module Data.Mutable.URef+ ( -- * Types+ URef+ , IOURef+ -- * Functions+ , asURef+ , MutableRef (..)+ ) where++import Data.Mutable.Class+import Control.Monad.Primitive (PrimMonad, PrimState)+import Control.Monad.ST (ST)+import Control.Monad (liftM)+import qualified Data.Vector.Unboxed.Mutable as VU+import qualified Data.Vector.Storable.Mutable as VS+import qualified Data.Vector.Mutable as VB+import qualified Data.Vector.Generic.Mutable as V++-- | An unboxed vector reference, supporting any monad.+newtype URef s a = URef (VU.MVector s a)++asURef :: URef s a -> URef s a+asURef x = x+{-# INLINE asURef #-}++-- | An unboxed IO vector reference.+type IOURef = URef (PrimState IO)++instance MutableContainer (URef s a) where+ type MCState (URef s a) = s+instance VU.Unbox a => MutableRef (URef s a) where+ type RefElement (URef s a) = a++ newRef = liftM URef . V.replicate 1+ {-# INLINE newRef#-}++ readRef (URef v) = V.unsafeRead v 0+ {-# INLINE readRef #-}++ writeRef (URef v) = V.unsafeWrite v 0+ {-# INLINE writeRef #-}++ modifyRef (URef v) f = V.unsafeRead v 0 >>= V.unsafeWrite v 0 . f+ {-# INLINE modifyRef #-}++ modifyRef' = modifyRef+ {-# INLINE modifyRef' #-}
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Michael Snoyman++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,7 @@+This package provides common mutable containers, such as double-ended queues+and doubly-linked lists. It is implemented as both an abstract set of type+classes, and concrete implementations.++Note that this library should be considered extremely experimental. That said,+it currently has 100% test coverage and has some performance tuning, though the+API is expected to change significantly.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/bench.hs view
@@ -0,0 +1,35 @@+import Criterion.Main+import Data.Mutable.Class+import Control.Monad+import Data.IORef (IORef)+import Data.Sequence (Seq)+import Data.Mutable.Deque+import Data.Mutable.DList++test name forceType = bench name $ whnfIO $ do+ let x = 5 :: Int+ coll <- fmap forceType newColl+ replicateM_ 500 $ pushFront coll x+ replicateM_ 500 $ pushBack coll x+ replicateM_ 200 $ void $ popFront coll+ replicateM_ 200 $ void $ popBack coll+ replicateM_ 500 $ do+ pushBack coll x+ pushFront coll x+ void $ popFront coll+ replicateM_ 500 $ do+ pushBack coll x+ pushFront coll x+ replicateM_ 500 $ do+ pushBack coll x+ void $ popFront coll+{-# INLINE test #-}++main :: IO ()+main = defaultMain+ [ test "IORef [Int]" (id :: IORef [Int] -> IORef [Int])+ , test "IORef (Seq Int)" (id :: IORef (Seq Int) -> IORef (Seq Int))+ , test "UDeque" asUDeque+ , test "SDeque" asSDeque+ , test "DList" asDList+ ]
+ mutable-containers.cabal view
@@ -0,0 +1,54 @@+name: mutable-containers+version: 0.1.0.0+synopsis: Abstactions and concrete implementations of mutable containers+description: See docs and README at <http://www.stackage.org/package/mutable-containers>+homepage: https://github.com/fpco/mutable-containers+license: MIT+license-file: LICENSE+author: Michael Snoyman+maintainer: michael@fpcomplete.com+category: Data+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ exposed-modules: Data.Mutable.SRef+ Data.Mutable.Class+ Data.Mutable.URef+ Data.Mutable.DList+ Data.Mutable.Deque+ build-depends: base >= 4.7 && < 5+ , primitive+ , containers+ , vector+ , mono-traversable+ default-language: Haskell2010++test-suite test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base+ , mutable-containers+ , hspec+ , QuickCheck+ , vector+ , primitive+ , containers+ default-language: Haskell2010++benchmark bench+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: bench.hs+ build-depends: base+ , mutable-containers+ , criterion+ , containers+ ghc-options: -Wall -O2 -rtsopts+ default-language: Haskell2010++source-repository head+ type: git+ location: git://github.com/fpco/mutable-containers.git
+ test/Spec.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE TypeFamilies #-}+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck.Arbitrary+import Test.QuickCheck.Gen+import Data.Mutable.Deque+import Control.Monad (forM_)+import Data.IORef+import Data.Primitive.MutVar (MutVar)+import Control.Monad.Primitive (PrimState)+import Data.Sequence (Seq)+import Data.STRef (STRef)+import Data.Vector (Vector)+import Data.Mutable.URef+import Data.Mutable.SRef+import Data.Mutable.DList++main :: IO ()+main = hspec spec++data RefAction+ = WriteRef Int+ | ModifyRef Int+ | ModifyRef' Int+ | AtomicModifyRef Int+ | AtomicModifyRef' Int+ deriving Show+instance Arbitrary RefAction where+ arbitrary = oneof+ [ fmap WriteRef arbitrary+ , fmap ModifyRef arbitrary+ , fmap ModifyRef' arbitrary+ , fmap AtomicModifyRef arbitrary+ , fmap AtomicModifyRef' arbitrary+ ]++data DequeAction+ = PushFront Int+ | PushBack Int+ | PopFront+ | PopBack+ deriving Show+instance Arbitrary DequeAction where+ arbitrary = oneof $ concat+ [ replicate 25 $ fmap PushFront arbitrary+ , replicate 25 $ fmap PushBack arbitrary+ , [return PopFront, return PopBack]+ ]++spec :: Spec+spec = do+ describe "Deque" $ do+ let test name forceType = prop name $ \actions -> do+ base <- newColl :: IO (IORef [Int])+ tested <- fmap forceType newColl+ forM_ (PopFront : PopBack : actions) $ \action -> do+ case action of+ PushFront i -> do+ pushFront base i+ pushFront tested i+ PushBack i -> do+ pushBack base i+ pushBack tested i+ PopFront -> do+ expected <- popFront base+ actual <- popFront tested+ actual `shouldBe` expected+ PopBack -> do+ expected <- popBack base+ actual <- popBack tested+ actual `shouldBe` expected+ let drain = do+ expected <- popBack base+ actual <- popBack tested+ actual `shouldBe` expected+ case actual of+ Just _ -> drain+ Nothing -> return $! ()+ drain+ test "UDeque" asUDeque+ test "SDeque" asSDeque+ test "DList" asDList+ test "MutVar Seq" (id :: MutVar (PrimState IO) (Seq Int) -> MutVar (PrimState IO) (Seq Int))+ test "STRef Vector" (id :: STRef (PrimState IO) (Vector Int) -> STRef (PrimState IO) (Vector Int))+ describe "Ref" $ do+ let test name forceType atomic atomic' = prop name $ \start actions -> do+ base <- fmap asIORef $ newRef start+ tested <- fmap forceType $ newRef start+ let check = do+ expected <- readRef base+ actual <- readRef tested+ expected `shouldBe` actual+ forM_ actions $ \action -> case action of+ WriteRef i -> do+ writeRef base i+ writeRef tested i+ check+ ModifyRef i -> do+ modifyRef base (+ i)+ modifyRef tested (+ i)+ check+ ModifyRef' i -> do+ modifyRef' base (subtract i)+ modifyRef' tested (subtract i)+ check+ AtomicModifyRef i -> do+ let f x = (x + i, ())+ atomicModifyRef base f+ atomic tested f+ check+ AtomicModifyRef' i -> do+ atomicModifyRef' base $ \x -> (x - i, ())+ atomic' tested $ \x -> (x - i, ())+ check+ test "URef" asURef modifyRefHelper modifyRefHelper'+ test "SRef" asSRef modifyRefHelper modifyRefHelper'+ test "STRef" asSTRef modifyRefHelper modifyRefHelper'+ test "MutVar" asMutVar atomicModifyRef atomicModifyRef'++modifyRefHelper :: (MCState c ~ PrimState IO, RefElement c ~ Int, MutableRef c)+ => c+ -> (Int -> (Int, ()))+ -> IO ()+modifyRefHelper ref f = modifyRef ref $ \i ->+ let (x, y) = f i+ in y `seq` x++modifyRefHelper' :: (MCState c ~ PrimState IO, RefElement c ~ Int, MutableRef c)+ => c+ -> (Int -> (Int, ()))+ -> IO ()+modifyRefHelper' ref f = modifyRef' ref $ \i ->+ let (x, y) = f i+ in y `seq` x