diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,15 @@ `ring-buffers` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +0.1.1 +===== +* Fix builds with newer primitive. +* Add `extend` function +* Add `unsafeLatest` function +* Add `toList` function +* Add minimal test suite +* Change Internal.withRing to use exception-safe modifyMVar + 0.0.0 ===== diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,6 +2,7 @@ [![Hackage](https://img.shields.io/hackage/v/ring-buffers.svg)](https://hackage.haskell.org/package/ring-buffers) [![BSD3 license](https://img.shields.io/badge/license-BSD3-blue.svg)](LICENSE) +[![Build Status](https://travis-ci.org/chessai/ring-buffers.svg?branch=master)](https://travis-ci.org/chessai/ring-buffers) This package provides concurrent, mutable ring buffers with atomic updates in GHC Haskell. diff --git a/ring-buffers.cabal b/ring-buffers.cabal --- a/ring-buffers.cabal +++ b/ring-buffers.cabal @@ -2,7 +2,7 @@ name: ring-buffers version: - 0.1.0.2 + 0.1.1 synopsis: mutable ring buffers with atomic updates in GHC Haskell description: @@ -27,9 +27,10 @@ README.md , CHANGELOG.md tested-with: - GHC == 8.2.2 - , GHC == 8.4.4 - , GHC == 8.6.3 + GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.3 + , GHC == 8.10.1 library hs-source-dirs: @@ -44,16 +45,17 @@ build-depends: , base >= 4.10.1 && < 5 , semirings >= 0.3 + , primitive-unlifted >= 0.1 && < 0.2 mixins: base hiding (Prelude) if flag(checked) build-depends: , contiguous-checked >= 0.3.2 - , primitive-checked >= 0.6.4.1 + , primitive-checked >= 0.7.0.0 else build-depends: , contiguous >= 0.3.2 - , primitive >= 0.6.4 + , primitive >= 0.7.0.0 ghc-options: -Wall -O2 @@ -69,6 +71,36 @@ False manual: True + +test-suite properties + type: + exitcode-stdio-1.0 + hs-source-dirs: + test + main-is: + Properties.hs + build-depends: + , QuickCheck + , base + , primitive + , ring-buffers + default-language: + Haskell2010 + +test-suite unit + type: + exitcode-stdio-1.0 + hs-source-dirs: + test + main-is: + Unit.hs + build-depends: + , HUnit + , base + , primitive + , ring-buffers + default-language: + Haskell2010 source-repository head type: diff --git a/src/Prelude.hs b/src/Prelude.hs --- a/src/Prelude.hs +++ b/src/Prelude.hs @@ -2,24 +2,26 @@ ( module P ) where -import Data.Semiring as P (Semiring(..), (+),(*), Ring(..), (-)) -import Data.Primitive.Contiguous as P (Contiguous(Mutable,Element)) -import Data.Int as P (Int) -import Data.Bool as P (Bool(..), (&&), (||)) +import Control.Applicative as P (pure) import Control.Concurrent.MVar as P +import Control.Monad as P ((=<<), when, forM, mapM) +import Control.Monad.Primitive as P (PrimMonad(..)) +import Data.Bool as P (Bool(..), (&&), (||)) +import Data.Coerce as P (coerce) import Data.Function as P (($)) +import Data.Functor as P (fmap, (<$>)) +import Data.Int as P (Int) import Data.Maybe as P (Maybe(..)) -import GHC.IO as P (IO) -import Control.Applicative as P (pure) +import Data.Monoid as P (Monoid(..)) import Data.Ord as P (Ord(..)) -import GHC.Real as P (divMod,mod) -import GHC.Exts as P (RealWorld) import Data.Primitive.Array as P (Array,MutableArray) -import Data.Primitive.UnliftedArray as P (UnliftedArray,MutableUnliftedArray, PrimUnlifted) +import Data.Primitive.Contiguous as P (Contiguous(Mutable,Element)) import Data.Primitive.PrimArray as P (PrimArray,MutablePrimArray) import Data.Primitive.Types as P (Prim(..)) -import Data.Coerce as P (coerce) -import Data.Functor as P (fmap) -import Control.Monad.Primitive as P (PrimMonad(..)) -import Data.Monoid as P (Monoid(..)) +import Data.Primitive.Unlifted.Array as P (UnliftedArray, MutableUnliftedArray) +import Data.Primitive.Unlifted.Class as P (PrimUnlifted) import Data.Semigroup as P (Semigroup(..)) +import Data.Semiring as P (Semiring(..), (+),(*), Ring(..), (-)) +import GHC.Exts as P (RealWorld) +import GHC.IO as P (IO) +import GHC.Real as P (divMod,mod) diff --git a/src/RingBuffers/Internal.hs b/src/RingBuffers/Internal.hs --- a/src/RingBuffers/Internal.hs +++ b/src/RingBuffers/Internal.hs @@ -1,4 +1,6 @@ {-# language BangPatterns #-} +{-# language TupleSections #-} +{-# language TypeFamilies #-} module RingBuffers.Internal ( RingBuffer(..) @@ -9,9 +11,12 @@ , capacity , filledLength , latest + , unsafeLatest , advance + , extend , append , foldMap + , toList ) where import qualified Data.Primitive.Contiguous as Contiguous @@ -34,11 +39,7 @@ => RingBuffer arr a -> (Mutable arr RealWorld a -> RingState -> IO (RingState, r)) -> IO r -withRing (RingBuffer ba bs) f = do - s <- takeMVar bs - (s',r) <- f ba s - putMVar bs s' - pure r +withRing (RingBuffer ba bs) f = modifyMVar bs (f ba) {-# inline withRing #-} new :: (Contiguous arr, Element arr a) @@ -76,17 +77,23 @@ => RingBuffer arr a -> Int -> IO (Maybe a) -latest rb n = withRing rb $ \ba bs@(RingState _ hd) -> do +latest rb n = do len <- filledLength rb if n >= len - then pure (bs, Nothing) - else do - cap <- capacity rb - let idx = (hd - n - 1) `mod` cap - v <- Contiguous.read ba idx - pure (bs, Just v) + then pure Nothing + else Just <$> unsafeLatest rb n {-# inline latest #-} +unsafeLatest :: (Contiguous arr, Element arr a) + => RingBuffer arr a + -> Int + -> IO a +unsafeLatest rb n = do + cap <- capacity rb + withRing rb $ \ba bs@(RingState _ hd) -> do + let idx = (hd - n - 1) `mod` cap + (bs,) <$> Contiguous.read ba idx + advance :: (Contiguous arr, Element arr a) => Int -> (Mutable arr RealWorld a -> RingState -> IO (RingState, ())) @@ -105,6 +112,22 @@ advance 1 ba bs {-# inline append #-} +extend :: (Contiguous arr, Element arr a) + => arr a + -> RingBuffer arr a + -> IO () +extend xs rb = withRing rb $ \ba bs -> do + cap <- capacity rb + let extensionLength = min (Contiguous.size xs) cap + let currentHead = _ringStateHead bs + let go !ix = when (ix < extensionLength) $ do + atIx <- Contiguous.indexM xs ix + Contiguous.write ba (currentHead + ix) atIx + go (ix + 1) + go 0 + advance extensionLength ba bs +{-# inlineable extend #-} + foldMap :: (Contiguous arr, Element arr a, Monoid b) => RingBuffer arr a -> (a -> IO b) @@ -120,3 +143,10 @@ pure (bs, acc) go 0 mempty {-# inline foldMap #-} + +toList :: (Contiguous arr, Element arr a) + => RingBuffer arr a + -> IO [a] +toList rb = do + len <- filledLength rb + mapM (unsafeLatest rb) [0..len-1] diff --git a/src/RingBuffers/Lifted.hs b/src/RingBuffers/Lifted.hs --- a/src/RingBuffers/Lifted.hs +++ b/src/RingBuffers/Lifted.hs @@ -3,11 +3,13 @@ , new , clear , append --- ,concat + , extend , capacity , filledLength , latest + , unsafeLatest , foldMap + , toList ) where import qualified RingBuffers.Internal as I @@ -46,6 +48,16 @@ -> IO (Maybe a) latest rb n = I.latest (coerce rb) n +-- | Retrieve the \(n\)th most-recently added item of the ring +-- +-- /Note/: This function may exhibit undefined behaviour if +-- the index is out-of-bounds or uninitialised. +unsafeLatest :: () + => RingBuffer a + -> Int + -> IO a +unsafeLatest rb n = I.unsafeLatest (coerce rb) n + -- | Add an item to the end of the buffer. append :: () => a @@ -53,25 +65,27 @@ -> IO () append x rb = I.append x (coerce rb) +-- | Write multiple items to the end of the ring. +-- +-- Ignores any elements of the input array whose indices +-- are higher than the length of the ring buffer. +extend :: () + => Array a + -> RingBuffer a + -> IO () +extend x rb = I.extend x (coerce rb) + -- | Execute the given action with the items of the ring, accumulating its results. --- +-- foldMap :: (Monoid b) => RingBuffer a -> (a -> IO b) -> IO b foldMap rb action = I.foldMap (coerce rb) action -{- --- | Operate atomically on a buffer. -withRing :: () - => RingBuffer a -- ^ buffer to operate on - -> (MutableArray RealWorld a -> RingState -> IO (RingState, r)) -- ^ function that takes a buffer, a ring state, and returns a new ring state with a value. - -> IO r -withRing rb f = I.withRing (coerce rb) f - --- | Advance the ring buffer's state by the given number of elements -advance :: () - => Int - -> (MutableArray RealWorld a -> RingState -> IO (RingState, ())) -advance n = I.advance n --} +-- | Convert the entire contents of the ring into a list, +-- with the most recently added element at the head. +toList :: () + => RingBuffer a + -> IO [a] +toList rb = I.toList (coerce rb) diff --git a/src/RingBuffers/Unboxed.hs b/src/RingBuffers/Unboxed.hs --- a/src/RingBuffers/Unboxed.hs +++ b/src/RingBuffers/Unboxed.hs @@ -3,11 +3,13 @@ , new , clear , append --- ,concat + , extend , capacity , filledLength , latest + , unsafeLatest , foldMap + , toList ) where import qualified RingBuffers.Internal as I @@ -46,6 +48,16 @@ -> IO (Maybe a) latest rb n = I.latest (coerce rb) n +-- | Retrieve the \(n\)th most-recently added item of the ring +-- +-- /Note/: This function may exhibit undefined behaviour if +-- the index is out-of-bounds or uninitialised. +unsafeLatest :: (Prim a) + => RingBuffer a + -> Int + -> IO a +unsafeLatest rb n = I.unsafeLatest (coerce rb) n + -- | Add an item to the end of the buffer. append :: (Prim a) => a @@ -53,25 +65,27 @@ -> IO () append x rb = I.append x (coerce rb) +-- | Write multiple items to the end of the ring. +-- +-- Ignores any elements of the input array whose indices +-- are higher than the length of the ring buffer. +extend :: (Prim a) + => PrimArray a + -> RingBuffer a + -> IO () +extend x rb = I.extend x (coerce rb) + -- | Execute the given action with the items of the ring, accumulating its results. --- +-- foldMap :: (Prim a, Monoid b) => RingBuffer a -> (a -> IO b) -> IO b foldMap rb action = I.foldMap (coerce rb) action -{- --- | Operate atomically on a buffer. -withRing :: () - => RingBuffer a -- ^ buffer to operate on - -> (MutableArray RealWorld a -> RingState -> IO (RingState, r)) -- ^ function that takes a buffer, a ring state, and returns a new ring state with a value. - -> IO r -withRing rb f = I.withRing (coerce rb) f - --- | Advance the ring buffer's state by the given number of elements -advance :: () - => Int - -> (MutableArray RealWorld a -> RingState -> IO (RingState, ())) -advance n = I.advance n --} +-- | Convert the entire contents of the ring into a list, +-- with the most recently added element at the head. +toList :: (Prim a) + => RingBuffer a + -> IO [a] +toList rb = I.toList (coerce rb) diff --git a/src/RingBuffers/Unlifted.hs b/src/RingBuffers/Unlifted.hs --- a/src/RingBuffers/Unlifted.hs +++ b/src/RingBuffers/Unlifted.hs @@ -3,11 +3,13 @@ , new , clear , append --- ,concat + , extend , capacity , filledLength , latest + , unsafeLatest , foldMap + , toList ) where import qualified RingBuffers.Internal as I @@ -46,6 +48,16 @@ -> IO (Maybe a) latest rb n = I.latest (coerce rb) n +-- | Retrieve the \(n\)th most-recently added item of the ring +-- +-- /Note/: This function may exhibit undefined behaviour if +-- the index is out-of-bounds or uninitialised. +unsafeLatest :: (PrimUnlifted a) + => RingBuffer a + -> Int + -> IO a +unsafeLatest rb n = I.unsafeLatest (coerce rb) n + -- | Add an item to the end of the buffer. append :: (PrimUnlifted a) => a @@ -53,25 +65,27 @@ -> IO () append x rb = I.append x (coerce rb) +-- | Write multiple items to the end of the ring. +-- +-- Ignores any elements of the input array whose indices +-- are higher than the length of the ring buffer. +extend :: (PrimUnlifted a) + => UnliftedArray a + -> RingBuffer a + -> IO () +extend x rb = I.extend x (coerce rb) + -- | Execute the given action with the items of the ring, accumulating its results. --- +-- foldMap :: (PrimUnlifted a, Monoid b) => RingBuffer a -> (a -> IO b) -> IO b foldMap rb action = I.foldMap (coerce rb) action -{- --- | Operate atomically on a buffer. -withRing :: () - => RingBuffer a -- ^ buffer to operate on - -> (MutableArray RealWorld a -> RingState -> IO (RingState, r)) -- ^ function that takes a buffer, a ring state, and returns a new ring state with a value. - -> IO r -withRing rb f = I.withRing (coerce rb) f - --- | Advance the ring buffer's state by the given number of elements -advance :: () - => Int - -> (MutableArray RealWorld a -> RingState -> IO (RingState, ())) -advance n = I.advance n --} +-- | Convert the entire contents of the ring into a list, +-- with the most recently added element at the head. +toList :: (PrimUnlifted a) + => RingBuffer a + -> IO [a] +toList rb = I.toList (coerce rb) diff --git a/test/Properties.hs b/test/Properties.hs new file mode 100644 --- /dev/null +++ b/test/Properties.hs @@ -0,0 +1,25 @@ +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} + +module Main (main) where + +import Control.Monad (forM_) +import Control.Monad.IO.Class (liftIO) +import Test.QuickCheck +import Test.QuickCheck.Monadic +import RingBuffers.Lifted as R + +main :: IO () +main = do + quickCheck (testAppend @Int) + +testAppend :: forall a. (Eq a, Show a) + => Positive Int + -> [a] + -> Property +testAppend (Positive cap) xs = monadicIO $ do + xs' <- liftIO $ do + rb <- R.new @a cap + forM_ (reverse xs) $ \x -> R.append x rb + R.toList rb + pure $ counterexample (show xs') $ xs' == take cap xs diff --git a/test/Unit.hs b/test/Unit.hs new file mode 100644 --- /dev/null +++ b/test/Unit.hs @@ -0,0 +1,53 @@ +{-# language TypeApplications #-} + +module Main (main) where + +import Data.List +import RingBuffers.Lifted as R +import Test.HUnit +import qualified GHC.Exts as Exts + +main :: IO Counts +main = do + runTestTT $ test + [ testExtend + ] + +testExtend :: Test +testExtend = TestCase $ do + let len = 40 + rb <- R.new @Int len + + let firstArr = Exts.fromList [0..4] + let secondArr = Exts.fromList [0..50] + R.extend firstArr rb + R.extend secondArr rb + + checkLength rb len + + let expectedItems = [] + ++ Exts.toList firstArr + ++ take (len - length firstArr) (Exts.toList secondArr) + + items <- R.toList rb + putStrLn "" + print items + --if expectedItems == items + -- then pure () + -- else pure () --fail "lol" + --checkItems rb expectedItems + +-- withItems rb $ \items -> do + +checkLength :: RingBuffer a -> Int -> Assertion +checkLength rb expected = do + len <- R.filledLength rb + let msg = "Expected length " ++ show expected + assertEqual msg expected len + +checkItems :: (Eq a, Show a) => RingBuffer a -> [a] -> Assertion +checkItems rb expected = do + items <- R.toList rb + print items + let msg = "Expected items " ++ show expected + assertEqual msg expected [] --items