├── LICENSE ├── Properties.hs ├── README.md ├── Setup.hs ├── Test.hs ├── ring-buffer.cabal └── src └── Data └── RingBuffer.hs /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Ben Gamari 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Ben Gamari nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Properties.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.IO.Class 2 | import Test.QuickCheck 3 | import Test.QuickCheck.Monadic 4 | import qualified Data.RingBuffer as R 5 | import qualified Data.Vector as V 6 | 7 | testAppend :: (Eq a, Show a) 8 | => Positive Int -> [a] -> Property 9 | testAppend (Positive cap) xs = monadicIO $ do 10 | r <- liftIO $ R.new cap :: PropertyM IO (R.RingBuffer V.Vector a) 11 | liftIO $ mapM_ (`R.append` r) (reverse xs) 12 | xs' <- liftIO $ R.toList r 13 | return $ counterexample (show xs') $ xs' == take cap xs 14 | 15 | main :: IO () 16 | main = quickCheck (testAppend :: Positive Int -> [Int] -> Property) 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ring-buffer 2 | =========== 3 | 4 | A concurrent mutable ring-buffer in Haskell. 5 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | import Data.List 4 | import qualified Data.Vector as V 5 | import qualified Data.Vector.Generic as VG 6 | import Data.RingBuffer as RB 7 | import Test.HUnit 8 | 9 | main :: IO () 10 | main = do 11 | runTestTT $ test [testConcat] 12 | return () 13 | 14 | testConcat :: Test 15 | testConcat = TestCase $ do 16 | rb <- RB.new 40 :: IO (RB.RingBuffer V.Vector Int) 17 | --mapM_ (flip RB.append rb) [0..44] 18 | RB.concat (V.fromList [0..4]) rb 19 | RB.concat (V.fromList [0..50]) rb 20 | 21 | checkLength rb 40 22 | checkItems rb [50,49..11] 23 | withItems rb $ \items -> do 24 | let expected = [11..50] 25 | assertEqual "withItems: expected" expected (sort $ V.toList items) 26 | 27 | checkLength :: VG.Vector v a => RingBuffer v a -> Int -> Assertion 28 | checkLength rb expected = do 29 | len <- RB.length rb 30 | assertEqual ("Expected length "++show expected) expected len 31 | 32 | checkItems :: (Eq a, Show a, VG.Vector v a) 33 | => RingBuffer v a -> [a] -> Assertion 34 | checkItems rb expected = do 35 | items <- RB.toList rb 36 | assertEqual ("Expected items "++show expected) expected items 37 | -------------------------------------------------------------------------------- /ring-buffer.cabal: -------------------------------------------------------------------------------- 1 | name: ring-buffer 2 | version: 0.4 3 | synopsis: A concurrent, mutable ring-buffer 4 | description: A mutable ring-buffer implementation suitable for concurrent access. 5 | homepage: http://github.com/bgamari/ring-buffer 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Ben Gamari 9 | maintainer: ben@smart-cactus.org 10 | copyright: (c) 2014 Ben Gamari 11 | category: Data 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | 15 | source-repository head 16 | type: git 17 | location: git://github.com/bgamari/ring-buffer 18 | 19 | library 20 | exposed-modules: Data.RingBuffer 21 | build-depends: base >=4.7 && <4.21, 22 | vector >=0.10 && <0.14, 23 | mtl >=2.2 && <2.4, 24 | primitive >=0.5 && <0.10, 25 | exceptions >=0.8 && <0.11 26 | hs-source-dirs: src 27 | default-language: Haskell2010 28 | 29 | test-suite properties 30 | type: exitcode-stdio-1.0 31 | main-is: Properties.hs 32 | default-language: Haskell2010 33 | build-depends: base, 34 | QuickCheck >= 2.7 && < 2.16, 35 | vector, 36 | ring-buffer 37 | 38 | test-suite tests 39 | type: exitcode-stdio-1.0 40 | main-is: Test.hs 41 | default-language: Haskell2010 42 | build-depends: base, 43 | HUnit, 44 | vector, 45 | ring-buffer 46 | -------------------------------------------------------------------------------- /src/Data/RingBuffer.hs: -------------------------------------------------------------------------------- 1 | -- | This is a thread-safe implementation of a mutable ring-buffer 2 | -- built upon @vector@. 3 | 4 | module Data.RingBuffer ( RingBuffer 5 | , new 6 | , clear 7 | , append 8 | , concat 9 | , capacity 10 | , length 11 | , latest 12 | , toList 13 | , withItems 14 | ) where 15 | 16 | import qualified Data.Vector.Generic as VG 17 | import qualified Data.Vector.Generic.Mutable as VGM 18 | import Control.Applicative 19 | import Control.Concurrent 20 | import Control.Monad (when) 21 | import Control.Monad.Catch 22 | import Control.Monad.State 23 | import Control.Monad.Reader 24 | import Control.Monad.Primitive 25 | import Prelude hiding (length, concat) 26 | 27 | -- | A concurrent ring buffer. 28 | data RingBuffer v a 29 | = RingBuffer { ringBuffer :: !(VG.Mutable v (PrimState IO) a) 30 | , ringState :: !(MVar RingState) 31 | } 32 | 33 | data RingState = RingState { ringFull :: !Bool -- ^ is the ring full? 34 | , ringHead :: !Int -- ^ index of next entry to be written 35 | } 36 | 37 | -- | We use the @Mutable@ vector type to ensure injectiveness 38 | type RingM m vm a = StateT RingState (ReaderT (vm (PrimState IO) a) m) 39 | 40 | -- | Atomically perform an action with the ring 41 | withRing :: (VG.Vector v a, MonadIO m, MonadMask m) 42 | => RingBuffer v a 43 | -> RingM m (VG.Mutable v) a r 44 | -> m r 45 | withRing rb action = mask_ $ do 46 | s <- liftIO $ takeMVar (ringState rb) 47 | (r, s') <- runReaderT (runStateT action s) (ringBuffer rb) 48 | liftIO $ putMVar (ringState rb) s' 49 | return r 50 | 51 | advance :: (VGM.MVector v a, MonadIO m) => Int -> RingM m v a () 52 | advance n = do 53 | RingState full pos <- get 54 | cap <- capacity' 55 | let (a, pos') = (pos + n) `divMod` cap 56 | put $ RingState (full || a > 0) pos' 57 | 58 | -- | Create a new ring of a given length 59 | -- 60 | -- /Note:/ size must be non-zero 61 | new :: (VG.Vector v a) => Int -> IO (RingBuffer v a) 62 | new n = do 63 | when (n < 1) $ fail "Data.RingBuffer.new: invalid ring size" 64 | buffer <- VGM.new n 65 | state0 <- newMVar $ RingState False 0 66 | return $ RingBuffer { ringBuffer=buffer, ringState=state0 } 67 | 68 | -- | Reset the ringbuffer to its empty state 69 | clear :: VG.Vector v a => RingBuffer v a -> IO () 70 | clear rb = withRing rb $ put $ RingState False 0 71 | 72 | -- | Add an item to the end of the ring 73 | append :: (VG.Vector v a) => a -> RingBuffer v a -> IO () 74 | append x rb = withRing rb $ do 75 | s <- get 76 | liftIO $ VGM.unsafeWrite (ringBuffer rb) (ringHead s) x 77 | advance 1 78 | 79 | -- | Add multiple items to the end of the ring 80 | -- This ignores any items above the length of the ring 81 | concat :: (VG.Vector v a) => v a -> RingBuffer v a -> IO () 82 | concat xs rb = withRing rb $ do 83 | cap <- capacity' 84 | let takeN = min (VG.length xs) cap 85 | xs' <- liftIO $ VG.unsafeThaw $ VG.drop (VG.length xs - takeN) xs 86 | pos <- gets ringHead 87 | 88 | let untilWrap = cap - pos 89 | src = VGM.take untilWrap xs' 90 | dest = VGM.take (min takeN untilWrap) $ VGM.drop pos $ ringBuffer rb 91 | liftIO $ VGM.copy dest src 92 | 93 | -- did we wrap around? 94 | when (takeN > untilWrap) $ do 95 | let src' = VGM.drop untilWrap xs' 96 | dest' = VGM.take (takeN - untilWrap) $ ringBuffer rb 97 | liftIO $ VGM.copy dest' src' 98 | advance takeN 99 | 100 | -- | The maximum number of items the ring can contain 101 | capacity :: (VG.Vector v a) => RingBuffer v a -> Int 102 | capacity rb = VGM.length (ringBuffer rb) 103 | 104 | -- | The maximum number of items the ring can contain 105 | capacity' :: (VGM.MVector v a, MonadIO m) => RingM m v a Int 106 | capacity' = asks VGM.length 107 | 108 | -- | The current filled length of the ring 109 | length' :: (VGM.MVector v a, MonadIO m) => RingM m v a Int 110 | length' = do 111 | RingState full pos <- get 112 | if full 113 | then capacity' 114 | else return pos 115 | 116 | -- | The current filled length of the ring 117 | length :: (VG.Vector v a) => RingBuffer v a -> IO Int 118 | length rb = withRing rb length' 119 | 120 | -- | Retrieve the \(n\)th most-recently added item of the ring 121 | latest :: (VG.Vector v a) => RingBuffer v a -> Int -> IO (Maybe a) 122 | latest rb n = withRing rb $ do 123 | len <- length' 124 | if n >= len 125 | then return Nothing 126 | else Just <$> latest' n 127 | 128 | latest' :: (VGM.MVector v a, MonadIO m) => Int -> RingM m v a a 129 | latest' n = do 130 | len <- length' 131 | cap <- capacity' 132 | when (n >= len) $ error "Data.RingBuffer.latest': invalid index" 133 | RingState _ hd <- get 134 | let idx = (hd - n - 1) `mod` cap 135 | buf <- ask 136 | liftIO $ VGM.unsafeRead buf idx 137 | 138 | -- | Get the entire contents of the ring, with the most recently added element 139 | -- at the head. Note that this is rather inefficient. 140 | toList :: (VG.Vector v a) => RingBuffer v a -> IO [a] 141 | toList rb = withRing rb $ do 142 | len <- length' 143 | mapM latest' [0..len-1] 144 | 145 | -- | Execute the given action with the items of the ring. 146 | -- Note that no references to the vector may leak out of the action as 147 | -- it will later be mutated. Moreover, the items in the vector are in 148 | -- no particular order. 149 | withItems :: (MonadIO m, MonadMask m, VG.Vector v a) 150 | => RingBuffer v a -> (v a -> m b) -> m b 151 | withItems rb action = withRing rb $ do 152 | frozen <- liftIO $ VG.unsafeFreeze (ringBuffer rb) 153 | n <- length' 154 | lift $ lift $ action (VG.take n frozen) 155 | --------------------------------------------------------------------------------