packages feed

rrb-vector 0.1.0.0 → 0.1.1.0

raw patch · 15 files changed

+489/−248 lines, 15 filesdep +ghc-heap-viewdep +tastydep +tasty-benchdep −QuickCheckdep −gaugedep −hspecdep ~deepseqdep ~indexed-traversablePVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-heap-view, tasty, tasty-bench, tasty-quickcheck

Dependencies removed: QuickCheck, gauge, hspec

Dependency ranges changed: deepseq, indexed-traversable

API changes (from Hackage documentation)

+ Data.RRBVector: replicate :: Int -> a -> Vector a

Files

+ CHANGELOG.md view
@@ -0,0 +1,12 @@+# 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+  - Add strictness tests++# 0.1.0.0 - June 2021++* Initial release
README.md view
@@ -1,5 +1,6 @@ # rbb-vector -An implementation of a Relaxed Radix Balanced Vector (RRB-Vector).+An implementation of a Relaxed Radix Balanced Vector (RRB-Vector), an efficient sequence data structure.+It supports fast indexing, iteration, concatenation and splitting.  For more information, see [`rrb-vector` on Hackage](https://hackage.haskell.org/package/rrb-vector).
bench/Main.hs view
@@ -1,22 +1,24 @@+{-# LANGUAGE BangPatterns #-}+ import Data.Functor ((<&>)) -import Gauge.Main+import Test.Tasty.Bench  import qualified Data.RRBVector as RRB  main :: IO ()-main = defaultMain $ [10, 100, 1_000, 10_000, 100_000] <&> \n ->-    let v = RRB.fromList [1..n]-        idx = [n `div` 10, n `div` 2, n - n `div` 10]+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 "><" $ nf (\vec -> vec RRB.>< vec) v-    , bench "|>" $ nf (RRB.|> 42) v-    , bench "<|" $ nf (42 RRB.<|) v-    , bgroup "take" $ idx <&> \i -> bench (show i) $ nf (RRB.take i) v-    , bgroup "drop" $ idx <&> \i -> bench (show i) $ nf (RRB.drop i) v-    , bgroup "lookup" $ idx <&> \i -> bench (show i) $ nf (RRB.lookup i) v-    , bgroup "adjust" $ idx <&> \i -> bench (show i) $ nf (RRB.adjust i (+ 1)) v+    , 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 "index" $ nf (RRB.lookup idx) v+    , bench "adjust" $ whnf (RRB.adjust idx (+ 1)) v     , bench "foldl" $ nf (foldl (+) 0) v     , bench "foldr" $ nf (foldr (+) 0) v     ]
bench/Traverse.hs view
@@ -1,21 +1,25 @@ {-# LANGUAGE BangPatterns #-} +import Control.Applicative (liftA2)+import Control.Monad (replicateM) import Data.Foldable (foldl', toList) import Data.Functor -import Gauge.Main+import Test.Tasty.Bench  import qualified Data.RRBVector as RRB  main :: IO ()-main = defaultMain $ [10, 100, 1_000] <&> \n ->+main = defaultMain $ [100, 1000, 10000] <&> \n ->     let !v = RRB.fromList [1..n]+        !idx = n `div` 2     in bgroup (show n)-        [ bench "f1 (where)" $ nf (\v -> f1 v v) v-        , bench "f2" $ nf (\v -> f2 v v) v+        [ 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         ]-  where-    f1 xs ys = foldl' (\acc x -> acc RRB.>< RRB.fromList (replicate n x)) RRB.empty xs-      where-        n = length ys-    f2 xs ys = foldl' (\acc x -> acc RRB.>< RRB.fromList (replicate (length ys) x)) RRB.empty xs
rrb-vector.cabal view
@@ -1,5 +1,5 @@ name:               rrb-vector-version:            0.1.0.0+version:            0.1.1.0 synopsis:           Efficient RRB-Vectors description:   An RRB-Vector is an efficient sequence data structure.@@ -18,13 +18,15 @@ copyright:          2021 konsumlamm category:           Data Structures build-type:         Simple-extra-source-files: README.md+extra-source-files:+  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  source-repository head   type:     git-  location: https://github.com/konsumlamm/rbb-vector+  location: https://github.com/konsumlamm/rrb-vector  library   hs-source-dirs:       src@@ -43,12 +45,18 @@  test-suite test   hs-source-dirs:       test-  main-is:              Spec.hs+  main-is:              Main.hs+  other-modules:+    Arbitrary+    Properties+    Strictness   type:                 exitcode-stdio-1.0   ghc-options:          -Wall -Wno-orphans -Wno-type-defaults-  build-depends:        base >= 4.11 && < 5, rrb-vector, hspec, QuickCheck+  build-depends:        base >= 4.11 && < 5, deepseq, indexed-traversable, rrb-vector, tasty, tasty-quickcheck+  if impl(ghc == 8.10.*)+    build-depends:      ghc-heap-view   default-language:     Haskell2010-  default-extensions:   ExtendedDefaultRules, NumericUnderscores+  default-extensions:   ExtendedDefaultRules, ScopedTypeVariables  benchmark rrb-bench   hs-source-dirs:       bench@@ -56,8 +64,8 @@   type:                 exitcode-stdio-1.0   default-language:     Haskell2010   ghc-options:          -O2-  build-depends:        base >= 4.11 && < 5, gauge, rrb-vector-  default-extensions:   ExtendedDefaultRules, NumericUnderscores+  build-depends:        base >= 4.11 && < 5, rrb-vector, tasty-bench+  default-extensions:   ExtendedDefaultRules  benchmark traverse   hs-source-dirs:       bench@@ -65,5 +73,5 @@   type:                 exitcode-stdio-1.0   default-language:     Haskell2010   ghc-options:          -O2-  build-depends:        base >= 4.11 && < 5, gauge, rrb-vector, primitive-  default-extensions:   ExtendedDefaultRules, NumericUnderscores+  build-depends:        base >= 4.11 && < 5, primitive, rrb-vector, tasty-bench+  default-extensions:   ExtendedDefaultRules
src/Data/RRBVector.hs view
@@ -21,7 +21,7 @@ module Data.RRBVector     ( Vector     -- * Construction-    , empty, singleton, fromList+    , empty, singleton, fromList, replicate     -- ** Concatenation     , (<|), (|>), (><)     -- * Deconstruction@@ -45,7 +45,7 @@     , zip, zipWith, unzip     ) where -import Prelude hiding (lookup, take, drop, splitAt, map, reverse, zip, zipWith, unzip)+import Prelude hiding (replicate, lookup, take, drop, splitAt, map, reverse, zip, zipWith, unzip)  import Data.Foldable.WithIndex import Data.Functor.WithIndex
src/Data/RRBVector/Internal.hs view
@@ -10,7 +10,7 @@     -- * Internal     , blockShift, blockSize, treeSize, computeSizes, up     -- * Construction-    , empty, singleton, fromList+    , empty, singleton, fromList, replicate     -- ** Concatenation     , (<|), (|>), (><)     -- * Deconstruction@@ -43,12 +43,13 @@ import Data.Foldable (Foldable(..), for_) import Data.Functor.Classes import Data.Functor.Identity (Identity(..))-import Data.Maybe (fromMaybe) import qualified Data.List as List+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) import Text.Read-import Prelude hiding (lookup, map, take, drop, splitAt, head, last, reverse, zip, zipWith, unzip)  import Data.Functor.WithIndex import Data.Foldable.WithIndex@@ -63,13 +64,15 @@ infixr 5 <| infixl 5 |> +type Shift = Int+ -- Invariant: Children of a Balanced node are always balanced. -- A Leaf node is considered balanced. -- Nodes are always non-empty. data Tree a-    = Balanced !(A.Array (Tree a))-    | Unbalanced !(A.Array (Tree a)) !(PrimArray Int)-    | Leaf !(A.Array a)+    = Balanced {-# UNPACK #-} !(A.Array (Tree a))+    | Unbalanced {-# UNPACK #-} !(A.Array (Tree a)) !(PrimArray Int)+    | Leaf {-# UNPACK #-} !(A.Array a)  -- | A vector. --@@ -78,35 +81,31 @@     = Empty     | Root         !Int -- size-        !Int -- shift (blockShift * height)+        !Shift -- shift (blockShift * height)         !(Tree a)  -- The number of bits used per level.-blockShift :: Int+blockShift :: Shift blockShift = 4-{-# INLINE blockShift #-}  -- The maximum size of a block. blockSize :: Int-blockSize = 1 `shiftL` blockShift+blockSize = 1 `unsafeShiftL` blockShift  -- The mask used to extract the index into the array. blockMask :: Int blockMask = blockSize - 1 -up :: Int -> Int+up :: Shift -> Shift up sh = sh + blockShift-{-# INLINE up #-} -down :: Int -> Int+down :: Shift -> Shift down sh = sh - blockShift-{-# INLINE down #-} -radixIndex :: Int -> Int -> Int-radixIndex i sh = i `shiftR` sh .&. blockMask-{-# INLINE radixIndex #-}+radixIndex :: Int -> Shift -> Int+radixIndex i sh = i `unsafeShiftR` sh .&. blockMask -relaxedRadixIndex :: PrimArray Int -> Int -> Int -> (Int, Int)+relaxedRadixIndex :: PrimArray Int -> Int -> Shift -> (Int, Int) relaxedRadixIndex sizes i sh =     let guess = radixIndex i sh -- guess <= idx         idx = loop guess@@ -116,7 +115,6 @@     loop idx =         let current = indexPrimArray sizes idx -- idx will always be in range for a well-formed tree         in if i < current then idx else loop (idx + 1)-{-# INLINE relaxedRadixIndex #-}  treeToArray :: Tree a -> A.Array (Tree a) treeToArray (Balanced arr) = arr@@ -129,44 +127,52 @@ treeBalanced (Leaf _) = True  -- @treeSize sh@ is the size of a tree with shift @sh@.-treeSize :: Int -> Tree a -> Int+treeSize :: Shift -> Tree a -> Int treeSize = go 0   where-    go acc _ (Leaf arr) = acc + length arr+    go !acc !_ (Leaf arr) = acc + length arr     go acc _ (Unbalanced _ sizes) = acc + indexPrimArray sizes (sizeofPrimArray sizes - 1)     go acc sh (Balanced arr) =         let i = length arr - 1-        in go (acc + i * (1 `shiftL` sh)) (down sh) (A.index arr i)+        in go (acc + i * (1 `unsafeShiftL` sh)) (down sh) (A.index arr i) {-# INLINE treeSize #-}  -- @computeSizes sh@ turns an array into a tree node by computing the sizes of its subtrees. -- @sh@ is the shift of the resulting tree.-computeSizes :: Int -> A.Array (Tree a) -> Tree a-computeSizes sh arr = runST $ do-    let len = length arr-        maxSize = 1 `shiftL` sh -- the maximum size of a subtree-    sizes <- newPrimArray len-    let loop acc isBalanced i-            | i < len =-                let subtree = A.index arr i-                    size = treeSize (down sh) subtree-                    acc' = acc + size-                    isBalanced' = isBalanced && if i == len - 1 then treeBalanced subtree else size == maxSize-                in writePrimArray sizes i acc' *> loop acc' isBalanced' (i + 1)-            | otherwise = pure isBalanced-    isBalanced <- loop 0 True 0-    if isBalanced then-        pure $ Balanced arr-    else do-        sizes <- unsafeFreezePrimArray sizes -- safe because the mutable @sizes@ isn't used afterwards-        pure $ Unbalanced arr sizes+computeSizes :: Shift -> A.Array (Tree a) -> Tree a+computeSizes !sh arr+    | isBalanced = Balanced arr+    | otherwise = runST $ do+        sizes <- newPrimArray (length arr)+        let loop acc i+                | i < len =+                    let size = treeSize (down sh) (A.index arr i)+                        acc' = acc + size+                    in writePrimArray sizes i acc' *> loop acc' (i + 1)+                | otherwise = do+                    sizes <- unsafeFreezePrimArray sizes -- safe because the mutable @sizes@ isn't used afterwards+                    pure $ Unbalanced arr sizes+        loop 0 0+  where+    maxSize = 1 `unsafeShiftL` sh -- the maximum size of a subtree +    len = length arr++    lenM1 = len - 1++    isBalanced = go 0+      where+        go i+            | i < lenM1 = treeSize (down sh) subtree == maxSize && go (i + 1)+            | otherwise = treeBalanced subtree+          where+            subtree = A.index arr i+ -- Integer log base 2. log2 :: Int -> Int log2 x = bitSizeMinus1 - countLeadingZeros x   where     bitSizeMinus1 = finiteBitSize (0 :: Int) - 1-{-# INLINE log2 #-}  instance Show1 Vector where     liftShowsPrec sp sl p v = showsUnaryWith (liftShowsPrec sp sl) "fromList" p (toList v)@@ -195,7 +201,8 @@     compare = compare1  instance Semigroup (Vector a) where-    v1 <> v2 = v1 >< v2+    (<>) = (><)+    stimes = stimesMonoid  instance Monoid (Vector a) where     mempty = empty@@ -243,45 +250,47 @@      null Empty = True     null Root{} = False-    {-# INLINE null #-}      length Empty = 0     length (Root s _ _) = s-    {-# INLINE length #-}  instance FoldableWithIndex Int Vector where-    ifoldr f z0 v = foldr (\x g !i -> f i x (g (i + 1))) (const z0) v 0+    ifoldr f z0 v = foldr' (\x g !i -> f i x (g (i + 1))) (const z0) v 0+    {-# INLINE ifoldr #-} -    ifoldl f z0 v = foldl (\g x !i -> f i (g (i - 1)) x) (const z0) v (length v - 1)+    ifoldl f z0 v = foldl' (\g x !i -> f i (g (i - 1)) x) (const z0) v (length v - 1)+    {-# INLINE ifoldl #-}  instance Functor Vector where     fmap = map-    x <$ v = fromList (replicate (length v) x)+    x <$ v = replicate (length v) x  instance FunctorWithIndex Int Vector where     imap f v = runIdentity $ evalIndexed (traverse (Indexed . f') v) 0       where-        f' x i = i `seq` WithIndex (i + 1) (Identity (f i x))+        f' x !i = WithIndex (i + 1) (Identity (f i x))  instance Traversable Vector where     traverse _ Empty = pure Empty     traverse f (Root size sh tree) = Root size sh <$> traverseTree tree       where         traverseTree (Balanced arr) = Balanced <$> A.traverse' traverseTree arr-        traverseTree (Unbalanced arr sizes) = Unbalanced <$> A.traverse' traverseTree arr <*> pure sizes+        traverseTree (Unbalanced arr sizes) = flip Unbalanced sizes <$> A.traverse' traverseTree arr         traverseTree (Leaf arr) = Leaf <$> A.traverse f arr+    {-# INLINE traverse #-}  instance TraversableWithIndex Int Vector where     itraverse f v = evalIndexed (traverse (Indexed . f') v) 0       where-        f' x i = i `seq` WithIndex (i + 1) (f i x)+        f' x !i = WithIndex (i + 1) (f i x)+    {-# 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 = foldl' (\acc x -> acc >< fromList (replicate (length ys) x)) empty xs+    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@@ -343,14 +352,16 @@         buffer <- Buffer.new blockSize         let loop [] = do                 result <- Buffer.get buffer-                pure [f result]+                let !x = f result+                pure [x]             loop (t : ts) = do                 size <- Buffer.size buffer                 if size == blockSize then do                     result <- Buffer.get buffer                     Buffer.push buffer t                     rest <- loop ts-                    pure (f result : rest)+                    let !x = f result+                    pure (x : rest)                 else do                     Buffer.push buffer t                     loop ts@@ -361,6 +372,27 @@         [tree] -> Root (treeSize sh tree) sh tree         trees' -> iterateNodes (up sh) trees' +-- | \(O(\log n)\). @replicate n x@ creates a vector of length @n@ with every element set to @x@.+--+-- >>> replicate 5 42+-- fromList [42,42,42,42,42]+--+-- @since 0.1.1.0+replicate :: Int -> a -> Vector a+replicate n x+    | n <= 0 = Empty+    | n <= blockSize = Root n 0 (Leaf $ A.replicate n x)+    | otherwise = iterateNodes blockShift (Leaf $ A.replicate blockSize x) (Leaf $ A.replicate (lastIdx .&. blockMask + 1) x)+  where+    lastIdx = n - 1++    -- @full@ is a full subtree, @rest@ is the last subtree+    iterateNodes !sh !full !rest =+        let subtreesM1 = lastIdx `unsafeShiftR` sh -- the number of subtrees minus 1+            full' = Balanced $ A.replicate blockSize full+            rest' = Balanced $ A.replicateSnoc (subtreesM1 .&. blockMask) full rest+        in if subtreesM1 < blockSize then Root n sh rest' else iterateNodes (up sh) full' rest'+ -- | \(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@@ -377,6 +409,7 @@ -- | \(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+{-# INLINE index #-}  -- | \(O(\log n)\). A flipped version of 'lookup'. (!?) :: Vector a -> Int -> Maybe a@@ -451,7 +484,7 @@ -- -- > zip = zipWith (,) zip :: Vector a -> Vector b -> Vector (a, b)-zip v1 v2 = fromList $ List.zip (toList v1) (toList v2)+zip = zipWith (,)  -- | \(O(\min(n_1, n_2))\). 'zipWith' generalizes 'zip' by zipping with the function. zipWith :: (a -> b -> c) -> Vector a -> Vector b -> Vector c@@ -462,7 +495,10 @@ -- >>> 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 = (map fst v, map snd v)+unzip v =+    let !left = map fst v+        !right = map snd v+    in (left, right)  -- | \(O(\log n)\). The first element and the vector without the first element, or 'Nothing' if the vector is empty. --@@ -516,46 +552,50 @@ v >< Empty = v Root size1 sh1 tree1 >< Root size2 sh2 tree2 =     let maxShift = max sh1 sh2-        newTree = mergeTrees tree1 sh1 tree2 sh2-    in case singleTree newTree of-        Just newTree -> Root (size1 + size2) maxShift newTree-        Nothing -> Root (size1 + size2) (up maxShift) newTree+        upMaxShift = up maxShift+        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)   where-    mergeTrees (Leaf arr1) _ (Leaf arr2) _ = Balanced $-        if length arr1 == blockSize then A.from2 (Leaf arr1) (Leaf arr2)-        else if length arr1 + length arr2 <= blockSize then A.singleton (Leaf (arr1 <> arr2))-        else+    mergeTrees tree1@(Leaf arr1) !_ tree2@(Leaf arr2) !_+        | length arr1 == blockSize = A.from2 tree1 tree2+        | length arr1 + length arr2 <= blockSize = A.singleton $! Leaf (arr1 <> arr2)+        | otherwise =             let (left, right) = A.splitAt (arr1 <> arr2) blockSize-            in A.from2 (Leaf left) (Leaf right)+                !leftTree = Leaf left+                !rightTree = Leaf right+            in A.from2 leftTree rightTree     mergeTrees tree1 sh1 tree2 sh2 = case compare sh1 sh2 of         LT ->-            let right = treeToArray tree2-                (rightHead, rightTail) = viewl right+            let !right = treeToArray tree2+                (rightHead, rightTail) = viewlArr right                 merged = mergeTrees tree1 sh1 rightHead (down sh2)-            in mergeRebalance sh2 A.empty (treeToArray merged) rightTail+            in mergeRebalance sh2 A.empty merged rightTail         GT ->-            let left = treeToArray tree1-                (leftInit, leftLast) = viewr left+            let !left = treeToArray tree1+                (leftInit, leftLast) = viewrArr left                 merged = mergeTrees leftLast (down sh1) tree2 sh2-            in mergeRebalance sh1 leftInit (treeToArray merged) A.empty+            in mergeRebalance sh1 leftInit merged A.empty         EQ ->-            let left = treeToArray tree1-                right = treeToArray tree2-                (leftInit, leftLast) = viewr left-                (rightHead, rightTail) = viewl right+            let !left = treeToArray tree1+                !right = treeToArray tree2+                (leftInit, leftLast) = viewrArr left+                (rightHead, rightTail) = viewlArr right                 merged = mergeTrees leftLast (down sh1) rightHead (down sh2)-            in mergeRebalance sh1 leftInit (treeToArray merged) rightTail+            in mergeRebalance sh1 leftInit merged rightTail       where-        viewl arr = (A.head arr, A.drop arr 1)-        viewr arr = (A.take arr (length arr - 1), A.last arr)+        viewlArr arr = (A.head arr, A.drop arr 1) -    -- the type annotations are necessary to compile-    mergeRebalance :: forall a. Int -> A.Array (Tree a) -> A.Array (Tree a) -> A.Array (Tree a) -> Tree a-    mergeRebalance sh left center right+        viewrArr arr = (A.take arr (length arr - 1), A.last arr)++    -- the type signature is necessary to compile+    mergeRebalance :: forall a. Shift -> A.Array (Tree a) -> A.Array (Tree a) -> A.Array (Tree a) -> A.Array (Tree a)+    mergeRebalance !sh !left !center !right         | sh == blockShift = mergeRebalance' (\(Leaf arr) -> arr) Leaf         | otherwise = mergeRebalance' treeToArray (computeSizes (down sh))       where-        mergeRebalance' :: (Tree a -> A.Array t) -> (A.Array t -> Tree a) -> Tree a+        mergeRebalance' :: (Tree a -> A.Array t) -> (A.Array t -> Tree a) -> A.Array (Tree a)         mergeRebalance' extract construct = runST $ do             newRoot <- Buffer.new blockSize             newSubtree <- Buffer.new blockSize@@ -570,20 +610,14 @@                     Buffer.push newNode x             pushTo construct newNode newSubtree             pushTo (computeSizes sh) newSubtree newRoot-            computeSizes (up sh) <$> Buffer.get newRoot+            Buffer.get newRoot         {-# INLINE mergeRebalance' #-}          pushTo f from to = do             result <- Buffer.get from-            Buffer.push to (f result)+            Buffer.push to $! f result         {-# INLINE pushTo #-} -    singleTree (Balanced arr)-        | length arr == 1 = Just (A.head arr)-    singleTree (Unbalanced arr _)-        | length arr == 1 = Just (A.head arr)-    singleTree _ = Nothing- -- | \(O(\log n)\). Add an element to the left end of the vector. -- -- >>> 1 <| fromList [2, 3, 4]@@ -591,28 +625,28 @@ (<|) :: a -> Vector a -> Vector a x <| Empty = singleton x x <| Root size sh tree-    | insertShift > sh = Root (size + 1) insertShift (computeSizes insertShift (A.from2 (newBranch x sh) tree))+    | insertShift > sh = Root (size + 1) insertShift (computeSizes insertShift (let !new = newBranch x sh in A.from2 new tree))     | otherwise = Root (size + 1) sh (consTree sh tree)   where     consTree sh (Balanced arr)-        | sh == insertShift = computeSizes sh (A.cons arr (newBranch x (down sh)))+        | sh == insertShift = computeSizes sh (A.cons arr $! newBranch x (down sh))         | otherwise = computeSizes sh (A.adjust' arr 0 (consTree (down sh)))     consTree sh (Unbalanced arr _)-        | sh == insertShift = computeSizes sh (A.cons arr (newBranch x (down sh)))+        | sh == insertShift = computeSizes sh (A.cons arr $! newBranch x (down sh))         | otherwise = computeSizes sh (A.adjust' arr 0 (consTree (down sh)))     consTree _ (Leaf arr) = Leaf $ A.cons arr x      insertShift = computeShift size sh (up sh) tree      -- compute the shift at which the new branch needs to be inserted (0 means there is space in the leaf)-    -- the index is computed for efficient calculation of the shift in a balanced subtree-    computeShift i sh min (Balanced _) =-        let newShift = (log2 i `div` blockShift) * blockShift+    -- 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         in if newShift > sh then min else newShift     computeShift _ sh min (Unbalanced arr sizes) =-        let i' = indexPrimArray sizes 0 -- the size of the first subtree+        let sz' = indexPrimArray sizes 0 -- the size of the first subtree             newMin = if length arr < blockSize then sh else min-        in computeShift i' (down sh) newMin (A.head arr)+        in computeShift sz' (down sh) newMin (A.head arr)     computeShift _ _ min (Leaf arr) = if length arr < blockSize then 0 else min  -- | \(O(\log n)\). Add an element to the right end of the vector.@@ -622,14 +656,14 @@ (|>) :: Vector a -> a -> Vector a Empty |> x = singleton x Root size sh tree |> x-    | insertShift > sh = Root (size + 1) insertShift (computeSizes insertShift (A.from2 tree (newBranch x sh)))+    | insertShift > sh = Root (size + 1) insertShift (computeSizes insertShift (A.from2 tree $! newBranch x sh))     | otherwise = Root (size + 1) sh (snocTree sh tree)   where     snocTree sh (Balanced arr)-        | sh == insertShift = Balanced $ A.snoc arr (newBranch x (down sh)) -- the current subtree is fully balanced+        | sh == insertShift = Balanced (A.snoc arr $! newBranch x (down sh)) -- the current subtree is fully balanced         | otherwise = Balanced $ A.adjust' arr (length arr - 1) (snocTree (down sh))     snocTree sh (Unbalanced arr sizes)-        | sh == insertShift = Unbalanced (A.snoc arr (newBranch x (down sh))) newSizesSnoc+        | sh == insertShift = Unbalanced (A.snoc arr $! newBranch x (down sh)) newSizesSnoc         | otherwise = Unbalanced (A.adjust' arr (length arr - 1) (snocTree (down sh))) newSizesAdjust       where         -- snoc the last size + 1@@ -653,23 +687,23 @@     insertShift = computeShift size sh (up sh) tree      -- compute the shift at which the new branch needs to be inserted (0 means there is space in the leaf)-    -- the index is computed for efficient calculation of the shift in a balanced subtree-    computeShift i sh min (Balanced _) =-        let newShift = (countTrailingZeros i `div` blockShift) * blockShift+    -- the size is computed for efficient calculation of the shift in a balanced subtree+    computeShift !sz !sh !min (Balanced _) =+        let newShift = (countTrailingZeros sz `div` blockShift) * blockShift         in if newShift > sh then min else newShift     computeShift _ sh min (Unbalanced arr sizes) =-        let i' = indexPrimArray sizes (sizeofPrimArray sizes - 1) - indexPrimArray sizes (sizeofPrimArray sizes - 2) -- sizes has at least 2 elements, otherwise the node would be balanced+        let lastIdx = sizeofPrimArray sizes - 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 i' (down sh) newMin (A.last arr)+        in computeShift sz' (down sh) newMin (A.last arr)     computeShift _ _ min (Leaf arr) = if length arr < blockSize then 0 else min  -- create a new tree with shift @sh@-newBranch :: a -> Int -> Tree a+newBranch :: a -> Shift -> Tree a newBranch x = go   where-    go 0 = Leaf $ A.singleton x-    go sh = Balanced $ A.singleton (go (down sh))-{-# INLINE newBranch #-}+    go 0 = Leaf (A.singleton x)+    go sh = Balanced (A.singleton $! go (down sh))  -- splitting
src/Data/RRBVector/Internal/Array.hs view
@@ -8,6 +8,7 @@ module Data.RRBVector.Internal.Array     ( Array, MutableArray     , empty, singleton, from2+    , replicate, replicateSnoc     , index, head, last     , update, adjust, adjust'     , take, drop, splitAt@@ -24,7 +25,7 @@ import Control.Monad.ST import Data.Foldable (Foldable(..)) import Data.Primitive.SmallArray-import Prelude hiding (take, drop, splitAt, head, last, map, traverse, read)+import Prelude hiding (replicate, take, drop, splitAt, head, last, map, traverse, read)  -- start length array data Array a = Array !Int !Int !(SmallArray a)@@ -40,41 +41,35 @@         !len' = len1 + len2  instance Foldable Array where-    foldr f = \z (Array start len arr) ->-        let !end = start + len+    foldr f z (Array start len arr) =+        let end = start + len             go i                 | i == end = z                 | (# x #) <- indexSmallArray## arr i = f x (go (i + 1))         in go start-    {-# INLINE foldr #-} -    foldl f = \z (Array start len arr) ->+    foldl f z (Array start len arr) =         let go i                 | i < start = z                 | (# x #) <- indexSmallArray## arr i = f (go (i - 1)) x         in go (start + len - 1)-    {-# INLINE foldl #-} -    foldr' f = \z (Array start len arr) ->+    foldr' f z (Array start len arr) =         let go i !acc                 | i < start = acc                 | (# x #) <- indexSmallArray## arr i = go (i - 1) (f x acc)         in go (start + len - 1) z-    {-# INLINE foldr' #-} -    foldl' f = \z (Array start len arr) ->-        let !end = start + len+    foldl' f z (Array start len arr) =+        let end = start + len             go i !acc                 | i == end = acc                 | (# x #) <- indexSmallArray## arr i = go (i + 1) (f acc x)         in go start z-    {-# INLINE foldl' #-}      null arr = length arr == 0-    {-# INLINE null #-}      length (Array _ len _) = len-    {-# INLINE length #-}  instance (NFData a) => NFData (Array a) where     rnf = foldl' (\_ x -> rnf x) ()@@ -93,6 +88,18 @@     sma <- newSmallArray 2 x     writeSmallArray sma 1 y     pure sma++replicate :: Int -> a -> Array a+replicate n x = Array 0 n $ runSmallArray (newSmallArray n x)++-- > replicateSnoc n x y = snoc (replicate n x) y+replicateSnoc :: Int -> a -> a -> Array a+replicateSnoc n x y = Array 0 len $ runSmallArray $ do+    sma <- newSmallArray len x+    writeSmallArray sma n y+    pure sma+  where+    len = n + 1  index :: Array a -> Int -> a index (Array start _ arr) idx = indexSmallArray arr (start + idx)
src/Data/RRBVector/Internal/Buffer.hs view
@@ -23,7 +23,7 @@ push (Buffer buffer offset) x = do     idx <- readIntRef offset     A.write buffer idx x-    modifyIntRef offset (+ 1)+    writeIntRef offset (idx + 1)  get :: Buffer s a -> ST s (A.Array a) get (Buffer buffer offset) = do
src/Data/RRBVector/Internal/IntRef.hs view
@@ -3,7 +3,6 @@     , newIntRef     , readIntRef     , writeIntRef-    , modifyIntRef     ) where  import Control.Monad.ST@@ -14,7 +13,7 @@ newIntRef :: Int -> ST s (IntRef s) newIntRef i = do     arr <- newPrimArray 1-    setPrimArray arr 0 1 i+    writePrimArray arr 0 i     pure (IntRef arr) {-# INLINE newIntRef #-} @@ -25,9 +24,3 @@ writeIntRef :: IntRef s -> Int -> ST s () writeIntRef (IntRef arr) = writePrimArray arr 0 {-# INLINE writeIntRef #-}--modifyIntRef :: IntRef s -> (Int -> Int) -> ST s ()-modifyIntRef (IntRef arr) f = do-    i <- readPrimArray arr 0-    writePrimArray arr 0 (f i)-{-# INLINE modifyIntRef #-}
+ test/Arbitrary.hs view
@@ -0,0 +1,11 @@+module Arbitrary where++import Test.Tasty.QuickCheck++import qualified Data.RRBVector as V+import Data.RRBVector.Internal.Debug++-- TODO: improve instance+instance (Arbitrary a) => Arbitrary (V.Vector a) where+    arbitrary = oneof [V.fromList <$> arbitrary, fromListUnbalanced <$> arbitrary]+
+ test/Main.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE BangPatterns #-}++import Test.Tasty+import Test.Tasty.QuickCheck++import Properties (properties)+import Strictness (strictness)++main :: IO ()+main = defaultMain . localOption (QuickCheckTests 1000) . localOption (QuickCheckMaxSize 10000) $ testGroup "rrb-vector"+    [ properties+    , strictness+    ]
+ test/Properties.hs view
@@ -0,0 +1,166 @@+module Properties+    ( properties+    ) where++import Data.Foldable (toList)+import Data.List (uncons)+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.Tasty+import Test.Tasty.QuickCheck++import Arbitrary ()++default (Int)++type V = V.Vector++lookupList :: Int -> [a] -> Maybe a+lookupList i ls+    | i < length ls = Just (ls !! i)+    | otherwise = Nothing++updateList :: Int -> a -> [a] -> [a]+updateList i x ls+    | i < length ls = let (left, _ : right) = splitAt i ls in left ++ (x : right)+    | otherwise = ls++adjustList :: Int -> (a -> a) -> [a] -> [a]+adjustList i f ls+    | i < length ls = let (left, x : right) = splitAt i ls in left ++ (f x : right)+    | otherwise = ls++insertAtList :: Int -> a -> [a] -> [a]+insertAtList i x ls = let (left, right) = splitAt i ls in left ++ (x : right)++deleteAtList :: Int -> [a] -> [a]+deleteAtList i ls+    | i < length ls = let (left, _ : right) = splitAt i ls in left ++ right+    | otherwise = ls++unsnoc :: [a] -> Maybe ([a], a)+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+        ]+    ]++properties :: TestTree+properties = testGroup "properties"+    [ testGroup "fromList"+        [ testProperty "satisfies `fromList . toList = id`" $ \v -> V.fromList (toList v) === v+        , 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+        ]+    , 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+        ]+    , 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+        ]+    , 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+        ]+    , 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)+        ]+    , testGroup "lookup"+        [ testProperty "gets the element at the index" $ \v (NonNegative i) -> V.lookup i v === lookupList i (toList v)+        , testProperty "returns Nothing for negative indices" $ \v (Negative i) -> V.lookup i v === Nothing+        ]+    , 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+        ]+    , 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+        ]+    , 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+        ]+    , 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+        ]+    , 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+        ]+    , 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+        ]+    , 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+        ]+    , testGroup "splitAt"+        [ testProperty "splits the vector" $ \v n -> let (v1, v2) = V.splitAt n v in (toList v1, toList v2) === splitAt n (toList v)+        ]+    , testGroup "insertAt"+        [ testProperty "inserts an element" $ \v i x -> toList (V.insertAt i x v) === insertAtList i x (toList v)+        , 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+        ]+    , 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 "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+        ]+    , testGroup "reverse"+        [ testProperty "reverses the vector" $ \v -> toList (V.reverse v) === reverse (toList v)+        ]+    , testGroup "zip"+        [ testProperty "zips two vectors" $ \v1 v2 -> toList (V.zip v1 v2) === zip (toList v1) (toList 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+        ]+    , testGroup "unzip"+        [ testProperty "unzips the vector" $ \v -> (\(xs, ys) -> (toList xs, toList ys)) (V.unzip v) === unzip (toList v)+        ]+    , instances+    ]
− test/Spec.hs 
@@ -1,83 +0,0 @@-import Data.Foldable (toList)-import Data.List (uncons)--import Test.Hspec-import Test.Hspec.QuickCheck-import Test.QuickCheck--import qualified Data.RRBVector as V-import Data.RRBVector.Internal.Debug (fromListUnbalanced)--default (Int)--instance (Arbitrary a) => Arbitrary (V.Vector a) where-    arbitrary = oneof [V.fromList <$> arbitrary, fromListUnbalanced <$> arbitrary]--lookupList :: Int -> [a] -> Maybe a-lookupList i ls-    | i < length ls = Just (ls !! i)-    | otherwise = Nothing--updateList :: Int -> a -> [a] -> [a]-updateList i x ls-    | i < length ls = let (left, _ : right) = splitAt i ls in left ++ (x : right)-    | otherwise = ls--adjustList :: Int -> (a -> a) -> [a] -> [a]-adjustList i f ls-    | i < length ls = let (left, x : right) = splitAt i ls in left ++ (f x : right)-    | otherwise = ls--unsnoc :: [a] -> Maybe ([a], a)-unsnoc [] = Nothing-unsnoc ls = Just (init ls, last ls)--main :: IO ()-main = hspec . modifyMaxSuccess maxN . modifyMaxSize maxN $ do-    prop "satisfies `fromList . toList == id`" $ \v -> V.fromList (toList v) === v-    prop "satisfies `toList . fromList == id`" $ \ls -> toList (V.fromList ls) === ls--    describe "lookup" $ do-        prop "gets the element at the index" $ \v (NonNegative i) -> V.lookup i v === lookupList i (toList v)-        prop "returns Nothing for negative indices" $ \v (Negative i) -> V.lookup i v === Nothing--    describe "update" $ do-        prop "updates the element at the index" $ \v (NonNegative i) x -> toList (V.update i x v) === updateList i x (toList v)-        prop "returns the vector for negative indices" $ \v (Negative i) x -> V.update i x v === v--    describe "adjust" $ do-        prop "adjusts the element at the index" $ \v (NonNegative i) -> toList (V.adjust i (+ 1) v) === adjustList i (+ 1) (toList v)-        prop "returns the vector for negative indices" $ \v (Negative i) -> V.adjust i (+ 1) v === v--    describe "><" $ do-        prop "concatenates two vectors" $ \v1 v2 -> toList (v1 V.>< v2) === toList v1 ++ toList v2-        prop "works for the empty vector" $ \v -> (V.empty V.>< v `shouldBe` v) .&&. (v V.>< V.empty `shouldBe` v)--    describe "|>" $ do-        prop "appends an element" $ \v x -> toList (v V.|> x) === toList v ++ [x]-        prop "works for the empty vector" $ \x -> V.empty V.|> x `shouldBe` V.singleton x--    describe "<|" $ do-        prop "prepends an element" $ \x v -> toList (x V.<| v) === x : toList v-        prop "works for the empty vector" $ \x -> x V.<| V.empty `shouldBe` V.singleton x--    describe "take" $ do-        prop "takes n elements" $ \v (Positive n) -> toList (V.take n v) === take n (toList v)-        prop "returns the empty vector for non-positive n" $ \v (NonPositive n) -> V.take n v === V.empty--    describe "drop" $ do-        prop "drops n elements" $ \v (Positive n) -> toList (V.drop n v) === drop n (toList v)-        prop "does nothing for non-positive n" $ \v (NonPositive n) -> V.drop n v === v--    describe "viewl" $ do-        prop "works like uncons" $ \v -> fmap (\(x, xs) -> (x, toList xs)) (V.viewl v) === uncons (toList v)-        prop "works for the empty vector" $ V.viewl V.empty `shouldBe` Nothing--    describe "viewr" $ do-        prop "works like unsnoc" $ \v -> fmap (\(xs, x) -> (toList xs, x)) (V.viewr v) === unsnoc (toList v)-        prop "works for the empty vector" $ V.viewr V.empty `shouldBe` Nothing--    describe "map" $ do-        prop "maps over the vector" $ \v -> toList (V.map (+ 1) v) === map (+ 1) (toList v)-  where-    maxN = const 10_000
+ test/Strictness.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}++#define GHC_HEAP_VIEW defined(VERSION_ghc_heap_view)++module Strictness+    ( strictness+    ) where++#if GHC_HEAP_VIEW+import Control.DeepSeq (deepseq)+import GHC.AssertNF (isNF)+#endif+import qualified Data.RRBVector as V+import Test.Tasty+import Test.Tasty.QuickCheck++import Arbitrary ()++default (Int)++#if GHC_HEAP_VIEW+testNF :: a -> Property+testNF !x = ioProperty (isNF x)++tailVector :: V.Vector a -> Maybe (V.Vector a)+tailVector v = case V.viewl v of+    Nothing -> Nothing+    Just (_, xs) -> Just xs++initVector :: V.Vector a -> Maybe (V.Vector a)+initVector v = case V.viewr v of+    Nothing -> Nothing+    Just (xs, _) -> Just xs+#endif++strictness :: TestTree+strictness = testGroup "strictness"+#if GHC_HEAP_VIEW+    [ testGroup "nf"+        [ testProperty "empty" $ testNF V.empty+        , testProperty "singleton" $ testNF (V.singleton 42)+        , testProperty "fromList" $ \ls -> ls `deepseq` testNF (V.fromList ls)+        , testProperty "replicate" $ \n -> testNF (V.replicate n 42)+        , testProperty "update" $ \v (NonNegative i) -> v `deepseq` testNF (V.update i 42 v)+        , testProperty "adjust'" $ \v (NonNegative i) -> v `deepseq` testNF (V.adjust' i (+ 1) v)+        , testProperty "<|" $ \v -> v `deepseq` testNF (42 V.<| v)+        , testProperty "|>" $ \v -> v `deepseq` testNF (v V.|> 42)+        , testProperty "><" $ \v1 v2 -> v1 `deepseq` v2 `deepseq` testNF (v1 V.>< v2)+        , testProperty "take" $ \v n -> v `deepseq` testNF (V.take n v)+        , testProperty "drop" $ \v n -> v `deepseq` testNF (V.drop n v)+        , testProperty "splitAt" $ \v n -> v `deepseq` testNF (V.splitAt n v)+        , testProperty "insertAt" $ \v i -> v `deepseq` testNF (V.insertAt i 42 v)+        , 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 "reverse" $ \v -> v `deepseq` testNF (V.reverse v)+        ]+    , testGroup "bottom"+#else+    [ testGroup "bottom"+#endif+        [ testProperty "singleton" $ V.singleton undefined `seq` ()+        , testProperty "fromList" $ \n -> V.fromList (replicate n undefined) `seq` ()+        , testProperty "replicate" $ \n -> V.replicate n undefined `seq` ()+        , testProperty "<|" $ \v -> undefined V.<| v `seq` ()+        , testProperty "|>" $ \v -> v V.|> undefined `seq` ()+        , testProperty "update" $ \v i -> V.update i undefined v `seq` ()+        , 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` ()+        ]+    ]