pvector 0.1.0.1 → 0.1.1

raw patch · 8 files changed

+196/−190 lines, 8 filesdep +primitive-checkeddep +quickcheck-classes-basedep +tastydep −hspecdep ~QuickCheckdep ~containersdep ~quickcheck-instancesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: primitive-checked, quickcheck-classes-base, tasty, tasty-hunit, tasty-quickcheck

Dependencies removed: hspec

Dependency ranges changed: QuickCheck, containers, quickcheck-instances

API changes (from Hackage documentation)

Files

• pvector.cabal +18/−8
• src/Data/Vector/Persistent/Internal.hs +40/−41
• src/Data/Vector/Persistent/Internal/Array.hs +26/−8
• test/Arbitrary.hs +11/−0
• test/Main.hs +10/−0
• test/PersistentVectorSpec.hs +0/−132
• test/Properties.hs +91/−0
• test/Spec.hs +0/−1

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: pvector-version: 0.1.0.1+version: 0.1.1 synopsis: Fast persistent vectors description:   An persistent vector is an efficient sequence data structure.@@ -18,7 +18,7 @@   README.md extra-doc-files:   docs/diagram.png-tested-with: GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.2+tested-with: GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.6, GHC == 9.4.4, GHC == 9.6.1  flag debug   description: Enable array bounds checking@@ -76,9 +76,14 @@     -Werror=missing-methods   build-depends:     base >= 4.12 && <5,-    primitive >= 0.6.4.0 && <0.8,     deepseq >=1.1 && <1.5,     vector-stream ^>= 0.1.0.0,+  if flag(debug)+    build-depends:+      primitive-checked,+  else+    build-depends:+      primitive >= 0.6.4.0 && <0.8,  library   import: common-options@@ -111,14 +116,19 @@   import: common-options, rtsopts   type: exitcode-stdio-1.0   hs-source-dirs: test-  main-is: Spec.hs+  main-is: Main.hs   other-modules:-    PersistentVectorSpec+    Properties+    Arbitrary   build-depends:     pvector,-    hspec ^>= 2.9.4,-    QuickCheck ^>= 2.14.2,-    quickcheck-instances ^>= 0.3.27,+    containers,+    tasty,+    tasty-hunit,+    tasty-quickcheck,+    QuickCheck,+    quickcheck-instances,+    quickcheck-classes-base,   build-tool-depends:     hspec-discover:hspec-discover,   cpp-options: -DTEST

@@ -45,16 +45,17 @@ -- | A vector. -- -- The instances are based on those of @Seq@s, which are in turn based on those of lists.-data Vector a = -- |-  -- Invariants: The only time tail can be empty is when init is empty.-  -- Otherwise tailOffset will give the wrong value.-  RootNode-  { size :: !Int,-    -- | 1 << 'shift' is the maximum that each child can contain-    shift :: !Int,-    init :: !(Array (Node a)),-    tail :: !(Array a)-  }+data Vector a+  = -- |+    -- Invariants: The only time tail can be empty is when init is empty.+    -- Otherwise tailOffset will give the wrong value.+    RootNode+    { size :: !Int,+      -- | 1 << 'shift' is the maximum that each child can contain+      shift :: !Int,+      init :: !(Array (Node a)),+      tail :: !(Array a)+    }  instance Show1 Vector where   liftShowsPrec sp sl p v = showsUnaryWith (liftShowsPrec sp sl) "fromList" p (toList v)@@ -265,7 +266,7 @@   -- Room in tail, and vector non-empty   | (size .&. keyMask) /= 0 =       vec-        { tail = updateResizeSmallArray tail (size .&. keyMask) a,+        { tail = snocSmallArray tail a,           size = size + 1         }   | otherwise = snocArr vec 1 $ singletonSmallArray a@@ -355,14 +356,14 @@   | otherwise = go ix (shift vec - keyBits) (indexSmallArray (init vec) (ix !>>. shift vec))   where     go ix 0 !node = indexSmallArray## (getDataNode node) (ix .&. keyMask)-    go ix level !node = go ix (level - keyBits) (indexSmallArray (getInternalNode node) ix')+    go ix level !node = go ix (level - keyBits) node'       where-        ix' = (ix !>>. level) .&. keyMask+        !(# node' #) = indexSmallArray## (getInternalNode node) ((ix !>>. level) .&. keyMask) {-# NOINLINE unsafeIndex# #-} -lookup# :: Int -> Vector a -> (# (# #)| a #)+lookup# :: Int -> Vector a -> (# (# #) | a #) lookup# ix vec-  | (fromIntegral ix :: Word) >= fromIntegral (length vec) = (# (##) | #)+  | (fromIntegral ix :: Word) >= fromIntegral (length vec) = (# (# #) | #)   | otherwise = case Exts.inline unsafeIndex# vec ix of (# x #) -> (# | x #) {-# NOINLINE lookup# #-} @@ -397,6 +398,7 @@ adjust f = adjust# $ \x -> (# f x #) {-# INLINE adjust #-} +-- needs better tests for this adjust# :: (a -> (# a #)) -> Int -> Vector a -> Vector a adjust# f ix vec@RootNode {size, shift, tail}   -- Invalid index. This funny business uses a single test to determine whether@@ -406,14 +408,14 @@   | otherwise = vec {init = go ix shift (init vec)}   where     go ix level vec-      | level == keyBits,-        let !node = DataNode $ modifySmallArray# (getDataNode vec') (ix .&. keyMask) f =-          updateSmallArray vec ix' node-      | otherwise,-        let !node = go ix (level - keyBits) (getInternalNode vec') =-          updateSmallArray vec ix' $! InternalNode node+      | level == keyBits =+          let !node = DataNode $ modifySmallArray# (getDataNode vec') (ix .&. keyMask) f+           in updateSmallArray vec ix' node+      | otherwise =+          let !node = go ix (level - keyBits) (getInternalNode vec')+           in updateSmallArray vec ix' $! InternalNode node       where-        ix' = (ix !>>. level) .&. keyBits+        ix' = (ix !>>. level) .&. keyMask         vec' = indexSmallArray vec ix' {-# INLINE adjust# #-} @@ -434,7 +436,7 @@           (\node -> updateSmallArray vec ix' $! InternalNode node)             <$> go ix (level - keyBits) (getInternalNode vec')       where-        ix' = (ix !>>. level) .&. keyBits+        ix' = (ix !>>. level) .&. keyMask         vec' = indexSmallArray vec ix' {-# INLINE adjustF #-} @@ -476,13 +478,12 @@   | 0 <- size = Nothing   -- we need to have this case because we can't run unsnocTail, there is nothing left in the tail   | 1 <- size, (# x #) <- indexSmallArray## tail 0 = Just (empty, x)-  | nullSmallArray tail',-    (# init', tail' #) <- unsnocTail# size shift init =-      Just (vec {size = size - 1, init = init', tail = tail'}, a)-  | otherwise = Just (vec {size = size - 1, tail = tail'}, a)-  where-    a = lastSmallArray tail-    tail' = popSmallArray tail+  | otherwise = case unsnocSmallArray tail of+      Nothing ->+        let !(# init', tail' #) = unsnocTail# size shift init+            !(# x #) = lastSmallArray# tail'+         in Just (vec {size = size - 1, init = init', tail = popSmallArray tail'}, x)+      Just (tail', a) -> Just (vec {size = size - 1, tail = tail'}, a) {-# INLINEABLE unsnoc #-}  unsnocTail# :: Int -> Int -> Array (Node a) -> (# Array (Node a), Array a #)@@ -497,9 +498,7 @@             else (# updateSmallArray parent subIx $ InternalNode child', tail #)       where         child = indexSmallArray parent subIx-        -- we need to subtract 2 because the first subtraction gets us to the tail element-        -- the second subtraction gets to the last element in the tree-        subIx = ((size - 2) !>>. level) .&. keyMask+        subIx = ((size - 1) !>>. level) .&. keyMask {-# INLINE unsnocTail# #-}  -- | The index of the first element of the tail of the vector (that is, the@@ -599,7 +598,7 @@  keyBits :: Int #ifdef TEST-keyBits = 1+keyBits = 2 #else keyBits = 5 #endif@@ -680,17 +679,17 @@     step [] = pure Stream.Done     step ((n, i) : rest) = case n of       InternalNode ns-        | i >= sizeofSmallArray ns -> pure $ Stream.Skip rest-        | otherwise -> do+        | i < sizeofSmallArray ns -> do             let !(# ns' #) = indexSmallArray## ns i                 !i' = i + 1             pure $ Stream.Skip $ (ns', 0) : (n, i') : rest+        | otherwise -> pure $ Stream.Skip rest       DataNode xs-        | i >= sizeofSmallArray xs -> pure $ Stream.Skip rest-        | otherwise -> do+        | i < sizeofSmallArray xs -> do             let !(# x #) = indexSmallArray## xs i                 !i' = i + 1             pure $ Stream.Yield x $ (n, i') : rest+        | otherwise -> pure $ Stream.Skip rest     {-# INLINE step #-} {-# INLINE streamL #-} @@ -707,13 +706,13 @@         | otherwise -> do             let !(# n' #) = indexSmallArray## ns i                 !i' = i - 1-            pure $ case n' of+            case n' of               InternalNode ns -> do                 let !z = sizeofSmallArray ns - 1-                Stream.Skip $ (n', z) : (n, i') : rest+                pure $ Stream.Skip $ (n', z) : (n, i') : rest               DataNode xs -> do                 let !z = sizeofSmallArray xs - 1-                Stream.Skip $ (n', z) : (n, i') : rest+                pure $ Stream.Skip $ (n', z) : (n, i') : rest       DataNode xs         | i < 0 -> pure $ Stream.Skip rest         | otherwise -> do

@@ -1,13 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedSums #-} {-# LANGUAGE UnboxedTuples #-}  module Data.Vector.Persistent.Internal.Array   ( Array,     MArray,     nullSmallArray,-    lastSmallArray,+    lastSmallArray#,     singletonSmallArray,     twoSmallArray,     updateSmallArray,@@ -27,6 +26,8 @@     modifySmallArray#,     mapSmallArray#,     shrinkSmallMutableArray_,+    snocSmallArray,+    unsnocSmallArray,   ) where @@ -68,9 +69,18 @@ nullSmallArray arr = sizeofSmallArray arr == 0 {-# INLINE nullSmallArray #-} -lastSmallArray :: SmallArray a -> a-lastSmallArray arr = indexSmallArray arr $ sizeofSmallArray arr+unsnocSmallArray :: SmallArray a -> Maybe (SmallArray a, a)+unsnocSmallArray arr = do+  let len = sizeofSmallArray arr+  when (len == 0) Nothing+  x <- indexSmallArrayM arr (len - 1)+  let !arr' = cloneSmallArray arr 0 (len - 1)+  pure (arr', x)+{-# INLINE unsnocSmallArray #-} +lastSmallArray# :: SmallArray a -> (# a #)+lastSmallArray# arr = indexSmallArray## arr $ sizeofSmallArray arr+ singletonSmallArray :: a -> Array a singletonSmallArray a = runSmallArray $ newSmallArray 1 a {-# INLINE singletonSmallArray #-}@@ -107,11 +117,19 @@   pure marr {-# INLINE modifySmallArray# #-} -updateResizeSmallArray :: Array a -> Int -> a -> Array a-updateResizeSmallArray arr i a = runSmallArray $ do-  marr <- thawSmallArray arr 0 (max len (i + 1))-  writeSmallArray marr i a+snocSmallArray :: Array a -> a -> Array a+snocSmallArray arr x = runSmallArray $ do+  marr <- newSmallArray (sizeofSmallArray arr + 1) x+  copySmallArray marr 0 arr 0 (sizeofSmallArray arr)   pure marr+{-# INLINE snocSmallArray #-}++-- this is wrong+updateResizeSmallArray :: Array a -> Int -> a -> Array a+updateResizeSmallArray arr i a =+  if i == len+    then snocSmallArray arr a+    else updateSmallArray arr i a   where     len = sizeofSmallArray arr {-# INLINE updateResizeSmallArray #-}

@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Arbitrary where++import Data.Vector.Persistent (Vector)+import qualified Data.Vector.Persistent as PVec+import Test.QuickCheck++instance Arbitrary a => Arbitrary (Vector a) where+  arbitrary = PVec.fromList <$> arbitrary+  shrink = map PVec.fromList . shrink . PVec.toList

@@ -0,0 +1,10 @@+import qualified Properties+import Test.Tasty++main :: IO ()+main =+  defaultMain $+    testGroup+      "main"+      [ Properties.tests+      ]

@@ -1,132 +0,0 @@-module PersistentVectorSpec (spec) where--import Data.Foldable (foldl')-import Data.Function ((&))-import Data.Primitive.SmallArray-import Data.Vector.Persistent (Vector)-import qualified Data.Vector.Persistent.Internal as Vector-import Data.Vector.Persistent.Internal.Array-import GHC.Exts (fromList, toList)-import Test.Hspec-import Test.Hspec.QuickCheck-import Test.QuickCheck--spec :: Spec-spec = parallel $ do-  prop "toList fromList identity" $ \(l :: [Int]) ->-    l === toList (fromList @(Vector _) l)--  prop "fmap" fmapProp--  prop "foldr" $ \(l :: [Int]) ->-    foldr (:) [] l === foldr (:) [] (fromList @(Vector _) l)--  prop "foldl" $ \(l :: [Int]) ->-    foldl (flip (:)) [] l === foldl (flip (:)) [] (fromList @(Vector _) l)--  it "update bad" $-    propUpdate-      64-      0-      ((repeat 0 & take 64) ++ [1] ++ (repeat 0 & take 32))--  -- this is somehow broken-  prop "update" propUpdate-  -- prop "update" $ \(ix :: Int) (a :: Int) (l :: [Int]) ->-  --   ix >= 0 ==> do-  --     let arr = fromList @(Array _) l-  --         arr'-  --           | ix >= sizeofSmallArray arr = arr-  --           | otherwise = updateSmallArray arr ix a-  -- toList arr' == toList (Vector.update ix a $ fromList @(Vector _) l)--  prop "traverse" $ \(l :: [Int]) -> do-    let go a = ([a], a)-    fmap toList (traverse go (fromList @(Vector _) l)) === traverse go l--  prop "index" indexProp--  it "index weierd" $ indexProp 9 [1 :: Int .. 15]--  prop "eq self" $ \(l :: [Int]) ->-    fromList @(Vector _) l === fromList l--  prop "eq" $ \(l :: [Int]) (l' :: [Int]) ->-    (l == l') === (fromList @(Vector _) l == fromList @(Vector _) l')--  prop "mappend" $ \(l :: [Int]) (l' :: [Int]) ->-    l <> l' === toList (fromList @(Vector _) l <> fromList @(Vector _) l')--  it "unsnoc bad" $ unsnocProp (replicate 65 0) 1--  prop "unsnoc" unsnocProp--  prop "snoc unsnoc" snocUnsnocProp--  describe "indexed" $ do-    prop "imap" $ \(l :: [Int]) ->-      zip [0 :: Int ..] l === toList (Vector.imap (,) (fromList @(Vector _) l))--propUpdate :: Int -> Int -> [Int] -> Property-propUpdate ix a l =-  ix >= 0 ==> do-    let arr = fromList @(Array _) l-        arr'-          | ix >= sizeofSmallArray arr = arr-          | otherwise = updateSmallArray arr ix a-    toList arr' === toList (Vector.update ix a $ fromList @(Vector _) l)--fmapProp :: [Int] -> Property-fmapProp l = do-  let vec = fmap (+ 20) (fromList @(Vector _) l)-      res = toList vec-  map (+ 20) l === res--snocUnsnocProp :: Int -> Bool-snocUnsnocProp times = do-  Vector.null-    . unsnocTimes-    . snocTimes-    . unsnocTimes-    . snocTimes-    $ Vector.empty-  where-    snocTimes vec = foldl' Vector.snoc vec [1 .. times]-    unsnocTimes vec = foldl' (\vec _ -> unsnoc' vec) vec [1 .. times]--unsnocProp :: [Int] -> Int -> Property-unsnocProp l i = do-  let l' = reverse $ drop i $ reverse l-      vec = fromList @(Vector _) l-      vec' =-        foldl'-          ( \vec _ -> case Vector.unsnoc vec of-              Nothing -> Vector.empty-              Just (vec, _) -> vec-          )-          vec-          [1 .. i]-  l' === toList vec'--unsnoc' :: Vector a -> Vector a-unsnoc' vec = case Vector.unsnoc vec of-  Just (vec, _) -> vec-  _ -> error "empty vector"--indexProp :: Int -> [Int] -> Property-indexProp ix l = do-  let indexMaybeList :: [a] -> Int -> Maybe a-      indexMaybeList xs n-        | n < 0 = Nothing-        -- Definition adapted from GHC.List-        | otherwise =-            foldr-              ( \x r k -> case k of-                  0 -> Just x-                  _ -> r (k - 1)-              )-              (const Nothing)-              xs-              n-      vec = fromList @(Vector _) l-  indexMaybeList l ix === Vector.lookup ix vec

@@ -0,0 +1,91 @@+{-# LANGUAGE TemplateHaskell #-}++module Properties where++import Arbitrary ()+import Data.Bifunctor (first)+import Data.Foldable (toList)+import Data.Proxy (Proxy (..))+import qualified Data.Sequence as Seq+import Data.Vector.Persistent (Vector)+import qualified Data.Vector.Persistent as PVec+import Test.QuickCheck+import Test.QuickCheck.Classes.Base+import Test.Tasty+import Test.Tasty.QuickCheck++prop_toList_fromList_identity :: [Int] -> Property+prop_toList_fromList_identity l = l === PVec.toList (PVec.fromList l)++prop_fmap :: Fun Int Int -> [Int] -> Property+prop_fmap (applyFun -> f) l = map f l === PVec.toList (fmap f (PVec.fromList l))++prop_update :: NonNegative Int -> Int -> [Int] -> Property+prop_update (NonNegative ix) a l =+  toList (Seq.update ix a $ Seq.fromList l)+    === toList (PVec.update ix a $ PVec.fromList l)++prop_adjust :: Fun Int Int -> NonNegative Int -> [Int] -> Property+prop_adjust (applyFun -> f) (NonNegative i) l =+  toList (Seq.adjust f i $ Seq.fromList l)+    === PVec.toList (PVec.adjust f i $ PVec.fromList l)++prop_foldr :: [Int] -> Property+prop_foldr l = foldr (:) [] l === foldr (:) [] (PVec.fromList l)++prop_foldl :: [Int] -> Property+prop_foldl l = foldl (flip (:)) [] l === foldl (flip (:)) [] (PVec.fromList l)++prop_traverse :: [Int] -> Property+prop_traverse l = do+  let go a = ([a], a)+  fmap toList (traverse go (PVec.fromList l)) === traverse go l++prop_index :: NonNegative Int -> [Int] -> Property+prop_index (NonNegative i) l = Seq.lookup i (Seq.fromList l) === PVec.lookup i (PVec.fromList l)++prop_mappend :: [Int] -> [Int] -> Property+prop_mappend l1 l2 = PVec.toList (PVec.fromList l1 <> PVec.fromList l2) === l1 <> l2++prop_snoc :: [Int] -> Int -> Property+prop_snoc l a = PVec.toList (PVec.fromList l `PVec.snoc` a) === l ++ [a]++unsnoc :: [a] -> Maybe ([a], a)+unsnoc [] = Nothing+unsnoc (a : as) = case unsnoc as of+  Nothing -> Just ([], a)+  Just (as', a') -> Just (a : as', a')++prop_unsnoc :: [Int] -> Property+prop_unsnoc l = unsnoc l === fmap (first PVec.toList) (PVec.unsnoc (PVec.fromList l))++$(return [])++tests :: TestTree+tests =+  testGroup+    "Properties"+    [ testProperties "PersistentVector" $allProperties,+      testGroup "Laws" $ testLaws <$> laws+    ]+  where+    laws =+      [ eqLaws p,+        ordLaws p,+        isListLaws p,+        semigroupLaws p,+        monoidLaws p,+        showLaws p,+        functorLaws p',+        applicativeLaws p',+        monadLaws p',+        foldableLaws p',+        traversableLaws p',+        alternativeLaws p',+        monadPlusLaws p'+      ]+    p = Proxy @(Vector Int)+    p' = Proxy @Vector++testLaws :: Laws -> TestTree+testLaws (Laws name pairs) = testGroup name (map (uncurry testProperty) pairs)

@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}