packages feed

pvector (empty) → 0.1.0.0

raw patch · 14 files changed

+1684/−0 lines, 14 filesdep +QuickCheckdep +basedep +containersbinary-added

Dependencies added: QuickCheck, base, containers, criterion, deepseq, hspec, persistent-vector, primitive, pvector, quickcheck-instances, rrb-vector, unordered-containers, vector, vector-stream

Files

+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# 0.1.0.0++* Initial release
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2022, Brian Shu+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its+   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 HOLDER 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,10 @@+![Haskell](https://img.shields.io/badge/Haskell-5e5086?style=for-the-badge&logo=haskell&logoColor=white)+![Hackage](https://img.shields.io/hackage/v/pvector?color=5e5184&style=for-the-badge)+![GitHub Workflow Status](https://img.shields.io/github/workflow/status/oberblastmeister/pvector/Haskell-CI?style=for-the-badge)++# pvector++An implementation of persistent vectors, an efficient sequence data structure.+It supports fast indexing, iteration, and snocing.++For more information, see [`pvector` on Hackage](https://hackage.haskell.org/package/pvector).
+ bench/Main.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE PackageImports #-}++module Main where++import Control.DeepSeq (NFData)+import Criterion.Main+import Data.Foldable (foldl')+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import qualified Data.List as List+import Data.Maybe (fromJust)+import qualified Data.RRBVector as RRBVector+import qualified Data.Sequence as Seq+import qualified Data.Vector as VB+import qualified "persistent-vector" Data.Vector.Persistent as Vector.Persistent.Other+import qualified "pvector" Data.Vector.Persistent as Vector.Persistent+import qualified "pvector" Data.Vector.Persistent.Internal as Vector.Persistent.Internal+import GHC.Exts (IsList (..))++data Snocer where+  Snocer :: NFData (f Int) => String -> ([Int] -> f Int) -> (f Int -> Int -> f Int) -> Snocer++data FromList where+  FromList :: String -> ([Int] -> f Int) -> FromList++data Map where+  Map :: NFData (f Int) => String -> ([Int] -> f Int) -> (f Int -> f Int) -> Map++data Indexer where+  Indexer :: NFData (f Int) => String -> ([Int] -> f Int) -> (f Int -> Int -> Int) -> Indexer++data Updater where+  Updater :: NFData (f Int) => String -> ([Int] -> f Int) -> (f Int -> Int -> f Int) -> Updater++data Folder where+  Folder :: (NFData (f Int), NFData a) => String -> ([Int] -> f Int) -> (f Int -> a) -> Folder++sampleHashMap :: [Int] -> HashMap Int Int+sampleHashMap is = HashMap.fromList $ fmap (\i -> (i, i)) is++snocHashMap :: HashMap Int Int -> Int -> HashMap Int Int+snocHashMap map i = HashMap.insert i i map++main :: IO ()+main =+  defaultMainWith+    defaultConfig+    [ bgroup "snoc" $+        snocs+          [ Snocer "Data.Vector.Persistent" fromList Vector.Persistent.snoc,+            Snocer "Data.Vector.Persistent.Other" Vector.Persistent.Other.fromList Vector.Persistent.Other.snoc,+            Snocer "Data.RRBVector" fromList (RRBVector.|>),+            Snocer "Data.Vector" fromList VB.snoc,+            Snocer "Data.HashMap.Strict" sampleHashMap snocHashMap,+            Snocer "Data.Sequence" fromList (Seq.|>)+          ],+      bgroup "fromList" $+        fromLists+          [ FromList "Data.Vector.Persistent" Vector.Persistent.fromList,+            FromList "Data.RRBVector" RRBVector.fromList,+            FromList "Data.Vector" VB.fromList,+            FromList "Data.HashMap.Strict" sampleHashMap,+            FromList "Data.Sequence" Seq.fromList+          ],+      bgroup "map" $+        maps+          [ Map "Data.Vector.Persistent" fromList (Vector.Persistent.map (20 +)),+            Map "Data.Vector.Persistent.Other" Vector.Persistent.Other.fromList (Vector.Persistent.Other.map (20 +)),+            Map "Data.RRBVector" fromList (RRBVector.map (20 +))+          ],+      bgroup "index" $+        indexers+          [ Indexer "Data.Vector.Persistent" fromList (\vec i -> fromJust $ Vector.Persistent.lookup i vec),+            Indexer "Data.Vector.Persistent.Other" Vector.Persistent.Other.fromList (\vec i -> fromJust $ Vector.Persistent.Other.index vec i),+            Indexer "Data.RRBVector" fromList (\vec i -> fromJust $ RRBVector.lookup i vec),+            Indexer "Data.Vector" fromList (\vec i -> fromJust $ vec VB.!? i),+            Indexer "Data.HashMap.Strict" sampleHashMap (\map i -> fromJust $ map HashMap.!? i),+            Indexer "Data.Sequence" fromList (\seq i -> fromJust $ seq Seq.!? i)+          ],+      bgroup "update" $+        updaters+          [ Updater "Data.Vector.Persistent" fromList (\vec i -> Vector.Persistent.update i i vec),+            Updater "Data.RRBVector" fromList (\vec i -> RRBVector.update i i vec),+            -- be careful here, ptrEq might cause nothing to be inserted+            Updater "Data.HashMap.Strict" sampleHashMap (\map i -> HashMap.insert i 0 map)+          ],+      bgroup "fold" $+        vectorFolders+          [ Folder "normal" Vector.Persistent.fromList sum,+            -- Folder "toList" Vector.Persistent.fromList (sum . Vector.Persistent.toList),+            -- Folder "streamL" Vector.Persistent.fromList Vector.Persistent.Internal.streamSumL,+            -- Folder "streamR" Vector.Persistent.fromList Vector.Persistent.Internal.streamSumR,+            Folder "Data.RRBVector" RRBVector.fromList sum+          ],+      bgroup "equality" $+        vectorFolders+          [ Folder "normal" Vector.Persistent.fromList (\x -> Vector.Persistent.Internal.persistentVectorEq x x)+          ],+      bgroup "compare" $+        vectorFolders+          [ Folder "normal" Vector.Persistent.fromList Vector.Persistent.Internal.persistentVectorCompare+          ]+    ]+  where+    bench' sections = bench $ List.intercalate "/" sections++    -- 1.5x-2x faster than RRBVector+    -- 2x faster than HashMap+    -- way slower than Seq+    snocs funcs =+      [ env (pure $ sample []) $ \seq -> env (pure [1 .. size]) $ \list ->+          ( bench'+              [title, "size " ++ show size]+              (whnf (foldl' func seq) list)+          )+        | size <- sizes,+          Snocer title sample func <- funcs+      ]++    fromLists funcs =+      [ env (pure [1 .. size]) $ \list ->+          (bench' [title, "size " ++ show size] (whnf func list))+        | size <- sizes,+          FromList title func <- funcs+      ]++    maps funcs =+      [ env (pure $ fromList [1 .. size]) $ \vec ->+          (bench' [title, "size " ++ show size] (whnf func vec))+        | size <- sizes,+          Map title fromList func <- funcs+      ]++    -- 1.5x-2x faster than RRBVector+    -- 2x slower than Vector+    -- 2x faster than HashMap+    -- Seq has really slow indexing+    indexers funcs =+      [ env+          ( let seq = sample indices+                indices = [0 .. size - 1]+             in pure (seq, indices)+          )+          $ \(~(seq, indices)) ->+            ( bench'+                [title, "size " ++ show size]+                ( whnf+                    ( \indices ->+                        foldl'+                          (\seq index -> let !_ = func seq index in seq)+                          seq+                          indices+                    )+                    indices+                )+            )+        | size <- sizes,+          Indexer title sample func <- funcs+      ]++    updaters funcs =+      [ env+          ( let seq = sample indices+                indices = [0 .. size - 1]+             in pure (seq, indices)+          )+          $ \(~(seq, indices)) ->+            ( bench'+                [title, "size " ++ show size]+                (whnf (\indices -> foldl' func seq indices) indices)+            )+        | size <- sizes,+          Updater title sample func <- funcs+      ]++    vectorFolders funcs =+      [ env (pure $ fromList [1 .. size]) $ \vec ->+          ( bench'+              [title, "size " ++ show size]+              (nf func vec)+          )+        | size <- sizes,+          Folder title fromList func <- funcs+      ]++sizes :: [Int]+sizes = take 4 allSizes++allSizes :: [Int]+allSizes = [10 ^ i | i <- [1 :: Int ..]]++-- streamSumL :: Vector.Persistent.Vector Int -> Int+-- streamSumL = runIdentity . Stream.foldl' (+) 0 . streamL++-- streamSumR :: Vector.Persistent.Vector Int -> Int+-- streamSumR = runIdentity . Stream.foldl' (+) 0 . streamR
+ docs/diagram.png view

binary file changed (absent → 21635 bytes)

+ pvector.cabal view
@@ -0,0 +1,139 @@+cabal-version: 3.0+name: pvector+version: 0.1.0.0+synopsis: Fast persistent vectors+description:+  An persistent vector is an efficient sequence data structure.+  It supports fast indexing, iteration, snocing.+homepage: https://github.com/oberblastmeister/pvector+bug-reports: https://github.com/oberblastmeister/pvector/issues+license: BSD-3-Clause+license-file: LICENSE+author: Brian Shu+maintainer: littlebubu.shu@gmail.com+copyright: 2022 Brian Shu+category: Data+extra-source-files:+  CHANGELOG.md+  README.md+extra-doc-files:+  docs/diagram.png+tested-with: GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.2++flag debug+  description: Enable array bounds checking+  manual: True+  default: False++common common-options+  default-language: Haskell2010+  default-extensions:+    FlexibleInstances,+    FlexibleContexts,+    InstanceSigs,+    MultiParamTypeClasses,+    ConstraintKinds,+    LambdaCase,+    EmptyCase,+    TupleSections,+    BangPatterns,+    TypeApplications,+    StandaloneDeriving,+    OverloadedStrings,+    RankNTypes,+    ScopedTypeVariables,+    NamedFieldPuns,+    DuplicateRecordFields,+    DataKinds,+    ConstraintKinds,+    TypeApplications,+    KindSignatures,+    DeriveFoldable,+    DeriveFunctor,+    DeriveGeneric,+    DeriveDataTypeable,+    DeriveLift,+    DeriveTraversable ,+    GeneralizedNewtypeDeriving,+    GADTs,+    PolyKinds,+    ViewPatterns,+    PatternSynonyms,+    TypeFamilies,+    TypeFamilyDependencies,+    FunctionalDependencies,+    ExistentialQuantification,+    TypeOperators,+  ghc-options:+    -Wall+    -Wincomplete-record-updates+    -Wredundant-constraints+    -Wno-name-shadowing+    -- until OverloadedRecordUpdate stabilizes+    -Wno-ambiguous-fields+    -Werror=incomplete-patterns+    -Werror=incomplete-uni-patterns+    -Werror=missing-methods+  build-depends:+    base >= 4.12 && <5,+    primitive >= 0.6.4.0 && <0.8,+    deepseq >=1.1 && <1.5,+    vector-stream ^>= 0.1.0.0,++library+  import: common-options+  hs-source-dirs: src+  exposed-modules:+    Data.Vector.Persistent+    Data.Vector.Persistent.Unsafe+    Data.Vector.Persistent.Internal+    Data.Vector.Persistent.Internal.Buffer+    Data.Vector.Persistent.Internal.Array+    Data.Vector.Persistent.Internal.CoercibleUtils+  if flag(debug)+    cpp-options: -DDEBUG+    if impl(ghc >= 9.2.2)+      ghc-options: -fcheck-prim-bounds++  -- uncomment to inspect generated code+  -- ghc-options: -O2+  -- ghc-options: -ddump-simpl -ddump-stg-final -ddump-cmm -ddump-asm -ddump-to-file+  -- ghc-options: -dsuppress-coercions -dsuppress-unfoldings -dsuppress-module-prefixes+  -- ghc-options: -dsuppress-uniques -dsuppress-timestamps++common rtsopts+  ghc-options:+    -threaded+    -rtsopts+    -with-rtsopts=-N++test-suite pvector-test+  import: common-options, rtsopts+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Spec.hs+  other-modules:+    PersistentVectorSpec+  build-depends:+    pvector,+    hspec ^>= 2.9.4,+    QuickCheck ^>= 2.14.2,+    quickcheck-instances ^>= 0.3.27,+  build-tool-depends:+    hspec-discover:hspec-discover,+  cpp-options: -DTEST++benchmark pvector-bench+  import: common-options, rtsopts+  type: exitcode-stdio-1.0+  hs-source-dirs: bench+  main-is: Main.hs+  ghc-options: -O2+  build-depends:+    pvector,+    criterion ^>= 1.5.13.0,+    rrb-vector ^>= 0.1.1.0,+    vector ^>= 0.12.3.1,+    unordered-containers ^>= 0.2.17.0,+    containers >= 0.5.5.1 && < 0.7,+    persistent-vector ^>= 0.2.0,
+ src/Data/Vector/Persistent.hs view
@@ -0,0 +1,61 @@+-- |+-- The @'Vector' a@ type is an persistent vector of elements of type @a@.+--+-- This module should be imported qualified, to avoid name clashes with the "Prelude".+-- +-- Many operations have a average-case complexity of /O(log n)/.  The+-- implementation uses a large base (i.e. 32) so in practice these+-- operations are constant time.+--+-- = Comparison with Data.RRBVector and Data.Sequence+-- * Persistent vectors generally have less operations than sequences or RRBVectors but those operations can be faster.+-- * Persistent vectors have the fastest indexing.+-- * Persistent vectors are faster than RRBVectors at snocing because of tail optimization.+--   Snocing is a near constant time operation.+--   Snocing is still slower than sequences.+-- * RRBVectors are faster than persistent vectors at splitting and merging, but still slower than sequences.+-- * RRBVectors are faster than Sequences at indexing but slower than persistent vectors.+-- * Sequences have the fastest consing, snocing, and merging, but the slowest indexing.+-- +-- ![diagram](docs/diagram.png)+module Data.Vector.Persistent+  ( foldr,+    foldr',+    foldl,+    foldl',+    Vector ((:|>), Empty),+    (|>),+    empty,+    length,+    lookup,+    index,+    (!?),+    (!),+    update,+    adjust,+    adjustF,+    snoc,+    singleton,+    null,+    (//),+    (><),+    map,+    traverse,+    toList,+    fromList,+    unsnoc,+  )+where++import Data.Vector.Persistent.Internal+import Prelude hiding+  ( filter,+    foldl,+    foldr,+    length,+    lookup,+    map,+    null,+    reverse,+    traverse,+  )
+ src/Data/Vector/Persistent/Internal.hs view
@@ -0,0 +1,732 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE UnboxedTuples #-}++module Data.Vector.Persistent.Internal where++import Control.Applicative (Alternative, liftA2)+import qualified Control.Applicative+import Control.DeepSeq (NFData (rnf), NFData1, rnf1)+import qualified Control.DeepSeq+import Control.Monad (MonadPlus)+import qualified Control.Monad.Fail as Fail+import Control.Monad.Primitive (PrimMonad)+import Control.Monad.ST (runST)+import Data.Bits (Bits, unsafeShiftL, unsafeShiftR, (.&.))+import qualified Data.Foldable as Foldable+import Data.Functor.Classes+  ( Show1,+    liftShowsPrec,+    showsPrec1,+    showsUnaryWith,+  )+import Data.Functor.Identity (Identity (..))+import Data.Primitive.SmallArray+import Data.Stream.Monadic (Stream (Stream))+import qualified Data.Stream.Monadic as Stream+import qualified Data.Traversable as Traversable+import Data.Vector.Persistent.Internal.Array+import qualified Data.Vector.Persistent.Internal.Buffer as Buffer+import Data.Vector.Persistent.Internal.CoercibleUtils+import GHC.Exts (IsList)+import qualified GHC.Exts as Exts+import GHC.Stack (HasCallStack)+import Prelude hiding (init, length, lookup, map, null, tail)++#ifdef INSPECTION+{-# LANGUAGE TemplateHaskell #-}+import Test.Inspection+#endif++type role Vector representational++-- | A vector.+--+-- The instances are based on those of @Seq@s, which are in turn based on those of lists.+data Vector a = -- |+  -- Invariants: The only time tail can be empty is when init is empty.+  -- Otherwise tailOffset will give the wrong value.+  RootNode+  { size :: !Int,+    -- | 1 << 'shift' is the maximum that each child can contain+    shift :: !Int,+    init :: !(Array (Node a)),+    tail :: !(Array a)+  }++instance Show1 Vector where+  liftShowsPrec sp sl p v = showsUnaryWith (liftShowsPrec sp sl) "fromList" p (toList v)++instance Show a => Show (Vector a) where+  showsPrec = showsPrec1++instance Eq a => Eq (Vector a) where+  (==) = persistentVectorEq+  {-# INLINE (==) #-}++instance Ord a => Ord (Vector a) where+  compare = persistentVectorCompare+  {-# INLINE compare #-}++instance Functor Vector where+  fmap = Data.Vector.Persistent.Internal.map+  {-# INLINE fmap #-}++instance Foldable Vector where+  foldr = Data.Vector.Persistent.Internal.foldr+  {-# INLINE foldr #-}+  foldl = Data.Vector.Persistent.Internal.foldl+  {-# INLINE foldl #-}+  foldl' = Data.Vector.Persistent.Internal.foldl'+  {-# INLINE foldl' #-}+  foldr' = Data.Vector.Persistent.Internal.foldr'+  {-# INLINE foldr' #-}+  length = Data.Vector.Persistent.Internal.length+  {-# INLINE length #-}+  null = Data.Vector.Persistent.Internal.null+  {-# INLINE null #-}++instance Traversable Vector where+  traverse = Data.Vector.Persistent.Internal.traverse+  {-# INLINE traverse #-}++instance Semigroup (Vector a) where+  (<>) = (><)+  {-# INLINE (<>) #-}++instance Monoid (Vector a) where+  mempty = empty+  {-# INLINE mempty #-}++instance NFData a => NFData (Vector a) where+  rnf = rnf1+  {-# INLINE rnf #-}++instance Applicative Vector where+  pure = singleton+  {-# INLINE pure #-}+  fs <*> xs = foldl' (\acc f -> acc >< map f xs) empty fs++instance Monad Vector where+  xs >>= f = foldl' (\acc x -> acc >< f x) empty xs+  {-# INLINE (>>=) #-}++instance Fail.MonadFail Vector where+  fail _ = empty+  {-# INLINE fail #-}++instance Alternative Vector where+  empty = empty+  {-# INLINE empty #-}+  (<|>) = (><)+  {-# INLINE (<|>) #-}++instance MonadPlus Vector++instance NFData1 Vector where+  liftRnf f = foldl' (\_ x -> f x) ()+  {-# INLINE liftRnf #-}++data Node a+  = InternalNode {getInternalNode :: !(Array (Node a))}+  | DataNode {getDataNode :: !(Array a)}+  deriving (Show)++instance Eq a => Eq (Node a) where+  (==) = nodeEq+  {-# INLINE (==) #-}++instance Ord a => Ord (Node a) where+  compare = nodeCompare+  {-# INLINE compare #-}++instance IsList (Vector a) where+  type Item (Vector a) = a+  fromList = Data.Vector.Persistent.Internal.fromList+  {-# INLINE fromList #-}+  toList = Data.Vector.Persistent.Internal.toList+  {-# INLINE toList #-}++-- | \(O(n)\) Lazy right fold.+foldr :: (a -> b -> b) -> b -> Vector a -> b+foldr f z = runIdentity #. Stream.foldr f z . streamL+{-# INLINE foldr #-}++-- | \(O(n)\) Strict right fold.+foldr' :: (a -> b -> b) -> b -> Vector a -> b+foldr' f z = runIdentity #. Stream.foldl' (flip f) z . streamR+{-# INLINE foldr' #-}++-- | \(O(n)\) Lazy left fold.+foldl :: (b -> a -> b) -> b -> Vector a -> b+foldl f z = runIdentity #. Stream.foldr (flip f) z . streamR+{-# INLINE foldl #-}++-- | \(O(n)\) Strict left fold.+foldl' :: (b -> a -> b) -> b -> Vector a -> b+foldl' f z = runIdentity #. Stream.foldl' f z . streamL+{-# INLINE foldl' #-}++-- | \(O(n)\) Indexed lazy right fold.+ifoldr :: (Int -> a -> b -> b) -> b -> Vector a -> b+ifoldr f z = runIdentity #. Stream.foldr (uncurry f) z . istreamL+{-# INLINE ifoldr #-}++-- | \(O(n)\) Indexed lazy left fold.+ifoldl :: (Int -> b -> a -> b) -> b -> Vector a -> b+ifoldl f z = runIdentity #. Stream.foldr (\(i, x) y -> f i y x) z . istreamR+{-# INLINE ifoldl #-}++-- | \(O(n)\) Indexed strict right fold.+ifoldr' :: (Int -> a -> b -> b) -> b -> Vector a -> b+ifoldr' f z = runIdentity #. Stream.foldl' (\y (i, x) -> f i x y) z . istreamR+{-# INLINE ifoldr' #-}++-- | \(O(n)\) Indexed strict left fold.+ifoldl' :: (Int -> b -> a -> b) -> b -> Vector a -> b+ifoldl' f z = runIdentity #. Stream.foldl' (\y (i, x) -> f i y x) z . istreamL+{-# INLINE ifoldl' #-}++persistentVectorEq :: Eq a => Vector a -> Vector a -> Bool+persistentVectorEq+  RootNode {size, shift, init, tail}+  RootNode {size = size', shift = shift', init = init', tail = tail'} =+    size == size' && (size == 0 || (shift == shift' && tail == tail' && init == init'))+{-# INLINEABLE persistentVectorEq #-}++nodeEq :: Eq a => Node a -> Node a -> Bool+nodeEq (InternalNode ns) (InternalNode ns') = ns == ns'+nodeEq (DataNode as) (DataNode as') = as == as'+nodeEq _ _ = False+{-# INLINEABLE nodeEq #-}++persistentVectorCompare :: Ord a => Vector a -> Vector a -> Ordering+persistentVectorCompare+  RootNode {size, init, tail}+  RootNode {size = size', init = init', tail = tail'} =+    compare size size'+      <> if size == 0+        then EQ+        else compare init init' <> compare tail tail'+{-# INLINEABLE persistentVectorCompare #-}++nodeCompare :: Ord a => Node a -> Node a -> Ordering+nodeCompare (DataNode as) (DataNode as') = compare as as'+nodeCompare (InternalNode ns) (InternalNode ns') = compare ns ns'+nodeCompare (DataNode _) (InternalNode _) = LT+nodeCompare (InternalNode _) (DataNode _) = GT+{-# INLINEABLE nodeCompare #-}++-- | \(O(1)\). A vector with a single element.+singleton :: a -> Vector a+singleton a = RootNode {size = 1, shift = keyBits, tail = singletonSmallArray a, init = emptySmallArray}+{-# INLINE singleton #-}++-- | \(O(1)\). The empty vector.+empty :: Vector a+empty = RootNode {size = 0, shift = keyBits, init = emptySmallArray, tail = emptySmallArray}+{-# NOINLINE empty #-}++-- | \(O(1)\) Return 'True' if the vector is empty, 'False' otherwise.+null :: Vector a -> Bool+null xs = length xs == 0+{-# INLINE null #-}++-- | \(O(\log n)\). An alias for 'snoc'+-- Mnemonic: a triangle with the single element at the pointy end.+(|>) :: Vector a -> a -> Vector a+(|>) = snoc+{-# INLINE (|>) #-}++-- | \(O(\log n)\). A bidirectional pattern synonym viewing the rear of a non-empty+-- sequence.+pattern (:|>) :: Vector a -> a -> Vector a+pattern vec :|> x <-+  (unsnoc -> Just (vec, x))+  where+    vec :|> x = vec |> x++infixl 5 :|>++-- | \(O(1)\). A bidirectional pattern synonym matching an empty sequence.+pattern Empty :: Vector a+pattern Empty <-+  (null -> True)+  where+    Empty = empty++{-# COMPLETE (:|>), Empty #-}++-- | \(O(\log n)\) Add an element to the end of the vector.+snoc :: Vector a -> a -> Vector a+snoc vec@RootNode {size, tail} a+  -- Room in tail, and vector non-empty+  | (size .&. keyMask) /= 0 =+      vec+        { tail = updateResizeSmallArray tail (size .&. keyMask) a,+          size = size + 1+        }+  | otherwise = snocArr vec 1 $ singletonSmallArray a+{-# INLINEABLE snoc #-}++-- Invariant: the tail must be large enough to mutably write to it+-- Best to use this with emptyMaxTail+-- After calling this many times you must run shrink+unsafeSnoc :: Vector a -> a -> Vector a+unsafeSnoc vec@RootNode {size, tail} a+  -- Room in tail, and vector non-empty+  | (size .&. keyMask) /= 0 =+      vec+        { tail =+            -- update the array in place+            runST $ do+              marr <- unsafeThawSmallArray tail+              writeSmallArray marr (size .&. keyMask) a+              unsafeFreezeSmallArray marr,+          size = size + 1+        }+  | otherwise = snocArr vec 1 $ singletonSmallArray a+{-# INLINEABLE unsafeSnoc #-}++-- Invariant: arr cannot be empty+snocArr ::+  -- | The Vector to perform the operation on+  Vector a ->+  -- | The the added size. We can't find this from the array because the array might have bogus size due to undefined elements+  Int ->+  -- | The array to add as the new tail+  Array a ->+  Vector a+snocArr vec@RootNode {size, shift, tail} addedSize arr+  | null vec =+      RootNode+        { size = addedSize,+          shift = keyBits,+          tail = arr,+          init = emptySmallArray+        }+  | size !>>. keyBits > 1 !<<. shift =+      RootNode+        { size = size + addedSize,+          shift = shift + keyBits,+          init =+            let !path = newPath shift tail+                !internal = InternalNode $ init vec+             in twoSmallArray internal path,+          tail = arr+        }+  | otherwise =+      RootNode+        { size = size + addedSize,+          shift,+          init = snocTail size tail shift $ init vec,+          tail = arr+        }+{-# INLINE snocArr #-}++snocTail :: Int -> Array a -> Int -> Array (Node a) -> Array (Node a)+snocTail size tail = go+  where+    go !level !parent = updateResizeSmallArray parent subIx toInsert+      where+        toInsert+          | level == keyBits = DataNode tail+          | subIx < sizeofSmallArray parent =+              let vec' = indexSmallArray parent subIx+               in InternalNode $ go (level - keyBits) (getInternalNode vec')+          | otherwise = newPath (level - keyBits) tail+        subIx = ((size - 1) !>>. level) .&. keyMask+{-# INLINE snocTail #-}++newPath :: Int -> Array a -> Node a+newPath 0 tail = DataNode tail+newPath level tail = InternalNode $ singletonSmallArray $! newPath (level - keyBits) tail++unsafeIndex :: Vector a -> Int -> a+unsafeIndex vec ix | (# a #) <- Exts.inline unsafeIndex# vec ix = a+{-# NOINLINE unsafeIndex #-}++unsafeIndex# :: Vector a -> Int -> (# a #)+unsafeIndex# vec ix+  | ix >= tailOffset vec = indexSmallArray## (tail vec) (ix .&. keyMask)+  -- no need to use keyMask here as we are at the top+  | otherwise = go ix (shift vec - keyBits) (indexSmallArray (init vec) (ix !>>. shift vec))+  where+    go ix 0 !node = indexSmallArray## (getDataNode node) (ix .&. keyMask)+    go ix level !node = go ix (level - keyBits) (indexSmallArray (getInternalNode node) ix')+      where+        ix' = (ix !>>. level) .&. keyMask+{-# NOINLINE unsafeIndex# #-}++lookup# :: Int -> Vector a -> (# (# #)| a #)+lookup# ix vec+  | (fromIntegral ix :: Word) >= fromIntegral (length vec) = (# (##) | #)+  | otherwise = case Exts.inline unsafeIndex# vec ix of (# x #) -> (# | x #)+{-# NOINLINE lookup# #-}++-- | \(O(\log n)\). The element at the index or 'Nothing' if the index is out of range.+lookup :: Int -> Vector a -> Maybe a+lookup ix vec+  | (fromIntegral ix :: Word) >= fromIntegral (length vec) = Nothing+  | otherwise = case unsafeIndex# vec ix of (# x #) -> Just x+{-# INLINE lookup #-}++-- | \(O(\log n)\). The element at the index. Calls 'error' if the index is out of range.+index :: HasCallStack => Int -> Vector a -> a+index ix vec+  | ix < 0 = moduleError "index" $ "negative index: " ++ show ix+  | ix >= length vec = moduleError "index" $ "index too large: " ++ show ix+  | otherwise = Exts.inline unsafeIndex vec ix+{-# INLINEABLE index #-}++-- | \(O(\log n)\). A flipped version of 'index'.+(!) :: HasCallStack => Vector a -> Int -> a+(!) = flip index+{-# INLINE (!) #-}++-- | \(O(\log n)\). A flipped version of 'lookup'.+(!?) :: Vector a -> Int -> Maybe a+(!?) = flip lookup+{-# INLINE (!?) #-}++-- | \(O(\log n)\). Adjust the element at the index by applying the function to it.+-- If the index is out of range, the original vector is returned.+adjust :: (a -> a) -> Int -> Vector a -> Vector a+adjust f = adjust# $ \x -> (# f x #)+{-# INLINE adjust #-}++adjust# :: (a -> (# a #)) -> Int -> Vector a -> Vector a+adjust# f ix vec@RootNode {size, shift, tail}+  -- Invalid index. This funny business uses a single test to determine whether+  -- ix is too small (negative) or too large (at least sz).+  | (fromIntegral ix :: Word) >= fromIntegral size = vec+  | ix >= tailOffset vec = vec {tail = modifySmallArray# tail (ix .&. keyMask) f}+  | otherwise = vec {init = go ix shift (init vec)}+  where+    go ix level vec+      | level == keyBits,+        let !node = DataNode $ modifySmallArray# (getDataNode vec') (ix .&. keyMask) f =+          updateSmallArray vec ix' node+      | otherwise,+        let !node = go ix (level - keyBits) (getInternalNode vec') =+          updateSmallArray vec ix' $! InternalNode node+      where+        ix' = (ix !>>. level) .&. keyBits+        vec' = indexSmallArray vec ix'+{-# INLINE adjust# #-}++-- | \(O(\log n)\). Same as 'adjust' but can have effects through 'Applicative'+adjustF :: Applicative f => (a -> f a) -> Int -> Vector a -> f (Vector a)+adjustF f ix vec@RootNode {size, shift, tail}+  -- 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 size = pure vec+  | ix >= tailOffset vec = (\tail -> vec {tail}) <$> modifySmallArrayF tail (ix .&. keyMask) f+  | otherwise = (\init -> vec {init}) <$> go ix shift (init vec)+  where+    go ix level vec+      | level == keyBits =+          (\node' -> updateSmallArray vec ix' $! DataNode node')+            <$> modifySmallArrayF (getDataNode vec') (ix .&. keyMask) f+      | otherwise =+          (\node -> updateSmallArray vec ix' $! InternalNode node)+            <$> go ix (level - keyBits) (getInternalNode vec')+      where+        ix' = (ix !>>. level) .&. keyBits+        vec' = indexSmallArray vec ix'+{-# INLINE adjustF #-}++-- | \(O(\log n)\). Replace the element at the specified position.+-- If the position is out of range, the original sequence is returned.+update :: Int -> a -> Vector a -> Vector a+-- we could use adjust# (\_ -> (# x #)) to implement this+-- and the const like function would get optimized out+-- but we don't because we don't want to create any closures for the go function+-- so we rewrite out the loop and also lambda lift some arguments+-- also: trees are very shallow, so the loop won't be called much.+-- So allocating a closure to not have pass the arguments on the stack has too much overhead+update ix x vec@RootNode {size, shift, tail}+  -- 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 size = vec+  | ix >= tailOffset vec = vec {tail = updateSmallArray tail (ix .&. keyMask) x}+  | otherwise = vec {init = go ix x shift (init vec)}+  where+    go ix x level vec+      | level == keyBits =+          let !node = DataNode $ updateSmallArray (getDataNode vec') (ix .&. keyMask) x+           in updateSmallArray vec ix' node+      | otherwise =+          let !node = go ix x (level - keyBits) (getInternalNode vec')+           in updateSmallArray vec ix' $! InternalNode node+      where+        ix' = (ix !>>. level) .&. keyMask+        vec' = indexSmallArray vec ix'+{-# INLINEABLE update #-}++-- | \(O(\log n)\). Decompose a list into its head and tail.+--+-- * If the list is empty, returns 'Nothing'.+-- * If the list is non-empty, returns @'Just' (x, xs)@,+-- where @x@ is the head of the list and @xs@ its tail.+unsnoc :: Vector a -> Maybe (Vector a, a)+unsnoc vec@RootNode {size, tail, init, shift}+  | 0 <- size = Nothing+  -- we need to have this case because we can't run unsnocTail, there is nothing left in the tail+  | 1 <- size, (# x #) <- indexSmallArray## tail 0 = Just (empty, x)+  | nullSmallArray tail',+    (# init', tail' #) <- unsnocTail# size shift init =+      Just (vec {size = size - 1, init = init', tail = tail'}, a)+  | otherwise = Just (vec {size = size - 1, tail = tail'}, a)+  where+    a = lastSmallArray tail+    tail' = popSmallArray tail+{-# INLINEABLE unsnoc #-}++unsnocTail# :: Int -> Int -> Array (Node a) -> (# Array (Node a), Array a #)+unsnocTail# = go+  where+    go size !level !parent+      | level == keyBits = (# popSmallArray parent, getDataNode child #)+      | otherwise = do+          let (# child', tail #) = go size (level - keyBits) (getInternalNode child)+          if nullSmallArray child'+            then (# popSmallArray parent, tail #)+            else (# updateSmallArray parent subIx $ InternalNode child', tail #)+      where+        child = indexSmallArray parent subIx+        -- we need to subtract 2 because the first subtraction gets us to the tail element+        -- the second subtraction gets to the last element in the tree+        subIx = ((size - 2) !>>. level) .&. keyMask+{-# INLINE unsnocTail# #-}++-- | 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.+--+-- Caution: Only gives a sensible result if the vector is nonempty.+tailOffset :: Vector a -> Int+tailOffset vec = (length vec - 1) .&. ((-1) !<<. keyBits)+{-# INLINE tailOffset #-}++-- | \(O(1)\) Get the length of the vector.+length :: Vector a -> Int+length = size+{-# INLINE length #-}++impossibleError :: forall a. a+impossibleError = error "this should be impossible"++moduleError :: forall a. HasCallStack => String -> String -> a+moduleError fun msg = error ("Data.Vector.Persistent.Internal" ++ fun ++ ':' : ' ' : msg)+{-# NOINLINE moduleError #-}++toList :: Vector a -> [a]+toList = pureStreamToList . streamL+{-# INLINE toList #-}++-- | Convert a 'Stream' to a list+pureStreamToList :: Stream Identity a -> [a]+pureStreamToList s = Exts.build (\c n -> runIdentity $ Stream.foldr c n s)+{-# INLINE pureStreamToList #-}++-- | \(O(n)\). Apply a function to all values in the vector.+map :: (a -> b) -> Vector a -> Vector b+map f vec@RootNode {init, tail} = vec {tail = fmap f tail, init = mapSmallArray' go init}+  where+    go (DataNode as) = DataNode $ fmap f as+    go (InternalNode ns) = InternalNode $ mapSmallArray' go ns+{-# INLINE map #-}++-- | \(O(n)\). Apply a function to all values of a vector and its index.+imap :: (Int -> a -> b) -> Vector a -> Vector b+imap f vec@RootNode {size, shift, init, tail}+  | size == 0 = empty+  | otherwise =+      vec+        { init = imapStepSmallArray 0 (1 !<<. shift) (go $! shift - keyBits) init,+          tail = imapStepSmallArray (tailOffset vec) 1 f tail+        }+  where+    go _shift i0 (DataNode as) = DataNode $ imapStepSmallArray i0 1 f as+    go shift i0 (InternalNode ns) = InternalNode $ imapStepSmallArray i0 (1 !<<. shift) (go $! shift - keyBits) ns+{-# INLINE imap #-}++traverse :: Applicative f => (a -> f b) -> Vector a -> f (Vector b)+traverse f vec@RootNode {init, tail} =+  liftA2+    (\init tail -> vec {init, tail})+    (Traversable.traverse go init)+    (Traversable.traverse f tail)+  where+    go (DataNode as) = DataNode <$> Traversable.traverse f as+    go (InternalNode ns) = InternalNode <$> Traversable.traverse go ns+{-# INLINE traverse #-}++itraverse :: Applicative f => (Int -> a -> f b) -> Vector a -> f (Vector b)+itraverse f vec@RootNode {size, shift, init, tail}+  | size == 0 = pure empty+  | otherwise =+      liftA2+        (\init tail -> vec {init, tail})+        (itraverseStepSmallArray 0 (1 !<<. shift) (go $! shift - keyBits) init)+        (itraverseStepSmallArray (tailOffset vec) 1 f tail)+  where+    go _shift i0 (DataNode as) = DataNode <$> itraverseStepSmallArray i0 1 f as+    go shift i0 (InternalNode ns) = InternalNode <$> itraverseStepSmallArray i0 (1 !<<. shift) (go $! shift - keyBits) ns+{-# INLINE itraverse #-}++-- | \(O(n)\). For each pair @(i,a)@ from the vector of index/value pairs,+-- replace the vector element at position @i@ by @a@.+--+-- > update <5,9,2,7> <(2,1),(0,3),(2,8)> = <3,9,8,7>+(//) :: Vector a -> [(Int, a)] -> Vector a+(//) = Exts.inline Foldable.foldl' $ flip $ uncurry update++-- | \(O(n)\). Concatenate two vectors.+(><) :: Vector a -> Vector a -> Vector a+(><) = Exts.inline foldl' snoc++-- | Check the invariant of the vector+invariant :: Vector a -> Bool+invariant _vec = True++-- | \(O(n)\). Create a vector from a list.+fromList :: [a] -> Vector a+fromList = unstream . Stream.fromList++keyBits :: Int+#ifdef TEST+keyBits = 1+#else+keyBits = 5+#endif++nodeWidth :: Int+nodeWidth = 1 !<<. keyBits++keyMask :: Int+keyMask = nodeWidth - 1++(!<<.) :: Bits a => a -> Int -> a+(!<<.) = unsafeShiftL+{-# INLINE (!<<.) #-}++(!>>.) :: Bits a => a -> Int -> a+(!>>.) = unsafeShiftR+{-# INLINE (!>>.) #-}++infixl 8 !<<., !>>.++unstream :: Stream Identity a -> Vector a+unstream stream = runST $ do+  streamToContents stream >>= \case+    (size, tail, [tree]) ->+      pure RootNode {size, shift = keyBits, tail, init = pure tree}+    (size, tail, ls') -> do+      let iterateNodes !shift trees =+            nodes (Prelude.reverse trees) >>= \case+              [tree] -> pure RootNode {size, shift, tail, init = getInternalNode tree}+              trees' -> iterateNodes (shift + keyBits) trees'+      iterateNodes keyBits ls'+  where+    nodes trees = do+      buffer <- Buffer.newWithCapacity nodeWidth+      (buffer, acc) <-+        Foldable.foldlM+          ( \(!buffer, acc) t ->+              if Buffer.length buffer == nodeWidth+                then do+                  result <- Buffer.freeze buffer+                  buffer <- Buffer.push t $ Buffer.clear buffer+                  pure (buffer, InternalNode result : acc)+                else do+                  buffer <- Buffer.push t buffer+                  pure (buffer, acc)+          )+          (buffer, [])+          trees+      final <- Buffer.unsafeFreeze buffer+      pure $ InternalNode final : acc+{-# INLINE unstream #-}++streamToContents :: PrimMonad m => Stream Identity a -> m (Int, SmallArray a, [Node a])+streamToContents (Stream step s) = do+  buffer <- Buffer.newWithCapacity nodeWidth+  loop (0 :: Int) buffer [] s+  where+    loop !size !buffer acc s = do+      case runIdentity $ step s of+        Stream.Yield x s' -> do+          if Buffer.length buffer == nodeWidth+            then do+              result <- Buffer.freeze buffer+              buffer <- Buffer.push x $ Buffer.clear buffer+              loop (size + 1) buffer (DataNode result : acc) s'+            else do+              buffer <- Buffer.push x buffer+              loop (size + 1) buffer acc s'+        Stream.Skip s' -> loop size buffer acc s'+        Stream.Done -> do+          tail <- Buffer.unsafeFreeze buffer+          pure (size, tail, acc)+{-# INLINE streamToContents #-}++streamL :: Monad m => Vector a -> Stream m a+streamL RootNode {init, tail} = Stream step [(InternalNode init, 0 :: Int), (DataNode tail, 0)]+  where+    step [] = pure Stream.Done+    step ((n, i) : rest) = case n of+      InternalNode ns+        | i >= sizeofSmallArray ns -> pure $ Stream.Skip rest+        | otherwise -> do+            let !(# ns' #) = indexSmallArray## ns i+                !i' = i + 1+            pure $ Stream.Skip $ (ns', 0) : (n, i') : rest+      DataNode xs+        | i >= sizeofSmallArray xs -> pure $ Stream.Skip rest+        | otherwise -> do+            let !(# x #) = indexSmallArray## xs i+                !i' = i + 1+            pure $ Stream.Yield x $ (n, i') : rest+    {-# INLINE step #-}+{-# INLINE streamL #-}++streamR :: Monad m => Vector a -> Stream m a+streamR RootNode {init, tail} = Stream step [(DataNode tail, tailSize), (InternalNode init, initSize)]+  where+    !tailSize = sizeofSmallArray tail - 1+    !initSize = sizeofSmallArray init - 1++    step [] = pure Stream.Done+    step ((n, i) : rest) = case n of+      InternalNode ns+        | i < 0 -> pure $ Stream.Skip rest+        | otherwise -> do+            let !(# n' #) = indexSmallArray## ns i+                !i' = i - 1+            pure $ case n' of+              InternalNode ns -> do+                let !z = sizeofSmallArray ns - 1+                Stream.Skip $ (n', z) : (n, i') : rest+              DataNode xs -> do+                let !z = sizeofSmallArray xs - 1+                Stream.Skip $ (n', z) : (n, i') : rest+      DataNode xs+        | i < 0 -> pure $ Stream.Skip rest+        | otherwise -> do+            let !(# x #) = indexSmallArray## xs i+                !i' = i - 1+            pure $ Stream.Yield x $ (n, i') : rest+    {-# INLINE step #-}+{-# INLINE streamR #-}++istreamL :: Monad m => Vector a -> Stream m (Int, a)+istreamL = Stream.indexed . streamL+{-# INLINE istreamL #-}++istreamR :: Monad m => Vector a -> Stream m (Int, a)+istreamR vec = Stream.indexedR (length vec - 1) $ streamR vec+{-# INLINE istreamR #-}
+ src/Data/Vector/Persistent/Internal/Array.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE UnboxedTuples #-}++module Data.Vector.Persistent.Internal.Array+  ( Array,+    MArray,+    nullSmallArray,+    lastSmallArray,+    singletonSmallArray,+    twoSmallArray,+    updateSmallArray,+    modifySmallArray,+    modifySmallArrayF,+    modifySmallArray',+    updateResizeSmallArray,+    popSmallArray,+    undefinedElem,+    ifoldrStepSmallArray,+    ifoldlStepSmallArray,+    ifoldrStepSmallArray',+    ifoldlStepSmallArray',+    imapStepSmallArray,+    imapStepSmallArray',+    itraverseStepSmallArray,+    modifySmallArray#,+    mapSmallArray#,+    shrinkSmallMutableArray_,+  )+where++import Control.Applicative (liftA2)+import Control.Monad (when)+import Control.Monad.Primitive (PrimMonad, PrimState)+import Control.Monad.ST (ST, runST)+import Data.Coerce (coerce)+import Data.Functor (($>))+import Data.Functor.Identity (Identity (..))+import qualified Data.Primitive as Primitive+import Data.Primitive.SmallArray+import GHC.Exts (SmallMutableArray#)++type Array = SmallArray++type MArray = SmallMutableArray++-- | Used to support older ghcs.+shrinkSmallMutableArray_ :: PrimMonad m => MArray (PrimState m) a -> Int -> m (MArray (PrimState m) a)+#if __GLASGOW_HASKELL__ >= 810+shrinkSmallMutableArray_ marr n = Primitive.shrinkSmallMutableArray marr n $> marr+#else+shrinkSmallMutableArray_ mary n = Primitive.cloneSmallMutableArray mary 0 n+#endif +{-# INLINE shrinkSmallMutableArray_ #-}++mapSmallArray# :: (a -> (# b #)) -> SmallArray a -> SmallArray b+mapSmallArray# f sa = createSmallArray (length sa) (error "mapSmallArray#") $ \smb -> do+  let go i =+        when (i < length sa) $ do+          x <- indexSmallArrayM sa i+          let !(# y #) = f x+          writeSmallArray smb i y *> go (i + 1)+  go 0+{-# INLINE mapSmallArray# #-}++nullSmallArray :: SmallArray a -> Bool+nullSmallArray arr = sizeofSmallArray arr == 0+{-# INLINE nullSmallArray #-}++lastSmallArray :: SmallArray a -> a+lastSmallArray arr = indexSmallArray arr $ sizeofSmallArray arr++singletonSmallArray :: a -> Array a+singletonSmallArray a = runSmallArray $ newSmallArray 1 a+{-# INLINE singletonSmallArray #-}++twoSmallArray :: a -> a -> Array a+twoSmallArray x y = runSmallArray $ do+  marr <- newSmallArray 2 x+  writeSmallArray marr 1 y+  pure marr+{-# INLINE twoSmallArray #-}++updateSmallArray :: Array a -> Int -> a -> Array a+updateSmallArray arr i x = modifySmallArray# arr i $ \_ -> (# x #)+{-# INLINE updateSmallArray #-}++modifySmallArray :: Array a -> Int -> (a -> a) -> Array a+modifySmallArray arr i f = modifySmallArray# arr i $ \x -> (# f x #)+{-# INLINE modifySmallArray #-}++modifySmallArrayF :: Functor f => Array a -> Int -> (a -> f a) -> f (Array a)+modifySmallArrayF arr i f | (# x #) <- indexSmallArray## arr i = updateSmallArray arr i <$> f x+{-# INLINE modifySmallArrayF #-}++modifySmallArray' :: Array a -> Int -> (a -> a) -> Array a+modifySmallArray' arr i f = modifySmallArray# arr i $ \x -> let !x' = f x in (# x' #)+{-# INLINE modifySmallArray' #-}++modifySmallArray# :: Array a -> Int -> (a -> (# a #)) -> Array a+modifySmallArray# arr i f = runSmallArray $ do+  marr <- thawSmallArray arr 0 $ sizeofSmallArray arr+  x <- indexSmallArrayM arr i+  let !(# x' #) = f x+  writeSmallArray marr i x'+  pure marr+{-# INLINE modifySmallArray# #-}++updateResizeSmallArray :: Array a -> Int -> a -> Array a+updateResizeSmallArray arr i a = runSmallArray $ do+  marr <- thawSmallArray arr 0 (max len (i + 1))+  writeSmallArray marr i a+  pure marr+  where+    len = sizeofSmallArray arr+{-# INLINE updateResizeSmallArray #-}++popSmallArray :: Array a -> Array a+popSmallArray arr = runSmallArray $ thawSmallArray arr 0 (sizeofSmallArray arr - 1)+{-# INLINE popSmallArray #-}++undefinedElem :: forall a. a+undefinedElem = error "undefined element"+{-# NOINLINE undefinedElem #-}++ifoldrStepSmallArray :: Int -> Int -> (Int -> a -> b -> b) -> b -> SmallArray a -> b+ifoldrStepSmallArray i0 step f z arr = do+  let len = sizeofSmallArray arr+      go i j+        | i == len = z+        | (# x #) <- indexSmallArray## arr i = f j x (go (i + 1) $! j + step)+  go 0 i0+{-# INLINE ifoldrStepSmallArray #-}++ifoldlStepSmallArray :: Int -> Int -> (Int -> b -> a -> b) -> b -> SmallArray a -> b+ifoldlStepSmallArray i0 step f z arr = do+  let len = sizeofSmallArray arr+      go i j+        | i < 0 = z+        | (# x #) <- indexSmallArray## arr i = f j (go (i - 1) $! j - step) x+  go (len - 1) i0+{-# INLINE ifoldlStepSmallArray #-}++ifoldrStepSmallArray' :: Int -> Int -> (Int -> a -> b -> b) -> b -> SmallArray a -> b+ifoldrStepSmallArray' i0 step f z arr = do+  let go i j acc+        | i < 0 = acc+        | (# x #) <- indexSmallArray## arr i = (go (i - 1) $! (j - step)) $! f j x acc+  go (sizeofSmallArray arr) i0 z+{-# INLINE ifoldrStepSmallArray' #-}++ifoldlStepSmallArray' :: Int -> Int -> (Int -> b -> a -> b) -> b -> SmallArray a -> b+ifoldlStepSmallArray' i0 step f z arr = do+  let go i j acc+        | i == sizeofSmallArray arr = acc+        | (# x #) <- indexSmallArray## arr i = (go (i + 1) $! (j + step)) $! f j acc x+  go 0 i0 z+{-# INLINE ifoldlStepSmallArray' #-}++imapStepSmallArray :: Int -> Int -> (Int -> a -> b) -> SmallArray a -> SmallArray b+imapStepSmallArray i0 step f arr = createSmallArray len undefinedElem $ \marr -> do+  let go i k = when (i < len) $ do+        x <- indexSmallArrayM arr i+        writeSmallArray marr i (f k x)+        go (i + 1) $! k + step+  go 0 i0+  where+    len = sizeofSmallArray arr+{-# INLINE imapStepSmallArray #-}++imapStepSmallArray' :: Int -> (a -> Int) -> (Int -> a -> b) -> SmallArray a -> SmallArray b+imapStepSmallArray' i0 step f arr = createSmallArray len undefinedElem $ \marr -> do+  let go i k = when (i < len) $ do+        x <- indexSmallArrayM arr i+        writeSmallArray marr i $! f k x+        go (i + 1) $! k + step x+  go 0 i0+  where+    len = sizeofSmallArray arr+{-# INLINE imapStepSmallArray' #-}++newtype STA a = STA {_runSTA :: forall s. SmallMutableArray# s a -> ST s (SmallArray a)}++runSTA :: Int -> STA a -> SmallArray a+runSTA !sz = \(STA m) ->+  runST $+    newSmallArray sz undefinedElem+      >>= \(SmallMutableArray ar#) -> m ar#++itraverseStepSmallArray :: Applicative f => Int -> Int -> (Int -> a -> f b) -> SmallArray a -> f (SmallArray b)+itraverseStepSmallArray i0 step f = \ !arr -> do+  let len = sizeofSmallArray arr+      go i k+        | i == len =+            pure $ STA $ \marr -> unsafeFreezeSmallArray (SmallMutableArray marr)+        | (# x #) <- indexSmallArray## arr i =+            liftA2+              (\b (STA m) -> STA $ \marr -> writeSmallArray (SmallMutableArray marr) i b >> m marr)+              (f k x)+              (go (i + 1) $! k + step)+  if len == 0+    then pure emptySmallArray+    else runSTA len <$> go 0 i0+{-# INLINE [1] itraverseStepSmallArray #-}++{-# RULES+"itraverseStepSmallArray/ST" forall i0 step (f :: Int -> a -> ST s b).+  itraverseStepSmallArray i0 step f =+    itraverseStepSmallArrayP i0 step f+"itraverseStepSmallArray/IO" forall i0 step (f :: Int -> a -> IO b).+  itraverseStepSmallArray i0 step f =+    itraverseStepSmallArrayP i0 step f+"itraverseStepSmallArray/Id" forall i0 step (f :: Int -> a -> Identity b).+  itraverseStepSmallArray i0 step f =+    ( coerce ::+        (SmallArray a -> SmallArray (Identity b)) ->+        SmallArray a ->+        Identity (SmallArray b)+    )+      (imapStepSmallArray i0 step f)+  #-}++-- | This is the fastest, most straightforward way to traverse+-- an array, but it only works correctly with a sufficiently+-- "affine" 'PrimMonad' instance. In particular, it must only produce+-- /one/ result array. 'Control.Monad.Trans.List.ListT'-transformed+-- monads, for example, will not work right at all.+itraverseStepSmallArrayP :: PrimMonad m => Int -> Int -> (Int -> a -> m b) -> SmallArray a -> m (SmallArray b)+itraverseStepSmallArrayP i0 step f = \ !ary -> do+  let len = sizeofSmallArray ary+      go i k marr+        | i == len = unsafeFreezeSmallArray marr+        | otherwise = do+            a <- indexSmallArrayM ary i+            b <- f k a+            writeSmallArray marr i b+            (go (i + 1) $! k + step) marr+  marr <- newSmallArray len undefinedElem+  go 0 i0 marr+{-# INLINE itraverseStepSmallArrayP #-}
+ src/Data/Vector/Persistent/Internal/Buffer.hs view
@@ -0,0 +1,94 @@+module Data.Vector.Persistent.Internal.Buffer where++import Control.Monad.Primitive+import Data.Primitive.SmallArray+import Data.Vector.Persistent.Internal.Array (shrinkSmallMutableArray_)+import Prelude hiding (length)++data Buffer s a = Buffer+  { offset :: !Int,+    marr :: !(SmallMutableArray s a)+  }++new :: (PrimMonad m, s ~ PrimState m) => m (Buffer s a)+new = do+  marr <- newSmallArray 0 undefinedElem+  pure Buffer {offset = 0, marr}+{-# INLINE new #-}++newWithCapacity :: (PrimMonad m, s ~ PrimState m) => Int -> m (Buffer s a)+newWithCapacity cap = do+  marr <- newSmallArray cap undefinedElem+  pure Buffer {offset = 0, marr}+{-# INLINE newWithCapacity #-}++push :: (PrimMonad m, s ~ PrimState m) => a -> Buffer s a -> m (Buffer s a)+push a buffer = do+  buffer' <-+    if length buffer == capacity buffer+      then resize buffer+      else pure buffer+  writeSmallArray (marr buffer') (length buffer) a+  pure buffer' {offset = offset buffer' + 1}+{-# INLINE push #-}++read :: (PrimMonad m, s ~ PrimState m) => Int -> Buffer s a -> m a+read i Buffer {marr} = readSmallArray marr i+{-# INLINE read #-}++write :: (PrimMonad m, s ~ PrimState m) => Int -> a -> Buffer s a -> m ()+write i a Buffer {marr} = writeSmallArray marr i a+{-# INLINE write #-}++clear :: Buffer s a -> Buffer s a+clear = shrink 0+{-# INLINE clear #-}++shrink :: Int -> Buffer s a -> Buffer s a+shrink i buffer = buffer {offset = i}+{-# INLINE shrink #-}++unsafeShrink :: (PrimMonad m, s ~ PrimState m) => Int -> Buffer s a -> m (Buffer s a)+unsafeShrink i Buffer {marr} = do+  marr <- shrinkSmallMutableArray_ marr i+  pure Buffer {marr, offset = i}+{-# INLINE unsafeShrink #-}++capacity :: Buffer s a -> Int+capacity Buffer {marr} = sizeofSmallMutableArray marr+{-# INLINE capacity #-}++null :: Buffer s a -> Bool+null = (0 ==) . length++length :: Buffer s a -> Int+length = offset+{-# INLINE length #-}++undefinedElem :: forall a. a+undefinedElem = error "undefined element"+{-# NOINLINE undefinedElem #-}++resize :: (PrimMonad m, s ~ PrimState m) => Buffer s a -> m (Buffer s a)+resize buffer = do+  if capacity buffer == 0+    then grow 32 buffer+    else grow (capacity buffer) buffer+{-# INLINE resize #-}++grow :: (PrimMonad m, s ~ PrimState m) => Int -> Buffer s a -> m (Buffer s a)+grow more buffer@Buffer {marr, offset} = do+  marr' <- newSmallArray (sizeofSmallMutableArray marr + more) undefinedElem+  copySmallMutableArray marr' 0 marr 0 offset+  pure buffer {marr = marr'}+{-# INLINE grow #-}++freeze :: (PrimMonad m, s ~ PrimState m) => Buffer s a -> m (SmallArray a)+freeze Buffer {marr, offset} = freezeSmallArray marr 0 offset+{-# INLINE freeze #-}++unsafeFreeze :: (PrimMonad m, s ~ PrimState m) => Buffer s a -> m (SmallArray a)+unsafeFreeze Buffer {marr, offset} = do+  marr <- shrinkSmallMutableArray_ marr offset+  unsafeFreezeSmallArray marr+{-# INLINE unsafeFreeze #-}
+ src/Data/Vector/Persistent/Internal/CoercibleUtils.hs view
@@ -0,0 +1,37 @@+module Data.Vector.Persistent.Internal.CoercibleUtils where++import Data.Coerce (Coercible, coerce)++-- | Coercive left-composition.+--+-- >>> (All #. not) True+-- All {getAll = False}+--+-- The semantics with respect to bottoms are:+--+-- @+-- p '#.' ⊥ ≡ ⊥+-- p '#.' f ≡ p '.' f+-- @+infixr 9 #.++(#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c+(#.) _ = coerce+{-# INLINE (#.) #-}++-- | Coercive right-composition.+--+-- >>> (stimes 2 .# Product) 3+-- Product {getProduct = 9}+--+-- The semantics with respect to bottoms are:+--+-- @+-- ⊥ '.#' p ≡ ⊥+-- f '.#' p ≡ p '.' f+-- @+infixr 9 .#++(.#) :: Coercible a b => (b -> c) -> (a -> b) -> a -> c+(.#) f _ = coerce f+{-# INLINE (.#) #-}
+ src/Data/Vector/Persistent/Unsafe.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE MagicHash #-}++module Data.Vector.Persistent.Unsafe+  ( unsafeIndex,+    unsafeIndex#,+  )+where++import Data.Vector.Persistent.Internal
+ test/PersistentVectorSpec.hs view
@@ -0,0 +1,132 @@+module PersistentVectorSpec (spec) where++import Data.Foldable (foldl')+import Data.Function ((&))+import Data.Primitive.SmallArray+import Data.Vector.Persistent (Vector)+import qualified Data.Vector.Persistent.Internal as Vector+import Data.Vector.Persistent.Internal.Array+import GHC.Exts (fromList, toList)+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++spec :: Spec+spec = parallel $ do+  prop "toList fromList identity" $ \(l :: [Int]) ->+    l === toList (fromList @(Vector _) l)++  prop "fmap" fmapProp++  prop "foldr" $ \(l :: [Int]) ->+    foldr (:) [] l === foldr (:) [] (fromList @(Vector _) l)++  prop "foldl" $ \(l :: [Int]) ->+    foldl (flip (:)) [] l === foldl (flip (:)) [] (fromList @(Vector _) l)++  it "update bad" $+    propUpdate+      64+      0+      ((repeat 0 & take 64) ++ [1] ++ (repeat 0 & take 32))++  -- this is somehow broken+  prop "update" propUpdate+  -- prop "update" $ \(ix :: Int) (a :: Int) (l :: [Int]) ->+  --   ix >= 0 ==> do+  --     let arr = fromList @(Array _) l+  --         arr'+  --           | ix >= sizeofSmallArray arr = arr+  --           | otherwise = updateSmallArray arr ix a+  -- toList arr' == toList (Vector.update ix a $ fromList @(Vector _) l)++  prop "traverse" $ \(l :: [Int]) -> do+    let go a = ([a], a)+    fmap toList (traverse go (fromList @(Vector _) l)) === traverse go l++  prop "index" indexProp++  it "index weierd" $ indexProp 9 [1 :: Int .. 15]++  prop "eq self" $ \(l :: [Int]) ->+    fromList @(Vector _) l === fromList l++  prop "eq" $ \(l :: [Int]) (l' :: [Int]) ->+    (l == l') === (fromList @(Vector _) l == fromList @(Vector _) l')++  prop "mappend" $ \(l :: [Int]) (l' :: [Int]) ->+    l <> l' === toList (fromList @(Vector _) l <> fromList @(Vector _) l')++  it "unsnoc bad" $ unsnocProp (replicate 65 0) 1++  prop "unsnoc" unsnocProp++  prop "snoc unsnoc" snocUnsnocProp++  describe "indexed" $ do+    prop "imap" $ \(l :: [Int]) ->+      zip [0 :: Int ..] l === toList (Vector.imap (,) (fromList @(Vector _) l))++propUpdate :: Int -> Int -> [Int] -> Property+propUpdate ix a l =+  ix >= 0 ==> do+    let arr = fromList @(Array _) l+        arr'+          | ix >= sizeofSmallArray arr = arr+          | otherwise = updateSmallArray arr ix a+    toList arr' === toList (Vector.update ix a $ fromList @(Vector _) l)++fmapProp :: [Int] -> Property+fmapProp l = do+  let vec = fmap (+ 20) (fromList @(Vector _) l)+      res = toList vec+  map (+ 20) l === res++snocUnsnocProp :: Int -> Bool+snocUnsnocProp times = do+  Vector.null+    . unsnocTimes+    . snocTimes+    . unsnocTimes+    . snocTimes+    $ Vector.empty+  where+    snocTimes vec = foldl' Vector.snoc vec [1 .. times]+    unsnocTimes vec = foldl' (\vec _ -> unsnoc' vec) vec [1 .. times]++unsnocProp :: [Int] -> Int -> Property+unsnocProp l i = do+  let l' = reverse $ drop i $ reverse l+      vec = fromList @(Vector _) l+      vec' =+        foldl'+          ( \vec _ -> case Vector.unsnoc vec of+              Nothing -> Vector.empty+              Just (vec, _) -> vec+          )+          vec+          [1 .. i]+  l' === toList vec'++unsnoc' :: Vector a -> Vector a+unsnoc' vec = case Vector.unsnoc vec of+  Just (vec, _) -> vec+  _ -> error "empty vector"++indexProp :: Int -> [Int] -> Property+indexProp ix l = do+  let indexMaybeList :: [a] -> Int -> Maybe a+      indexMaybeList xs n+        | n < 0 = Nothing+        -- Definition adapted from GHC.List+        | otherwise =+            foldr+              ( \x r k -> case k of+                  0 -> Just x+                  _ -> r (k - 1)+              )+              (const Nothing)+              xs+              n+      vec = fromList @(Vector _) l+  indexMaybeList l ix === Vector.lookup ix vec
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}