packages feed

rrb-vector 0.1.1.0 → 0.2.0.0

raw patch · 15 files changed

+525/−238 lines, 15 filesdep +nothunksdep +quickcheck-classes-basedep −ghc-heap-viewdep ~basedep ~indexed-traversabledep ~primitivesetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: nothunks, quickcheck-classes-base

Dependencies removed: ghc-heap-view

Dependency ranges changed: base, indexed-traversable, primitive

API changes (from Hackage documentation)

+ Data.RRBVector: map' :: (a -> b) -> Vector a -> Vector b
+ Data.RRBVector: unzipWith :: (a -> (b, c)) -> Vector a -> (Vector b, Vector c)
+ Data.RRBVector.Internal.Debug: data Tree a
+ Data.RRBVector.Internal.Debug: pattern Balanced :: Array (Tree a) -> Tree a
+ Data.RRBVector.Internal.Debug: pattern Empty :: Vector a
+ Data.RRBVector.Internal.Debug: pattern Leaf :: Array a -> Tree a
+ Data.RRBVector.Internal.Debug: pattern Root :: Int -> Shift -> Tree a -> Vector a
+ Data.RRBVector.Internal.Debug: pattern Unbalanced :: Array (Tree a) -> PrimArray Int -> Tree a
+ Data.RRBVector.Internal.Debug: type Shift = Int

Files

CHANGELOG.md view
@@ -1,7 +1,20 @@+# 0.2.0.0++* 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`++* 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,12 +6,14 @@  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@@ -19,6 +21,7 @@     , bench "drop" $ whnf (RRB.drop 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/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.0.0 synopsis:           Efficient RRB-Vectors description:   An RRB-Vector is an efficient sequence data structure.@@ -22,11 +22,11 @@   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.5, GHC == 9.4.4  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 +37,9 @@     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+  build-depends:        base >= 4.11 && < 5, deepseq ^>= 1.4.3, indexed-traversable ^>= 0.1, primitive >= 0.7 && < 0.9+  ghc-options:          -O2 -Wall -Wno-name-shadowing -Werror=missing-methods -Werror=missing-fields   default-language:     Haskell2010  test-suite test@@ -52,9 +51,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, 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 +63,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
@@ -40,9 +40,9 @@     , module Data.Functor.WithIndex     , module Data.Traversable.WithIndex     -- * Transformations-    , map, reverse+    , map, map', reverse     -- * Zipping and unzipping-    , zip, zipWith, unzip+    , zip, zipWith, unzip, unzipWith     ) where  import Prelude hiding (replicate, lookup, take, drop, splitAt, map, reverse, zip, zipWith, unzip)
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@@ -23,9 +25,9 @@     , take, drop, splitAt     , insertAt, deleteAt     -- * Transformations-    , map, reverse+    , map, map', reverse     -- * Zipping and unzipping-    , zip, zipWith, unzip+    , zip, zipWith, unzip, unzipWith     ) where  import Control.Applicative (Alternative, liftA2)@@ -33,17 +35,15 @@ 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@@ -55,10 +55,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 +65,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 +131,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)@@ -189,6 +189,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 +205,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 +260,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,9 +325,12 @@     {-# 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@@ -294,6 +342,10 @@  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 +353,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 +406,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 +447,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 +457,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 +504,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,34 +527,69 @@     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 zipWith f v1 v2 = fromList $ List.zipWith f (toList v1) (toList v2) +-- TODO: unzip = unzipWith id -- | \(O(n)\). Unzip a vector of pairs. -- -- >>> 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 Empty = (Empty, Empty)+unzip (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 id arr of+        (!left, !right) -> (Leaf left, Leaf right) +-- | \(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,14 +614,36 @@     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. insertAt :: Int -> a -> Vector a -> Vector a@@ -560,9 +672,9 @@   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@@ -666,21 +778,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 +803,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 +818,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
@@ -3,18 +3,27 @@ {-# 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+    , ifoldrStep, ifoldlStep, ifoldrStep', ifoldlStep'     , empty, singleton, from2     , 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@@ -25,21 +34,12 @@ 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 +74,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" @@ -155,6 +185,15 @@   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 +216,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 +276,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@@ -11,20 +16,26 @@ import Data.RRBVector.Internal.IntRef import qualified Data.RRBVector.Internal.Array as A +-- | A mutable array buffer with a fixed capacity. data Buffer s a = Buffer !(A.MutableArray 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     offset <- newIntRef 0     pure (Buffer buffer offset) +-- | \(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     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@@ -32,6 +43,7 @@     writeIntRef offset 0     pure 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,19 @@ module Data.RRBVector.Internal.Debug     ( showTree     , fromListUnbalanced+    , pattern Empty, pattern Root+    , Tree, Shift+    , pattern Balanced, pattern Unbalanced, pattern Leaf     ) where  import Control.Monad.ST (runST) import Data.Foldable (toList) import Data.List (intercalate)-import Data.Primitive (primArrayToList)+import Data.Primitive.PrimArray (PrimArray, primArrayToList) -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.Buffer as Buffer  -- | \(O(n)\). Show the underlying tree of a vector.@@ -30,10 +37,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 +64,24 @@     {-# 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 #-}
− 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 #-}
test/Arbitrary.hs view
@@ -1,11 +1,37 @@+{-# LANGUAGE FlexibleInstances #-}+ module Arbitrary where +import Control.Applicative (liftA2)+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/Properties.hs view
@@ -2,14 +2,14 @@     ( properties     ) where -import Data.Foldable (toList)+import Control.Applicative (liftA2)+import Data.Foldable (Foldable(..)) import Data.List (uncons)+import Data.Proxy (Proxy(..)) import Prelude hiding ((==)) -- use @===@ instead -import Data.Foldable.WithIndex-import Data.Functor.WithIndex-import Data.Traversable.WithIndex import qualified Data.RRBVector as V+import Test.QuickCheck.Classes.Base import Test.Tasty import Test.Tasty.QuickCheck @@ -19,6 +19,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 +48,16 @@ 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+ properties :: TestTree properties = testGroup "properties"     [ testGroup "fromList"@@ -163,4 +142,73 @@         [ testProperty "unzips the vector" $ \v -> (\(xs, ys) -> (toList xs, toList ys)) (V.unzip v) === unzip (toList v)         ]     , instances+    , laws+    ]++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     ]
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` ()         ]     ]