persistent-vector 0.1.1 → 0.2.0
raw patch · 6 files changed
+573/−502 lines, 6 filesdep +semigroupsdep +transformersdep ~QuickCheckdep ~criteriondep ~deepseq
Dependencies added: semigroups, transformers
Dependency ranges changed: QuickCheck, criterion, deepseq, test-framework, test-framework-quickcheck2
Files
- ChangeLog.md +18/−0
- persistent-vector.cabal +15/−11
- src/Data/Vector/Persistent.hs +383/−376
- src/Data/Vector/Persistent/Array.hs +83/−36
- src/Data/Vector/Persistent/Unsafe.hs +0/−28
- tests/pvTests.hs +74/−51
+ ChangeLog.md view
@@ -0,0 +1,18 @@+# v0.2.0++- Fix the slicing/take/drop operations++ The operations now have worse performance (linear), but are at least correct. They will be replaced by more efficient implementations in later version.++- Implement additional fold variants (David Feuer @treeowl)+- Improve the representation of the `Vector (David Feuer @treeowl)++ It is now more compact and unboxes better. This removes some "impossible" cases from the code.++- Strictness fixes (David Feuer @treeowl)++ Includes making `snoc` more strict, which should improve performance.++- Fix the traversal order in `traverse`++ Before, the tail was traversed in the wrong order.
persistent-vector.cabal view
@@ -1,16 +1,17 @@ name: persistent-vector-version: 0.1.1+version: 0.2.0 synopsis: A persistent sequence based on array mapped tries license: BSD3 license-file: LICENSE author: Tristan Ravitch-maintainer: tristan@nochair.net+maintainer: tristan@ravit.ch category: Data build-type: Simple cabal-version: >=1.10-extra-source-files: README.md+extra-source-files: README.md, ChangeLog.md homepage: https://github.com/travitch/persistent-vector bug-reports: https://github.com/travitch/persistent-vector/issues+tested-with: GHC == 7.10.2, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.2 description: This package provides persistent vectors based on array mapped@@ -39,11 +40,15 @@ default-language: Haskell2010 exposed-modules: Data.Vector.Persistent other-modules: Data.Vector.Persistent.Array- Data.Vector.Persistent.Unsafe- build-depends: base ==4.*, deepseq+ build-depends: base ==4.*,+ deepseq >= 1 && < 1.5,+ transformers >= 0.3 && < 0.6+ if !impl(ghc >= 8.0)+ build-depends: semigroups == 0.18.* hs-source-dirs: src ghc-options: -Wall- ghc-prof-options: -auto-all+ if impl(ghc >= 8.0)+ ghc-options: -Wcompat test-suite pvTests default-language: Haskell2010@@ -53,9 +58,9 @@ ghc-options: -Wall build-depends: persistent-vector, base == 4.*,- QuickCheck > 2.4,- test-framework,- test-framework-quickcheck2+ QuickCheck > 2.4 && < 2.15,+ test-framework >= 0.6 && < 0.9,+ test-framework-quickcheck2 >= 0.3 && < 0.4 benchmark pvBench default-language: Haskell2010@@ -63,11 +68,10 @@ hs-source-dirs: bench main-is: pvBench.hs ghc-options: -Wall -O2- ghc-prof-options: -auto-all build-depends: persistent-vector, base == 4.*, containers,- criterion >= 1 && < 1.2,+ criterion >= 1 && < 1.6, deepseq source-repository head
src/Data/Vector/Persistent.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE BangPatterns #-}+{- OPTIONS_GHC -Wall #-}+ -- | This is a port of the persistent vector from clojure to Haskell. -- It is spine-strict and lazy in the elements. --@@ -5,6 +10,10 @@ -- bounds given are mostly O(1), but only if you are willing to accept -- that the tree cannot have height greater than 7 on 32 bit systems -- and maybe 8 on 64 bit systems.+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{- options_ghc -ddump-simpl #-}+ module Data.Vector.Persistent ( Vector, -- * Construction@@ -12,569 +21,567 @@ singleton, snoc, fromList,+ append, -- * Queries null, length, -- * Indexing index, unsafeIndex,+ unsafeIndexA,+ unsafeIndex#, take, drop, splitAt,- -- * Slicing slice,+ -- ** Slicing Storage Management shrink, -- * Modification update, (//), -- * Folds foldr,+ foldr',+ foldl, foldl', -- * Transformations map, reverse, -- * Searches- filter,- partition, takeWhile,- dropWhile+ dropWhile,+ filter,+ partition ) where -import Prelude hiding ( null, length, tail, take,- drop, map, foldr, reverse,- splitAt, filter, takeWhile, dropWhile- )+import Prelude hiding+ ( null, length, tail, take+ , drop, map, foldr, foldl+ , reverse, splitAt, filter+ , takeWhile, dropWhile ) import qualified Control.Applicative as Ap import Control.DeepSeq-import Data.Bits+import Data.Bits hiding (shiftR, shiftL) import qualified Data.Foldable as F import qualified Data.List as L-import qualified Data.Monoid as M+import Data.Semigroup as Sem import qualified Data.Traversable as T+import Control.Applicative.Backwards import Data.Vector.Persistent.Array ( Array ) import qualified Data.Vector.Persistent.Array as A+#if !MIN_VERSION_base(4,8,0)+import Data.Word (Word)+#endif -- Note: using Int here doesn't give the full range of 32 bits on a 32 -- bit machine (it is fine on 64) -- | Persistent vectors based on array mapped tries-data Vector a = EmptyVector- | RootNode { vecSize :: {-# UNPACK #-} !Int- , vecShift :: {-# UNPACK #-} !Int- , vecOffset :: {-# UNPACK #-} !Int- , vecCapacity :: {-# UNPACK #-} !Int- , vecTail :: ![a]- , intVecPtrs :: {-# UNPACK #-} !(Array (Vector a))- }- | InternalNode { intVecPtrs :: {-# UNPACK #-} !(Array (Vector a))- }- | DataNode { dataVec :: {-# UNPACK #-} !(Array a)- }- deriving (Show)+data Vector a+ = RootNode+ { vecSize :: !Int+ , vecShift :: !Int+ , vecTail :: ![a]+ , intVecPtrs :: !(Array (Vector_ a))+ }+ deriving Show -instance (Eq a) => Eq (Vector a) where+data Vector_ a+ = InternalNode+ { intVecPtrs_ :: !(Array (Vector_ a))+ }+ | DataNode+ { dataVec :: !(Array a)+ }+ deriving Show++instance Eq a => Eq (Vector a) where (==) = pvEq -instance (Ord a) => Ord (Vector a) where+instance Eq a => Eq (Vector_ a) where+ (==) = pvEq_++instance Ord a => Ord (Vector a) where compare = pvCompare +instance Ord a => Ord (Vector_ a) where+ compare = pvCompare_+ instance F.Foldable Vector where+ foldMap = T.foldMapDefault foldr = foldr+ foldl = foldl+#if MIN_VERSION_base(4,6,0)+ foldr' = foldr'+ foldl' = foldl'+#endif+#if MIN_VERSION_base(4,8,0)+ length = length+ null = null+#endif instance Functor Vector where fmap = map -instance M.Monoid (Vector a) where+instance Sem.Semigroup (Vector a) where+ (<>) = append++instance Monoid (Vector a) where mempty = empty- mappend = append+ -- Defined for compatibility with ghc 8.2+ mappend = (<>) instance T.Traversable Vector where traverse = pvTraverse -instance (NFData a) => NFData (Vector a) where+instance NFData a => NFData (Vector a) where rnf = pvRnf -{-# INLINABLE pvEq #-}--- | A dispatcher between various equality tests. The length check is--- extremely cheap. There is another optimized check for the case--- where neither input is sliced. For sliced inputs, we currently--- fall back to a list conversion.-pvEq :: (Eq a) => Vector a -> Vector a -> Bool-pvEq EmptyVector EmptyVector = True-pvEq v1@RootNode { } v2@RootNode { }- | length v1 /= length v2 = False- | isNotSliced v1 && isNotSliced v2 = pvSimpleEq v1 v2- | otherwise = F.toList v1 == F.toList v2-pvEq (DataNode a1) (DataNode a2) = a1 == a2-pvEq (InternalNode a1) (InternalNode a2) = a1 == a2-pvEq _ _ = False+instance NFData a => NFData (Vector_ a) where+ rnf = pvRnf_ --- | A simple equality implementation for unsliced vectors. This can--- proceed structurally.-pvSimpleEq :: (Eq a) => Vector a -> Vector a -> Bool-pvSimpleEq EmptyVector EmptyVector = True-pvSimpleEq (RootNode sz1 sh1 _ _ t1 v1) (RootNode sz2 sh2 _ _ t2 v2) =- sz1 == sz2 && sh1 == sh2 && t1 == t2 && v1 == v2-pvSimpleEq (DataNode a1) (DataNode a2) = a1 == a2-pvSimpleEq (InternalNode a1) (InternalNode a2) = a1 == a2-pvSimpleEq _ _ = False+shiftR :: Int -> Int -> Int+{-# INLINE shiftR #-}+shiftR = unsafeShiftR -{-# INLINABLE pvCompare #-}--- | A dispatcher for comparison tests-pvCompare :: (Ord a) => Vector a -> Vector a -> Ordering-pvCompare EmptyVector EmptyVector = EQ-pvCompare (DataNode a1) (DataNode a2) = compare a1 a2-pvCompare (InternalNode a1) (InternalNode a2) = compare a1 a2-pvCompare v1@RootNode { vecSize = s1 } v2@RootNode { vecSize = s2 }- | s1 /= s2 = compare s1 s2- | isNotSliced v1 && isNotSliced v2 = pvSimpleCompare v1 v2- | otherwise = compare (F.toList v1) (F.toList v2)-pvCompare EmptyVector _ = LT-pvCompare _ EmptyVector = GT-pvCompare (DataNode _) (InternalNode _) = LT-pvCompare (InternalNode _) (DataNode _) = GT-pvCompare _ _ = error "Data.Vector.Persistent: unexpected root node"+shiftL :: Int -> Int -> Int+{-# INLINE shiftL #-}+shiftL = unsafeShiftL +{-# INLINABLE pvEq #-}+pvEq :: Eq a => Vector a -> Vector a -> Bool+pvEq (RootNode sz1 sh1 t1 v1) (RootNode sz2 sh2 t2 v2) =+ sz1 == sz2 && (sz1 == 0 || (sh1 == sh2 && t1 == t2 && v1 == v2)) +{-# INLINABLE pvEq_ #-}+pvEq_ :: Eq a => Vector_ a -> Vector_ a -> Bool+pvEq_ (DataNode a1) (DataNode a2) = a1 == a2+pvEq_ (InternalNode a1) (InternalNode a2) = a1 == a2+pvEq_ _ _ = False -pvSimpleCompare :: (Ord a) => Vector a -> Vector a -> Ordering-pvSimpleCompare EmptyVector EmptyVector = EQ-pvSimpleCompare (RootNode _ _ _ _ t1 v1) (RootNode _ _ _ _ t2 v2) =- case compare v1 v2 of- EQ -> compare t1 t2- o -> o-pvSimpleCompare (DataNode a1) (DataNode a2) = compare a1 a2-pvSimpleCompare (InternalNode a1) (InternalNode a2) = compare a1 a2-pvSimpleCompare EmptyVector _ = LT-pvSimpleCompare _ EmptyVector = GT-pvSimpleCompare (InternalNode _) (DataNode _) = GT-pvSimpleCompare (DataNode _) (InternalNode _) = LT-pvSimpleCompare _ _ = error "Data.Vector.Persistent.pvSimpleCompare: Unexpected mismatch"+{-# INLINABLE pvCompare #-}+pvCompare :: Ord a => Vector a -> Vector a -> Ordering+pvCompare (RootNode sz1 _ t1 v1) (RootNode sz2 _ t2 v2) =+ compare sz1 sz2 <> if sz1 == 0 then EQ else compare v1 v2 <> compare t1 t2 +{-# INLINABLE pvCompare_ #-}+pvCompare_ :: Ord a => Vector_ a -> Vector_ a -> Ordering+pvCompare_ (DataNode a1) (DataNode a2) = compare a1 a2+pvCompare_ (InternalNode a1) (InternalNode a2) = compare a1 a2+pvCompare_ (DataNode _) (InternalNode _) = LT+pvCompare_ (InternalNode _) (DataNode _) = GT + {-# INLINABLE map #-}--- | O(n) Map over the vector+-- | \( O(n) \) Map over the vector map :: (a -> b) -> Vector a -> Vector b map f = go where- go EmptyVector = EmptyVector- go (DataNode v) = DataNode (A.map f v)- go (InternalNode v) = InternalNode (A.map (fmap f) v)- go (RootNode sz sh off cap t v) =+ go (RootNode sz sh t v) = let t' = L.map f t- v' = A.map (fmap f) v- in RootNode sz sh off cap t' v'+ v' = A.map go_ v+ in RootNode sz sh t' v' --- | A more strict 3 tuple for the folds-data FoldInfo a = FI a !Int !Int+ go_ (DataNode v) = DataNode (A.map f v)+ go_ (InternalNode v) = InternalNode (A.map go_ v) -{-# INLINABLE foldr #-}--- | O(n) Right fold over the vector+{-# INLINE foldr #-}+-- | \( O(n) \) Right fold over the vector foldr :: (a -> b -> b) -> b -> Vector a -> b-foldr _ s0 EmptyVector = s0-foldr f s0 v- | isNotSliced v = sgo v s0- | otherwise =- case go v (FI s0 (max 0 (vecCapacity v - vecSize v)) (length v)) of (FI r _ _) -> r+foldr f = go where- go EmptyVector seed = seed- go (DataNode a) s@(FI seed nskip len)- | len <= 0 = s- | nskip == 0 = FI (A.boundedFoldr f (32 - len) 32 seed a) 0 (len - A.length a)- | nskip >= 32 = FI seed (nskip - 32) len- | otherwise =- let end = min (max 0 (32 - nskip)) 32- start = 32 - (len + nskip)- taken = end - max 0 start- in FI (A.boundedFoldr f start end seed a) 0 (len - taken)- go (InternalNode as) seed =- A.foldr go seed as- -- Note: if there is a tail at all, the elements are live (slice- -- drops unused tail elements)- go (RootNode _ _ _ _ t as) (FI s nskip l) =- let tseed = L.foldl' (flip f) s t- seed = FI tseed nskip (l - L.length t)- in A.foldr go seed as-- -- A simpler variant for unsliced vectors (the common case) that is- -- significantly more efficient- sgo EmptyVector seed = seed- sgo (DataNode a) seed = A.foldr f seed a- sgo (InternalNode as) seed = A.foldr sgo seed as- sgo (RootNode _ _ _ _ t as) seed =- let tseed = L.foldl' (flip f) seed t- in A.foldr sgo tseed as+ go seed (RootNode _ _ t as) = {-# SCC "gorRootNode" #-}+ let tseed = F.foldr f seed (L.reverse t)+ in A.foldr go_ tseed as+ go_ (DataNode a) seed = {-# SCC "gorDataNode" #-} A.foldr f seed a+ go_ (InternalNode as) seed = {-# SCC "gorInternalNode" #-}+ A.foldr go_ seed as -{-# INLINABLE foldl' #-}--- | O(n) Strict left fold over the vector-foldl' :: (b -> a -> b) -> b -> Vector a -> b-foldl' _ s0 EmptyVector = s0-foldl' f s0 v- | isNotSliced v = sgo s0 v- | otherwise =- case go (FI s0 (vecOffset v) (length v)) v of (FI r _ _) -> r+-- | \( O(n) \) Strict right fold over the vector.+--+-- Note: Strict in the initial accumulator value.+foldr' :: (a -> b -> b) -> b -> Vector a -> b+{-# INLINE foldr' #-}+foldr' f = go where- go seed EmptyVector = seed- go s@(FI seed nskip len) (DataNode a)- | len <= 0 = s- | nskip == 0 = FI (A.boundedFoldl' f 0 (min len 32) seed a) 0 (len - A.length a)- | nskip >= 32 = FI seed (nskip - 32) len- | otherwise =- let end = min 32 (len + nskip)- start = nskip- taken = end - max 0 start- in FI (A.boundedFoldl' f start end seed a) 0 (len - taken)- go seed (InternalNode as) =- A.foldl' go seed as- go (FI s nskip l) (RootNode _ _ _ _ t as) =- let FI rseed _ _ = A.foldl' go (FI s nskip (l - L.length t)) as- in FI (L.foldr (flip f) rseed t) 0 0+ go !seed (RootNode _ _ t as) = {-# SCC "gorRootNode" #-}+ let !tseed = F.foldl' (flip f) seed t+ in A.foldr' go_ tseed as+ go_ (DataNode a) !seed = {-# SCC "gorDataNode" #-} A.foldr' f seed a+ go_ (InternalNode as) !seed = {-# SCC "gorInternalNode" #-}+ A.foldr' go_ seed as - sgo seed EmptyVector = seed- sgo seed (DataNode a) = A.foldl' f seed a- sgo seed (InternalNode as) =- A.foldl' sgo seed as- sgo seed (RootNode _ _ _ _ t as) =- let rseed = A.foldl' sgo seed as+-- | \( O(n) \) Left fold over the vector.+foldl :: (b -> a -> b) -> b -> Vector a -> b+{-# INLINE foldl #-}+foldl f = go+ where+ go seed (RootNode _ _ t as) =+ let rseed = A.foldl go_ seed as in F.foldr (flip f) rseed t -{-# INLINABLE pvTraverse #-}-pvTraverse :: (Ap.Applicative f) => (a -> f b) -> Vector a -> f (Vector b)+ go_ seed (DataNode a) = {-# SCC "golDataNode" #-} A.foldl f seed a+ go_ seed (InternalNode as) =+ A.foldl go_ seed as++-- | \( O(n) \) Strict left fold over the vector.+--+-- Note: Strict in the initial accumulator value.+foldl' :: (b -> a -> b) -> b -> Vector a -> b+{-# INLINE foldl' #-}+foldl' f = go+ where+ go !seed (RootNode _ _ t as) =+ let !rseed = A.foldl' go_ seed as+ in F.foldl' f rseed (L.reverse t)+ go_ !seed (DataNode a) = {-# SCC "golDataNode" #-} A.foldl' f seed a+ go_ !seed (InternalNode as) =+ A.foldl' go_ seed as++{-# INLINE pvTraverse #-}+pvTraverse :: Ap.Applicative f => (a -> f b) -> Vector a -> f (Vector b) pvTraverse f = go where- go EmptyVector = Ap.pure EmptyVector- go (DataNode a) = DataNode Ap.<$> A.traverseArray f a- go (InternalNode as) = InternalNode Ap.<$> A.traverseArray go as- go (RootNode sz sh off cap t as) =- RootNode sz sh off cap Ap.<$> T.traverse f t Ap.<*> A.traverseArray go as+ go (RootNode sz sh t as)+ | sz == 0 = Ap.pure empty+ | otherwise = Ap.liftA2 (\as' t' -> RootNode sz sh t' as') (A.traverseArray go_ as) (forwards $ T.traverse (Backwards . f) t)+ go_ (DataNode a) = DataNode Ap.<$> A.traverseArray f a+ go_ (InternalNode as) = InternalNode Ap.<$> A.traverseArray go_ as -{-# INLINABLE append #-}+-- | \( O(m) \) Append two 'Vector' instances+--+-- > append v1 v2+--+-- This operation is linear in the length of @v2@ (where @length v1 == n@ and @length v2 == m@). append :: Vector a -> Vector a -> Vector a-append EmptyVector v = v-append v EmptyVector = v-append v1 v2 = foldl' snoc v1 v2+append v1 v2+ | null v1 = v2+ | null v2 = v1+append v1 v2 = F.foldl' snoc v1 v2 {-# INLINABLE pvRnf #-}-pvRnf :: (NFData a) => Vector a -> ()-pvRnf = F.foldr deepseq ()+pvRnf :: NFData a => Vector a -> ()+pvRnf (RootNode _ _ t as) = rnf as `seq` rnf t --- | O(1) The empty vector+{-# INLINABLE pvRnf_ #-}+pvRnf_ :: NFData a => Vector_ a -> ()+pvRnf_ (DataNode a) = rnf a+pvRnf_ (InternalNode a) = rnf a++-- | \( O(1) \) The empty vector. empty :: Vector a-empty = EmptyVector+empty = RootNode 0 5 [] A.empty --- | O(1) Test to see if the vector is empty.+-- | \( O(1) \) Test to see if the vector is empty. null :: Vector a -> Bool-null EmptyVector = True-null _ = False+null xs = length xs == 0 --- | O(1) Get the length of the vector.+-- | \( O(1) \) Get the length of the vector. length :: Vector a -> Int-length EmptyVector = 0-length RootNode { vecSize = s, vecOffset = off } = s - off-length InternalNode {} = error "Data.Vector.Persistent.length: Internal nodes should not be exposed"-length DataNode {} = error "Data.Vector.Persistent.length: Data nodes should not be exposed"+length RootNode { vecSize = s } = s --- | O(1) Bounds-checked indexing into a vector.+-- | \( O(1) \) Bounds-checked indexing into a vector. index :: Vector a -> Int -> Maybe a index v ix- | length v > ix = Just $ unsafeIndex v ix+ -- Check if the index is valid. This funny business uses a single test to+ -- determine whether ix is too small (negative) or too large (at least the+ -- length of the vector).+ | (fromIntegral ix :: Word) < fromIntegral (length v)+ = unsafeIndexA v ix | otherwise = Nothing --- | O(1) Unchecked indexing into a vector.+-- Index into a list from the rear. ----- Note that out-of-bounds indexing might not even crash - it will+-- revIx# [1..3] 0 = (# 3 #)+-- revIx# [1..3] 1 = (# 2 #)+-- revIx# [1..3] 2 = (# 1 #)+--+-- This is the same as reversing the list and then indexing+-- into it, but it doesn't need to allocate a reversed copy+-- of the list.+--+-- TODO: produce an error if the index is too large, instead of+-- just giving a wrong answer. This just requires a custom+-- version of `drop`.+revIx# :: [a] -> Int -> (# a #)+revIx# xs i = go xs (L.drop (i + 1) xs)+ where+ go :: [a] -> [b] -> (# a #)+ go (a : _) [] = (# a #)+ go (_ : as) (_ : bs) = go as bs+ go _ _ = error "revIx#: Whoopsy!"++-- | \( O(1) \) Unchecked indexing into a vector.+--+-- Out-of-bounds indexing might not even crash—it will -- usually just return nonsense values.+--+-- Note: the actual lookup is not performed until the result is forced.+-- This can cause a memory leak if the result of indexing is stored, unforced,+-- after the rest of the vector becomes garbage. To avoid this, use+-- 'unsafeIndexA' or 'unsafeIndex#' instead. unsafeIndex :: Vector a -> Int -> a-unsafeIndex vec userIndex- | ix >= tailOffset vec && vecCapacity vec < vecSize vec =- L.reverse (vecTail vec) !! (ix .&. 0x1f)+unsafeIndex vec ix+ | (# a #) <- unsafeIndex# vec ix+ = a++-- | \( O(1) \) Unchecked indexing into a vector in the context of an arbitrary+-- 'Ap.Applicative' functor. If the 'Ap.Applicative' is "strict" (such as 'IO',+-- (strict) @ST s@, (strict) @StateT@, or 'Maybe', but not @Identity@,+-- @ReaderT@, etc.), then the lookup is performed before the next action. This+-- avoids space leaks that can result from lazy uses of 'unsafeIndex'. See the+-- documentation for 'unsafeIndex#' for a custom 'Ap.Applicative' that can be+-- especially useful in conjunction with this function.+--+-- Note that out-of-bounds indexing might not even crash—it will usually just+-- return nonsense values.+unsafeIndexA :: Ap.Applicative f => Vector a -> Int -> f a+{-# INLINABLE unsafeIndexA #-}+unsafeIndexA vec ix+ | (# a #) <- unsafeIndex# vec ix+ = Ap.pure a++-- | \( O(1) \) Unchecked indexing into a vector.+--+-- Note that out-of-bounds indexing might not even crash—it will+-- usually just return nonsense values.+--+-- This function exists mostly because there is not, as yet, a well-known,+-- canonical, and convenient /lifted/ unary tuple. So we instead offer an+-- eager indexing function returning an /unlifted/ unary tuple. Users who+-- prefer to avoid such "low-level" features can do something like this:+--+-- @+-- data Solo a = Solo a deriving Functor+-- instance Applicative Solo where+-- pure = Solo+-- liftA2 f (Solo a) (Solo b) = Solo (f a b)+-- @+--+-- Now+--+-- @+-- unsafeIndexA :: Vector a -> Int -> Solo a+-- @+unsafeIndex# :: Vector a -> Int -> (# a #)+unsafeIndex# vec ix+ | ix >= tailOffset vec =+ (vecTail vec) `revIx#` (ix .&. 0x1f) | otherwise = let sh = vecShift vec in go (sh - 5) (A.index (intVecPtrs vec) (ix `shiftR` sh)) where- -- The user is indexing from zero but there could be some masked- -- portion of the vector due to the offset - we have to correct to- -- an internal offset- ix = vecOffset vec + userIndex go level v- | level == 0 = A.index (dataVec v) (ix .&. 0x1f)+ | level == 0 = A.index# (dataVec v) (ix .&. 0x1f) | otherwise = let nextVecIx = (ix `shiftR` level) .&. 0x1f- v' = intVecPtrs v+ v' = intVecPtrs_ v in go (level - 5) (A.index v' nextVecIx) --- | O(1) Construct a vector with a single element.+-- | \( O(1) \) Construct a vector with a single element. singleton :: a -> Vector a singleton elt = RootNode { vecSize = 1 , vecShift = 5- , vecOffset = 0- , vecCapacity = 0 , vecTail = [elt]- , intVecPtrs = A.fromList 0 []+ , intVecPtrs = A.empty } -- | A helper to copy an array and add an element to the end. arraySnoc :: Array a -> a -> Array a-arraySnoc a elt = A.run $ do+arraySnoc !a elt = A.run $ do let alen = A.length a a' <- A.new_ (1 + alen) A.copy a 0 a' 0 alen A.write a' alen elt return a' --- | O(1) Append an element to the end of the vector.+-- | \( O(1) \) Append an element to the end of the vector. snoc :: Vector a -> a -> Vector a-snoc EmptyVector elt = singleton elt-snoc v@RootNode { vecSize = sz, vecShift = sh, vecOffset = off, vecTail = t } elt- -- In this case, we are operating on a slice that has free space at- -- the end inside of its tree. Use 'update' to replace the formerly- -- unreachable element and then make it reachable.- | vecCapacity v >= sz =- let v' = v { vecSize = sz + 1 }- in update (sz - off) elt v'+-- We break this up into two pieces. We let the common case inline:+-- that is the case of a nonempty vector with room in its tail.+-- The case of an empty vector isn't common enough to bother inlining,+-- and the case of a full tail is expensive anyway, so there's nothing+-- to be gained by inlining. The remaining question: do we actually+-- benefit from letting *any* of this inline? To be determined, but my+-- guess is a strong maybe.+snoc v@RootNode { vecSize = sz, vecTail = t } elt+ -- Room in tail, and vector non-empty | sz .&. 0x1f /= 0 = v { vecTail = elt : t, vecSize = sz + 1 }+ | otherwise = snocMain v elt++snocMain :: Vector a -> a -> Vector a+{-# NOINLINE snocMain #-}+snocMain v elt+ | null v = singleton elt+snocMain v@RootNode { vecSize = sz, vecShift = sh, vecTail = t } elt -- Overflow current root | sz `shiftR` 5 > 1 `shiftL` sh = RootNode { vecSize = sz + 1 , vecShift = sh + 5- , vecOffset = vecOffset v- , vecCapacity = vecCapacity v + 32 , vecTail = [elt]- , intVecPtrs = A.fromList 2 [ InternalNode (intVecPtrs v)- , newPath sh t- ]+ , intVecPtrs =+ let !np = newPath sh t+ in A.fromList 2 [ InternalNode (intVecPtrs v)+ , np+ ] } -- Insert into the tree | otherwise = RootNode { vecSize = sz + 1 , vecShift = sh- , vecOffset = vecOffset v- , vecCapacity = vecCapacity v + 32 , vecTail = [elt] , intVecPtrs = pushTail sz t sh (intVecPtrs v) }-snoc _ _ = error "Data.Vector.Persistent.snoc: Internal nodes should not be exposed to the user" -- | A recursive helper for 'snoc'. This finds the place to add new -- elements.-pushTail :: Int -> [a] -> Int -> Array (Vector a) -> Array (Vector a)-pushTail cnt t = go+pushTail :: Int -> [a] -> Int -> Array (Vector_ a) -> Array (Vector_ a)+pushTail !cnt t !foo !bar = go foo bar where- go level parent- | level == 5 = arraySnoc parent (DataNode (A.fromList 32 (L.reverse t)))+ go !level !parent+ | level == 5 = arraySnoc parent $! DataNode (A.fromListRev 32 t) | subIdx < A.length parent = let nextVec = A.index parent subIdx- toInsert = go (level - 5) (intVecPtrs nextVec)- in A.update parent subIdx (InternalNode toInsert)- | otherwise = arraySnoc parent (newPath (level - 5) t)+ toInsert = go (level - 5) (intVecPtrs_ nextVec)+ in A.update parent subIdx $! InternalNode toInsert+ | otherwise = arraySnoc parent $! newPath (level - 5) t where subIdx = ((cnt - 1) `shiftR` level) .&. 0x1f -- | The other recursive helper for 'snoc'. This one builds out a -- sub-tree to the current depth.-newPath :: Int -> [a] -> Vector a+newPath :: Int -> [a] -> Vector_ a newPath level t- | level == 0 = DataNode (A.fromList 32 (L.reverse t))- | otherwise = InternalNode $ A.fromList 1 $ [newPath (level - 5) t]+ | level == 0 = DataNode (A.fromListRev 32 t)+ | otherwise = InternalNode $ A.singleton $! newPath (level - 5) t --- | O(1) Update a single element at @ix@ with new value @elt@ in--- @v@.+-- | Update a single element at @ix@ with new value @elt@.+updateList :: Int -> a -> [a] -> [a]+-- We do this pretty strictly to avoid building up thunks in the tail+-- and to release the replaced value promptly.+updateList !_ _ [] = []+updateList 0 x (_ : ys) = x : ys+updateList n x (y : ys) = (y :) $! updateList (n - 1) x ys++-- | \( O(1) \) Update a single element at @ix@ with new value @elt@ in @v@. -- -- > update ix elt v update :: Int -> a -> Vector a -> Vector a-update ix elt = (// [(ix, elt)])---- | O(n) Bulk update.------ > v // updates------ For each (index, element) pair in @updates@, modify @v@ such that--- the @index@th position of @v@ is @element@.--- Indices in @updates@ that are not in @v@ are ignored-(//) :: Vector a -> [(Int, a)] -> Vector a-(//) = L.foldr replaceElement--replaceElement :: (Int, a) -> Vector a -> Vector a-replaceElement _ EmptyVector = EmptyVector-replaceElement (userIndex, elt) v@(RootNode { vecSize = sz, vecShift = sh, vecTail = t })- -- Invalid index- | sz <= ix || ix < 0 = v- -- Item is in tail,- | ix >= toff && vecCapacity v < sz =- case t of- -- The tail can only be empty if this was a slice where the last- -- array in the tree is full and the slice left no tail. This- -- is rare but we have to handle it.- [] -> v { vecTail = [elt] }- _ ->- let tix = sz - 1 - ix- (keepHead, _:keepTail) = L.splitAt tix t- in v { vecTail = keepHead ++ (elt : keepTail) }+update ix elt v@(RootNode { vecSize = sz, vecShift = sh, vecTail = t })+ -- Invalid index. This funny business uses a single test to determine whether+ -- ix is too small (negative) or too large (at least sz).+ | (fromIntegral ix :: Word) >= fromIntegral sz = v+ -- Item is in tail+ | ix >= tailOffset v =+ let tix = sz - 1 - ix+ in v { vecTail = updateList tix elt t} -- Otherwise the item to be replaced is in the tree | otherwise = v { intVecPtrs = go sh (intVecPtrs v) } where- ix = userIndex + vecOffset v- toff = tailOffset v go level vec -- At the data level, modify the vector and start propagating it up | level == 5 =- let dnode = DataNode $ A.update (dataVec vec') (ix .&. 0x1f) elt+ let !dnode = DataNode $ A.update (dataVec vec') (ix .&. 0x1f) elt in A.update vec vix dnode -- In the tree, find the appropriate sub-array, call -- recursively, and re-allocate current array | otherwise =- let rnode = go (level - 5) (intVecPtrs vec')+ let !rnode = go (level - 5) (intVecPtrs_ vec') in A.update vec vix (InternalNode rnode) where vix = (ix `shiftR` level) .&. 0x1f vec' = A.index vec vix-replaceElement _ _ = error "Data.Vector.Persistent.replaceElement: should not see internal nodes" --- | O(1) Return a slice of @v@ of length @length@ starting at index--- @start@. The returned vector may have fewer than @length@ elements--- if the bounds are off on either side (the start is negative or--- length takes it past the end).------ A slice of negative or zero length is the empty vector.+-- | \( O(n) \) Bulk update. ----- > slice start length v+-- > v // updates ----- Note that a slice retains all of the references that the vector it--- is derived from has. They are not reachable via any traversals and--- are not counted towards its size, but this may lead to references--- living longer than intended. If is important to you that this not--- happen, call 'shrink' on the return value of 'slice' to drop unused--- space and references.-slice :: Int -> Int -> Vector a -> Vector a-slice _ _ EmptyVector = EmptyVector-slice start userLen v@RootNode { vecSize = sz, vecOffset = off, vecCapacity = cap, vecTail = t }- | len <= 0 = EmptyVector- -- All the retained data is in the tail, so zero everything else out- | toff < start =- let t' = L.reverse $ L.take userLen $ L.drop (start - toff) $ L.reverse t- in v { vecOffset = 0- , vecCapacity = 0- , intVecPtrs = A.fromList 0 []- , vecSize = L.length t'- , vecTail = t'- }- -- Start was negative, so we really start at zero and retain at most- -- (len + start) elements. In this case vecOffset remains the same.- | start < 0 =- let eltsRetained = min (len + start) sz- in v { vecSize = eltsRetained- , vecTail = L.drop (sz - eltsRetained) t- }- -- If capacity < start, the tail needs to be modified from the front- -- in fact, max 0 (start - capacity) items need to be dropped from the- -- list- | otherwise =- let newOff = off + start- newSize = min (newOff + len) sz- ntake = max 0 (start - cap)- t' = L.drop (sz - newSize) t- in v { vecOffset = newOff- , vecSize = newSize- , vecTail = L.take (L.length t' - ntake) t'- }+-- For each @(index, element)@ pair in @updates@, modify @v@ such that+-- the @index@th position of @v@ is @element@.+-- Indices in @updates@ that are not in @v@ are ignored. The updates are+-- applied in order, so the last one at each index takes effegct.+(//) :: Vector a -> [(Int, a)] -> Vector a+-- Note: we fully apply foldl' to get everything to unbox.+(//) vec = L.foldl' replaceElement vec where- toff = tailOffset v- len = max 0 (min userLen (sz - start))-slice _ _ _ = error "Data.Vector.Persistent.slice: Internal node"---- Note that slice removes unneeded elements from the tail so that--- snoc can mostly work unchanged. snoc does need to change if the--- slice takes so many elements that parts of the tree contain--- inaccessible elements. In that case, just use update instead.---- | O(1) Take the first @i@ elements of the vector.------ Note that this is just a wrapper around slice and the resulting--- slice retains references that are inaccessible. Use 'shrink' if--- this is undesirable.-take :: Int -> Vector a -> Vector a-take = slice 0---- | O(1) Drop @i@ elements from the front of the vector.------ Note that this is just a wrapper around slice.-drop :: Int -> Vector a -> Vector a-drop i v = slice i (length v) v---- | O(1) Split the vector at the given position.-splitAt :: Int -> Vector a -> (Vector a, Vector a)-splitAt ix v = (take ix v, drop ix v)+ replaceElement v (ix, a) = update ix a v --- | O(n) Force a sliced vector to drop any unneeded space and--- references.+-- | The index of the first element of the tail of the vector (that is, the+-- *last* element of the list representing the tail). This is also the number+-- of elements stored in the array tree. ----- This is a no-op for an un-sliced vector.-shrink :: Vector a -> Vector a-shrink EmptyVector = EmptyVector-shrink v- | isNotSliced v = v- | otherwise = fromList $ F.toList v+-- Caution: Only gives a sensible result if the vector is nonempty.+tailOffset :: Vector a -> Int+tailOffset v = (length v - 1) .&. ((-1) `shiftL` 5) --- | O(n) Reverse a vector+-- | \( O(n) \) Reverse a vector reverse :: Vector a -> Vector a-reverse = fromList . foldl' (flip (:)) []+{-# NOINLINE reverse #-}+reverse = foldr' (flip snoc) empty --- | O(n) Filter according to the predicate+-- | \( O(n) \) Filter according to the predicate. filter :: (a -> Bool) -> Vector a -> Vector a-filter p = foldl' go empty+filter p = \ !vec -> foldl' go empty vec where- go acc e = if p e then snoc acc e else acc+ go !acc e = if p e then snoc acc e else acc --- | O(n) Return the elements that do and do not obey the predicate+-- | \( O(n) \) Return the elements that do and do not obey the predicate partition :: (a -> Bool) -> Vector a -> (Vector a, Vector a)-partition p = spToPair . foldl' go (SP empty empty)+partition p v0 = case F.foldl' go (TwoVec empty empty) v0 of+ TwoVec v1 v2 -> (v1, v2) where- go (SP atrue afalse) e =- if p e then SP (snoc atrue e) afalse else SP atrue (snoc afalse e)+ go (TwoVec atrue afalse) e =+ if p e then TwoVec (snoc atrue e) afalse else TwoVec atrue (snoc afalse e) --- | O(n) Construct a vector from a list.+data TwoVec a = TwoVec {-# UNPACK #-} !(Vector a) {-# UNPACK #-} !(Vector a)++-- | \( O(n) \) Construct a vector from a list fromList :: [a] -> Vector a fromList = F.foldl' snoc empty -data StrictPair a b = SP !a !b--spSnd :: StrictPair a b -> b-spSnd (SP _ v) = v+-- | \( O(n) \) Take @n@ elements starting from the start of the 'Vector'+take :: Int -> Vector a -> Vector a+take n v = fromList (L.take n (F.toList v)) -spToPair :: StrictPair a b -> (a, b)-spToPair (SP a b) = (a, b)+-- | \( O(n) \) Drop @n@ elements starting from the start of the 'Vector'+drop :: Int -> Vector a -> Vector a+drop n v = fromList (L.drop n (F.toList v)) --- | O(n) Apply a predicate @p@ to the vector, returning the longest--- prefix of elements that satisfy @p@.-takeWhile :: (a -> Bool) -> Vector a -> Vector a-takeWhile p = spSnd . foldl' f (SP True empty)- where- f (SP True v) e =- if p e then SP True (snoc v e)- else SP False v- f a _ = a+-- | \( O(n) \) Split the vector into two at the given index+--+-- Note that this function strictly computes both result vectors (once the tuple+-- itself is reduced to whnf)+splitAt :: Int -> Vector a -> (Vector a, Vector a)+splitAt idx v+ | (front_list, rear_list) <- L.splitAt idx (F.toList v)+ , !front <- fromList front_list+ , !rear <- fromList rear_list+ = (front, rear) --- | O(n) Returns the longest suffix after @takeWhile p v@.-dropWhile :: (a -> Bool) -> Vector a -> Vector a-dropWhile p = spSnd . foldl' f (SP True empty)- where- f a@(SP True v) e =- if p e then a- else SP False (snoc v e)- f (SP False v) e = SP False (snoc v e)+-- | \( O(n) \) Return a slice of @v@ of length @length@ starting at index+-- @start@. The returned vector may have fewer than @length@ elements+-- if the bounds are off on either side (the start is negative or+-- length takes it past the end).+--+-- A slice of negative or zero length is the empty vector.+--+-- > slice start length v+slice :: Int -> Int -> Vector a -> Vector a+slice start len v = fromList (L.take len (L.drop start (F.toList v))) --- Helpers+-- | \( O(1) \) Drop any unused space in the vector+--+-- NOTE: This is currently the identity+shrink :: Vector a -> Vector a+shrink = id -tailOffset :: Vector a -> Int-tailOffset EmptyVector = 0-tailOffset v- | len < 32 = 0- | otherwise = (len - 1) `shiftR` 5 `shiftL` 5- where- len = vecSize v+-- | \( O(n) \) Apply a predicate p to the vector, returning the longest prefix of elements that satisfy p.+takeWhile :: (a -> Bool) -> Vector a -> Vector a+takeWhile p = fromList . L.takeWhile p . F.toList -isNotSliced :: Vector a -> Bool-isNotSliced v = vecOffset v == 0 && vecCapacity v < vecSize v+-- | \( O(n) \) Returns the longest suffix after takeWhile p v.+dropWhile :: (a -> Bool) -> Vector a -> Vector a+dropWhile p = fromList . L.dropWhile p . F.toList
src/Data/Vector/Persistent/Array.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples #-}-{-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-}+{-# OPTIONS_GHC -funbox-strict-fields #-} -- | -- Module: Data.Vector.Persistent.Array -- Copyright: Johan Tibell <johan.tibell@gmail.com>@@ -15,6 +15,7 @@ -- * Creation , new , new_+ , empty , singleton , singleton' , pair@@ -25,6 +26,7 @@ , read , write , index+ , index# , index_ , indexM_ , update@@ -44,9 +46,11 @@ , copyM -- * Folds+ , foldl , foldl' , boundedFoldl' , foldr+ , foldr' , boundedFoldr , thaw@@ -55,19 +59,21 @@ , traverseArray , filter , fromList+ , fromListRev , toList ) where import qualified Data.Traversable as Traversable import qualified Control.Applicative as A import Control.DeepSeq-import Control.Monad.ST hiding (runST)+import Control.Monad.ST import qualified GHC.Exts as Ext import GHC.ST (ST(..))-import Prelude hiding (filter, foldr, length, map, read)-import qualified Prelude as P--import Data.Vector.Persistent.Unsafe (runST)+import Prelude hiding (filter, foldl, foldr, length, map, read)+import qualified Data.Foldable as F+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (mappend)+#endif ------------------------------------------------------------------------ @@ -79,11 +85,13 @@ # define CHECK_OP(_func_,_op_,_lhs_,_rhs_) \ if not ((_lhs_) _op_ (_rhs_)) then error ("Data.HashMap.Array." ++ (_func_) ++ ": Check failed: _lhs_ _op_ _rhs_ (" ++ show (_lhs_) ++ " vs. " ++ show (_rhs_) ++ ")") else # define CHECK_GT(_func_,_lhs_,_rhs_) CHECK_OP(_func_,>,_lhs_,_rhs_)+# define CHECK_GE(_func_,_lhs_,_rhs_) CHECK_OP(_func_,>=,_lhs_,_rhs_) # define CHECK_LE(_func_,_lhs_,_rhs_) CHECK_OP(_func_,<=,_lhs_,_rhs_) #else # define CHECK_BOUNDS(_func_,_len_,_k_) # define CHECK_OP(_func_,_op_,_lhs_,_rhs_) # define CHECK_GT(_func_,_lhs_,_rhs_)+# define CHECK_GE(_func_,_lhs_,_rhs_) # define CHECK_LE(_func_,_lhs_,_rhs_) #endif @@ -103,23 +111,15 @@ instance Ord a => Ord (Array a) where compare = arrayCompare -arrayEq :: (Eq a) => Array a -> Array a -> Bool-arrayEq a1 a2- | length a1 /= length a2 = False- | otherwise = P.foldr (\i a -> a && index a1 i == index a2 i) True [0..(length a1 - 1)]+arrayEq :: Eq a => Array a -> Array a -> Bool+{-# INLINABLE arrayEq #-}+arrayEq a1 a2 = length a1 == length a2 &&+ F.all (\i -> index a1 i == index a2 i) [0..(length a1 - 1)] -arrayCompare :: (Ord a) => Array a -> Array a -> Ordering-arrayCompare a1 a2- | length a1 < length a2 = LT- | length a1 > length a2 = GT- | otherwise = go EQ (length a1)- where- go GT _ = GT- go LT _ = LT- go EQ ix =- case ix < 0 of- True -> EQ- False -> go (compare (index a1 ix) (index a2 ix)) (ix - 1)+arrayCompare :: Ord a => Array a -> Array a -> Ordering+{-# INLINABLE arrayCompare #-}+arrayCompare a1 a2 = compare (length a1) (length a2) `mappend`+ F.foldMap (\i -> index a1 i `compare` index a2 i) [0..(length a1 - 1)] #if __GLASGOW_HASKELL__ >= 702 length :: Array a -> Int@@ -177,7 +177,7 @@ -- value. new :: Int -> a -> ST s (MArray s a) new n@(Ext.I# n#) b =- CHECK_GT("new",n,(0 :: Int))+ CHECK_GE("new",n,(0 :: Int)) ST $ \s -> case Ext.newArray# n# b s of (# s', ary #) -> (# s', marray ary n #)@@ -186,6 +186,13 @@ new_ :: Int -> ST s (MArray s a) new_ n = new n undefinedElem +-- The globally shared empty array. There's no point+-- allocating a new empty array every time we need one+-- when we can just follow a pointer to get one.+empty :: Array a+empty = runST (new_ 0 >>= unsafeFreeze)+{-# NOINLINE empty #-}+ singleton :: a -> Array a singleton x = runST (singleton' x) {-# INLINE singleton #-}@@ -220,6 +227,12 @@ case Ext.indexArray# (unArray ary) i# of (# b #) -> b {-# INLINE index #-} +index# :: Array a -> Int -> (# a #)+index# ary _i@(Ext.I# i#) =+ CHECK_BOUNDS("index", length ary, _i)+ Ext.indexArray# (unArray ary) i#+{-# INLINE index# #-}+ index_ :: Array a -> Int -> ST s a index_ ary _i@(Ext.I# i#) = CHECK_BOUNDS("index_", length ary, _i)@@ -350,38 +363,63 @@ return () {-# INLINE unsafeUpdate' #-} +-- | Note: strict in the initial accumulator value. foldl' :: (b -> a -> b) -> b -> Array a -> b-foldl' f z0 ary0 = go ary0 (length ary0) 0 z0+foldl' f !z0 !ary0 = go ary0 (length ary0) 0 z0 where- go ary n i !z+ go !ary n !i !z | i >= n = z- | otherwise = go ary n (i+1) (f z (index ary i))+ | (# x #) <- index# ary i+ = go ary n (i+1) (f z x) {-# INLINE foldl' #-} +foldl :: (b -> a -> b) -> b -> Array a -> b+foldl f z0 !ary0 = go ary0 (length ary0) z0+ where+ go !ary !i z+ | i == 0 = z+ | (# x #) <- index# ary (i - 1)+ = f (go ary (i-1) z) x+{-# INLINE foldl #-}+ boundedFoldl' :: (b -> a -> b) -> Int -> Int -> b -> Array a -> b-boundedFoldl' f start end z0 ary0 =+boundedFoldl' f !start !end z0 ary0 = go ary0 (min end (length ary0)) (max 0 start) z0 where go ary n i !z | i >= n = z- | otherwise = go ary n (i+1) (f z (index ary i))+ | (# x #) <- index# ary i+ = go ary n (i+1) (f z x) {-# INLINE boundedFoldl' #-} foldr :: (a -> b -> b) -> b -> Array a -> b-foldr f z0 ary0 = go ary0 (length ary0) 0 z0+foldr f z0 !ary0 = go ary0 (length ary0) 0 z0+-- foldr f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 where- go ary n i z+ go !ary !n !i z | i >= n = z- | otherwise = f (index ary i) (go ary n (i+1) z)+ | (# x #) <- index# ary i+ = f x (go ary n (i+1) z) {-# INLINE foldr #-} +-- | Note: Strict in the initial accumulator value.+foldr' :: (a -> b -> b) -> b -> Array a -> b+foldr' f !z0 !ary0 = go ary0 (length ary0) z0+ where+ go !ary !i !z+ | i == 0 = z+ | (# x #) <- index# ary (i - 1)+ = go ary (i-1) (f x z)+{-# INLINE foldr' #-}+ boundedFoldr :: (a -> b -> b) -> Int -> Int -> b -> Array a -> b-boundedFoldr f start end z0 ary0 =+boundedFoldr f !start !end z0 !ary0 = go ary0 (min end (length ary0)) (max 0 start) z0 where- go ary n i z+ go !ary !n !i z | i >= n = z- | otherwise = f (index ary i) (go ary n (i+1) z)+ | (# x #) <- index# ary i+ = f x (go ary n (i+1) z) {-# INLINE boundedFoldr #-} undefinedElem :: a@@ -455,8 +493,17 @@ go xs0 mary 0 where go [] !mary !_ = return mary- go (x:xs) mary i = do write mary i x- go xs mary (i+1)+ go (x:xs) !mary !i = do write mary i x+ go xs mary (i+1)++fromListRev :: Int -> [a] -> Array a+fromListRev n xs0 = run $ do+ mary <- new_ n+ go xs0 mary (n - 1)+ where+ go [] !mary !_ = return mary+ go (x:xs) !mary !i = do write mary i x+ go xs mary (i-1) toList :: Array a -> [a] toList = foldr (:) []
− src/Data/Vector/Persistent/Unsafe.hs
@@ -1,28 +0,0 @@-{-# LANGUAGE MagicHash, Rank2Types, UnboxedTuples #-}---- | This module exports a workaround for this bug:------ http://hackage.haskell.org/trac/ghc/ticket/5916------ Please read the comments in ghc/libraries/base/GHC/ST.lhs to--- understand what's going on here.------ Code that uses this module should be compiled with -fno-full-laziness-module Data.Vector.Persistent.Unsafe- ( runST- ) where--import GHC.Base (realWorld#)-import GHC.ST hiding (runST, runSTRep)---- | Return the value computed by a state transformer computation.--- The @forall@ ensures that the internal state used by the 'ST'--- computation is inaccessible to the rest of the program.-runST :: (forall s. ST s a) -> a-runST st = runSTRep (case st of { ST st_rep -> st_rep })-{-# INLINE runST #-}--runSTRep :: (forall s. STRep s a) -> a-runSTRep st_rep = case st_rep realWorld# of- (# _, r #) -> r-{-# INLINE [0] runSTRep #-}
tests/pvTests.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Main ( main ) where import Test.Framework ( defaultMain, Test )@@ -5,8 +6,12 @@ import Test.QuickCheck import qualified Data.Foldable as F-import Data.Monoid+import qualified Data.Monoid as DM import qualified Data.List as L+import qualified Control.Applicative as Ap+import qualified Data.Traversable as T++--import Data.Vector.Persistent ( Vector ) import qualified Data.Vector.Persistent as V newtype InputList = InputList [Int]@@ -14,57 +19,45 @@ instance Arbitrary InputList where arbitrary = sized inputList -data IndexableList = IndexableList [Int] Int- deriving (Show)--instance Arbitrary IndexableList where- arbitrary = sized indexableList--data SliceList = SliceList [Int] Int Int- deriving (Show)-instance Arbitrary SliceList where- arbitrary = sized sliceList+data SizedList = SizedList [Int] !Int+ deriving Show -sliceList :: Int -> Gen SliceList-sliceList sz = do- modifier <- choose (0, 100)- l <- vector (1 + (sz * modifier))- start <- choose (0, length l - 1)- len <- choose (0, 100)- return $ SliceList l start len+instance Arbitrary SizedList where+ arbitrary = sized sizedList -indexableList :: Int -> Gen IndexableList-indexableList sz = do- modifier <- choose (0, 100)- l <- vector (1 + (sz * modifier))- ix <- choose (0, length l - 1)- return $ IndexableList l ix+sizedList :: Int -> Gen SizedList+sizedList sz = do+ len <- chooseInt (0, sz)+ lst <- vector len+ return $ SizedList lst len inputList :: Int -> Gen InputList inputList sz = do- modifier <- choose (0, 100)- l <- vector (sz * modifier)- return $ InputList l+ len <- chooseInt (0, max 1 sz)+ InputList Ap.<$> vector len tests :: [Test] tests = [ testProperty "toListFromListIdent" prop_toListFromListIdentity , testProperty "fmap" prop_map , testProperty "foldrWorks" prop_foldrWorks , testProperty "foldlWorks" prop_foldlWorks+ , testProperty "traverseWorks" prop_traverseWorks , testProperty "updateWorks" prop_updateWorks , testProperty "indexingWorks" prop_indexingWorks- , testProperty "take" prop_take- , testProperty "drop" prop_drop- , testProperty "splitAt" prop_splitAt- , testProperty "slice" prop_slice- , testProperty "slicedFoldl'" prop_slicedFoldl'- , testProperty "slicedFoldr" prop_sliceFoldr , testProperty "mappendWorks" prop_mappendWorks+ , testProperty "eqWorksEqual" prop_eqWorks_equal+ , testProperty "eqWorks" prop_eqWorks , testProperty "shrink" prop_shrinkPreserves , testProperty "shrinkEq" prop_shrinkEquality , testProperty "appendAfterSlice" prop_appendAfterSlice , testProperty "takeWhile" prop_takeWhile , testProperty "dropWhile" prop_dropWhile+ , testProperty "take" prop_take+ , testProperty "drop" prop_drop+ , testProperty "splitAt" prop_splitAt+ , testProperty "slice" prop_slice+ , testProperty "slicedFoldl'" prop_slicedFoldl'+ , testProperty "slicedFoldr" prop_sliceFoldr ] main :: IO ()@@ -86,7 +79,7 @@ prop_foldlWorks :: InputList -> Bool prop_foldlWorks (InputList il) =- F.foldl' (flip (:)) [] il == V.foldl' (flip (:)) [] (V.fromList il)+ F.foldl (flip (:)) [] il == F.foldl (flip (:)) [] (V.fromList il) prop_updateWorks :: (InputList, Int, Int) -> Property prop_updateWorks (InputList il, ix, repl) =@@ -100,26 +93,60 @@ True -> il False -> keepHead ++ (repl : keepTail) -prop_indexingWorks :: IndexableList -> Bool-prop_indexingWorks (IndexableList il ix) =- (il !! ix) == (V.unsafeIndex (V.fromList il) ix)+prop_indexingWorks :: SizedList -> Bool+prop_indexingWorks (SizedList il sz) =+ il == [V.unsafeIndex vec ix | ix <- [0..sz - 1]]+ where+ vec = V.fromList il -prop_take :: IndexableList -> Bool-prop_take (IndexableList il ix) =+prop_mappendWorks :: (InputList, InputList) -> Bool+prop_mappendWorks (InputList il1, InputList il2) =+ (il1 `DM.mappend` il2) == F.toList (V.fromList il1 `DM.mappend` V.fromList il2)++prop_eqWorks_equal :: InputList -> Bool+prop_eqWorks_equal (InputList il) =+ V.fromList il == V.fromList il++prop_eqWorks :: InputList -> InputList -> Bool+prop_eqWorks (InputList il1) (InputList il2) =+ (V.fromList il1 == V.fromList il2) == (il1 == il2)++prop_traverseWorks :: InputList -> Bool+prop_traverseWorks (InputList il) =+ fmap F.toList (T.traverse go (V.fromList il)) == T.traverse go il+ where+ go a = ([a], a)++prop_take :: SizedList -> Bool+prop_take (SizedList il ix) = L.take ix il == F.toList (V.take ix (V.fromList il)) -prop_drop :: IndexableList -> Bool-prop_drop (IndexableList il ix) =+prop_drop :: SizedList -> Bool+prop_drop (SizedList il ix) = L.drop ix il == F.toList (V.drop ix (V.fromList il)) -prop_splitAt :: IndexableList -> Bool-prop_splitAt (IndexableList il ix) =+prop_splitAt :: SizedList -> Bool+prop_splitAt (SizedList il ix) = let (v1, v2) = V.splitAt ix (V.fromList il) in L.splitAt ix il == (F.toList v1, F.toList v2) listSlice :: Int -> Int -> [a] -> [a] listSlice s n = L.take n . (L.drop s) +data SliceList = SliceList [Int] !Int !Int+ deriving (Show)++instance Arbitrary SliceList where+ arbitrary = sized sliceList++sliceList :: Int -> Gen SliceList+sliceList sz = do+ modifier <- choose (0, 100)+ l <- vector (1 + (sz * modifier))+ start <- choose (0, length l - 1)+ len <- choose (0, 100)+ return $ SliceList l start len+ prop_slice :: SliceList -> Bool prop_slice (SliceList il s n) = listSlice s n il == F.toList (V.slice s n (V.fromList il))@@ -132,10 +159,6 @@ prop_slicedFoldl' (SliceList il s n) = L.foldl' (flip (:)) [] (listSlice s n il) == V.foldl' (flip (:)) [] (V.slice s n (V.fromList il)) -prop_mappendWorks :: (InputList, InputList) -> Bool-prop_mappendWorks (InputList il1, InputList il2) =- (il1 `mappend` il2) == F.toList (V.fromList il1 `mappend` V.fromList il2)- prop_shrinkPreserves :: SliceList -> Bool prop_shrinkPreserves (SliceList il s n) = F.toList v0 == F.toList (V.shrink v0)@@ -155,14 +178,14 @@ v0 = V.slice s n (V.fromList il) v1 = V.snoc v0 elt -prop_takeWhile :: IndexableList -> Bool-prop_takeWhile (IndexableList il ix) =+prop_takeWhile :: SizedList -> Bool+prop_takeWhile (SizedList il ix) = L.takeWhile (<ix) il == F.toList v where v = V.takeWhile (<ix) $ V.fromList il -prop_dropWhile :: IndexableList -> Bool-prop_dropWhile (IndexableList il ix) =+prop_dropWhile :: SizedList -> Bool+prop_dropWhile (SizedList il ix) = L.dropWhile (<ix) il == F.toList v where v = V.dropWhile (<ix) $ V.fromList il