packages feed

persistent-vector (empty) → 0.1.0.0

raw patch · 9 files changed

+1511/−0 lines, 9 filesdep +QuickCheckdep +basedep +containerssetup-changed

Dependencies added: QuickCheck, base, containers, criterion, deepseq, persistent-vector, test-framework, test-framework-quickcheck2

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Tristan Ravitch++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Tristan Ravitch nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,67 @@+# Persistent Vector++A library providing persistent (purely functional) vectors for Haskell+based on array mapped tries.++## Description++These persistent vectors are modeled on the persistent vector used by+clojure, with an API modeled after Data.Sequence from the containers+library.  This data structure is *spine strict* and is not useful for+incremental consumption.  If you need that, stick to lists.  It is+still lazy in the elements.++While per-element operations are O(log(n)), the internal tree can+never be more than 7 or 8 deep.  Thus, they are effectively constant+time.++This implementation adds O(1) slicing support for vectors that I do+not believe clojure supports.  The implementation cheats, though, and+slices can retain references to objects that cannot be indexed.++## Performance++Performance is an important consideration for a data structure like+this.  The package contains a criterion benchmark suite that attempts+to compare the performance of persistent vectors against a variety of+existing persistent data structures.  As an overview of the results I+have observed:++ * Traversing and building lists is faster than the same operations+   with persistent vectors.++ * (Strict) left folds over persistent vectors are faster than left+   folds over Sequences.  Right folds over Sequences are faster than+   right folds over vectors.++ * Indexing persistent vectors is faster than indexing sequences and+   IntMaps (and, of course, lists).++ * Appending to vectors is slightly faster than appending to a Sequence.+   It is much faster than appending to an IntMap.++ * Updating an element at an index in a vector is *slower* than+   updating an index in a Sequence (but still faster than an IntMap).++Overall, it seems like persistent vectors are efficient at most tasks.+If you only need a (strict) left fold, they are efficient for+traversal.  Indexing and construction are very fast, but Sequences are+superior for element-wise updates.++## Implementation++## TODO++ * More of the Data.Sequence API++ * More efficient Eq and Ord instances.  This is tricky in the+   presence of slicing.  There are faster implementations for unsliced+   inputs.++ * Implement something to make parallel reductions simple (maybe+   something like vector-strategies)++ * Implement cons.  Cons can use the space that is hidden by the+   offset cheaply.  It can also make a variant of pushTail+   (pushHead) that allocates fragments of preceeding sub-trees.+   Each cons call will modify the offset of its result vector.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/pvBench.hs view
@@ -0,0 +1,166 @@+module Main ( main ) where++import Criterion.Config+import Criterion.Main++import Control.DeepSeq+import qualified Data.Foldable as F+import Data.IntMap ( IntMap )+import qualified Data.IntMap as IM+import qualified Data.List as L+import Data.Sequence ( Seq )+import qualified Data.Sequence as S+import Data.Vector.Persistent ( Vector )+import qualified Data.Vector.Persistent as V++testListRTraversal :: [Int] -> Int+testListRTraversal = L.foldr (+) 0++testListLSTraversal :: [Int] -> Int+testListLSTraversal = L.foldl' (+) 0++testVecRTraversal :: Vector Int -> Int+testVecRTraversal = V.foldr (+) 0++testIMRTraversal :: IntMap Int -> Int+testIMRTraversal = F.foldr (+) 0++testVecLTraversal :: Vector Int -> Int+testVecLTraversal = V.foldl' (+) 0++testSeqRTraversal :: Seq Int -> Int+testSeqRTraversal = F.foldr (+) 0++testSeqLTraversal :: Seq Int -> Int+testSeqLTraversal = F.foldl (+) 0++testVecLSTraversal :: Vector Int -> Int+testVecLSTraversal = V.foldl' (+) 0++testSeqLSTraversal :: Seq Int -> Int+testSeqLSTraversal = F.foldl' (+) 0++testListIndex :: [Int] -> Int -> Int+testListIndex = (!!)++testSeqIndex :: Seq Int -> Int -> Int+testSeqIndex = S.index++testVecIndex :: Vector Int -> Int -> Int+testVecIndex = V.unsafeIndex++testIMIndex :: IntMap Int -> Int -> Maybe Int+testIMIndex = flip IM.lookup++testSeqRange :: Seq Int -> Int -> Int -> Int+testSeqRange s start end = sum $ map (S.index s) [start..end]++testVecRange :: Vector Int -> Int -> Int -> Int+testVecRange v start end = sum $ map (V.unsafeIndex v) [start..end]++testIMAppend :: IntMap Int -> Int -> Int -> IntMap Int+testIMAppend im ix i = IM.insert ix i im++testSeqAppend :: Seq Int -> Int -> Seq Int+testSeqAppend = (S.|>)++testVecAppend :: Vector Int -> Int -> Vector Int+testVecAppend = V.snoc++testIMUpdate :: IntMap Int -> Int -> Int -> IntMap Int+testIMUpdate m ix elt = IM.insert ix elt m++testSeqUpdate :: Seq Int -> Int -> Int -> Seq Int+testSeqUpdate s ix elt = S.update ix elt s++testVecUpdate :: Vector Int -> Int -> Int -> Vector Int+testVecUpdate v ix elt = V.update ix elt v++testIMBuild :: Int -> IntMap Int+testIMBuild len =+  let l = [0..len]+  in L.foldl' (\m (ix, elt) -> IM.insert ix elt m) IM.empty (zip l l)++testSeqBuild :: Int -> Seq Int+testSeqBuild len = L.foldl' (S.|>) S.empty [0..len]++testVecBuild :: Int -> Vector Int+testVecBuild len = L.foldl' V.snoc V.empty [0..len]++main :: IO ()+main = defaultMainWith defaultConfig setup [+  bgroup "traverse1000" [ bench "ListR1000" $ whnf testListRTraversal l1000+                        , bench "IMR1000" $ whnf testIMRTraversal im1000+                        , bench "SeqR1000" $ whnf testSeqRTraversal s1000+                        , bench "VecR1000" $ whnf testVecRTraversal v1000+                        , bench "SeqL1000" $ whnf testSeqLTraversal s1000+                        , bench "VecL1000" $ whnf testVecLTraversal v1000+                        , bench "ListLS1000" $ whnf testListLSTraversal l1000+                        , bench "SeqLS1000" $ whnf testSeqLSTraversal s1000+                        , bench "VecLS1000" $ whnf testVecLSTraversal v1000+                        ],+  bgroup "indexAt3_1000" [ bench "List1000" $ whnf (testListIndex l1000) 3+                         , bench "IM1000" $ whnf (testIMIndex im1000) 3+                         , bench "Seq1000" $ whnf (testSeqIndex s1000) 3+                         , bench "Vec1000" $ whnf (testVecIndex v1000) 3+                         ],+  bgroup "indexAt30_1000" [ bench "List1000" $ whnf (testListIndex l1000) 30+                          , bench "IM1000" $ whnf (testIMIndex im1000) 30+                          , bench "Seq1000" $ whnf (testSeqIndex s1000) 30+                          , bench "Vec1000" $ whnf (testVecIndex v1000) 30+                          ],+  bgroup "indexAt30_10000" [ bench "Seq10000" $ whnf (testSeqIndex s10000) 30+                           , bench "Vec10000" $ whnf (testVecIndex v10000) 30+                           ],+  bgroup "indexAt3000_10000" [ bench "IM1000" $ whnf (testIMIndex im10000) 3000+                             , bench "Seq10000" $ whnf (testSeqIndex s10000) 3000+                             , bench "Vec10000" $ whnf (testVecIndex v10000) 3000+                             ],+  bgroup "indexRange501-550_10000" [ bench "Seq10000" $ whnf (testSeqRange s10000 501) 550+                                   , bench "Vec10000" $ whnf (testVecRange v10000 501) 550+                                   ],+  bgroup "indexRange5001-5500_100000" [ bench "Seq10000" $ whnf (testSeqRange s100000 5001) 5500+                                      , bench "Vec10000" $ whnf (testVecRange v100000 5001) 5500+                                      ],+  bgroup "appendValue1000" [ bench "IM1000" $ whnf (testIMAppend im1000 1000) 1+                           , bench "Seq1000" $ whnf (testSeqAppend s1000) 1+                           , bench "Vec1000" $ whnf (testVecAppend v1000) 1+                           ],+  bgroup "appendValue100000" [ bench "IM100000" $ whnf (testIMAppend im100000 100000) 1+                             , bench "Seq100000" $ whnf (testSeqAppend s100000) 1+                             , bench "Vec100000" $ whnf (testVecAppend v100000) 1+                             ],+  bgroup "updateIndex5_1000" [ bench "IM1000" $ whnf (testIMUpdate im1000 5) 342+                             , bench "Seq1000" $ whnf (testSeqUpdate s1000 5) 342+                             , bench "Vec1000" $ whnf (testVecUpdate v1000 5) 342+                             ],+  bgroup "updateIndex5000_100000" [ bench "IM100000" $ whnf (testIMUpdate im100000 5000) 342+                                  , bench "Seq100000" $ whnf (testSeqUpdate s100000 5000) 342+                                  , bench "Vec100000" $ whnf (testVecUpdate v100000 5000) 342+                                  ],+  bgroup "build1000" [ bench "IM1000" $ whnf testIMBuild 1000+                     , bench "Seq1000" $ whnf testSeqBuild 1000+                     , bench "Vec1000" $ whnf testVecBuild 1000+                     ]+  ]+  where+    setup = do+      l1000 `deepseq` l10000 `deepseq` l10000 `deepseq`+        v1000 `deepseq` v10000 `deepseq` v100000 `deepseq`+        im1000 `deepseq` im10000 `deepseq` im100000 `deepseq` return ()+      S.sort s1000 `seq` S.sort s10000 `seq` S.sort s100000 `seq` return ()+    l1000 :: [Int]+    l1000 = [0..1000]+    l10000 :: [Int]+    l10000 = [0..10000]+    l100000 :: [Int]+    l100000 = [0..100000]+    v1000 = V.fromList l1000+    v10000 = V.fromList l10000+    v100000 = V.fromList l100000+    s1000 = S.fromList l1000+    s10000 = S.fromList l10000+    s100000 = S.fromList l100000+    im1000 = IM.fromList (zip l1000 l1000)+    im10000 = IM.fromList (zip l10000 l10000)+    im100000 = IM.fromList (zip l100000 l100000)
+ persistent-vector.cabal view
@@ -0,0 +1,69 @@+name: persistent-vector+version: 0.1.0.0+synopsis: A persistent sequence based on array mapped tries+license: BSD3+license-file: LICENSE+author: Tristan Ravitch+maintainer: travitch@cs.wisc.edu+category: Data+build-type: Simple+cabal-version: >=1.10+extra-source-files: README.md++description:+  This package provides persistent vectors based on array mapped+  tries.  The implementation is based on the persistent vectors used+  in clojure, but in a Haskell-style API.  The API is modeled after+  Data.Sequence from the containers library.+  .+  Technically, the element-wise operations are O(log(n)), but the+  underlying tree cannot be more than 7 or 8 levels deep so this is+  effectively constant time.+  .+  One change from the clojure implementation is that this version supports+  O(1) slicing, though it does cheat a little.  Slices retain references+  to elements that cannot be indexed.  These extra references (and the space+  they occupy) can be reclaimed by 'shrink'ing the slice.  This seems like+  a reasonable tradeoff, and, I believe, mirrors the behavior of the vector+  library.+  .+  Highlights:+  .+    * O(1) append element, indexing, updates, length, and slicing+  .+    * Reasonably compact representation++library+  default-language: Haskell2010+  exposed-modules: Data.Vector.Persistent+  other-modules: Data.Vector.Persistent.Array+                 Data.Vector.Persistent.Unsafe+  build-depends: base ==4.5.*, deepseq+  hs-source-dirs: src+  ghc-options: -Wall+  ghc-prof-options: -auto-all++test-suite pvTests+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  main-is: pvTests.hs+  hs-source-dirs: tests+  ghc-options: -Wall+  build-depends: persistent-vector,+                 base == 4.*,+                 QuickCheck > 2.4,+                 test-framework,+                 test-framework-quickcheck2++benchmark pvBench+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  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,+                 deepseq
+ src/Data/Vector/Persistent.hs view
@@ -0,0 +1,519 @@+-- | This is a port of the persistent vector from clojure to Haskell.+-- It is spine-strict and lazy in the elements.+--+-- The implementation is based on array mapped tries.  The complexity+-- 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.+module Data.Vector.Persistent (+  Vector,+  -- * Construction+  empty,+  singleton,+  snoc,+  fromList,+  -- * Queries+  null,+  length,+  -- * Indexing+  index,+  unsafeIndex,+  take,+  drop,+  splitAt,+  -- * Slicing+  slice,+  shrink,+  -- * Modification+  update,+  (//),+  -- * Folds+  foldr,+  foldl',+  -- * Transformations+  map,+  reverse,+  -- * Searches+  filter,+  partition+  ) where++import Prelude hiding ( null, length, tail, take,+                        drop, map, foldr, reverse,+                        splitAt, filter+                      )++import Control.Applicative hiding ( empty )+import Control.DeepSeq+import Data.Bits+import Data.Foldable ( Foldable )+import qualified Data.Foldable as F+import qualified Data.List as L+import Data.Monoid ( Monoid )+import qualified Data.Monoid as M+import Data.Traversable ( Traversable )+import qualified Data.Traversable as T++import Data.Vector.Persistent.Array ( Array )+import qualified Data.Vector.Persistent.Array as A++-- 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 :: !(Array (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+  compare = pvCompare++instance Foldable Vector where+  foldr = foldr++instance Functor Vector where+  fmap = map++instance Monoid (Vector a) where+  mempty = empty+  mappend = append++instance Traversable Vector where+  traverse = pvTraverse++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 v1 v2+  | length v1 /= length v2 = False+  | isNotSliced v1 && isNotSliced v2 = pvSimpleEq v1 v2+  | otherwise = F.toList v1 == F.toList v2++-- | 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++{-# INLINABLE pvCompare #-}+-- | A dispatcher for comparison tests+pvCompare :: (Ord a) => Vector a -> Vector a -> Ordering+pvCompare v1 v2+  | length v1 /= length v2 = compare (length v1) (length v2)+  | isNotSliced v1 && isNotSliced v2 = pvSimpleCompare v1 v2+  | otherwise = compare (F.toList v1) (F.toList v2)++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 map #-}+-- | 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) =+      let t' = L.map f t+          v' = A.map (fmap f) v+      in RootNode sz sh off cap t' v'++{-# INLINABLE 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 (s0, max 0 (vecCapacity v - vecSize v), length v) of (r, _, _) -> r+  where+    go EmptyVector seed = seed+    go (DataNode a) (seed, nskip, len)+      | len <= 0 = (seed, 0, 0)+      | nskip == 0 = (A.boundedFoldr f (32 - len) 32 seed a, 0, len - A.length a)+      | nskip >= 32 = (seed, nskip - 32, len)+      | otherwise =+        let end = min (max 0 (32 - nskip)) 32+            start = 32 - (len + nskip)+            taken = end - max 0 start+        in (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) (s, nskip, l) =+      let tseed = L.foldl' (flip f) s t+          seed = (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++{-# 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 (s0, vecOffset v, length v) v of (r, _, _) -> r+  where+    go seed EmptyVector = seed+    go (seed, nskip, len) (DataNode a)+      | len <= 0 = (seed, 0, 0)+      | nskip == 0 = (A.boundedFoldl' f 0 (min len 32) seed a, 0, len - A.length a)+      | nskip >= 32 = (seed, nskip - 32, len)+      | otherwise =+        let end = min 32 (len + nskip)+            start = nskip+            taken = end - max 0 start+        in (A.boundedFoldl' f start end seed a, 0, len - taken)+    go seed (InternalNode as) =+      A.foldl' go seed as+    go (s, nskip, l) (RootNode _ _ _ _ t as) =+      let (rseed, _, _) = A.foldl' go (s, nskip, l - L.length t) as+      in (L.foldr (flip f) rseed t, 0, 0)++    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+      in F.foldr (flip f) rseed t++{-# INLINABLE pvTraverse #-}+pvTraverse :: (Applicative f) => (a -> f b) -> Vector a -> f (Vector b)+pvTraverse f = go+  where+    go EmptyVector = pure EmptyVector+    go (DataNode a) = DataNode <$> A.traverse f a+    go (InternalNode as) = InternalNode <$> A.traverse go as+    go (RootNode sz sh off cap t as) =+      RootNode sz sh off cap <$> T.traverse f t <*> A.traverse go as++{-# INLINABLE append #-}+append :: Vector a -> Vector a -> Vector a+append EmptyVector v = v+append v EmptyVector = v+append v1 v2 = F.foldl' snoc v1 (F.toList v2)++{-# INLINABLE pvRnf #-}+pvRnf :: (NFData a) => Vector a -> ()+pvRnf = F.foldr deepseq ()++-- | O(1) The empty vector+empty :: Vector a+empty = EmptyVector++-- | O(1) Test to see if the vector is empty.+null :: Vector a -> Bool+null EmptyVector = True+null _ = False++-- | 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"++-- | O(1) Bounds-checked indexing into a vector.+index :: Vector a -> Int -> Maybe a+index v ix+  | length v > ix = Just $ unsafeIndex v ix+  | otherwise = Nothing++-- | O(1) Unchecked indexing into a vector.+--+-- Note that out-of-bounds indexing might not even crash - it will+-- usually just return nonsense values.+unsafeIndex :: Vector a -> Int -> a+unsafeIndex vec userIndex+  | ix >= tailOffset vec && vecCapacity vec < vecSize vec =+    L.reverse (vecTail vec) !! (ix .&. 0x1f)+  | otherwise = go (vecShift vec) vec+  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)+      | otherwise =+        let nextVecIx = (ix `shiftR` level) .&. 0x1f+            v' = intVecPtrs v+        in go (level - 5) (A.index v' nextVecIx)++-- | 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 []+           }++-- | 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+  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.+snoc :: Vector a -> a -> Vector a+snoc EmptyVector elt = singleton elt+snoc v@RootNode { vecSize = sz, vecShift = sh, 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' = update sz elt v+    in v' { vecSize = vecSize v' + 1 }+  -- Room in tail+  | sz .&. 0x1f /= 0 = v { vecTail = elt : t, vecSize = sz + 1 }+  -- 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+                                         ]+             }+  -- 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+  where+    go level parent+      | level == 5 = arraySnoc parent (DataNode (A.fromList 32 (L.reverse 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)+      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 level t+  | level == 0 = DataNode (A.fromList 32 (L.reverse t))+  | otherwise = InternalNode $ A.fromList 1 $ [newPath (level - 5) t]++-- | 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 =+    let tix = sz - 1 - ix+        (keepHead, _:keepTail) = L.splitAt tix t+    in v { vecTail = keepHead ++ (elt : keepTail) }+  -- 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+        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')+          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.+--+-- > slice start length v+--+-- 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+  -- 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'+           }+  where+    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)++-- | O(n) Force a sliced vector to drop any unneeded space and+-- references.+--+-- 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++-- | O(n) Reverse a vector+reverse :: Vector a -> Vector a+reverse = fromList . foldl' (flip (:)) []++-- | O(n) Filter according to the predicate+filter :: (a -> Bool) -> Vector a -> Vector a+filter p = foldl' go empty+  where+    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+partition :: (a -> Bool) -> Vector a -> (Vector a, Vector a)+partition p = foldl' go (empty, empty)+  where+    go (atrue, afalse) e =+      if p e then (snoc atrue e, afalse) else (atrue, snoc afalse e)++-- | O(n) Construct a vector from a list.+fromList :: [a] -> Vector a+fromList = F.foldl' snoc empty++-- Helpers++tailOffset :: Vector a -> Int+tailOffset v+  | len < 32 = 0+  | otherwise = (len - 1) `shiftR` 5 `shiftL` 5+  where+    len = length v++isNotSliced :: Vector a -> Bool+isNotSliced v = vecOffset v == 0 && vecCapacity v < vecSize v
+ src/Data/Vector/Persistent/Array.hs view
@@ -0,0 +1,481 @@+{-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples #-}+{-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-}++-- | Zero based arrays.+--+-- Note that no bounds checking are performed.+module Data.Vector.Persistent.Array+    ( Array+    , MArray++      -- * Creation+    , new+    , new_+    , singleton+    , singleton'+    , pair++      -- * Basic interface+    , length+    , lengthM+    , read+    , write+    , index+    , index_+    , indexM_+    , update+    , update'+    , updateWith+    , unsafeUpdate'+    , insert+    , insert'+    , delete+    , delete'++    , unsafeFreeze+    , unsafeThaw+    , run+    , run2+    , copy+    , copyM++      -- * Folds+    , foldl'+    , boundedFoldl'+    , foldr+    , boundedFoldr++    , thaw+    , map+    , map'+    , traverse+    , filter+    , fromList+    , toList+    ) where++import qualified Data.Traversable as Traversable+import Control.Applicative (Applicative)+import Control.DeepSeq+import Control.Monad.ST hiding (runST)+import GHC.Exts+import GHC.ST (ST(..))+import Prelude hiding (filter, foldr, length, map, read)+import qualified Prelude as P++import Data.Vector.Persistent.Unsafe (runST)++------------------------------------------------------------------------++#if defined(ASSERTS)+-- This fugly hack is brought by GHC's apparent reluctance to deal+-- with MagicHash and UnboxedTuples when inferring types. Eek!+# define CHECK_BOUNDS(_func_,_len_,_k_) \+if (_k_) < 0 || (_k_) >= (_len_) then error ("Data.HashMap.Array." ++ (_func_) ++ ": bounds error, offset " ++ show (_k_) ++ ", length " ++ show (_len_)) else+# 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_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_LE(_func_,_lhs_,_rhs_)+#endif++data Array a = Array {+      unArray :: !(Array# a)+#if __GLASGOW_HASKELL__ < 702+    , length :: !Int+#endif+    }++instance Show a => Show (Array a) where+    show = show . toList++instance Eq a => Eq (Array a) where+  (==) = arrayEq++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)]++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)++#if __GLASGOW_HASKELL__ >= 702+length :: Array a -> Int+length ary = I# (sizeofArray# (unArray ary))+{-# INLINE length #-}+#endif++-- | Smart constructor+array :: Array# a -> Int -> Array a+#if __GLASGOW_HASKELL__ >= 702+array ary _n = Array ary+#else+array = Array+#endif+{-# INLINE array #-}++data MArray s a = MArray {+      unMArray :: !(MutableArray# s a)+#if __GLASGOW_HASKELL__ < 702+    , lengthM :: !Int+#endif+    }++#if __GLASGOW_HASKELL__ >= 702+lengthM :: MArray s a -> Int+lengthM mary = I# (sizeofMutableArray# (unMArray mary))+{-# INLINE lengthM #-}+#endif++-- | Smart constructor+marray :: MutableArray# s a -> Int -> MArray s a+#if __GLASGOW_HASKELL__ >= 702+marray mary _n = MArray mary+#else+marray = MArray+#endif+{-# INLINE marray #-}++------------------------------------------------------------------------++instance NFData a => NFData (Array a) where+    rnf = rnfArray++rnfArray :: NFData a => Array a -> ()+rnfArray ary0 = go ary0 n0 0+  where+    n0 = length ary0+    go !ary !n !i+        | i >= n = ()+        | otherwise = rnf (index ary i) `seq` go ary n (i+1)+{-# INLINE rnfArray #-}++-- | Create a new mutable array of specified size, in the specified+-- state thread, with each element containing the specified initial+-- value.+new :: Int -> a -> ST s (MArray s a)+new n@(I# n#) b =+    CHECK_GT("new",n,(0 :: Int))+    ST $ \s ->+        case newArray# n# b s of+            (# s', ary #) -> (# s', marray ary n #)+{-# INLINE new #-}++new_ :: Int -> ST s (MArray s a)+new_ n = new n undefinedElem++singleton :: a -> Array a+singleton x = runST (singleton' x)+{-# INLINE singleton #-}++singleton' :: a -> ST s (Array a)+singleton' x = new 1 x >>= unsafeFreeze+{-# INLINE singleton' #-}++pair :: a -> a -> Array a+pair x y = run $ do+    ary <- new 2 x+    write ary 1 y+    return ary+{-# INLINE pair #-}++read :: MArray s a -> Int -> ST s a+read ary _i@(I# i#) = ST $ \ s ->+    CHECK_BOUNDS("read", lengthM ary, _i)+        readArray# (unMArray ary) i# s+{-# INLINE read #-}++write :: MArray s a -> Int -> a -> ST s ()+write ary _i@(I# i#) b = ST $ \ s ->+    CHECK_BOUNDS("write", lengthM ary, _i)+        case writeArray# (unMArray ary) i# b s of+            s' -> (# s' , () #)+{-# INLINE write #-}++index :: Array a -> Int -> a+index ary _i@(I# i#) =+    CHECK_BOUNDS("index", length ary, _i)+        case indexArray# (unArray ary) i# of (# b #) -> b+{-# INLINE index #-}++index_ :: Array a -> Int -> ST s a+index_ ary _i@(I# i#) =+    CHECK_BOUNDS("index_", length ary, _i)+        case indexArray# (unArray ary) i# of (# b #) -> return b+{-# INLINE index_ #-}++indexM_ :: MArray s a -> Int -> ST s a+indexM_ ary _i@(I# i#) =+    CHECK_BOUNDS("index_", lengthM ary, _i)+        ST $ \ s# -> readArray# (unMArray ary) i# s#+{-# INLINE indexM_ #-}++unsafeFreeze :: MArray s a -> ST s (Array a)+unsafeFreeze mary+    = ST $ \s -> case unsafeFreezeArray# (unMArray mary) s of+                   (# s', ary #) -> (# s', array ary (lengthM mary) #)+{-# INLINE unsafeFreeze #-}++unsafeThaw :: Array a -> ST s (MArray s a)+unsafeThaw ary+    = ST $ \s -> case unsafeThawArray# (unArray ary) s of+                   (# s', mary #) -> (# s', marray mary (length ary) #)+{-# INLINE unsafeThaw #-}++run :: (forall s . ST s (MArray s e)) -> Array e+run act = runST $ act >>= unsafeFreeze+{-# INLINE run #-}++run2 :: (forall s. ST s (MArray s e, a)) -> (Array e, a)+run2 k = runST (do+                 (marr,b) <- k+                 arr <- unsafeFreeze marr+                 return (arr,b))++-- | Unsafely copy the elements of an array. Array bounds are not checked.+copy :: Array e -> Int -> MArray s e -> Int -> Int -> ST s ()+#if __GLASGOW_HASKELL__ >= 702+copy !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) =+    CHECK_LE("copy", _sidx + _n, length src)+    CHECK_LE("copy", _didx + _n, lengthM dst)+        ST $ \ s# ->+        case copyArray# (unArray src) sidx# (unMArray dst) didx# n# s# of+            s2 -> (# s2, () #)+#else+copy !src !sidx !dst !didx n =+    CHECK_LE("copy", sidx + n, length src)+    CHECK_LE("copy", didx + n, lengthM dst)+        copy_loop sidx didx 0+  where+    copy_loop !i !j !c+        | c >= n = return ()+        | otherwise = do b <- index_ src i+                         write dst j b+                         copy_loop (i+1) (j+1) (c+1)+#endif++-- | Unsafely copy the elements of an array. Array bounds are not checked.+copyM :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s ()+#if __GLASGOW_HASKELL__ >= 702+copyM !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) =+    CHECK_BOUNDS("copyM: src", lengthM src, _sidx + _n - 1)+    CHECK_BOUNDS("copyM: dst", lengthM dst, _didx + _n - 1)+    ST $ \ s# ->+    case copyMutableArray# (unMArray src) sidx# (unMArray dst) didx# n# s# of+        s2 -> (# s2, () #)+#else+copyM !src !sidx !dst !didx n =+    CHECK_BOUNDS("copyM: src", lengthM src, sidx + n - 1)+    CHECK_BOUNDS("copyM: dst", lengthM dst, didx + n - 1)+    copy_loop sidx didx 0+  where+    copy_loop !i !j !c+        | c >= n = return ()+        | otherwise = do b <- indexM_ src i+                         write dst j b+                         copy_loop (i+1) (j+1) (c+1)+#endif++-- | /O(n)/ Insert an element at the given position in this array,+-- increasing its size by one.+insert :: Array e -> Int -> e -> Array e+insert ary idx b = runST (insert' ary idx b)+{-# INLINE insert #-}++-- | /O(n)/ Insert an element at the given position in this array,+-- increasing its size by one.+insert' :: Array e -> Int -> e -> ST s (Array e)+insert' ary idx b =+    CHECK_BOUNDS("insert'", count + 1, idx)+        do mary <- new_ (count+1)+           copy ary 0 mary 0 idx+           write mary idx b+           copy ary idx mary (idx+1) (count-idx)+           unsafeFreeze mary+  where !count = length ary+{-# INLINE insert' #-}++-- | /O(n)/ Update the element at the given position in this array.+update :: Array e -> Int -> e -> Array e+update ary idx b = runST (update' ary idx b)+{-# INLINE update #-}++-- | /O(n)/ Update the element at the given position in this array.+update' :: Array e -> Int -> e -> ST s (Array e)+update' ary idx b =+    CHECK_BOUNDS("update'", count, idx)+        do mary <- thaw ary 0 count+           write mary idx b+           unsafeFreeze mary+  where !count = length ary+{-# INLINE update' #-}++-- | /O(n)/ Update the element at the given positio in this array, by+-- applying a function to it.  Evaluates the element to WHNF before+-- inserting it into the array.+updateWith :: Array e -> Int -> (e -> e) -> Array e+updateWith ary idx f = update ary idx $! f (index ary idx)+{-# INLINE updateWith #-}++-- | /O(1)/ Update the element at the given position in this array,+-- without copying.+unsafeUpdate' :: Array e -> Int -> e -> ST s ()+unsafeUpdate' ary idx b =+    CHECK_BOUNDS("unsafeUpdate'", length ary, idx)+        do mary <- unsafeThaw ary+           write mary idx b+           _ <- unsafeFreeze mary+           return ()+{-# INLINE unsafeUpdate' #-}++foldl' :: (b -> a -> b) -> b -> Array a -> b+foldl' f z0 ary0 = go ary0 (length ary0) 0 z0+  where+    go ary n i !z+        | i >= n    = z+        | otherwise = go ary n (i+1) (f z (index ary i))+{-# INLINE foldl' #-}++boundedFoldl' :: (b -> a -> b) -> Int -> Int -> b -> Array a -> b+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))+{-# INLINE boundedFoldl' #-}++foldr :: (a -> b -> b) -> b -> Array a -> b+foldr f z0 ary0 = go ary0 (length ary0) 0 z0+  where+    go ary n i z+        | i >= n    = z+        | otherwise = f (index ary i) (go ary n (i+1) z)+{-# INLINE foldr #-}++boundedFoldr :: (a -> b -> b) -> Int -> Int -> b -> Array a -> b+boundedFoldr 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 = f (index ary i) (go ary n (i+1) z)+{-# INLINE boundedFoldr #-}++undefinedElem :: a+undefinedElem = error "Data.HashMap.Array: Undefined element"+{-# NOINLINE undefinedElem #-}++thaw :: Array e -> Int -> Int -> ST s (MArray s e)+#if __GLASGOW_HASKELL__ >= 702+thaw !ary !_o@(I# o#) !n@(I# n#) =+    CHECK_LE("thaw", _o + n, length ary)+        ST $ \ s -> case thawArray# (unArray ary) o# n# s of+            (# s2, mary# #) -> (# s2, marray mary# n #)+#else+thaw !ary !o !n =+    CHECK_LE("thaw", o + n, length ary)+        do mary <- new_ n+           copy ary o mary 0 n+           return mary+#endif+{-# INLINE thaw #-}++-- | /O(n)/ Delete an element at the given position in this array,+-- decreasing its size by one.+delete :: Array e -> Int -> Array e+delete ary idx = runST (delete' ary idx)+{-# INLINE delete #-}++-- | /O(n)/ Delete an element at the given position in this array,+-- decreasing its size by one.+delete' :: Array e -> Int -> ST s (Array e)+delete' ary idx = do+    mary <- new_ (count-1)+    copy ary 0 mary 0 idx+    copy ary (idx+1) mary idx (count-(idx+1))+    unsafeFreeze mary+  where !count = length ary+{-# INLINE delete' #-}++map :: (a -> b) -> Array a -> Array b+map f = \ ary ->+    let !n = length ary+    in run $ do+        mary <- new_ n+        go ary mary 0 n+  where+    go ary mary i n+        | i >= n    = return mary+        | otherwise = do+             write mary i $ f (index ary i)+             go ary mary (i+1) n+{-# INLINE map #-}++-- | Strict version of 'map'.+map' :: (a -> b) -> Array a -> Array b+map' f = \ ary ->+    let !n = length ary+    in run $ do+        mary <- new_ n+        go ary mary 0 n+  where+    go ary mary i n+        | i >= n    = return mary+        | otherwise = do+             write mary i $! f (index ary i)+             go ary mary (i+1) n+{-# INLINE map' #-}++fromList :: Int -> [a] -> Array a+fromList n xs0 = run $ do+    mary <- new_ n+    go xs0 mary 0+  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 (:) []++traverse :: Applicative f => (a -> f b) -> Array a -> f (Array b)+traverse f = \ ary -> fromList (length ary) `fmap`+                      Traversable.traverse f (toList ary)+{-# INLINE traverse #-}++filter :: (a -> Bool) -> Array a -> Array a+filter p = \ ary ->+    let !n = length ary+    in run $ do+        mary <- new_ n+        go ary mary 0 0 n+  where+    go ary mary i j n+        | i >= n    = if i == j+                      then return mary+                      else do mary2 <- new_ j+                              copyM mary 0 mary2 0 j+                              return mary2+        | p el      = write mary j el >> go ary mary (i+1) (j+1) n+        | otherwise = go ary mary (i+1) j n+      where el = index ary i+{-# INLINE filter #-}
+ src/Data/Vector/Persistent/Unsafe.hs view
@@ -0,0 +1,28 @@+{-# 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
@@ -0,0 +1,149 @@+module Main ( main ) where++import Test.Framework ( defaultMain, Test )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.QuickCheck++import qualified Data.Foldable as F+import Data.Monoid+import qualified Data.List as L+import qualified Data.Traversable as T++import Data.Vector.Persistent ( Vector )+import qualified Data.Vector.Persistent as V++newtype InputList = InputList [Int]+                  deriving (Show)+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++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++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++inputList :: Int -> Gen InputList+inputList sz = do+  modifier <- choose (0, 100)+  l <- vector (sz * modifier)+  return $ InputList l++tests :: [Test]+tests = [ testProperty "toListFromListIdent" prop_toListFromListIdentity+        , testProperty "fmap" prop_map+        , testProperty "foldrWorks" prop_foldrWorks+        , testProperty "foldlWorks" prop_foldlWorks+        , 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 "shrink" prop_shrinkPreserves+        , testProperty "shrinkEq" prop_shrinkEquality+        ]++main :: IO ()+main = defaultMain tests++prop_toListFromListIdentity :: InputList -> Bool+prop_toListFromListIdentity (InputList il) =+  il == F.toList (V.fromList il)++prop_map :: InputList -> Bool+prop_map (InputList il) =+  L.map f il == F.toList (fmap f (V.fromList il))+  where+    f = (+20)++prop_foldrWorks :: InputList -> Bool+prop_foldrWorks (InputList il) =+  F.foldr (+) 0 il == F.foldr (+) 0 (V.fromList il)++prop_foldlWorks :: InputList -> Bool+prop_foldlWorks (InputList il) =+  F.foldl' (flip (:)) [] il == V.foldl' (flip (:)) [] (V.fromList il)++prop_updateWorks :: (InputList, Int, Int) -> Property+prop_updateWorks (InputList il, ix, repl) =+  ix >= 0 ==> rlist == F.toList (v V.// [(ix, repl)])+  where+    v = V.fromList il+    (keepHead, _:keepTail) = L.splitAt ix il+    rlist = case null il of+      True -> []+      False -> case ix >= length il of+        True -> il+        False -> keepHead ++ (repl : keepTail)++prop_indexingWorks :: IndexableList -> Bool+prop_indexingWorks (IndexableList il ix) =+  (il !! ix) == (V.unsafeIndex (V.fromList il) ix)++prop_take :: IndexableList -> Bool+prop_take (IndexableList il ix) =+  L.take ix il == F.toList (V.take ix (V.fromList il))++prop_drop :: IndexableList -> Bool+prop_drop (IndexableList il ix) =+  L.drop ix il == F.toList (V.drop ix (V.fromList il))++prop_splitAt :: IndexableList -> Bool+prop_splitAt (IndexableList 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)++prop_slice :: SliceList -> Bool+prop_slice (SliceList il s n) =+  listSlice s n il == F.toList (V.slice s n (V.fromList il))++prop_sliceFoldr :: SliceList -> Bool+prop_sliceFoldr (SliceList il s n) =+  L.foldr (:) [] (listSlice s n il) == V.foldr (:) [] (V.slice s n (V.fromList il))++prop_slicedFoldl' :: SliceList -> Bool+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)+  where+    v0 = V.slice s n (V.fromList il)++prop_shrinkEquality :: SliceList -> Bool+prop_shrinkEquality (SliceList il s n) =+  v0 == V.shrink v0+  where+    v0 = V.slice s n (V.fromList il)