rrb-vector 0.1.1.0 → 0.2.2.1
raw patch · 17 files changed
Files
- CHANGELOG.md +29/−0
- Setup.hs +0/−2
- bench/Main.hs +11/−1
- bench/Traverse.hs +0/−25
- rrb-vector.cabal +25/−19
- src/Data/RRBVector.hs +8/−2
- src/Data/RRBVector/Internal.hs +228/−106
- src/Data/RRBVector/Internal/Array.hs +121/−18
- src/Data/RRBVector/Internal/Buffer.hs +21/−5
- src/Data/RRBVector/Internal/Debug.hs +146/−7
- src/Data/RRBVector/Internal/Indexed.hs +0/−26
- src/Data/RRBVector/Internal/IntRef.hs +8/−0
- src/Data/RRBVector/Internal/Sorting.hs +49/−0
- test/Arbitrary.hs +31/−2
- test/Main.hs +0/−2
- test/Properties.hs +154/−37
- test/Strictness.hs +33/−11
CHANGELOG.md view
@@ -1,7 +1,36 @@+# 0.2.2.1 - July 2024++* Add `sort`, `sortBy`, `sortOn` ([#23](https://github.com/konsumlamm/rrb-vector/pull/22))+* Fix bug in `><` ([#19](https://github.com/konsumlamm/rrb-vector/pull/19))+* Fix bug in `<|` ([#18](https://github.com/konsumlamm/rrb-vector/pull/18))++# 0.2.1.0 - December 2023++* Add `findIndexL`, `findIndexR`, `findIndicesL`, `findIndicesR`+* Fix bug in `|>` & `<|` ([#10](https://github.com/konsumlamm/rrb-vector/issues/10))++# 0.2.0.1 - October 2023++* Support `primitive-0.9` and `deepseq-1.5`++# 0.2.0.0 - February 2023++* Add `map'` & `unzipWith`+* Make `zip` & `unzip` more strict+* Make all functions strict in the index+* Make the `FoldableWithIndex`, `FunctorWithIndex`, `TraversableWithIndex` instances more efficient+* Implement `ifoldMap` in the `FoldableWithIndex` instance+* Implement `fail` in the `Monad` instance+* Add `Shift`, `Tree` and unidirectional pattern synonyms for `Vector` and `Tree` to `Data.RRBVector.Internal.Debug`+* Support `primitive-0.8`++* Test typeclass laws+ # 0.1.1.0 - August 2021 * Add `replicate` * Various optimizations+ * Switch to the [`tasty` framework](https://hackage.haskell.org/package/tasty) for benchmarks and tests * Extend the test suite - Add properties for more functions and some typeclass instances
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
bench/Main.hs view
@@ -6,19 +6,29 @@ import qualified Data.RRBVector as RRB +default (Int)+ main :: IO () main = defaultMain $ [10, 100, 1000, 10000, 100000] <&> \n -> let !v = RRB.fromList [1..n] !idx = n `div` 2 in bgroup (show n)- [ bench "fromList" $ nf RRB.fromList [1..n]+ [ bench "fromList" $ whnf RRB.fromList [1..n] , bench "><" $ whnf (\vec -> vec RRB.>< vec) v , bench "|>" $ whnf (RRB.|> 42) v , bench "<|" $ whnf (42 RRB.<|) v , bench "take" $ whnf (RRB.take idx) v , bench "drop" $ whnf (RRB.drop idx) v+ , bench "splitAt" $ whnf (RRB.splitAt idx) v+ , bench "insertAt" $ whnf (RRB.insertAt idx 42) v+ , bench "deleteAt" $ whnf (RRB.deleteAt idx) v , bench "index" $ nf (RRB.lookup idx) v , bench "adjust" $ whnf (RRB.adjust idx (+ 1)) v+ , bench "map" $ whnf (RRB.map (+ 1)) v , bench "foldl" $ nf (foldl (+) 0) v , bench "foldr" $ nf (foldr (+) 0) v+ , bench "findIndexL" $ nf (RRB.findIndexL (== idx)) v+ , bench "findIndexR" $ nf (RRB.findIndexR (== idx)) v+ , bench "findIndicesL" $ nf (RRB.findIndicesL (== idx)) v+ , bench "findIndicesR" $ nf (RRB.findIndicesR (== idx)) v ]
− bench/Traverse.hs
@@ -1,25 +0,0 @@-{-# LANGUAGE BangPatterns #-}--import Control.Applicative (liftA2)-import Control.Monad (replicateM)-import Data.Foldable (foldl', toList)-import Data.Functor--import Test.Tasty.Bench--import qualified Data.RRBVector as RRB--main :: IO ()-main = defaultMain $ [100, 1000, 10000] <&> \n ->- let !v = RRB.fromList [1..n]- !idx = n `div` 2- in bgroup (show n)- [ bench "foldr" $ nf (foldr (+) 0) v- , bench "ifoldr" $ nf (RRB.ifoldr (\i x acc -> i + x + acc) 0) v- , bench "foldl" $ nf (foldl (+) 0) v- , bench "ifoldl" $ nf (RRB.ifoldl (\i acc x -> i + acc + x) 0) v- , bench "map" $ nf (RRB.map (+ 1)) v- , bench "imap" $ nf (RRB.imap (+)) v- , bench "traverse" $ nf (traverse (Just $!)) v- , bench "itraverse" $ nf (RRB.itraverse (\i x -> Just $! i + x)) v- ]
rrb-vector.cabal view
@@ -1,5 +1,5 @@ name: rrb-vector-version: 0.1.1.0+version: 0.2.2.1 synopsis: Efficient RRB-Vectors description: An RRB-Vector is an efficient sequence data structure.@@ -22,11 +22,21 @@ CHANGELOG.md README.md cabal-version: 2.0-tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.5, GHC == 9.0.1+tested-with:+ GHC == 8.4.4+ GHC == 8.6.5+ GHC == 8.8.4+ GHC == 8.10.7+ GHC == 9.0.2+ GHC == 9.2.8+ GHC == 9.4.8+ GHC == 9.6.5+ GHC == 9.8.2+ GHC == 9.10.1 source-repository head type: git- location: https://github.com/konsumlamm/rrb-vector+ location: https://github.com/konsumlamm/rrb-vector.git library hs-source-dirs: src@@ -37,10 +47,15 @@ Data.RRBVector.Internal Data.RRBVector.Internal.Array Data.RRBVector.Internal.Buffer- Data.RRBVector.Internal.Indexed Data.RRBVector.Internal.IntRef- build-depends: base >= 4.11 && < 5, deepseq ^>= 1.4.3, indexed-traversable ^>= 0.1, primitive ^>= 0.7- ghc-options: -O2 -Wall -Wno-name-shadowing+ Data.RRBVector.Internal.Sorting+ build-depends:+ base >= 4.11 && < 5,+ deepseq >= 1.4.3 && < 1.6,+ indexed-traversable ^>= 0.1,+ primitive >= 0.7.3 && < 0.10,+ samsort ^>= 0.1+ ghc-options: -O2 -Wall -Wno-name-shadowing -Werror=missing-methods -Werror=missing-fields default-language: Haskell2010 test-suite test@@ -52,9 +67,9 @@ Strictness type: exitcode-stdio-1.0 ghc-options: -Wall -Wno-orphans -Wno-type-defaults- build-depends: base >= 4.11 && < 5, deepseq, indexed-traversable, rrb-vector, tasty, tasty-quickcheck- if impl(ghc == 8.10.*)- build-depends: ghc-heap-view+ build-depends: base, containers, deepseq, quickcheck-classes-base, rrb-vector, tasty, tasty-quickcheck+ if impl(ghc >= 8.6)+ build-depends: nothunks default-language: Haskell2010 default-extensions: ExtendedDefaultRules, ScopedTypeVariables @@ -64,14 +79,5 @@ type: exitcode-stdio-1.0 default-language: Haskell2010 ghc-options: -O2- build-depends: base >= 4.11 && < 5, rrb-vector, tasty-bench- default-extensions: ExtendedDefaultRules--benchmark traverse- hs-source-dirs: bench- main-is: Traverse.hs- type: exitcode-stdio-1.0- default-language: Haskell2010- ghc-options: -O2- build-depends: base >= 4.11 && < 5, primitive, rrb-vector, tasty-bench+ build-depends: base, rrb-vector, tasty-bench default-extensions: ExtendedDefaultRules
src/Data/RRBVector.hs view
@@ -33,6 +33,7 @@ , adjust, adjust' , take, drop, splitAt , insertAt, deleteAt+ , findIndexL, findIndexR, findIndicesL, findIndicesR -- * With Index -- -- | Reexported from [indexed-traversable](https://hackage.haskell.org/package/indexed-traversable).@@ -40,9 +41,13 @@ , module Data.Functor.WithIndex , module Data.Traversable.WithIndex -- * Transformations- , map, reverse+ , map, map', reverse -- * Zipping and unzipping- , zip, zipWith, unzip+ , zip, zipWith, unzip, unzipWith+ -- * Sorting+ --+ -- | Currently implemented using [samsort](https://hackage.haskell.org/package/samsort).+ , sort, sortBy, sortOn ) where import Prelude hiding (replicate, lookup, take, drop, splitAt, map, reverse, zip, zipWith, unzip)@@ -52,3 +57,4 @@ import Data.Traversable.WithIndex import Data.RRBVector.Internal+import Data.RRBVector.Internal.Sorting
src/Data/RRBVector/Internal.hs view
@@ -3,12 +3,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Data.RRBVector.Internal ( Vector(..) , Tree(..)+ , Shift -- * Internal- , blockShift, blockSize, treeSize, computeSizes, up+ , blockShift, blockSize, treeSize, computeSizes, up, down -- * Construction , empty, singleton, fromList, replicate -- ** Concatenation@@ -22,30 +24,34 @@ , adjust, adjust' , take, drop, splitAt , insertAt, deleteAt+ , findIndexL, findIndexR, findIndicesL, findIndicesR -- * Transformations- , map, reverse+ , map, map', reverse -- * Zipping and unzipping- , zip, zipWith, unzip+ , zip, zipWith, unzip, unzipWith ) where +#if !(MIN_VERSION_base(4,18,0)) import Control.Applicative (Alternative, liftA2)+#else+import Control.Applicative (Alternative)+#endif import qualified Control.Applicative import Control.DeepSeq import Control.Monad (when, MonadPlus) import Control.Monad.ST (runST)-#if !(MIN_VERSION_base(4,13,0))-import Control.Monad.Fail (MonadFail(..))-#endif+import qualified Control.Monad.Fail as Fail import Control.Monad.Fix (MonadFix(..)) import Control.Monad.Zip (MonadZip(..)) import Data.Bits import Data.Foldable (Foldable(..), for_) import Data.Functor.Classes-import Data.Functor.Identity (Identity(..)) import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (fromMaybe) import Data.Semigroup+ import qualified GHC.Exts as Exts import GHC.Stack (HasCallStack) import Prelude hiding (replicate, lookup, map, take, drop, splitAt, head, last, reverse, zip, zipWith, unzip)@@ -55,10 +61,9 @@ import Data.Foldable.WithIndex import Data.Traversable.WithIndex -import Data.Primitive.PrimArray+import Data.Primitive.PrimArray hiding (sizeofPrimArray) -- use @length@ of the @A.Array@ instead import qualified Data.RRBVector.Internal.Array as A import qualified Data.RRBVector.Internal.Buffer as Buffer-import Data.RRBVector.Internal.Indexed infixr 5 >< infixr 5 <|@@ -66,9 +71,10 @@ type Shift = Int --- Invariant: Children of a Balanced node are always balanced.--- A Leaf node is considered balanced.+-- Invariants:+-- Children of a Balanced node are always balanced (a Leaf node is considered balanced). -- Nodes are always non-empty.+-- The two arrays in an Unbalanced node always have the same size. data Tree a = Balanced {-# UNPACK #-} !(A.Array (Tree a)) | Unbalanced {-# UNPACK #-} !(A.Array (Tree a)) !(PrimArray Int)@@ -131,7 +137,7 @@ treeSize = go 0 where go !acc !_ (Leaf arr) = acc + length arr- go acc _ (Unbalanced _ sizes) = acc + indexPrimArray sizes (sizeofPrimArray sizes - 1)+ go acc _ (Unbalanced arr sizes) = acc + indexPrimArray sizes (length arr - 1) go acc sh (Balanced arr) = let i = length arr - 1 in go (acc + i * (1 `unsafeShiftL` sh)) (down sh) (A.index arr i)@@ -143,7 +149,7 @@ computeSizes !sh arr | isBalanced = Balanced arr | otherwise = runST $ do- sizes <- newPrimArray (length arr)+ sizes <- newPrimArray len let loop acc i | i < len = let size = treeSize (down sh) (A.index arr i)@@ -168,7 +174,7 @@ where subtree = A.index arr i --- Integer log base 2.+-- | Integer log base 2. log2 :: Int -> Int log2 x = bitSizeMinus1 - countLeadingZeros x where@@ -189,6 +195,9 @@ readListPrec = readListPrecDefault instance Eq1 Vector where+ liftEq _ Empty Empty = True+ liftEq _ Empty _ = False+ liftEq _ _ Empty = False liftEq f v1 v2 = length v1 == length v2 && liftEq f (toList v1) (toList v2) instance (Eq a) => Eq (Vector a) where@@ -202,10 +211,12 @@ instance Semigroup (Vector a) where (<>) = (><)+ sconcat (v :| vs) = v >< mconcat vs stimes = stimesMonoid instance Monoid (Vector a) where mempty = empty+ mconcat = foldl' (><) empty instance Foldable Vector where foldr f acc = go@@ -255,20 +266,60 @@ length (Root s _ _) = s instance FoldableWithIndex Int Vector where- ifoldr f z0 v = foldr' (\x g !i -> f i x (g (i + 1))) (const z0) v 0+ ifoldMap f = ifoldr (\i x acc -> f i x <> acc) mempty+ {-# INLINE ifoldMap #-}++ ifoldr f acc = go+ where+ go Empty = acc+ go (Root _ sh tree) = ifoldrTree 0 sh tree acc++ ifoldrTree !i !sh (Balanced arr) acc' = A.ifoldrStep i (treeSize (down sh)) (flip ifoldrTree (down sh)) acc' arr+ ifoldrTree i sh (Unbalanced arr _) acc' = A.ifoldrStep i (treeSize (down sh)) (flip ifoldrTree (down sh)) acc' arr+ ifoldrTree i _ (Leaf arr) acc' = A.ifoldrStep i (\_ -> 1) f acc' arr {-# INLINE ifoldr #-} - ifoldl f z0 v = foldl' (\g x !i -> f i (g (i - 1)) x) (const z0) v (length v - 1)+ ifoldl f acc = go+ where+ go Empty = acc+ go (Root size sh tree) = ifoldlTree (size - 1) sh acc tree++ ifoldlTree !i !sh acc' (Balanced arr) = A.ifoldlStep i (treeSize (down sh)) (flip ifoldlTree (down sh)) acc' arr+ ifoldlTree i sh acc' (Unbalanced arr _) = A.ifoldlStep i (treeSize (down sh)) (flip ifoldlTree (down sh)) acc' arr+ ifoldlTree i _ acc' (Leaf arr) = A.ifoldlStep i (\_ -> 1) f acc' arr {-# INLINE ifoldl #-} + ifoldr' f acc = go+ where+ go Empty = acc+ go (Root size sh tree) = ifoldrTree' (size - 1) sh tree acc++ ifoldrTree' !i !sh (Balanced arr) acc' = A.ifoldrStep' i (treeSize (down sh)) (flip ifoldrTree' (down sh)) acc' arr+ ifoldrTree' i sh (Unbalanced arr _) acc' = A.ifoldrStep' i (treeSize (down sh)) (flip ifoldrTree' (down sh)) acc' arr+ ifoldrTree' i _ (Leaf arr) acc' = A.ifoldrStep' i (\_ -> 1) f acc' arr+ {-# INLINE ifoldr' #-}++ ifoldl' f acc = go+ where+ go Empty = acc+ go (Root _ sh tree) = ifoldlTree' 0 sh acc tree++ ifoldlTree' !i !sh acc' (Balanced arr) = A.ifoldlStep' i (treeSize (down sh)) (flip ifoldlTree' (down sh)) acc' arr+ ifoldlTree' i sh acc' (Unbalanced arr _) = A.ifoldlStep' i (treeSize (down sh)) (flip ifoldlTree' (down sh)) acc' arr+ ifoldlTree' i _ acc' (Leaf arr) = A.ifoldlStep' i (\_ -> 1) f acc' arr+ {-# INLINE ifoldl' #-}+ instance Functor Vector where fmap = map x <$ v = replicate (length v) x instance FunctorWithIndex Int Vector where- imap f v = runIdentity $ evalIndexed (traverse (Indexed . f') v) 0+ imap _ Empty = Empty+ imap f (Root size sh tree) = Root size sh (imapTree 0 sh tree) where- f' x !i = WithIndex (i + 1) (Identity (f i x))+ imapTree !i !sh (Balanced arr) = Balanced (A.imapStep' i (treeSize (down sh)) (\i -> imapTree i (down sh)) arr)+ imapTree i sh (Unbalanced arr sizes) = Unbalanced (A.imapStep' i (treeSize (down sh)) (\i -> imapTree i (down sh)) arr) sizes+ imapTree i _ (Leaf arr) = Leaf (A.imapStep i (\_ -> 1) f arr) instance Traversable Vector where traverse _ Empty = pure Empty@@ -280,20 +331,27 @@ {-# INLINE traverse #-} instance TraversableWithIndex Int Vector where- itraverse f v = evalIndexed (traverse (Indexed . f') v) 0+ itraverse _ Empty = pure Empty+ itraverse f (Root size sh tree) = Root size sh <$> itraverseTree 0 sh tree where- f' x !i = WithIndex (i + 1) (f i x)+ itraverseTree !i !sh (Balanced arr) = Balanced <$> A.itraverseStep' i (treeSize (down sh)) (\i -> itraverseTree i (down sh)) arr+ itraverseTree i sh (Unbalanced arr sizes) = flip Unbalanced sizes <$> A.itraverseStep' i (treeSize (down sh)) (\i -> itraverseTree i (down sh)) arr+ itraverseTree i _ (Leaf arr) = Leaf <$> A.itraverseStep i (\_ -> 1) f arr {-# INLINE itraverse #-} instance Applicative Vector where pure = singleton fs <*> xs = foldl' (\acc f -> acc >< map f xs) empty fs liftA2 f xs ys = foldl' (\acc x -> acc >< map (f x) ys) empty xs- xs *> ys = foldl' (\acc _ -> acc >< ys) empty xs+ xs *> ys = stimes (length xs) ys xs <* ys = foldl' (\acc x -> acc >< replicate (length ys) x) empty xs instance Monad Vector where xs >>= f = foldl' (\acc x -> acc >< f x) empty xs+ (>>) = (*>)+#if !(MIN_VERSION_base(4,13,0))+ fail = Fail.fail+#endif instance Alternative Vector where empty = empty@@ -301,11 +359,13 @@ instance MonadPlus Vector -instance MonadFail Vector where+instance Fail.MonadFail Vector where fail _ = empty instance MonadFix Vector where- mfix f = fromList $ fmap (\i -> let x = index i (f x) in x) [0..length (f err) - 1]+ mfix f = case f err of+ Empty -> Empty+ Root size _ _ -> fromList $ fmap (\i -> let x = f x ! i in x) [0..size - 1] where err = error "mfix for Data.RRBVector.Vector applied to strict function" @@ -352,16 +412,14 @@ buffer <- Buffer.new blockSize let loop [] = do result <- Buffer.get buffer- let !x = f result- pure [x]+ pure [f result] loop (t : ts) = do size <- Buffer.size buffer if size == blockSize then do result <- Buffer.get buffer Buffer.push buffer t rest <- loop ts- let !x = f result- pure (x : rest)+ pure (f result : rest) else do Buffer.push buffer t loop ts@@ -395,7 +453,7 @@ -- | \(O(\log n)\). The element at the index or 'Nothing' if the index is out of range. lookup :: Int -> Vector a -> Maybe a-lookup _ Empty = Nothing+lookup !_ Empty = Nothing lookup i (Root size sh tree) | i < 0 || i >= size = Nothing -- index out of range | otherwise = Just $ lookupTree i sh tree@@ -405,38 +463,41 @@ let (idx, subIdx) = relaxedRadixIndex sizes i sh in lookupTree subIdx (down sh) (A.index arr idx) lookupTree i _ (Leaf arr) = A.index arr (i .&. blockMask)+{-# INLINE lookup #-} -- | \(O(\log n)\). The element at the index. Calls 'error' if the index is out of range. index :: HasCallStack => Int -> Vector a -> a-index i = fromMaybe (error "AMT.index: index out of range") . lookup i+index i = fromMaybe (error "index out of range") . lookup i {-# INLINE index #-} -- | \(O(\log n)\). A flipped version of 'lookup'. (!?) :: Vector a -> Int -> Maybe a (!?) = flip lookup+{-# INLINE (!?) #-} -- | \(O(\log n)\). A flipped version of 'index'. (!) :: HasCallStack => Vector a -> Int -> a (!) = flip index+{-# INLINE (!) #-} -- | \(O(\log n)\). Update the element at the index with a new element. -- If the index is out of range, the original vector is returned. update :: Int -> a -> Vector a -> Vector a-update _ _ Empty = Empty+update !_ _ Empty = Empty update i x v@(Root size sh tree) | i < 0 || i >= size = v -- index out of range- | otherwise = Root size sh (adjustTree i sh tree)+ | otherwise = Root size sh (updateTree i sh tree) where- adjustTree i sh (Balanced arr) = Balanced (A.adjust' arr (radixIndex i sh) (adjustTree i (down sh)))- adjustTree i sh (Unbalanced arr sizes) =+ updateTree i sh (Balanced arr) = Balanced (A.adjust' arr (radixIndex i sh) (updateTree i (down sh)))+ updateTree i sh (Unbalanced arr sizes) = let (idx, subIdx) = relaxedRadixIndex sizes i sh- in Unbalanced (A.adjust' arr idx (adjustTree subIdx (down sh))) sizes- adjustTree i _ (Leaf arr) = Leaf (A.update arr (i .&. blockMask) x)+ in Unbalanced (A.adjust' arr idx (updateTree subIdx (down sh))) sizes+ updateTree i _ (Leaf arr) = Leaf (A.update arr (i .&. blockMask) x) -- | \(O(\log n)\). Adjust the element at the index by applying the function to it. -- If the index is out of range, the original vector is returned. adjust :: Int -> (a -> a) -> Vector a -> Vector a-adjust _ _ Empty = Empty+adjust !_ _ Empty = Empty adjust i f v@(Root size sh tree) | i < 0 || i >= size = v -- index out of range | otherwise = Root size sh (adjustTree i sh tree)@@ -449,7 +510,7 @@ -- | \(O(\log n)\). Like 'adjust', but the result of the function is forced. adjust' :: Int -> (a -> a) -> Vector a -> Vector a-adjust' _ _ Empty = Empty+adjust' !_ _ Empty = Empty adjust' i f v@(Root size sh tree) | i < 0 || i >= size = v -- index out of range | otherwise = Root size sh (adjustTree i sh tree)@@ -472,19 +533,30 @@ mapTree (Unbalanced arr sizes) = Unbalanced (A.map' mapTree arr) sizes mapTree (Leaf arr) = Leaf (A.map f arr) +-- | \(O(n)\). Like 'map', but the results of the function are forced.+--+-- @since 0.2.0.0+map' :: (a -> b) -> Vector a -> Vector b+map' _ Empty = Empty+map' f (Root size sh tree) = Root size sh (mapTree tree)+ where+ mapTree (Balanced arr) = Balanced (A.map' mapTree arr)+ mapTree (Unbalanced arr sizes) = Unbalanced (A.map' mapTree arr) sizes+ mapTree (Leaf arr) = Leaf (A.map' f arr)+ -- | \(O(n)\). Reverse the vector. -- -- >>> reverse (fromList [1, 2, 3]) -- fromList [3,2,1] reverse :: Vector a -> Vector a-reverse = fromList . foldl' (flip (:)) [] -- convert the vector to a reverse list and then rebuild+reverse v+ | length v <= 1 = v+ | otherwise = fromList (foldl' (flip (:)) [] v) -- convert the vector to a reverse list and then rebuild -- | \(O(\min(n_1, n_2))\). Take two vectors and return a vector of corresponding pairs. -- If one input is longer, excess elements are discarded from the right end.------ > zip = zipWith (,) zip :: Vector a -> Vector b -> Vector (a, b)-zip = zipWith (,)+zip v1 v2 = fromList $ List.zip (toList v1) (toList v2) -- | \(O(\min(n_1, n_2))\). 'zipWith' generalizes 'zip' by zipping with the function. zipWith :: (a -> b -> c) -> Vector a -> Vector b -> Vector c@@ -495,11 +567,25 @@ -- >>> unzip (fromList [(1, "a"), (2, "b"), (3, "c")]) -- (fromList [1,2,3],fromList ["a","b","c"]) unzip :: Vector (a, b) -> (Vector a, Vector b)-unzip v =- let !left = map fst v- !right = map snd v- in (left, right)+unzip = Exts.inline unzipWith id +-- | \(O(n)\). Unzip a vector with a function.+--+-- > unzipWith f = unzip . map f+--+-- @since 0.2.0.0+unzipWith :: (a -> (b, c)) -> Vector a -> (Vector b, Vector c)+unzipWith _ Empty = (Empty, Empty)+unzipWith f (Root size sh tree) = case unzipTree tree of+ (!left, !right) -> (Root size sh left, Root size sh right)+ where+ unzipTree (Balanced arr) = case A.unzipWith unzipTree arr of+ (!left, !right) -> (Balanced left, Balanced right)+ unzipTree (Unbalanced arr sizes) = case A.unzipWith unzipTree arr of+ (!left, !right) -> (Unbalanced left sizes, Unbalanced right sizes)+ unzipTree (Leaf arr) = case A.unzipWith f arr of+ (!left, !right) -> (Leaf left, Leaf right)+ -- | \(O(\log n)\). The first element and the vector without the first element, or 'Nothing' if the vector is empty. -- -- >>> viewl (fromList [1, 2, 3])@@ -524,23 +610,76 @@ lastTree (Unbalanced arr _) = lastTree (A.last arr) lastTree (Leaf arr) = A.last arr +-- | \(O(\log n)\). The first @i@ elements of the vector.+-- If @i@ is negative, the empty vector is returned. If the vector contains less than @i@ elements, the whole vector is returned.+take :: Int -> Vector a -> Vector a+take !_ Empty = Empty+take n v@(Root size sh tree)+ | n <= 0 = empty+ | n >= size = v+ | otherwise = normalize $ Root n sh (takeTree (n - 1) sh tree)++-- | \(O(\log n)\). The vector without the first @i@ elements.+-- If @i@ is negative, the whole vector is returned. If the vector contains less than @i@ elements, the empty vector is returned.+drop :: Int -> Vector a -> Vector a+drop !_ Empty = Empty+drop n v@(Root size sh tree)+ | n <= 0 = v+ | n >= size = empty+ | otherwise = normalize $ Root (size - n) sh (dropTree n sh tree)+ -- | \(O(\log n)\). Split the vector at the given index. -- -- > splitAt n v = (take n v, drop n v) splitAt :: Int -> Vector a -> (Vector a, Vector a)-splitAt n v =- let !left = take n v- !right = drop n v- in (left, right)+splitAt !_ Empty = (Empty, Empty)+splitAt n v@(Root size sh tree)+ | n <= 0 = (empty, v)+ | n >= size = (v, empty)+ | otherwise =+ let !left = normalize $ Root n sh (takeTree (n - 1) sh tree)+ !right = normalize $ Root (size - n) sh (dropTree n sh tree)+ in (left, right) --- | \(O(\log n)\). Insert an element at the given index.+-- | \(O(\log n)\). Insert an element at the given index, shifting the rest of the vector over.+-- If the index is negative, add the element to the left end of the vector.+-- If the index is bigger than or equal to the length of the vector, add the element to the right end of the vector. insertAt :: Int -> a -> Vector a -> Vector a insertAt i x v = let (left, right) = splitAt i v in (left |> x) >< right -- | \(O(\log n)\). Delete the element at the given index.+-- If the index is out of range, return the original vector. deleteAt :: Int -> Vector a -> Vector a deleteAt i v = let (left, right) = splitAt (i + 1) v in take i left >< right +-- | \(O(n)\). Find the first index from the left that satisfies the predicate.+--+-- @since 0.2.1.0+findIndexL :: (a -> Bool) -> Vector a -> Maybe Int+findIndexL f = ifoldr (\i x acc -> if f x then Just i else acc) Nothing+{-# INLINE findIndexL #-}++-- | \(O(n)\). Find the first index from the right that satisfies the predicate.+--+-- @since 0.2.1.0+findIndexR :: (a -> Bool) -> Vector a -> Maybe Int+findIndexR f = ifoldl (\i acc x -> if f x then Just i else acc) Nothing+{-# INLINE findIndexR #-}++-- | \(O(n)\). Find the indices that satisfy the predicate, starting from the left.+--+-- @since 0.2.1.0+findIndicesL :: (a -> Bool) -> Vector a -> [Int]+findIndicesL f = ifoldr (\i x acc -> if f x then i : acc else acc) []+{-# INLINE findIndicesL #-}++-- | \(O(n)\). Find the indices that satisfy the predicate, starting from the right.+--+-- @since 0.2.1.0+findIndicesR :: (a -> Bool) -> Vector a -> [Int]+findIndicesR f = ifoldl (\i acc x -> if f x then i : acc else acc) []+{-# INLINE findIndicesR #-}+ -- concatenation -- | \(O(\log \max(n_1, n_2))\). Concatenates two vectors.@@ -551,18 +690,15 @@ Empty >< v = v v >< Empty = v Root size1 sh1 tree1 >< Root size2 sh2 tree2 =- let maxShift = max sh1 sh2- upMaxShift = up maxShift+ let upMaxShift = up (max sh1 sh2) newArr = mergeTrees tree1 sh1 tree2 sh2- in if length newArr == 1- then Root (size1 + size2) maxShift (A.head newArr)- else Root (size1 + size2) upMaxShift (computeSizes upMaxShift newArr)+ in normalize $ Root (size1 + size2) upMaxShift (computeSizes upMaxShift newArr) where mergeTrees tree1@(Leaf arr1) !_ tree2@(Leaf arr2) !_ | length arr1 == blockSize = A.from2 tree1 tree2- | length arr1 + length arr2 <= blockSize = A.singleton $! Leaf (arr1 <> arr2)+ | length arr1 + length arr2 <= blockSize = A.singleton $! Leaf (arr1 A.++ arr2) | otherwise =- let (left, right) = A.splitAt (arr1 <> arr2) blockSize+ let (left, right) = A.splitAt (arr1 A.++ arr2) blockSize -- 'A.splitAt' doesn't copy anything !leftTree = Leaf left !rightTree = Leaf right in A.from2 leftTree rightTree@@ -641,7 +777,10 @@ -- compute the shift at which the new branch needs to be inserted (0 means there is space in the leaf) -- the size is computed for efficient calculation of the shift in a balanced subtree computeShift !sz !sh !min (Balanced _) =- let newShift = (log2 sz `div` blockShift) * blockShift+ -- @sz - 1@ is the index of the last element+ let hiShift = max ((log2 (sz - 1) `div` blockShift) * blockShift) 0 -- the shift of the root when normalizing+ hi = (sz - 1) `unsafeShiftR` hiShift -- the length of the root node when normalizing minus 1+ newShift = if hi < blockMask then hiShift else hiShift + blockShift in if newShift > sh then min else newShift computeShift _ sh min (Unbalanced arr sizes) = let sz' = indexPrimArray sizes 0 -- the size of the first subtree@@ -666,21 +805,20 @@ | sh == insertShift = Unbalanced (A.snoc arr $! newBranch x (down sh)) newSizesSnoc | otherwise = Unbalanced (A.adjust' arr (length arr - 1) (snocTree (down sh))) newSizesAdjust where+ len = length arr -- snoc the last size + 1 newSizesSnoc = runST $ do- let lenSizes = sizeofPrimArray sizes- newArr <- newPrimArray (lenSizes + 1)- copyPrimArray newArr 0 sizes 0 lenSizes- let lastSize = indexPrimArray sizes (lenSizes - 1)- writePrimArray newArr lenSizes (lastSize + 1)+ newArr <- newPrimArray (len + 1)+ copyPrimArray newArr 0 sizes 0 len+ let lastSize = indexPrimArray sizes (len - 1)+ writePrimArray newArr len (lastSize + 1) unsafeFreezePrimArray newArr -- adjust the last size with (+ 1) newSizesAdjust = runST $ do- let lenSizes = sizeofPrimArray sizes- newArr <- newPrimArray lenSizes- copyPrimArray newArr 0 sizes 0 lenSizes- let lastSize = indexPrimArray sizes (lenSizes - 1)- writePrimArray newArr (lenSizes - 1) (lastSize + 1)+ newArr <- newPrimArray len+ copyPrimArray newArr 0 sizes 0 len+ let lastSize = indexPrimArray sizes (len - 1)+ writePrimArray newArr (len - 1) (lastSize + 1) unsafeFreezePrimArray newArr snocTree _ (Leaf arr) = Leaf $ A.snoc arr x @@ -692,7 +830,7 @@ let newShift = (countTrailingZeros sz `div` blockShift) * blockShift in if newShift > sh then min else newShift computeShift _ sh min (Unbalanced arr sizes) =- let lastIdx = sizeofPrimArray sizes - 1+ let lastIdx = length arr - 1 sz' = indexPrimArray sizes lastIdx - indexPrimArray sizes (lastIdx - 1) -- the size of the last subtree newMin = if length arr < blockSize then sh else min in computeShift sz' (down sh) newMin (A.last arr)@@ -707,44 +845,28 @@ -- splitting --- | \(O(\log n)\). The first @i@ elements of the vector.--- If @i@ is negative, the empty vector is returned. If the vector contains less than @i@ elements, the whole vector is returned.-take :: Int -> Vector a -> Vector a-take _ Empty = Empty-take n v@(Root size sh tree)- | n <= 0 = empty- | n >= size = v- | otherwise = normalize $ Root n sh (takeTree (n - 1) sh tree)- where- -- the initial @i@ is @n - 1@ -- the index of the last element in the new tree- takeTree i sh (Balanced arr) =- let idx = radixIndex i sh- newArr = A.take arr (idx + 1)- in Balanced (A.adjust' newArr idx (takeTree i (down sh)))- takeTree i sh (Unbalanced arr sizes) =- let (idx, subIdx) = relaxedRadixIndex sizes i sh- newArr = A.take arr (idx + 1)- in computeSizes sh (A.adjust' newArr idx (takeTree subIdx (down sh)))- takeTree i _ (Leaf arr) = Leaf (A.take arr ((i .&. blockMask) + 1))+-- the initial @i@ is @n - 1@ -- the index of the last element in the new tree+takeTree :: Int -> Shift -> Tree a -> Tree a+takeTree i sh (Balanced arr) =+ let idx = radixIndex i sh+ newArr = A.take arr (idx + 1)+ in Balanced (A.adjust' newArr idx (takeTree i (down sh)))+takeTree i sh (Unbalanced arr sizes) =+ let (idx, subIdx) = relaxedRadixIndex sizes i sh+ newArr = A.take arr (idx + 1)+ in computeSizes sh (A.adjust' newArr idx (takeTree subIdx (down sh)))+takeTree i _ (Leaf arr) = Leaf (A.take arr ((i .&. blockMask) + 1)) --- | \(O(\log n)\). The vector without the first @i@ elements--- If @i@ is negative, the whole vector is returned. If the vector contains less than @i@ elements, the empty vector is returned.-drop :: Int -> Vector a -> Vector a-drop _ Empty = Empty-drop n v@(Root size sh tree)- | n <= 0 = v- | n >= size = empty- | otherwise = normalize $ Root (size - n) sh (dropTree n sh tree)- where- dropTree n sh (Balanced arr) =- let idx = radixIndex n sh- newArr = A.drop arr idx- in computeSizes sh (A.adjust' newArr 0 (dropTree n (down sh)))- dropTree n sh (Unbalanced arr sizes) =- let (idx, subIdx) = relaxedRadixIndex sizes n sh- newArr = A.drop arr idx- in computeSizes sh (A.adjust' newArr 0 (dropTree subIdx (down sh)))- dropTree n _ (Leaf arr) = Leaf (A.drop arr (n .&. blockMask))+dropTree :: Int -> Shift -> Tree a -> Tree a+dropTree n sh (Balanced arr) =+ let idx = radixIndex n sh+ newArr = A.drop arr idx+ in computeSizes sh (A.adjust' newArr 0 (dropTree n (down sh)))+dropTree n sh (Unbalanced arr sizes) =+ let (idx, subIdx) = relaxedRadixIndex sizes n sh+ newArr = A.drop arr idx+ in computeSizes sh (A.adjust' newArr 0 (dropTree subIdx (down sh)))+dropTree n _ (Leaf arr) = Leaf (A.drop arr (n .&. blockMask)) normalize :: Vector a -> Vector a normalize (Root size sh (Balanced arr))
src/Data/RRBVector/Internal/Array.hs view
@@ -1,45 +1,48 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UnboxedTuples #-} --- Warning: No bound checks are performed!+-- | This is an internal module.+--+-- It provides a thin wrapper over "Data.Primitive.SmallArray"+-- with \(O(1)\) slicing.+--+-- __Warning:__ No bound checks are performed! module Data.RRBVector.Internal.Array ( Array, MutableArray- , empty, singleton, from2+ , ifoldrStep, ifoldlStep, ifoldrStep', ifoldlStep'+ , empty, singleton, from2, wrap , replicate, replicateSnoc , index, head, last , update, adjust, adjust' , take, drop, splitAt- , snoc, cons+ , snoc, cons, (++) , map, map'+ , imapStep, imapStep'+ , unzipWith , traverse, traverse'+ , itraverseStep, itraverseStep' , new, read, write , freeze, thaw ) where -import Control.Applicative (Applicative(liftA2))+#if !(MIN_VERSION_base(4,18,0))+import Control.Applicative (liftA2)+#endif import Control.DeepSeq (NFData(..)) import Control.Monad (when) import Control.Monad.ST import Data.Foldable (Foldable(..)) import Data.Primitive.SmallArray-import Prelude hiding (replicate, take, drop, splitAt, head, last, map, traverse, read)+import Prelude hiding (replicate, take, drop, splitAt, head, last, map, traverse, read, unzip, (++)) -- start length array data Array a = Array !Int !Int !(SmallArray a) data MutableArray s a = MutableArray !Int !Int !(SmallMutableArray s a) -instance Semigroup (Array a) where- Array start1 len1 arr1 <> Array start2 len2 arr2 = Array 0 len' $ runSmallArray $ do- sma <- newSmallArray len' uninitialized- copySmallArray sma 0 arr1 start1 len1- copySmallArray sma len1 arr2 start2 len2- pure sma- where- !len' = len1 + len2- instance Foldable Array where foldr f z (Array start len arr) = let end = start + len@@ -74,6 +77,36 @@ instance (NFData a) => NFData (Array a) where rnf = foldl' (\_ x -> rnf x) () +ifoldrStep :: Int -> (a -> Int) -> (Int -> a -> b -> b) -> b -> Array a -> b+ifoldrStep i0 step f z (Array start len arr) =+ let end = start + len+ go !i !j -- i is the index in arr, j is the index for f+ | i == end = z+ | (# x #) <- indexSmallArray## arr i = f j x (go (i + 1) (j + step x))+ in go start i0++ifoldlStep :: Int -> (a -> Int) -> (Int -> b -> a -> b) -> b -> Array a -> b+ifoldlStep i0 step f z (Array start len arr) =+ let go !i !j -- i is the index in arr, j is the index for f+ | i < start = z+ | (# x #) <- indexSmallArray## arr i = f j (go (i - 1) (j - step x)) x+ in go (start + len - 1) i0++ifoldrStep' :: Int -> (a -> Int) -> (Int -> a -> b -> b) -> b -> Array a -> b+ifoldrStep' i0 step f z (Array start len arr) =+ let go !i !j !acc -- i is the index in arr, j is the index for f+ | i < start = acc+ | (# x #) <- indexSmallArray## arr i = go (i - 1) (j - step x) (f j x acc)+ in go (start + len - 1) i0 z++ifoldlStep' :: Int -> (a -> Int) -> (Int -> b -> a -> b) -> b -> Array a -> b+ifoldlStep' i0 step f z (Array start len arr) =+ let end = start + len+ go !i !j !acc -- i is the index in arr, j is the index for f+ | i == end = acc+ | (# x #) <- indexSmallArray## arr i = go (i + 1) (j + step x) (f j acc x)+ in go start i0 z+ uninitialized :: a uninitialized = errorWithoutStackTrace "uninitialized" @@ -89,6 +122,9 @@ writeSmallArray sma 1 y pure sma +wrap :: SmallArray a -> Array a+wrap arr = Array 0 (sizeofSmallArray arr) arr+ replicate :: Int -> a -> Array a replicate n x = Array 0 n $ runSmallArray (newSmallArray n x) @@ -140,21 +176,30 @@ last arr = index arr (length arr - 1) snoc :: Array a -> a -> Array a-snoc (Array _ len arr) x = Array 0 len' $ runSmallArray $ do+snoc (Array start len arr) x = Array 0 len' $ runSmallArray $ do sma <- newSmallArray len' x- copySmallArray sma 0 arr 0 len+ copySmallArray sma 0 arr start len pure sma where !len' = len + 1 cons :: Array a -> a -> Array a-cons (Array _ len arr) x = Array 0 len' $ runSmallArray $ do+cons (Array start len arr) x = Array 0 len' $ runSmallArray $ do sma <- newSmallArray len' x- copySmallArray sma 1 arr 0 len+ copySmallArray sma 1 arr start len pure sma where !len' = len + 1 +(++) :: Array a -> Array a -> Array a+Array start1 len1 arr1 ++ Array start2 len2 arr2 = Array 0 len' $ runSmallArray $ do+ sma <- newSmallArray len' uninitialized+ copySmallArray sma 0 arr1 start1 len1+ copySmallArray sma len1 arr2 start2 len2+ pure sma+ where+ !len' = len1 + len2+ map :: (a -> b) -> Array a -> Array b map f (Array start len arr) = Array 0 len $ runSmallArray $ do sma <- newSmallArray len uninitialized@@ -177,6 +222,46 @@ loop start 0 pure sma +-- helper function for implementing imap+imapStep :: Int -> (a -> Int) -> (Int -> a -> b) -> Array a -> Array b+imapStep i0 step f (Array start len arr) = Array 0 len $ runSmallArray $ do+ sma <- newSmallArray len uninitialized+ -- i is the index in arr, j is the index in sma, k is the index for f+ let loop !i !j !k = when (j < len) $ do+ x <- indexSmallArrayM arr i+ writeSmallArray sma j (f k x)+ loop (i + 1) (j + 1) (k + step x)+ loop start 0 i0+ pure sma++-- helper function for implementing imap+imapStep' :: Int -> (a -> Int) -> (Int -> a -> b) -> Array a -> Array b+imapStep' i0 step f (Array start len arr) = Array 0 len $ runSmallArray $ do+ sma <- newSmallArray len uninitialized+ -- i is the index in arr, j is the index in sma, k is the index for f+ let loop !i !j !k = when (j < len) $ do+ x <- indexSmallArrayM arr i+ writeSmallArray sma j $! f k x+ loop (i + 1) (j + 1) (k + step x)+ loop start 0 i0+ pure sma++unzipWith :: (a -> (b, c)) -> Array a -> (Array b, Array c)+unzipWith f (Array start len arr) = runST $ do+ sma1 <- newSmallArray len uninitialized+ sma2 <- newSmallArray len uninitialized+ -- i is the index in arr, j is the index in sma1/sma2+ let loop i j = when (j < len) $ do+ val <- indexSmallArrayM arr i+ let !(x, y) = f val+ writeSmallArray sma1 j x+ writeSmallArray sma2 j y+ loop (i + 1) (j + 1)+ loop start 0+ arr1 <- unsafeFreezeSmallArray sma1+ arr2 <- unsafeFreezeSmallArray sma2+ pure (Array 0 len arr1, Array 0 len arr2)+ newtype STA a = STA (forall s. SmallMutableArray s a -> ST s (SmallArray a)) runSTA :: Int -> STA a -> Array a@@ -197,6 +282,24 @@ | j == len = pure $ STA unsafeFreezeSmallArray | (# x #) <- indexSmallArray## arr i = liftA2 (\ !y (STA m) -> STA $ \sma -> writeSmallArray sma j y *> m sma) (f x) (go (i + 1) (j + 1)) in runSTA len <$> go start 0++-- helper function for implementing itraverse+itraverseStep :: (Applicative f) => Int -> (a -> Int) -> (Int -> a -> f b) -> Array a -> f (Array b)+itraverseStep i0 step f (Array start len arr) =+ -- i is the index in arr, j is the index in sma, k is the index for f+ let go !i !j !k+ | j == len = pure $ STA unsafeFreezeSmallArray+ | (# x #) <- indexSmallArray## arr i = liftA2 (\y (STA m) -> STA $ \sma -> writeSmallArray sma j y *> m sma) (f k x) (go (i + 1) (j + 1) (k + step x))+ in runSTA len <$> go start 0 i0++-- helper function for implementing itraverse+itraverseStep' :: (Applicative f) => Int -> (a -> Int) -> (Int -> a -> f b) -> Array a -> f (Array b)+itraverseStep' i0 step f (Array start len arr) =+ -- i is the index in arr, j is the index in sma, k is the index for f+ let go !i !j !k+ | j == len = pure $ STA unsafeFreezeSmallArray+ | (# x #) <- indexSmallArray## arr i = liftA2 (\ !y (STA m) -> STA $ \sma -> writeSmallArray sma j y *> m sma) (f k x) (go (i + 1) (j + 1) (k + step x))+ in runSTA len <$> go start 0 i0 new :: Int -> ST s (MutableArray s a) new len = MutableArray 0 len <$> newSmallArray len uninitialized
src/Data/RRBVector/Internal/Buffer.hs view
@@ -1,3 +1,8 @@+-- | This is an internal module.+--+-- A 'Buffer' is an array with a fixed capacity, used to build up 'Data.RRBVector.Internal.Array.Array's.+-- It is used in the implementation of 'Data.RRBVector.fromList' and 'Data.RRBVector.><'.+ module Data.RRBVector.Internal.Buffer ( Buffer , new@@ -8,30 +13,41 @@ import Control.Monad.ST +import Data.Primitive.SmallArray import Data.RRBVector.Internal.IntRef import qualified Data.RRBVector.Internal.Array as A -data Buffer s a = Buffer !(A.MutableArray s a) !(IntRef s)+-- | A mutable array buffer with a fixed capacity.+data Buffer s a = Buffer !(SmallMutableArray s a) !(IntRef s) +-- | \(O(n)\). Create a new empty buffer with the given capacity. new :: Int -> ST s (Buffer s a) new capacity = do- buffer <- A.new capacity+ buffer <- newSmallArray capacity uninitialized offset <- newIntRef 0 pure (Buffer buffer offset) +uninitialized :: a+uninitialized = errorWithoutStackTrace "uninitialized"++-- | \(O(1)\). Push a new element onto the buffer.+-- The size of the buffer must not exceed the capacity, but this is not checked. push :: Buffer s a -> a -> ST s () push (Buffer buffer offset) x = do idx <- readIntRef offset- A.write buffer idx x+ writeSmallArray buffer idx x writeIntRef offset (idx + 1) +-- | \(O(n)\). Freeze the content of the buffer and return it.+-- This resets the buffer so that it is empty. get :: Buffer s a -> ST s (A.Array a) get (Buffer buffer offset) = do len <- readIntRef offset- result <- A.freeze buffer 0 len+ result <- freezeSmallArray buffer 0 len writeIntRef offset 0- pure result+ pure (A.wrap result) +-- | \(O(1)\). Return the current size of the buffer. size :: Buffer s a -> ST s Int size (Buffer _ offset) = readIntRef offset {-# INLInE size #-}
src/Data/RRBVector/Internal/Debug.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE PatternSynonyms #-}+ {- | This module contains some debug utilities. It should only be used for debugging/testing purposes. -}@@ -5,14 +7,22 @@ module Data.RRBVector.Internal.Debug ( showTree , fromListUnbalanced+ , pattern Empty, pattern Root+ , Tree, Shift+ , pattern Balanced, pattern Unbalanced, pattern Leaf+ , Invariant, valid ) where import Control.Monad.ST (runST)-import Data.Foldable (toList)+import Data.Bits (shiftL)+import Data.Foldable (foldl', toList, traverse_) import Data.List (intercalate)-import Data.Primitive (primArrayToList)+import Data.Primitive.PrimArray (PrimArray, primArrayToList, indexPrimArray, sizeofPrimArray) -import Data.RRBVector.Internal+import Data.RRBVector.Internal hiding (Empty, Root, Balanced, Unbalanced, Leaf)+import qualified Data.RRBVector.Internal as RRB+import Data.RRBVector.Internal.Array (Array)+import qualified Data.RRBVector.Internal.Array as A import qualified Data.RRBVector.Internal.Buffer as Buffer -- | \(O(n)\). Show the underlying tree of a vector.@@ -30,10 +40,10 @@ -- -- Note that it is not possbible to create an invalid 'Vector' with this function. fromListUnbalanced :: [a] -> Vector a-fromListUnbalanced [] = Empty+fromListUnbalanced [] = RRB.Empty fromListUnbalanced [x] = singleton x-fromListUnbalanced ls = case nodes Leaf ls of- [tree] -> Root (treeSize 0 tree) 0 tree -- tree is a single leaf+fromListUnbalanced ls = case nodes RRB.Leaf ls of+ [tree] -> RRB.Root (treeSize 0 tree) 0 tree -- tree is a single leaf ls' -> iterateNodes blockShift ls' where n = blockSize - 1@@ -57,5 +67,134 @@ {-# INLINE nodes #-} iterateNodes sh trees = case nodes (computeSizes sh) trees of- [tree] -> Root (treeSize sh tree) sh tree+ [tree] -> RRB.Root (treeSize sh tree) sh tree trees' -> iterateNodes (up sh) trees'++pattern Empty :: Vector a+pattern Empty <- RRB.Empty++pattern Root :: Int -> Shift -> Tree a -> Vector a+pattern Root size sh tree <- RRB.Root size sh tree++{-# COMPLETE Empty, Root #-}++pattern Balanced :: Array (Tree a) -> Tree a+pattern Balanced arr <- RRB.Balanced arr++pattern Unbalanced :: Array (Tree a) -> PrimArray Int -> Tree a+pattern Unbalanced arr sizes <- RRB.Unbalanced arr sizes++pattern Leaf :: Array a -> Tree a+pattern Leaf arr <- RRB.Leaf arr++{-# COMPLETE Balanced, Unbalanced, Leaf #-}++-- | Structural invariants a vector is expected to hold.+data Invariant+ = RootSizeGt0 -- Root: Size > 0+ | RootShiftDiv -- Root: The shift at the root is divisible by blockShift+ | RootSizeCorrect -- Root: The size at the root is correct+ | RootGt1Child -- Root: The root has more than 1 child if not a Leaf+ | BalShiftGt0 -- Balanced: Shift > 0+ | BalNumChildren -- Balanced: The number of children is blockSize unless+ -- the parent is unbalanced or the node is on the right+ -- edge in which case it is in [1,blockSize]+ | BalFullChildren -- Balanced: All children are full, except for the last+ -- if the node is on the right edge+ | UnbalShiftGt0 -- Unbalanced: Shift > 0+ | UnbalParentUnbal -- Unbalanced: Parent is Unbalanced+ | UnbalNumChildren -- Unbalanced: The number of children is in [1,blockSize]+ | UnbalSizes -- Unbalanced: The sizes array is correct+ | UnbalNotBal -- Unbalanced: The tree is not full enough to be a+ -- Balanced+ | LeafShift0 -- Leaf: Shift == 0+ | LeafNumElems -- Leaf: The number of elements is in [1,blockSize]+ deriving Show++assert :: Invariant -> Bool -> Either Invariant ()+assert i False = Left i+assert _ True = pure ()++-- | Check tree invariants. Returns @Left@ on finding a violated invariant.+valid :: Vector a -> Either Invariant ()+valid RRB.Empty = pure ()+valid (RRB.Root size sh tree) = do+ assert RootSizeGt0 $ size > 0+ assert RootShiftDiv $ sh `mod` blockShift == 0+ assert RootSizeCorrect $ size == countElems tree+ assert RootGt1Child $ case tree of+ Balanced arr -> length arr > 1+ Unbalanced arr _ -> length arr > 1+ Leaf _ -> True+ validTree Unbal sh tree++data NodeDesc+ = Bal -- parent is Balanced+ | BalRightEdge -- parent is Balanced and this node is on the right edge+ | Unbal -- parent is Unbalanced++validTree :: NodeDesc -> Shift -> Tree a -> Either Invariant ()+validTree desc sh (RRB.Balanced arr) = do+ assert BalShiftGt0 $ sh > 0+ assert BalNumChildren $ case desc of+ Bal -> n == blockSize+ BalRightEdge -> n >= 1 && n <= blockSize+ Unbal -> n >= 1 && n <= blockSize+ assert BalFullChildren $+ all (\t -> countElems t == 1 `shiftL` sh) expectedFullChildren+ traverse_ (validTree Bal (down sh)) arrInit+ validTree descLast (down sh) (A.last arr)+ where+ n = length arr+ arrInit = A.take arr (n-1)+ expectedFullChildren = case desc of+ Bal -> arr+ BalRightEdge -> arrInit+ Unbal -> arrInit+ descLast = case desc of+ Bal -> Bal+ BalRightEdge -> BalRightEdge+ Unbal -> BalRightEdge+validTree desc sh (RRB.Unbalanced arr sizes) = do+ assert UnbalShiftGt0 $ sh > 0+ case desc of+ Bal -> assert UnbalParentUnbal False+ BalRightEdge -> assert UnbalParentUnbal False+ Unbal -> assert UnbalNumChildren $ n >= 1 && n <= blockSize+ assert UnbalSizes $ n == sizeofPrimArray sizes+ assert UnbalSizes $+ all (\i -> countElems (A.index arr i) == getSize sizes i) [0 .. n-1]+ assert UnbalNotBal $ not (couldBeBalanced sh arr sizes)+ traverse_ (validTree Unbal (down sh)) arr+ where+ n = length arr+validTree desc sh (RRB.Leaf arr) = do+ assert LeafShift0 $ sh == 0+ assert LeafNumElems $ case desc of+ Bal -> n == blockSize+ BalRightEdge -> n >= 1 && n <= blockSize+ Unbal -> n >= 1 && n <= blockSize+ where+ n = length arr++-- | Check whether an Unbalanced node could be Balanced.+couldBeBalanced :: Shift -> A.Array (Tree a) -> PrimArray Int -> Bool+couldBeBalanced sh arr sizes =+ all (\i -> getSize sizes i == 1 `shiftL` sh) [0 .. n-2] &&+ (case A.last arr of+ Balanced _ -> True+ Unbalanced arr' sizes' -> couldBeBalanced (down sh) arr' sizes'+ Leaf _ -> True)+ where+ n = length arr++getSize :: PrimArray Int -> Int -> Int+getSize sizes 0 = indexPrimArray sizes 0+getSize sizes i = indexPrimArray sizes i - indexPrimArray sizes (i-1)++countElems :: Tree a -> Int+countElems (RRB.Balanced arr) =+ foldl' (\acc tree -> acc + countElems tree) 0 arr+countElems (RRB.Unbalanced arr _) =+ foldl' (\acc tree -> acc + countElems tree) 0 arr+countElems (RRB.Leaf arr) = length arr
− src/Data/RRBVector/Internal/Indexed.hs
@@ -1,26 +0,0 @@-module Data.RRBVector.Internal.Indexed where---- TODO: use unboxed tuples?--data WithIndex a = WithIndex !Int a---- | > Compose (State Int) f a-newtype Indexed f a = Indexed { runIndexed :: Int -> WithIndex (f a) }--instance Functor f => Functor (Indexed f) where- fmap f (Indexed sf) = Indexed $ \s -> let WithIndex s' x = sf s in WithIndex s' (fmap f x)- {-# INLINE fmap #-}--instance Applicative f => Applicative (Indexed f) where- pure x = Indexed $ \s -> WithIndex s (pure x)- {-# INLINE pure #-}-- Indexed sfa <*> Indexed sfb = Indexed $ \s ->- let WithIndex s' f = sfa s- WithIndex s'' x = sfb s'- in WithIndex s'' (f <*> x)- {-# INLINE (<*>) #-}--evalIndexed :: Indexed f a -> Int -> f a-evalIndexed (Indexed sf) x = let WithIndex _ y = sf x in y-{-# INLINE evalIndexed #-}
src/Data/RRBVector/Internal/IntRef.hs view
@@ -1,3 +1,7 @@+-- | This is an internal module.+--+-- It works like "Data.STRef", but is specialized to 'Int' and more efficient.+ module Data.RRBVector.Internal.IntRef ( IntRef , newIntRef@@ -8,8 +12,10 @@ import Control.Monad.ST import Data.Primitive.PrimArray +-- | A mutable 'Int' reference. newtype IntRef s = IntRef (MutablePrimArray s Int) +-- | \(O(1)\). Create a new 'IntRef' that is initialized with @0@. newIntRef :: Int -> ST s (IntRef s) newIntRef i = do arr <- newPrimArray 1@@ -17,10 +23,12 @@ pure (IntRef arr) {-# INLINE newIntRef #-} +-- | \(O(1)\). Read the content of the 'IntRef'. readIntRef :: IntRef s -> ST s Int readIntRef (IntRef arr) = readPrimArray arr 0 {-# INLINE readIntRef #-} +-- | \(O(1)\). Write a value to the 'IntRef'. writeIntRef :: IntRef s -> Int -> ST s () writeIntRef (IntRef arr) = writePrimArray arr 0 {-# INLINE writeIntRef #-}
+ src/Data/RRBVector/Internal/Sorting.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}++module Data.RRBVector.Internal.Sorting+ ( sort+ , sortBy+ , sortOn+ ) where++import Data.Foldable (toList)+import Data.Foldable.WithIndex (ifor_)+import Data.Primitive.Array+import Data.SamSort (sortArrayBy)+import Data.Semigroup (Arg(..))++import Data.RRBVector.Internal++uninitialized :: a+uninitialized = errorWithoutStackTrace "uninitialized"++-- | \(O(n \log n)\). Sort the vector in ascending order.+-- The sort is stable, meaning the order of equal elements is preserved.+--+-- @since 0.2.2.0+sort :: (Ord a) => Vector a -> Vector a+sort = sortBy compare++-- | \(O(n \log n)\). Sort the vector in ascending order according to the specified comparison function.+-- The sort is stable, meaning the order of equal elements is preserved.+--+-- @since 0.2.2.0+sortBy :: (a -> a -> Ordering) -> Vector a -> Vector a+sortBy cmp v =+ let sortedArr = createArray (length v) uninitialized $ \arr@(MutableArray arr#) -> do+ ifor_ v (writeArray arr)+ sortArrayBy cmp arr# 0 (length v)+ in fromList . toList $ sortedArr++-- | \(O(n \log n)\). Sort the vector in ascending order by comparing the results of applying the key function to each element.+-- The sort is stable, meaning the order of equal elements is preserved.+-- @`sortOn` f@ is equivalent to @`sortBy` (`Data.Ord.comparing` f)@, but only evaluates @f@ once for each element.+--+-- @since 0.2.2.0+sortOn :: (Ord b) => (a -> b) -> Vector a -> Vector a+sortOn f v =+ let sortedArr = createArray (length v) uninitialized $ \arr@(MutableArray arr#) -> do+ ifor_ v $ \i x -> let !y = f x in writeArray arr i (Arg y x)+ sortArrayBy compare arr# 0 (length v)+ in fromList . fmap (\(Arg _ x) -> x) . toList $ sortedArr
test/Arbitrary.hs view
@@ -1,11 +1,40 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+ module Arbitrary where +#if !(MIN_VERSION_base(4,18,0))+import Control.Applicative (liftA2)+#endif+import Data.Foldable (toList)+ import Test.Tasty.QuickCheck import qualified Data.RRBVector as V import Data.RRBVector.Internal.Debug --- TODO: improve instance+builders :: [[a] -> V.Vector a]+builders = [V.fromList, fromListUnbalanced]+ instance (Arbitrary a) => Arbitrary (V.Vector a) where- arbitrary = oneof [V.fromList <$> arbitrary, fromListUnbalanced <$> arbitrary]+ arbitrary = arbitrary1+ shrink = shrink1 +-- TODO: improve instance+instance Arbitrary1 V.Vector where+ liftArbitrary gen = do+ build <- elements builders+ fmap build (liftArbitrary gen)++ liftShrink shr = concatMap (sequence builders) . liftShrink shr . toList++-- A custom 'Testable' instance to use 'showTree'.+instance {-# OVERLAPPING #-} (Arbitrary a, Show a, Testable prop) => Testable (V.Vector a -> prop) where+ property = propertyForAllShrinkShow arbitrary shrink (pure . showTree)++ propertyForAllShrinkShow gen shr shw f =+ propertyForAllShrinkShow+ (liftA2 (,) gen arbitrary)+ (liftShrink2 shr shrink)+ (\(x, y) -> shw x ++ [showTree y])+ (uncurry f)
test/Main.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE BangPatterns #-}- import Test.Tasty import Test.Tasty.QuickCheck
test/Properties.hs view
@@ -1,15 +1,24 @@+{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module Properties ( properties ) where -import Data.Foldable (toList)-import Data.List (uncons)+#if !(MIN_VERSION_base(4,18,0))+import Control.Applicative (liftA2)+#endif+import Data.Foldable (Foldable(..))+import Data.List (sort, sortBy, sortOn, uncons)+import Data.Ord (comparing)+import Data.Proxy (Proxy(..)) import Prelude hiding ((==)) -- use @===@ instead -import Data.Foldable.WithIndex-import Data.Functor.WithIndex-import Data.Traversable.WithIndex+import qualified Data.Sequence as Seq import qualified Data.RRBVector as V+import qualified Data.RRBVector.Internal.Debug as VDebug+import Test.QuickCheck.Classes.Base import Test.Tasty import Test.Tasty.QuickCheck @@ -19,6 +28,8 @@ type V = V.Vector +-- List equivalents of @Data.RRBVector@ functions+ lookupList :: Int -> [a] -> Maybe a lookupList i ls | i < length ls = Just (ls !! i)@@ -46,39 +57,23 @@ unsnoc [] = Nothing unsnoc ls = Just (init ls, last ls) -instances :: TestTree-instances = testGroup "instances"- [ testGroup "Foldable"- [ testProperty "foldr" $ \(v :: V Int) -> foldr (:) [] v === foldr (:) [] (toList v)- , testProperty "foldl" $ \(v :: V Int) -> foldl (flip (:)) [] v === foldl (flip (:)) [] (toList v)- ]- , testGroup "FoldableWithIndex"- [ testProperty "ifoldr" $ \(v :: V Int) -> ifoldr (\i x acc -> (i, x) : acc) [] v === ifoldr (\i x acc -> (i, x) : acc) [] (toList v)- , testProperty "ifoldl" $ \(v :: V Int) -> ifoldl (\i acc x -> (i, x) : acc) [] v === ifoldl (\i acc x -> (i, x) : acc) [] (toList v)- , testProperty "satisfies `ifoldr (const f) x v = foldr f x v`" $- \(v :: V Int) -> ifoldr (const (:)) [] v === foldr (:) [] v- , testProperty "satisfies `ifoldl (const f) x v = foldl f x v`" $- \(v :: V Int) -> ifoldl (const (flip (:))) [] v === foldl (flip (:)) [] v- ]- , testGroup "Functor"- [ testProperty "fmap" $ \v -> toList (V.map (+ 1) v) === map (+ 1) (toList v)- ]- , testGroup "FunctorWithIndex"- [ testProperty "imap" $ \(v :: V Int) -> toList (imap (,) v) === imap (,) (toList v)- , testProperty "satisfies `imap (const f) v = map f v`" $ \v -> imap (const (+ 1)) v === V.map (+ 1) v- ]- , testGroup "Traversable"- [ testProperty "traverse" $- \(v :: V Int) -> fmap toList (traverse (Just . (+ 1)) v) === traverse (Just . (+ 1)) (toList v)- ]- , testGroup "TraversableWithIndex"- [ testProperty "itraverse" $- \(v :: V Int) -> fmap toList (itraverse (\i x -> Just (i + x)) v) === itraverse (\i x -> Just (i + x)) (toList v)- , testProperty "satisfies `itraverse (const f) v = traverse f v`" $- \(v :: V Int) -> itraverse (const (Just . (+ 1))) v === traverse (Just . (+ 1)) v- ]- ] +testLaws :: Laws -> TestTree+testLaws (Laws name pairs) = testGroup name (map (uncurry testProperty) pairs)++proxyVInt :: Proxy (V Int)+proxyVInt = Proxy++proxyV :: Proxy V+proxyV = Proxy++checkValid :: Show a => V a -> Property+checkValid v = case VDebug.valid v of+ Left invariant ->+ counterexample ("Invariant violated: " ++ show invariant) $+ counterexample (VDebug.showTree v) False+ _ -> property ()+ properties :: TestTree properties = testGroup "properties" [ testGroup "fromList"@@ -86,22 +81,27 @@ , testProperty "satisfies `toList . fromList = id`" $ \ls -> toList (V.fromList ls) === ls , testProperty "satisfies `fromList [] = empty`" $ V.fromList [] === V.empty , testProperty "satisfies `fromList [x] = singleton x`" $ \x -> V.fromList [x] === V.singleton x+ , testProperty "valid" $ \xs -> checkValid (V.fromList xs) ] , testGroup "replicate" [ testProperty "satisifes `replicate n == fromList . replicate n`" $ \(Positive n) x -> V.replicate n x === V.fromList (replicate n x) , testProperty "returns the empty vector for non-positive n" $ \(NonPositive n) x -> V.replicate n x === V.empty+ , testProperty "valid" $ \n x -> checkValid (V.replicate n x) ] , testGroup "<|" [ testProperty "prepends an element" $ \x v -> toList (x V.<| v) === x : toList v , testProperty "works for the empty vector" $ \x -> x V.<| V.empty === V.singleton x+ , testProperty "valid" $ \x v -> checkValid (x V.<| v) ] , testGroup "|>" [ testProperty "appends an element" $ \v x -> toList (v V.|> x) === toList v ++ [x] , testProperty "works for the empty vector" $ \x -> V.empty V.|> x === V.singleton x+ , testProperty "valid" $ \v x -> checkValid (v V.|> x) ] , testGroup "><" [ testProperty "concatenates two vectors" $ \v1 v2 -> toList (v1 V.>< v2) === toList v1 ++ toList v2 , testProperty "works for the empty vector" $ \v -> (V.empty V.>< v === v) .&&. (v V.>< V.empty === v)+ , testProperty "valid" $ \v1 v2 -> checkValid (v1 V.>< v2) ] , testGroup "lookup" [ testProperty "gets the element at the index" $ \v (NonNegative i) -> V.lookup i v === lookupList i (toList v)@@ -110,57 +110,174 @@ , testGroup "update" [ testProperty "updates the element at the index" $ \v (NonNegative i) x -> toList (V.update i x v) === updateList i x (toList v) , testProperty "returns the vector for negative indices" $ \v (Negative i) x -> V.update i x v === v+ , testProperty "valid" $ \v i x -> checkValid (V.update i x v) ] , testGroup "adjust" [ testProperty "adjusts the element at the index" $ \v (NonNegative i) (Fn f) -> toList (V.adjust i f v) === adjustList i f (toList v) , testProperty "returns the vector for negative indices" $ \v (Negative i) (Fn f) -> V.adjust i f v === v+ , testProperty "valid" $ \v i (Fn f) -> checkValid (V.adjust i f v) ] , testGroup "adjust'" [ testProperty "adjusts the element at the index" $ \v (NonNegative i) (Fn f) -> toList (V.adjust' i f v) === adjustList i f (toList v) , testProperty "returns the vector for negative indices" $ \v (Negative i) (Fn f) -> V.adjust' i f v === v+ , testProperty "valid" $ \v i (Fn f) -> checkValid (V.adjust' i f v) ] , testGroup "viewl" [ testProperty "works like uncons" $ \v -> fmap (\(x, xs) -> (x, toList xs)) (V.viewl v) === uncons (toList v) , testProperty "works for the empty vector" $ V.viewl V.empty === Nothing+ , testProperty "valid" $ \v -> fmap (checkValid . snd) (V.viewl v) ] , testGroup "viewr" [ testProperty "works like unsnoc" $ \v -> fmap (\(xs, x) -> (toList xs, x)) (V.viewr v) === unsnoc (toList v) , testProperty "works for the empty vector" $ V.viewr V.empty === Nothing+ , testProperty "valid" $ \v -> fmap (checkValid . fst) (V.viewr v) ] , testGroup "take" [ testProperty "takes n elements" $ \v (Positive n) -> toList (V.take n v) === take n (toList v) , testProperty "returns the empty vector for non-positive n" $ \v (NonPositive n) -> V.take n v === V.empty+ , testProperty "valid" $ \v n -> checkValid (V.take n v) ] , testGroup "drop" [ testProperty "drops n elements" $ \v (Positive n) -> toList (V.drop n v) === drop n (toList v) , testProperty "returns the vector for non-positive n" $ \v (NonPositive n) -> V.drop n v === v+ , testProperty "valid" $ \v n -> checkValid (V.drop v n) ] , testGroup "splitAt" [ testProperty "splits the vector" $ \v n -> let (v1, v2) = V.splitAt n v in (toList v1, toList v2) === splitAt n (toList v)+ , testProperty "valid" $ \v n -> let (v1, v2) = V.splitAt n v in checkValid v1 .&&. checkValid v2 ] , testGroup "insertAt" [ testProperty "inserts an element" $ \v i x -> toList (V.insertAt i x v) === insertAtList i x (toList v)+ , testProperty "prepends for negative indices" $ \v (Negative i) x -> V.insertAt i x v === x V.<| v+ , testProperty "appends for too large indices" $ \v x -> forAll (arbitrary `suchThat` (> length v)) $ \i -> V.insertAt i x v === v V.|> x , testProperty "satisfies `insertAt 0 x v = x <| v`" $ \v x -> V.insertAt 0 x v === x V.<| v , testProperty "satisfies `insertAt (length v) x v = v |> x`" $ \v x -> V.insertAt (length v) x v === v V.|> x+ , testProperty "valid" $ \v i x -> checkValid (V.insertAt i x v) ] , testGroup "deleteAt" [ testProperty "deletes an element" $ \v (NonNegative i) -> toList (V.deleteAt i v) === deleteAtList i (toList v) , testProperty "returns the vector for negative indices" $ \v (Negative i) -> V.deleteAt i v === v+ , testProperty "returns the vector for too large indices" $ \v -> forAll (arbitrary `suchThat` (>= length v)) $ \i -> V.deleteAt i v === v , testProperty "satisfies `deleteAt 0 v = drop 1 v`" $ \v -> V.deleteAt 0 v === V.drop 1 v , testProperty "satisfies `deleteAt (length v - 1) v = take (length v - 1) v`" $ \v -> V.deleteAt (length v - 1) v === V.take (length v - 1) v+ , testProperty "valid" $ \v i -> checkValid (V.deleteAt i v) ]+ , testGroup "findIndexL"+ [ testProperty "finds the first index" $ \v (Fn f) -> V.findIndexL f v === Seq.findIndexL f (Seq.fromList (toList v))+ , testProperty "returns Nothing for the empty vector" $ \(Fn f) -> V.findIndexL f V.empty === Nothing+ ]+ , testGroup "findIndexR"+ [ testProperty "finds the last index" $ \v (Fn f) -> V.findIndexR f v === Seq.findIndexR f (Seq.fromList (toList v))+ , testProperty "returns Nothing for the empty vector" $ \(Fn f) -> V.findIndexR f V.empty === Nothing+ ]+ , localOption (QuickCheckMaxSize 1000) $ testGroup "findIndicesL"+ [ testProperty "finds the indices starting from the left" $ \v (Fn f) -> V.findIndicesL f v === Seq.findIndicesL f (Seq.fromList (toList v))+ , testProperty "returns [] for the empty vector" $ \(Fn f) -> V.findIndicesL f V.empty === []+ ]+ , localOption (QuickCheckMaxSize 1000) $ testGroup "findIndicesR"+ [ testProperty "finds the indices starting from the right" $ \v (Fn f) -> V.findIndicesR f v === Seq.findIndicesR f (Seq.fromList (toList v))+ , testProperty "returns [] for the empty vector" $ \(Fn f) -> V.findIndicesR f V.empty === []+ ] , testGroup "reverse" [ testProperty "reverses the vector" $ \v -> toList (V.reverse v) === reverse (toList v)+ , testProperty "valid" $ \v -> checkValid (V.reverse v) ] , testGroup "zip" [ testProperty "zips two vectors" $ \v1 v2 -> toList (V.zip v1 v2) === zip (toList v1) (toList v2)+ , testProperty "valid" $ \v1 v2 -> checkValid (V.zip v1 v2) ] , testGroup "zipWith" [ testProperty "zips two vectors with a function" $ \v1 v2 -> toList (V.zipWith (+) v1 v2) === zipWith (+) (toList v1) (toList v2) , testProperty "satisfies `zipWith (,) v1 v2 = zip v1 v2`" $ \v1 v2 -> V.zipWith (,) v1 v2 === V.zip v1 v2+ , testProperty "valid" $ \v1 v2 (Fn2 f) -> checkValid (V.zipWith f v1 v2) ] , testGroup "unzip" [ testProperty "unzips the vector" $ \v -> (\(xs, ys) -> (toList xs, toList ys)) (V.unzip v) === unzip (toList v)+ , testProperty "valid" $ \v -> let (v1, v2) = V.unzip v in checkValid v1 .&&. checkValid v2 ]+ , localOption (QuickCheckMaxSize 1000) $ testGroup "sorting"+ [ testProperty "sort" $ \v -> toList (V.sort v) === sort (toList v)+ , testProperty "sortBy" $ \v -> let cmp = comparing fst in toList (V.sortBy cmp v) === sortBy cmp (toList v)+ , testProperty "sortOn" $ \v -> let f = odd in toList (V.sortOn f v) === sortOn f (toList v)+ ] , instances+ , laws+ , issues+ ]++instances :: TestTree+instances = testGroup "instances"+ [ testGroup "Foldable"+ [ testProperty "foldr" $ \(v :: V Int) -> foldr (:) [] v === foldr (:) [] (toList v)+ , testProperty "foldl" $ \(v :: V Int) -> foldl (flip (:)) [] v === foldl (flip (:)) [] (toList v)+ , testProperty "foldr'" $ \(v :: V Int) -> foldr' (:) [] v === foldr' (:) [] (toList v)+ , testProperty "foldl'" $ \(v :: V Int) -> foldl' (flip (:)) [] v === foldl' (flip (:)) [] (toList v)+ ]+ , testGroup "FoldableWithIndex"+ [ testProperty "ifoldr" $ \(v :: V Int) -> V.ifoldr (\i x acc -> (i, x) : acc) [] v === V.ifoldr (\i x acc -> (i, x) : acc) [] (toList v)+ , testProperty "ifoldl" $ \(v :: V Int) -> V.ifoldl (\i acc x -> (i, x) : acc) [] v === V.ifoldl (\i acc x -> (i, x) : acc) [] (toList v)+ , testProperty "ifoldr'" $ \(v :: V Int) -> V.ifoldr' (\i x acc -> (i, x) : acc) [] v === V.ifoldr' (\i x acc -> (i, x) : acc) [] (toList v)+ , testProperty "ifoldl'" $ \(v :: V Int) -> V.ifoldl' (\i acc x -> (i, x) : acc) [] v === V.ifoldl' (\i acc x -> (i, x) : acc) [] (toList v)+ , testProperty "satisfies `ifoldr (const f) x v = foldr f x v`" $+ \(v :: V Int) -> V.ifoldr (const (:)) [] v === foldr (:) [] v+ , testProperty "satisfies `ifoldl (const f) x v = foldl f x v`" $+ \(v :: V Int) -> V.ifoldl (const (flip (:))) [] v === foldl (flip (:)) [] v+ ]+ , testGroup "Functor"+ [ testProperty "fmap" $ \v -> toList (V.map (+ 1) v) === map (+ 1) (toList v)+ ]+ , testGroup "FunctorWithIndex"+ [ testProperty "imap" $ \(v :: V Int) -> toList (V.imap (,) v) === V.imap (,) (toList v)+ , testProperty "satisfies `imap (const f) v = map f v`" $ \v -> V.imap (const (+ 1)) v === V.map (+ 1) v+ ]+ , testGroup "Traversable"+ [ testProperty "traverse" $+ \(v :: V Int) -> fmap toList (traverse (Just . (+ 1)) v) === traverse (Just . (+ 1)) (toList v)+ ]+ , testGroup "TraversableWithIndex"+ [ testProperty "itraverse" $+ \(v :: V Int) -> fmap toList (V.itraverse (\i x -> Just (i + x)) v) === V.itraverse (\i x -> Just (i + x)) (toList v)+ , testProperty "satisfies `itraverse (const f) v = traverse f v`" $+ \(v :: V Int) -> V.itraverse (const (Just . (+ 1))) v === traverse (Just . (+ 1)) v+ , testProperty "satisfies `imapDefault f v = imap f v`" $+ \(v :: V Int) -> V.imapDefault (,) v === V.imap (,) v+ ]+ , localOption (QuickCheckMaxSize 100) $ testGroup "Applicative"+ [ testProperty "liftA2" $+ \(v1 :: V Int) (v2 :: V Int) -> toList (liftA2 (,) v1 v2) === liftA2 (,) (toList v1) (toList v2)+ , testProperty "<*>" $+ \(v1 :: V Int) (v2 :: V Int) -> toList ((,) <$> v1 <*> v2) === ((,) <$> toList v1 <*> toList v2)+ , testProperty "*>" $+ \(v1 :: V Int) (v2 :: V Int) -> toList (v1 *> v2) === (toList v1 *> toList v2)+ , testProperty "<*" $+ \(v1 :: V Int) (v2 :: V Int) -> toList (v1 <* v2) === (toList v1 <* toList v2)+ ]+ ]++laws :: TestTree+laws = testGroup "typeclass laws"+ [ testLaws $ eqLaws proxyVInt+ , testLaws $ ordLaws proxyVInt+ , testLaws $ isListLaws proxyVInt+ , testLaws $ monoidLaws proxyVInt+ , localOption (QuickCheckTests 500) . localOption (QuickCheckMaxSize 1000) . testLaws $ semigroupLaws proxyVInt+ , localOption (QuickCheckMaxSize 500) . testLaws $ showLaws proxyVInt+ , localOption (QuickCheckMaxSize 1000) . testLaws $ showReadLaws proxyVInt+ , testLaws $ alternativeLaws proxyV+ , localOption (QuickCheckTests 100) . localOption (QuickCheckMaxSize 100) . testLaws $ applicativeLaws proxyV+ , localOption (QuickCheckTests 100) . testLaws $ foldableLaws proxyV+ , testLaws $ functorLaws proxyV+ , localOption (QuickCheckTests 100) . localOption (QuickCheckMaxSize 100) . testLaws $ monadLaws proxyV+ , testLaws $ monadPlusLaws proxyV+ , localOption (QuickCheckTests 500) . localOption (QuickCheckMaxSize 5000) . testLaws $ monadZipLaws proxyV+ , localOption (QuickCheckMaxSize 100) . testLaws $ traversableLaws proxyV+ ]++-- old issues, to avoid regressions+issues :: TestTree+issues = testGroup "issues"+ -- https://github.com/konsumlamm/rrb-vector/issues/10+ [ testProperty "#10" $ \x v -> case V.viewl v of+ Nothing -> property True+ Just (_, v') -> x V.<| v' === V.update 0 x v ]
test/Strictness.hs view
@@ -1,16 +1,17 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -#define GHC_HEAP_VIEW defined(VERSION_ghc_heap_view)- module Strictness ( strictness ) where -#if GHC_HEAP_VIEW+#ifdef VERSION_nothunks import Control.DeepSeq (deepseq)-import GHC.AssertNF (isNF)+import Data.Foldable (foldr', foldl', toList)+import Data.Maybe (isNothing)+import Data.RRBVector.Internal.Debug+import NoThunks.Class #endif+ import qualified Data.RRBVector as V import Test.Tasty import Test.Tasty.QuickCheck@@ -19,10 +20,23 @@ default (Int) -#if GHC_HEAP_VIEW-testNF :: a -> Property-testNF !x = ioProperty (isNF x)+#ifdef VERSION_nothunks+instance (NoThunks a) => NoThunks (V.Vector a) where+ showTypeOf _ = "Vector" + wNoThunks _ Empty = pure Nothing+ wNoThunks ctx (Root _ _ tree) = wNoThunks ctx tree++instance (NoThunks a) => NoThunks (Tree a) where+ showTypeOf _ = "Tree"++ wNoThunks ctx (Balanced arr) = noThunksInValues ctx (toList arr)+ wNoThunks ctx (Unbalanced arr _) = noThunksInValues ctx (toList arr)+ wNoThunks ctx (Leaf arr) = noThunksInValues ctx (toList arr)++testNF :: (NoThunks a) => a -> Property+testNF x = x `seq` ioProperty (isNothing <$> wNoThunks [] x)+ tailVector :: V.Vector a -> Maybe (V.Vector a) tailVector v = case V.viewl v of Nothing -> Nothing@@ -36,9 +50,9 @@ strictness :: TestTree strictness = testGroup "strictness"-#if GHC_HEAP_VIEW- [ testGroup "nf"- [ testProperty "empty" $ testNF V.empty+#ifdef VERSION_nothunks+ [ localOption (QuickCheckTests 500) $ testGroup "nf"+ [ testProperty "empty" $ testNF (V.empty :: V.Vector Int) , testProperty "singleton" $ testNF (V.singleton 42) , testProperty "fromList" $ \ls -> ls `deepseq` testNF (V.fromList ls) , testProperty "replicate" $ \n -> testNF (V.replicate n 42)@@ -54,7 +68,14 @@ , testProperty "deleteAt" $ \v i -> v `deepseq` testNF (V.deleteAt i v) , testProperty "viewl (tail)" $ \v -> v `deepseq` testNF (tailVector v) , testProperty "viewr (init)" $ \v -> v `deepseq` testNF (initVector v)+ , testProperty "map'" $ \v -> v `deepseq` testNF (V.map' (+ 1) v) , testProperty "reverse" $ \v -> v `deepseq` testNF (V.reverse v)+ , testProperty "zip" $ \v1 v2 -> v1 `deepseq` v2 `deepseq` testNF (V.zip v1 v2)+ , testProperty "unzip" $ \v -> v `deepseq` testNF (V.unzip v)+ , testProperty "foldr'" $ \v -> (v :: V.Vector Int) `deepseq` testNF (foldr' (:) [] v)+ , testProperty "foldl'" $ \v -> (v :: V.Vector Int) `deepseq` testNF (foldl' (flip (:)) [] v)+ , testProperty "ifoldr'" $ \v -> (v :: V.Vector Int) `deepseq` testNF (V.ifoldr' (const (:)) [] v)+ , testProperty "ifoldl'" $ \v -> (v :: V.Vector Int) `deepseq` testNF (V.ifoldl' (const (flip (:))) [] v) ] , testGroup "bottom" #else@@ -69,5 +90,6 @@ , testProperty "adjust" $ \v i -> V.adjust i (const undefined) v `seq` () , testProperty "insertAt" $ \v i -> V.insertAt i undefined v `seq` () , testProperty "map" $ \v -> V.map (const undefined) v `seq` ()+ , testProperty "zipWith" $ \v1 v2 -> V.zipWith (\_ _ -> undefined) v1 v2 `seq` () ] ]