extended-containers 0.1.0.0 → 0.1.1.0

raw patch · 14 files changed

+495/−352 lines, 14 filesdep +deepseqdep +primitivedep −transformersdep −vectorPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: deepseq, primitive

Dependencies removed: transformers, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• README.md +3/−1
• extended-containers.cabal +37/−31
• src/Data/AMT.hs +124/−124
• src/Data/Heap.hs +2/−2
• src/Data/Heap/Internal.hs +30/−47
• src/Data/PrioHeap.hs +30/−42
• src/Util/Internal/Array.hs +79/−0
• src/Util/Internal/Indexed.hs +18/−0
• src/Util/Internal/StrictList.hs +8/−0
• test/Data/AMT/Spec.hs +52/−0
• test/Data/Heap/Spec.hs +47/−0
• test/Data/PrioHeap/Spec.hs +47/−0
• test/Spec.hs +7/−105

@@ -0,0 +1,11 @@+# 0.1.1.0++* Add `Data.AMT.head`+* Add `NFData` instances for `Vector`, `Heap`, `PrioHeap`++* Add `deepseq`, `primitive` dependencies+* Remove `transformers`, `vector` dependencies++# 0.1.0.0++* Initial release

@@ -1,9 +1,11 @@ # extended-containers  This package provides container data structures, including heaps and array mapped tries.+For [`lens`](https://hackage.haskell.org/package/lens) instances, see [`extended-containers-lens`](https://hackage.haskell.org/package/extended-containers-lens). +See [`extended-containers` on Hackage](https://hackage.haskell.org/package/extended-containers) for more information.+ ## Plans  * add a `Data.Deque` module * add sorting to `Data.AMT`-* make an `extended-containers-lens` package for [`lens`](https://hackage.haskell.org/package/lens) instances

@@ -1,60 +1,66 @@-name:                extended-containers-version:             0.1.0.0-synopsis:            Heap and Vector container types+name:               extended-containers+version:            0.1.1.0+synopsis:           Heap and Vector container types description:   This package contains general-purpose implementations of various immutable container types   including vectors, heaps and priority heaps.-homepage:            https://github.com/konsumlamm/extended-containers#readme-bug-reports:         https://github.com/konsumlamm/extended-containers/issues-license:             BSD3-license-file:        LICENSE-author:              konsumlamm-maintainer:          konsumlamm@gmail.com-copyright:           2019 konsumlamm-build-type:          Simple-extra-source-files:  README.md-category:            Data Structures-cabal-version:       >= 1.10+homepage:           https://github.com/konsumlamm/extended-containers+bug-reports:        https://github.com/konsumlamm/extended-containers/issues+license:            BSD3+license-file:       LICENSE+author:             konsumlamm+maintainer:         konsumlamm@gmail.com+copyright:          2019-2021 konsumlamm+build-type:         Simple+extra-source-files:+  CHANGELOG.md+  README.md+category:           Data Structures+cabal-version:      2.0 tested-with:-  GHC == 8.0.1,   GHC == 8.0.2,   GHC == 8.2.2,-  GHC == 8.4.3,   GHC == 8.4.4,-  GHC == 8.6.3,-  GHC == 8.6.4,   GHC == 8.6.5,-  GHC == 8.8.2,-  GHC == 8.8.3+  GHC == 8.8.3,+  GHC == 8.10.4,+  GHC == 9.0.1  source-repository head   type:     git   location: https://github.com/konsumlamm/extended-containers.git  library-  hs-source-dirs:      src+  hs-source-dirs:       src   exposed-modules:     Data.AMT     Data.Heap     Data.PrioHeap   other-modules:     Data.Heap.Internal+    Util.Internal.Array+    Util.Internal.Indexed     Util.Internal.StrictList-  ghc-options:         -O2 -Wall -Wno-name-shadowing -Wredundant-constraints+  ghc-options:          -O2 -Wall -Wno-name-shadowing -Wredundant-constraints   build-depends:-    base         >= 4.9 && < 5,-    transformers >= 0.5.2 && < 0.6,-    vector       >= 0.11 && < 0.13-  default-language:    Haskell2010+    base       >= 4.9 && < 5,+    deepseq   ^>= 1.4.2,+    primitive ^>= 0.7.1+  default-language:     Haskell2010  test-suite test-  hs-source-dirs:      test-  main-is:             Spec.hs-  type:                exitcode-stdio-1.0-  ghc-options:         -Wall -Wno-orphans+  hs-source-dirs:       test+  main-is:              Spec.hs+  other-modules:+    Data.AMT.Spec+    Data.Heap.Spec+    Data.PrioHeap.Spec+  type:                 exitcode-stdio-1.0+  ghc-options:          -Wall -Wno-orphans -Wno-type-defaults   build-depends:     base                >= 4.9 && < 5,     extended-containers,     hspec               >= 2.2.4 && < 2.8,     QuickCheck          >= 2.8.2 && < 2.15-  default-language:    Haskell2010+  default-language:     Haskell2010+  default-extensions:   ExtendedDefaultRules

@@ -1,7 +1,5 @@ {-# LANGUAGE CPP #-}-#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE TypeFamilies #-}-#endif  {- | = Finite vectors@@ -13,14 +11,16 @@  This module should be imported qualified, to avoid name clashes with the 'Prelude'. -> import qualified Data.AMT as Vector- == Performance  The worst case running time complexities are given, with /n/ referring the the number of elements in the vector. A 'Vector' is particularly efficient for applications that require a lot of indexing and updates.-All logarithms are base 16, which means that /O(log n)/ behaves like /O(1)/ in practice.+All logarithms are base 16, which means that /O(log n)/ behaves more like /O(1)/ in practice. +For a similar container with efficient concatenation and splitting, but slower indexing and updates,+see [Seq](https://hackage.haskell.org/package/containers/docs/Data-Sequence.html) from the+[containers](https://hackage.haskell.org/package/containers) package.+ == Warning  The length of a 'Vector' must not exceed @'maxBound' :: 'Int'@.@@ -28,7 +28,8 @@  == Implementation -The implementation of 'Vector' uses array mapped tries.+The implementation of 'Vector' uses array mapped tries. For a good explanation,+see [this blog post](https://hypirion.com/musings/understanding-persistent-vector-pt-1). -}  module Data.AMT@@ -40,9 +41,8 @@     , unfoldr, unfoldl, iterateN     , (<|), (|>), (><)     -- * Deconstruction/Subranges-    , viewl-    , viewr-    , last+    , viewl, viewr+    , head, last     , take     -- * Indexing     , lookup, index@@ -76,61 +76,59 @@ import Data.Bits import Data.Foldable (foldl', toList) import Data.Functor.Classes-import Data.Functor.Compose-import Data.Functor.Identity import Data.List.NonEmpty (NonEmpty(..), (!!)) import qualified Data.List.NonEmpty as L import Data.Maybe (fromMaybe) #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup((<>))) #endif-#ifdef __GLASGOW_HASKELL__ import Data.String (IsString)-#endif import Data.Traversable (mapAccumL)-#ifdef __GLASGOW_HASKELL__ import GHC.Exts (IsList) import qualified GHC.Exts as Exts-#endif-import Prelude hiding ((!!), last, lookup, map, replicate, tail, take, unzip, unzip3, zip, zipWith, zip3, zipWith3)-import qualified Prelude as P+import Prelude hiding ((!!), head, last, lookup, map, replicate, tail, take, unzip, unzip3, zip, zipWith, zip3, zipWith3) import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec) -import Control.Monad.Trans.State.Strict (state, evalState)-import qualified Data.Vector as V-import qualified Data.Vector.Mutable as M+import Control.DeepSeq (NFData(..)) +import qualified Util.Internal.Array as A+import Util.Internal.Indexed (Indexed(..), evalIndexed)+ infixr 5 >< infixr 5 <| infixl 5 |>  data Tree a-    = Internal !(V.Vector (Tree a))-    | Leaf !(V.Vector a)+    = Internal !(A.Array (Tree a)) -- never empty+    | Leaf !(A.Array a)  -- | An array mapped trie. data Vector a     = Empty     | Root-        {-# UNPACK #-} !Int  -- size-        {-# UNPACK #-} !Int  -- offset (number of elements in the tree)-        {-# UNPACK #-} !Int  -- height (of the tree)-        !(Tree a)  -- tree-        !(NonEmpty a)  -- tail (reversed)+        {-# UNPACK #-} !Int  -- ^ size+        {-# UNPACK #-} !Int  -- ^ offset (number of elements in the tree)+        {-# UNPACK #-} !Int  -- ^ height (of the tree)+        !(Tree a)  -- ^ tree+        !(NonEmpty a)  -- ^ tail (reversed) +instance NFData a => NFData (Tree a) where+    rnf (Internal v) = rnf v+    rnf (Leaf v) = rnf v+ errorNegativeLength :: String -> a errorNegativeLength s = error $ "AMT." ++ s ++ ": expected a nonnegative length" --- The number of bits used per level.+-- | The number of bits used per level. bits :: Int bits = 4 {-# INLINE bits #-} --- The maximum size of the tail.+-- | The maximum size of the tail. tailSize :: Int tailSize = 1 `shiftL` bits --- The mask used to extract the index into the array.+-- | The mask used to extract the index into the array. mask :: Int mask = tailSize - 1 @@ -145,47 +143,40 @@     liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp rl) "fromList" fromList  instance Read a => Read (Vector a) where-#ifdef __GLASGOW_HASKELL__     readPrec = parens $ prec 10 $ do         Ident "fromList" <- lexP         xs <- readPrec         pure (fromList xs)-#else-    readsPrec = readsPrec1-    {-# INLINE readsPrec #-}-#endif  instance Eq1 Vector where     liftEq f v1 v2 = length v1 == length v2 && liftEq f (toList v1) (toList v2)  instance Eq a => Eq (Vector a) where     (==) = eq1-    {-# INLINE (==) #-}  instance Ord1 Vector where     liftCompare f v1 v2 = liftCompare f (toList v1) (toList v2)  instance Ord a => Ord (Vector a) where     compare = compare1-    {-# INLINE compare #-}  instance Semigroup (Vector a) where     (<>) = (><)-    {-# INLINE (<>) #-}  instance Monoid (Vector a) where     mempty = empty-    {-# INLINE mempty #-}      mappend = (<>)-    {-# INLINE mappend #-}  instance Foldable Vector where-    foldr _ acc Empty = acc-    foldr f acc (Root _ _ _ tree tail) = foldrTree tree (foldr f acc (L.reverse tail))+    foldr f acc = go       where+        go Empty = acc+        go (Root _ _ _ tree tail) = foldrTree tree (foldr f acc (L.reverse tail))+         foldrTree (Internal v) acc' = foldr foldrTree acc' v         foldrTree (Leaf v) acc' = foldr f acc' v+    {-# INLINE foldr #-}      null Empty = True     null Root{} = False@@ -197,34 +188,33 @@  instance Functor Vector where     fmap = map-    {-# INLINE fmap #-}  instance Traversable Vector where-    traverse _ Empty = pure Empty-    traverse f (Root s offset h tree tail) =-        Root s offset h <$> traverseTree tree <*> (L.reverse <$> traverse f (L.reverse tail))+    traverse f = go       where+        go Empty = pure empty+        go (Root s offset h tree (x :| tail)) =+            Root s offset h <$> traverseTree tree <*> (flip (:|) <$> traverseReverse tail <*> f x)++        traverseReverse [] = pure []+        traverseReverse (x : xs) = flip (:) <$> traverseReverse xs <*> f x+         traverseTree (Internal v) = Internal <$> traverse traverseTree v         traverseTree (Leaf v) = Leaf <$> traverse f v+    {-# INLINE traverse #-} -#ifdef __GLASGOW_HASKELL__ instance IsList (Vector a) where     type Item (Vector a) = a      fromList = fromList-    {-# INLINE fromList #-}      toList = toList-    {-# INLINE toList #-}  instance a ~ Char => IsString (Vector a) where     fromString = fromList-    {-# INLINE fromString #-}-#endif  instance Applicative Vector where     pure = singleton-    {-# INLINE pure #-}      fs <*> xs = foldl' (\acc f -> acc >< map f xs) empty fs @@ -233,46 +223,41 @@  instance Alternative Vector where     empty = empty-    {-# INLINE empty #-}      (<|>) = (><)-    {-# INLINE (<|>) #-}  instance MonadPlus Vector  instance MonadFail Vector where     fail _ = empty-    {-# INLINE fail #-}  instance MonadZip Vector where     mzip = zip-    {-# INLINE mzip #-}      mzipWith = zipWith-    {-# INLINE mzipWith #-}      munzip = unzip-    {-# INLINE munzip #-} +instance NFData a => NFData (Vector a) where+    rnf Empty = ()+    rnf (Root _ _ _ tree tail) = rnf tree `seq` rnf tail + -- | /O(1)/. The empty vector. -- -- > empty = fromList [] empty :: Vector a empty = Empty-{-# INLINE empty #-}  -- | /O(1)/. A vector with a single element. -- -- > singleton x = fromList [x] singleton :: a -> Vector a-singleton x = Root 1 0 0 (Leaf V.empty) (x :| [])-{-# INLINE singleton #-}+singleton x = Root 1 0 0 (Leaf A.empty) (x :| [])  -- | /O(n * log n)/. Create a new vector from a list. fromList :: [a] -> Vector a fromList = foldl' (|>) empty-{-# INLINE fromList #-}  -- | Create a new vector of the given length from a function. fromFunction :: Int -> (Int -> a) -> Vector a@@ -281,12 +266,14 @@     go i acc         | i < n = go (i + 1) (acc |> f i)         | otherwise = acc-{-# INLINE fromFunction #-}  -- | /O(n * log n)/. @replicate n x@ is a vector consisting of n copies of x. replicate :: Int -> a -> Vector a-replicate n = if n < 0 then errorNegativeLength "replicate" else runIdentity . replicateA n . Identity-{-# INLINE replicate #-}+replicate n x = if n < 0 then errorNegativeLength "replicate" else go 0 empty+  where+    go i acc+        | i < n = go (i + 1) (acc |> x)+        | otherwise = acc  -- | @replicateA@ is an 'Applicative' version of 'replicate'. replicateA :: Applicative f => Int -> f a -> f (Vector a)@@ -295,7 +282,6 @@     go i acc         | i < n = go (i + 1) ((|>) <$> acc <*> x)         | otherwise = acc-{-# INLINE replicateA #-}  -- | /O(n * log n)/. Build a vector from left to right by repeatedly applying a function to a seed value. unfoldr :: (b -> Maybe (a, b)) -> b -> Vector a@@ -317,8 +303,11 @@  -- | Constructs a vector by repeatedly applying a function to a seed value. iterateN :: Int -> (a -> a) -> a -> Vector a-iterateN n f x = if n < 0 then errorNegativeLength "iterateN" else replicateA n (state (\y -> (y, f y))) `evalState` x-{-# INLINE iterateN #-}+iterateN n f x = if n < 0 then errorNegativeLength "iterateN" else go 0 x empty+  where+    go i y acc+        | i < n = go (i + 1) (f y) (acc |> y)+        | otherwise = acc  -- | /O(n * log n)/. Add an element to the left end of the vector. (<|) :: a -> Vector a -> Vector a@@ -326,30 +315,30 @@  -- | /O(n * log n)/. The first element and the vector without the first element or 'Nothing' if the vector is empty. viewl :: Vector a -> Maybe (a, Vector a)-viewl Empty = Nothing-viewl v@Root{} =-    let ls = toList v-    in Just (head ls, fromList $ P.tail ls)+viewl v = case toList v of+    [] -> Nothing+    x : xs -> Just (x, fromList xs)  -- | /O(log n)/. Add an element to the right end of the vector. (|>) :: Vector a -> a -> Vector a Empty |> x = singleton x Root s offset h tree tail |> x     | s .&. mask /= 0 = Root (s + 1) offset h tree (x L.<| tail)-    | offset == 0 = Root (s + 1) s (h + 1) (Leaf $ V.fromList (toList $ L.reverse tail)) (x :| [])-    | offset == 1 `shiftL` (bits * h) = Root (s + 1) s (h + 1) (Internal $ V.fromList [tree, newPath h]) (x :| [])-    | otherwise = Root (s + 1) s h (insertTail (bits * (h - 1)) tree) (x :| [])+    -- tail is full+    | offset == 0 = Root (s + 1) s h (Leaf $ A.fromTail tailSize tail) (x :| [])+    | offset == 1 `shiftL` (bits * (h + 1)) = Root (s + 1) s (h + 1) (Internal $ A.fromList2 tree (newPath h)) (x :| [])+    | otherwise = Root (s + 1) s h (insertTail (bits * h) tree) (x :| [])   where     -- create a new path from the old tail-    newPath 1 = Leaf $ V.fromList (toList $ L.reverse tail)-    newPath h = Internal $ V.singleton (newPath (h - 1))+    newPath 0 = Leaf $ A.fromTail tailSize tail+    newPath h = Internal $ A.singleton (newPath (h - 1))      insertTail sh (Internal v)-        | index < V.length v = Internal $ V.modify (\v -> M.modify v (insertTail (sh - bits)) index) v-        | otherwise = Internal $ V.snoc v (newPath (sh `div` bits))+        | idx < length v = Internal $ A.adjust idx (insertTail (sh - bits)) v+        | otherwise = Internal $ A.snoc v (newPath (sh `div` bits - 1))       where-        index = offset `shiftR` sh .&. mask-    insertTail _ (Leaf _) = Leaf $ V.fromList (toList $ L.reverse tail)+        idx = offset `shiftR` sh .&. mask+    insertTail _ (Leaf _) = Leaf $ A.fromTail tailSize tail  -- | /O(log n)/. The vector without the last element and the last element or 'Nothing' if the vector is empty. viewr :: Vector a -> Maybe (Vector a, a)@@ -357,31 +346,37 @@ viewr (Root s offset h tree (x :| tail))     | not (null tail) = Just (Root (s - 1) offset h tree (L.fromList tail), x)     | s == 1 = Just (Empty, x)-    | s == tailSize + 1 = Just (Root (s - 1) 0 0 (Leaf V.empty) (getTail tree), x)-    | otherwise =-        let sh = bits * (h - 1)-        in Just (normalize $ Root (s - 1) (offset - tailSize) h (unsnocTree sh tree) (getTail tree), x)+    | s == tailSize + 1 = Just (Root (s - 1) 0 0 (Leaf A.empty) (getTail tree), x)+    | otherwise = Just (normalize $ Root (s - 1) (offset - tailSize) h (initTree (bits * h) tree) (getTail tree), x)   where-    index' = offset - tailSize - 1+    idx = offset - tailSize - 1 -    unsnocTree sh (Internal v) =-        let subIndex = index' `shiftR` sh .&. mask-            new = V.take (subIndex + 1) v-        in Internal $ V.modify (\v -> M.modify v (unsnocTree (sh - bits)) subIndex) new-    unsnocTree _ (Leaf v) = Leaf v+    initTree sh (Internal v) =+        let subIndex = idx `shiftR` sh .&. mask+            new = A.take (subIndex + 1) v+        in Internal $ A.adjust subIndex (initTree (sh - bits)) new+    initTree _ (Leaf v) = Leaf v -    getTail (Internal v) = getTail (V.last v)-    getTail (Leaf v) = L.fromList . reverse $ toList v+    getTail (Internal v) = getTail (A.last v)+    getTail (Leaf v) = A.toTail v      normalize (Root s offset h (Internal v) tail)-        | length v == 1 = Root s offset (h - 1) (v V.! 0) tail+        | length v == 1 = Root s offset (h - 1) (A.head v) tail     normalize v = v +-- | /O(log n)/. The first element in the vector or 'Nothing' if the vector is empty.+head :: Vector a -> Maybe a+head Empty = Nothing+head (Root _ 0 _ _ tail) = Just (L.last tail) -- offset 0, all elements are in the tail+head (Root _ _ _ tree _) = Just (headTree tree)+  where+    headTree (Internal v) = headTree (A.head v)+    headTree (Leaf v) = A.head v+ -- | /O(1)/. The last element in the vector or 'Nothing' if the vector is empty. last :: Vector a -> Maybe a last Empty = Nothing last (Root _ _ _ _ (x :| _)) = Just x-{-# INLINE last #-}  -- | /O(log n)/. Take the first n elements of the vector or the vector if n is larger than the length of the vector. -- Returns the empty vector if n is negative.@@ -391,39 +386,38 @@     | n <= 0 = Empty     | n >= s = root     | n > offset = Root n offset h tree (L.fromList $ L.drop (s - n) tail)-    | n <= tailSize = Root n 0 0 (Leaf V.empty) (getTail (bits * (h - 1)) tree)+    | n <= tailSize = Root n 0 0 (Leaf A.empty) (getTail (bits * h) tree)     | otherwise =-        let sh = bits * (h - 1)+        let sh = bits * h         in normalize $ Root n ((n - 1) .&. complement mask) h (takeTree sh tree) (getTail sh tree)  -- n - 1 because if 'n .&. mask == 0', we need to subtract tailSize   where-    -- index of the last element in the new vector-    index = n - 1+    idx = n - 1 -- index of the last element in the new vector -    index' = index - tailSize+    idx' = idx - tailSize      takeTree sh (Internal v) =-        let subIndex = index' `shiftR` sh .&. mask-            new = V.take (subIndex + 1) v-        in Internal $ V.modify (\v -> M.modify v (takeTree (sh - bits)) subIndex) new+        let subIndex = idx' `shiftR` sh .&. mask+            new = A.take (subIndex + 1) v+        in Internal $ A.adjust subIndex (takeTree (sh - bits)) new     takeTree _ (Leaf v) = Leaf v -    getTail sh (Internal v) = getTail (sh - bits) (v V.! (index `shiftR` sh .&. mask))-    getTail _ (Leaf v) = L.fromList . reverse . P.take (index .&. mask + 1) $ toList v+    getTail sh (Internal v) = getTail (sh - bits) (A.index (idx `shiftR` sh .&. mask) v)+    getTail _ (Leaf v) = A.toTail $ A.take (idx .&. mask + 1) v      normalize (Root s offset h (Internal v) tail)-        | length v == 1 = normalize $ Root s offset (h - 1) (v V.! 0) tail+        | length v == 1 = normalize $ Root s offset (h - 1) (A.head v) tail     normalize v = v  -- | /O(log n)/. The element at the index or 'Nothing' if the index is out of range. lookup :: Int -> Vector a -> Maybe a lookup _ Empty = Nothing lookup i (Root s offset h tree tail)-    | i < 0 || i >= s = Nothing-    | i < offset = Just $ lookupTree (bits * (h - 1)) tree+    | i < 0 || i >= s = Nothing  -- index out of range+    | i < offset = Just $ lookupTree (bits * h) tree     | otherwise = Just $ tail !! (s - i - 1)   where-    lookupTree sh (Internal v) = lookupTree (sh - bits) (v V.! (i `shiftR` sh .&. mask))-    lookupTree _ (Leaf v) = v V.! (i .&. mask)+    lookupTree sh (Internal v) = lookupTree (sh - bits) (A.index (i `shiftR` sh .&. mask) v)+    lookupTree _ (Leaf v) = A.index (i .&. mask) v  -- | /O(log n)/. The element at the index. Calls 'error' if the index is out of range. index :: Int -> Vector a -> a@@ -434,7 +428,7 @@ (!?) = flip lookup {-# INLINE (!?) #-} --- | /O(log n)/. Flipped version of 'lookup'.+-- | /O(log n)/. Flipped version of 'index'. (!) :: Vector a -> Int -> a (!) = flip index {-# INLINE (!) #-}@@ -450,16 +444,16 @@ adjust :: Int -> (a -> a) -> Vector a -> Vector a adjust _ _ Empty = Empty adjust i f root@(Root s offset h tree tail)-    | i < 0 || i >= s = root-    | i < offset = Root s offset h (adjustTree (bits * (h - 1)) tree) tail+    | i < 0 || i >= s = root  -- index out of range+    | i < offset = Root s offset h (adjustTree (bits * h) tree) tail     | otherwise = let (l, x : r) = L.splitAt (s - i - 1) tail in Root s offset h tree (L.fromList $ l ++ (f x : r))   where     adjustTree sh (Internal v) =-        let index = i `shiftR` sh .&. mask-        in Internal $ V.modify (\v -> M.modify v (adjustTree (sh - bits)) index) v+        let idx = i `shiftR` sh .&. mask+        in Internal $ A.adjust idx (adjustTree (sh - bits)) v     adjustTree _ (Leaf v) =-        let index = i .&. mask-        in Leaf $ V.modify (\v -> M.modify v f index) v+        let idx = i .&. mask+        in Leaf $ A.adjust idx f v  -- | /O(m * log n)/. Concatenate two vectors. (><) :: Vector a -> Vector a -> Vector a@@ -479,18 +473,26 @@ -- | /O(n)/. Map a function that has access to the index of an element over the vector. mapWithIndex :: (Int -> a -> b) -> Vector a -> Vector b mapWithIndex f = snd . mapAccumL (\i x -> i `seq` (i + 1, f i x)) 0+{-# INLINE mapWithIndex #-}  -- | /O(n)/. Fold the values in the vector, using the given monoid. foldMapWithIndex :: Monoid m => (Int -> a -> m) -> Vector a -> m foldMapWithIndex f = foldrWithIndex (\i -> mappend . f i) mempty+{-# INLINE foldMapWithIndex #-}  -- | /O(n)/. Fold using the given left-associative function that has access to the index of an element. foldlWithIndex :: (b -> Int -> a -> b) -> b -> Vector a -> b-foldlWithIndex f acc v = foldl (\g x i -> i `seq` f (g (i - 1)) i x) (const acc) v (length v - 1)+foldlWithIndex f acc v = foldl f' (const acc) v (length v - 1)+  where+    f' g x i = i `seq` f (g (i - 1)) i x+{-# INLINE foldlWithIndex #-}  -- | /O(n)/. Fold using the given right-associative function that has access to the index of an element. foldrWithIndex :: (Int -> a -> b -> b) -> b -> Vector a -> b-foldrWithIndex f acc v = foldr (\x g i -> i `seq` f i x (g (i + 1))) (const acc) v 0+foldrWithIndex f acc v = foldr f' (const acc) v 0+  where+    f' x g i = i `seq` f i x (g (i + 1))+{-# INLINE foldrWithIndex #-}  -- | /O(n)/. A strict version of 'foldlWithIndex'. -- Each application of the function is evaluated before using the result in the next application.@@ -510,9 +512,10 @@  -- | /O(n)/. Traverse the vector with a function that has access to the index of an element. traverseWithIndex :: Applicative f => (Int -> a -> f b) -> Vector a -> f (Vector b)-traverseWithIndex f v = evalState (getCompose $ traverse (Compose . state . flip f') v) 0+traverseWithIndex f v = evalIndexed (traverse (Indexed . f') v) 0   where-    f' i x = i `seq` (f i x, i + 1)+    f' x i = i `seq` (f i x, i + 1)+{-# INLINE traverseWithIndex #-}  -- | /O(n)/. Pair each element in the vector with its index. indexed :: Vector a -> Vector (Int, a)@@ -545,7 +548,6 @@ -- | /O(n)/. Transforms a vector of pairs into a vector of first components and a vector of second components. unzip :: Vector (a, b) -> (Vector a, Vector b) unzip v = (map fst v, map snd v)-{-# INLINE unzip #-}  -- | /O(n)/. Takes a vector of triples and returns three vectors, analogous to 'unzip'. unzip3 :: Vector (a, b, c) -> (Vector a, Vector b, Vector c)@@ -554,9 +556,7 @@     fst3 (x, _, _) = x     snd3 (_, y, _) = y     trd3 (_, _, z) = z-{-# INLINE unzip3 #-}  -- | /O(n)/. Create a list of index-value pairs from the vector. toIndexedList :: Vector a -> [(Int, a)] toIndexedList = foldrWithIndex (curry (:)) []-{-# INLINE toIndexedList #-}

@@ -15,9 +15,9 @@  == Implementation -The implementation uses skew binomial heaps, as described in+The implementation uses skew binomial heaps, as described by: -* Chris Okasaki, \"Purely Functional Data Structures\", 1998+* Chris Okasaki, \"Purely Functional Data Structures\", 1998. -}  module Data.Heap

@@ -1,7 +1,5 @@ {-# LANGUAGE CPP #-}-#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE TypeFamilies #-}-#endif  module Data.Heap.Internal     ( Heap(..)@@ -53,13 +51,13 @@ #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup((<>))) #endif-#ifdef __GLASGOW_HASKELL__ import GHC.Exts (IsList) import qualified GHC.Exts as Exts-#endif import Prelude hiding (break, drop, dropWhile, filter, map, reverse, span, splitAt, take, takeWhile) import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec) +import Control.DeepSeq (NFData(..))+ import Util.Internal.StrictList  -- | A skew binomial heap.@@ -79,15 +77,12 @@     , _children :: !(Forest a)     } +instance NFData a => NFData (Tree a) where+    rnf (Node _ x xs c) = rnf x `seq` rnf xs `seq` rnf c+ errorEmpty :: String -> a errorEmpty s = error $ "Heap." ++ s ++ ": empty heap" -instance Functor Tree where-    fmap f (Node r x xs c) = Node r (f x) (fmap f xs) (fmap (fmap f) c)--instance Foldable Tree where-    foldr f acc (Node _ x xs c) = f x (foldr f (foldr (flip (foldr f)) acc c) xs)- link :: Ord a => Tree a -> Tree a -> Tree a link t1@(Node r1 x1 xs1 c1) t2@(Node r2 x2 xs2 c2) = assert (r1 == r2) $     if x1 <= x2@@ -148,17 +143,12 @@  instance Show a => Show (Heap a) where     showsPrec = showsPrec1-    {-# INLINE showsPrec #-}  instance (Ord a, Read a) => Read (Heap a) where-#ifdef __GLASGOW_HASKELL__     readPrec = parens $ prec 10 $ do         Ident "fromList" <- lexP         xs <- readPrec         pure (fromList xs)-#else-    readsPrec = readsData $ readsUnaryWith readList "fromList" fromList-#endif  instance Ord a => Eq (Heap a) where     heap1 == heap2 = size heap1 == size heap2 && toAscList heap1 == toAscList heap2@@ -168,59 +158,63 @@  instance Ord a => Semigroup (Heap a) where     (<>) = union-    {-# INLINE (<>) #-}  instance Ord a => Monoid (Heap a) where     mempty = empty-    {-# INLINE mempty #-}      mappend = (<>)-    {-# INLINE mappend #-}  instance Foldable Heap where-    foldr _ acc Empty = acc-    foldr f acc (Heap _ x forest) = f x (foldr (flip (foldr f)) acc forest)+    foldr f acc = go+      where+        go Empty = acc+        go (Heap _ x forest) = f x (foldr foldTree acc forest) +        foldTree (Node _ x xs c) acc = f x (foldr f (foldr foldTree acc c) xs)+    {-# INLINE foldr #-}++    foldl f acc = go+      where+        go Empty = acc+        go (Heap _ x forest) = foldl foldTree (f acc x) forest++        foldTree acc (Node _ x xs c) = foldl foldTree (foldl f (f acc x) xs) c+    {-# INLINE foldl #-}+     null Empty = True     null Heap{} = False-    {-# INLINE null #-}      length = size-    {-# INLINE length #-}      minimum = findMin-    {-# INLINE minimum #-} -#ifdef __GLASGOW_HASKELL__ instance Ord a => IsList (Heap a) where     type Item (Heap a) = a      fromList = fromList-    {-# INLINE fromList #-}      toList = toList-    {-# INLINE toList #-}-#endif +instance NFData a => NFData (Heap a) where+    rnf Empty = ()+    rnf (Heap _ x forest) = rnf x `seq` rnf forest + -- | /O(1)/. The empty heap. -- -- > empty = fromList [] empty :: Heap a empty = Empty-{-# INLINE empty #-}  -- | /O(1)/. A heap with a single element. -- -- > singleton x = fromList [x] singleton :: a -> Heap a singleton x = Heap 1 x Nil-{-# INLINE singleton #-}  -- | /O(n)/. Create a heap from a list. fromList :: Ord a => [a] -> Heap a fromList = foldl' (flip insert) empty-{-# INLINE fromList #-}  -- | /O(1)/. Insert a new value into the heap. insert :: Ord a => a -> Heap a -> Heap a@@ -242,29 +236,26 @@ -- > unions = foldl union empty unions :: (Foldable f, Ord a) => f (Heap a) -> Heap a unions = foldl' union empty-{-# INLINE unions #-}  -- | /O(n)/. Map a function over the heap. map :: Ord b => (a -> b) -> Heap a -> Heap b map f = fromList . fmap f . toList-{-# INLINE map #-}  -- | /O(n)/, Map an increasing function over the heap. The precondition is not checked. mapMonotonic :: (a -> b) -> Heap a -> Heap b mapMonotonic _ Empty = Empty-mapMonotonic f (Heap s x forest) = Heap s (f x) (fmap (fmap f) forest)-{-# INLINE mapMonotonic #-}+mapMonotonic f (Heap s x forest) = Heap s (f x) (fmap mapTree forest)+  where+    mapTree (Node r x xs c) = Node r (f x) (fmap f xs) (fmap mapTree c)  -- | /O(n)/. Filter all elements that satisfy the predicate. filter :: Ord a => (a -> Bool) -> Heap a -> Heap a filter f = foldl' (\acc x -> if f x then insert x acc else acc) empty-{-# INLINE filter #-}  -- | /O(n)/. Partition the heap into two heaps, one with all elements that satisfy the predicate -- and one with all elements that don't satisfy the predicate. partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a) partition f = foldl' (\(h1, h2) x -> if f x then (insert x h1, h2) else (h1, insert x h2)) (empty, empty)-{-# INLINE partition #-}  -- | /O(n * log n)/. Fold the values in the heap in order, using the given monoid. foldMapOrd :: (Ord a, Monoid m) => (a -> m) -> Heap a -> m@@ -277,6 +268,7 @@     go h = case minView h of         Nothing -> acc         Just (x, h') -> f x (go h')+{-# INLINE foldrOrd #-}  -- | /O(n * log n)/. Fold the values in the heap in order, using the given left-associative function. foldlOrd :: Ord a => (b -> a -> b) -> b -> Heap a -> b@@ -285,6 +277,7 @@     go acc h = case minView h of         Nothing -> acc         Just (x, h') -> go (f acc x) h'+{-# INLINE foldlOrd #-}  -- | /O(n * log n)/. A strict version of 'foldrOrd'. -- Each application of the function is evaluated before using the result in the next application.@@ -306,7 +299,6 @@ size :: Heap a -> Int size Empty = 0 size (Heap s _ _) = s-{-# INLINE size #-}  -- | /O(n)/. Is the value a member of the heap? member :: Ord a => a -> Heap a -> Bool@@ -321,34 +313,28 @@  -- | /O(log n)/. The minimal element in the heap. Calls 'error' if the heap is empty. findMin :: Heap a -> a-findMin Empty = error "findMin: empty heap"-findMin (Heap _ x _) = x-{-# INLINE findMin #-}+findMin heap = fromMaybe (errorEmpty "findMin") (lookupMin heap)  -- | /O(log n)/. The minimal element in the heap or 'Nothing' if the heap is empty. lookupMin :: Heap a -> Maybe a lookupMin Empty = Nothing lookupMin (Heap _ x _) = Just $! x-{-# INLINE lookupMin #-}  -- | /O(log n)/. Delete the minimal element. Returns the empty heap if the heap is empty. deleteMin :: Ord a => Heap a -> Heap a deleteMin Empty = Empty deleteMin (Heap s _ f) = fromForest (s - 1) f-{-# INLINE deleteMin #-}  -- | /O(log n)/. Delete and find the minimal element. Calls 'error' if the heap is empty. -- -- > deleteFindMin heap = (findMin heap, deleteMin heap) deleteFindMin :: Ord a => Heap a -> (a, Heap a) deleteFindMin heap = fromMaybe (errorEmpty "deleteFindMin") (minView heap)-{-# INLINE deleteFindMin #-}  -- | /O(log n)/. Retrieves the minimal element of the heap and the heap stripped of that element or 'Nothing' if the heap is empty. minView :: Ord a => Heap a -> Maybe (a, Heap a) minView Empty = Nothing minView (Heap s x f) = Just (x, fromForest (s - 1) f)-{-# INLINE minView #-}  -- | /O(n * log n)/. @take n heap@ takes the @n@ smallest elements of @heap@, in ascending order. --@@ -423,14 +409,11 @@ -- | /O(n * log n)/. Create a descending list from the heap. toAscList :: Ord a => Heap a -> [a] toAscList = foldrOrd (:) []-{-# INLINE toAscList #-}  -- | /O(n * log n)/. Create a descending list from the heap. toDescList :: Ord a => Heap a -> [a] toDescList = foldlOrd (flip (:)) []-{-# INLINE toDescList #-}  -- | /O(n * log n)/. Sort a list using a heap. The sort is unstable. heapsort :: Ord a => [a] -> [a] heapsort = toAscList . fromList-{-# INLINE heapsort #-}

@@ -1,7 +1,5 @@ {-# LANGUAGE CPP #-}-#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE TypeFamilies #-}-#endif  {- | = Finite priority heaps@@ -20,9 +18,9 @@  == Implementation -The implementation uses skew binomial heaps, as described in+The implementation uses skew binomial heaps, as described by: -* Chris Okasaki, \"Purely Functional Data Structures\", 1998+* Chris Okasaki, \"Purely Functional Data Structures\", 1998. -}  module Data.PrioHeap@@ -85,13 +83,13 @@ #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup((<>))) #endif-#ifdef __GLASGOW_HASKELL__ import GHC.Exts (IsList) import qualified GHC.Exts as Exts-#endif import Prelude hiding (break, drop, dropWhile, filter, map, reverse, span, splitAt, take, takeWhile, uncurry) import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec) +import Control.DeepSeq (NFData(..))+ import qualified Data.Heap.Internal as Heap import Util.Internal.StrictList @@ -116,6 +114,12 @@     , _children :: !(Forest k a)     } +instance (NFData k, NFData a) => NFData (Pair k a) where+    rnf (Pair k x) = rnf k `seq` rnf x++instance (NFData k, NFData a) => NFData (Tree k a) where+    rnf (Node _ k x xs c) = rnf k `seq` rnf x `seq` rnf xs `seq` rnf c+ errorEmpty :: String -> a errorEmpty s = error $ "PrioHeap." ++ s ++ ": empty heap" @@ -186,11 +190,9 @@  instance Show k => Show1 (PrioHeap k) where     liftShowsPrec = liftShowsPrec2 showsPrec showList-    {-# INLINE liftShowsPrec #-}  instance (Show k, Show a) => Show (PrioHeap k a) where     showsPrec = showsPrec2-    {-# INLINE showsPrec #-}  instance (Ord k, Read k) => Read1 (PrioHeap k) where     liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList@@ -199,44 +201,33 @@         rl' = liftReadList rp rl  instance (Ord k, Read k, Read a) => Read (PrioHeap k a) where-#ifdef __GLASGOW_HASKELL__     readPrec = parens $ prec 10 $ do         Ident "fromList" <- lexP         xs <- readPrec         pure (fromList xs)-#else-    readsPrec = readsPrec1-    {-# INLINE readPrec #-}-#endif  instance Ord k => Eq1 (PrioHeap k) where     liftEq f heap1 heap2 = size heap1 == size heap2 && liftEq (liftEq f) (toAscList heap1) (toAscList heap2)  instance (Ord k, Eq a) => Eq (PrioHeap k a) where     (==) = eq1-    {-# INLINE (==) #-}  instance Ord k => Ord1 (PrioHeap k) where     liftCompare f heap1 heap2 = liftCompare (liftCompare f) (toAscList heap1) (toAscList heap2)  instance (Ord k, Ord a) => Ord (PrioHeap k a) where     compare = compare1-    {-# INLINE compare #-}  instance Ord k => Semigroup (PrioHeap k a) where     (<>) = union-    {-# INLINE (<>) #-}  instance Ord k => Monoid (PrioHeap k a) where     mempty = empty-    {-# INLINE mempty #-}      mappend = (<>)-    {-# INLINE mappend #-}  instance Functor (PrioHeap k) where     fmap = map-    {-# INLINE fmap #-}  instance Foldable (PrioHeap k) where     foldMap f = foldMapWithKey (const f)@@ -256,45 +247,40 @@      null Empty = True     null Heap{} = False-    {-# INLINE null #-}      length = size-    {-# INLINE length #-}  instance Traversable (PrioHeap k) where     traverse f = traverseWithKey (const f)     {-# INLINE traverse #-} -#ifdef __GLASGOW_HASKELL__ instance Ord k => IsList (PrioHeap k a) where     type Item (PrioHeap k a) = (k, a)      fromList = fromList-    {-# INLINE fromList #-}      toList = toList-    {-# INLINE toList #-}-#endif +instance (NFData k, NFData a) => NFData (PrioHeap k a) where+    rnf Empty = ()+    rnf (Heap _ k x forest) = rnf k `seq` rnf x `seq` rnf forest + -- | /O(1)/. The empty heap. -- -- > empty = fromList [] empty :: PrioHeap k a empty = Empty-{-# INLINE empty #-}  -- | /O(1)/. A heap with a single element. -- -- > singleton x = fromList [x] singleton :: k -> a -> PrioHeap k a singleton k x = Heap 1 k x Nil-{-# INLINE singleton #-}  -- | /O(n * log n)/. Create a heap from a list. fromList :: Ord k => [(k, a)] -> PrioHeap k a fromList = foldl' (\acc (key, x) -> insert key x acc) empty-{-# INLINE fromList #-}  -- | /O(1)/. Insert a new key and value into the heap. insert :: Ord k => k -> a -> PrioHeap k a -> PrioHeap k a@@ -316,7 +302,6 @@ -- > unions = foldl union empty unions :: (Foldable f, Ord k) => f (PrioHeap k a) -> PrioHeap k a unions = foldl' union empty-{-# INLINE unions #-}  -- | /O(n)/. Map a function over the heap. map :: (a -> b) -> PrioHeap k a -> PrioHeap k b@@ -329,14 +314,16 @@ mapWithKey f (Heap s key x forest) = Heap s key (f key x) (fmap mapTree forest)   where     mapTree (Node r key x xs c) = Node r key (f key x) (fmap mapPair xs) (fmap mapTree c)+     mapPair (Pair key x) = Pair key (f key x)-{-# INLINE mapWithKey #-}  -- | /O(n)/. Traverse the heap with a function that has access to the key associated with a value. traverseWithKey :: Applicative f => (k -> a -> f b) -> PrioHeap k a -> f (PrioHeap k b)-traverseWithKey _ Empty = pure Empty-traverseWithKey f (Heap s key x forest) = Heap s key <$> f key x <*> traverse traverseTree forest+traverseWithKey f = go   where+    go Empty = pure Empty+    go (Heap s key x forest) = Heap s key <$> f key x <*> traverse traverseTree forest+     traverseTree (Node r key x xs c) = Node r key <$> f key x <*> traverse traversePair xs <*> traverse traverseTree c     traversePair (Pair key x) = Pair key <$> f key x {-# INLINE traverseWithKey #-}@@ -406,17 +393,23 @@  -- | /O(n)/. Fold the keys and values in the heap, using the given right-associative function. foldrWithKey :: (k -> a -> b -> b) -> b -> PrioHeap k a -> b-foldrWithKey _ acc Empty = acc-foldrWithKey f acc (Heap _ key x forest) = f key x (foldr foldTree acc forest)+foldrWithKey f acc = go   where+    go Empty = acc+    go (Heap _ key x forest) = f key x (foldr foldTree acc forest)+     foldTree (Node _ key x xs c) acc = f key x (foldr (uncurry f) (foldr foldTree acc c) xs)+{-# INLINE foldrWithKey #-}  -- | /O(n)/. Fold the keys and values in the heap, using the given left-associative function. foldlWithKey :: (b -> k -> a -> b) -> b -> PrioHeap k a -> b-foldlWithKey _ acc Empty = acc-foldlWithKey f acc (Heap _ key x forest) = foldl foldTree (f acc key x) forest+foldlWithKey f acc = go   where+    go Empty = acc+    go (Heap _ key x forest) = foldl foldTree (f acc key x) forest+     foldTree acc (Node _ key x xs c) = foldl foldTree (foldl (uncurry . f) (f acc key x) xs) c+{-# INLINE foldlWithKey #-}  -- | /O(n)/. A strict version of 'foldrWithKey'. -- Each application of the function is evaluated before using the result in the next application.@@ -504,7 +497,6 @@ size :: PrioHeap k a -> Int size Empty = 0 size (Heap s _ _ _) = s-{-# INLINE size #-}  -- | /O(n)/. Is the key a member of the heap? member :: Ord k => k -> PrioHeap k a -> Bool@@ -513,7 +505,7 @@   where     kx `elemTree` (Node _ ky _ ys c) = kx <= ky && (any (\(Pair a _) -> kx == a) ys || any (kx `elemTree`) c) --- | /O(n)/. Is the value not a member of the heap?+-- | /O(n)/. Is the key not a member of the heap? notMember :: Ord k => k -> PrioHeap k a -> Bool notMember key = not . member key @@ -531,12 +523,10 @@ lookupMin :: PrioHeap k a -> Maybe (k, a) lookupMin Empty = Nothing lookupMin (Heap _ key x _) = Just (key, x)-{-# INLINE lookupMin #-}  -- | /O(1)/. The minimal element in the heap. Calls 'error' if the heap is empty. findMin :: PrioHeap k a -> (k, a) findMin heap = fromMaybe (errorEmpty "findMin") (lookupMin heap)-{-# INLINE findMin #-}  -- | /O(log n)/. Delete the minimal element. Returns the empty heap if the heap is empty. deleteMin :: Ord k => PrioHeap k a -> PrioHeap k a@@ -548,7 +538,6 @@ -- > deleteFindMin heap = (findMin heap, deleteMin heap) deleteFindMin :: Ord k => PrioHeap k a -> ((k, a), PrioHeap k a) deleteFindMin heap = fromMaybe (errorEmpty "deleteFindMin") (minView heap)-{-# INLINE deleteFindMin #-}  -- | /O(log n)/. Update the value at the minimal key. updateMin :: Ord k => (a -> Maybe a) -> PrioHeap k a -> PrioHeap k a@@ -566,7 +555,6 @@ minView :: Ord k => PrioHeap k a -> Maybe ((k, a), PrioHeap k a) minView Empty = Nothing minView (Heap s key x f) = Just ((key, x), fromForest (s - 1) f)-{-# INLINE minView #-}  -- | /O(n * log n)/. @take n heap@ takes the @n@ smallest elements of @heap@, in ascending order. --

@@ -0,0 +1,79 @@+-- | The functions in this module perform no bounds checking.++module Util.Internal.Array+    ( Array+    , empty+    , singleton+    , snoc+    , index+    , head, last+    , adjust+    , take+    , fromList2+    , fromTail+    , toTail+    ) where++import qualified Data.List.NonEmpty as L+import Prelude hiding (head, last, take)++import Data.Primitive.SmallArray++type Array a = SmallArray a++empty :: Array a+empty = mempty++singleton :: a -> Array a+singleton x = runSmallArray $ newSmallArray 1 x++snoc :: Array a -> a -> Array a+snoc arr x = runSmallArray $ do+    let size = length arr+    arr' <- newSmallArray (size + 1) x+    copySmallArray arr' 0 arr 0 size+    pure arr'++index :: Int -> Array a -> a+index = flip indexSmallArray++head :: Array a -> a+head arr = indexSmallArray arr 0++last :: Array a -> a+last arr = indexSmallArray arr (length arr - 1)++-- | Update the element at the specified index.+adjust :: Int -> (a -> a) -> Array a -> Array a+adjust i f arr = runSmallArray $ do+    arr' <- thawSmallArray arr 0 (length arr)+    let x = indexSmallArray arr i+    writeSmallArray arr' i (f x)+    pure arr'+{-# INLINE adjust #-}++take :: Int -> Array a -> Array a+take n arr = cloneSmallArray arr 0 n++fromList2 :: a -> a -> Array a+fromList2 x y = runSmallArray $ do+    arr <- newSmallArray 2 x+    writeSmallArray arr 1 y+    pure arr++-- | Convert a full tail into an array.+--+-- > fromTail = A.fromListN tailSize . reverse . toList+fromTail :: Int -> L.NonEmpty a -> Array a+fromTail size (x L.:| xs) = runSmallArray $ do+    arr <- newSmallArray size x+    let loop _ [] = pure ()+        loop i (y : ys) = writeSmallArray arr i y *> loop (i - 1) ys+    loop (size - 2) xs+    pure arr++-- | Convert an array into a tail.+--+-- > toTail = L.fromList . reverse . toList+toTail :: Array a -> L.NonEmpty a+toTail = L.fromList . foldl (flip (:)) []

@@ -0,0 +1,18 @@+module Util.Internal.Indexed where++-- | > Compose (State Int) f a+newtype Indexed f a = Indexed { runIndexed :: Int -> (f a, Int) }++instance Functor f => Functor (Indexed f) where+    fmap f (Indexed sf) = Indexed $ \s -> let (x, s') = sf s in (fmap f x, s')++instance Applicative f => Applicative (Indexed f) where+    pure x = Indexed $ (,) (pure x)++    Indexed sfa <*> Indexed sfb = Indexed $ \s ->+        let (f, s') = sfa s+            (x, s'') = sfb s'+        in (f <*> x, s'')++evalIndexed :: Indexed f a -> Int -> f a+evalIndexed (Indexed sf) x = fst (sf x)

@@ -1,3 +1,5 @@+-- | Used by "Data.Heap" and "Data.PrioHeap".+ module Util.Internal.StrictList     ( List(..)     , reverse@@ -5,6 +7,8 @@  import Prelude hiding (reverse) +import Control.DeepSeq (NFData(..))+ -- | A strict list. data List a = Nil | !a `Cons` !(List a) @@ -30,6 +34,10 @@         go Nil = pure Nil         go (x `Cons` xs) = Cons <$> f x <*> go xs     {-# INLINE traverse #-}++instance NFData a => NFData (List a) where+    rnf Nil = ()+    rnf (x `Cons` xs) = rnf x `seq` rnf xs  reverse :: List a -> List a reverse = rev Nil

@@ -0,0 +1,52 @@+module Data.AMT.Spec+    ( spec+    ) where++import Data.Foldable (toList)++import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck++import qualified Data.AMT as V++default (Int)++instance Arbitrary a => Arbitrary (V.Vector a) where+    arbitrary = fmap V.fromList arbitrary++unsnoc :: [a] -> Maybe ([a], a)+unsnoc [] = Nothing+unsnoc ls = Just (init ls, last ls)++(!?) :: [a] -> Int -> Maybe a+ls !? i+    | i < 0 || i >= length ls = Nothing+    | otherwise = Just (ls !! i)++spec :: Spec+spec = describe "Data.AMT" $ do+    prop "satisfies `fromList . toList == id`" $ \v -> V.fromList (toList v) === v+    prop "satisfies `toList . fromList == id`" $ \ls -> toList (V.fromList ls) === ls++    describe "length" $ do+        prop "returns the length" $ \ls -> length (V.fromList ls) === length ls+        it "returns 0 for the empty vector" $ length V.empty `shouldBe` 0++    describe "snoc" $ do+        prop "appends an element to the back" $ \v x -> toList (v V.|> x) === toList v ++ [x]+        prop "works for the empty vector" $ \x -> V.empty V.|> x `shouldBe` V.singleton x++    describe "unsnoc" $ do+        prop "analyzes the back of the vector" $ \v -> V.viewr v === fmap (\(xs, x) -> (V.fromList xs, x)) (unsnoc (toList v))+        it "returns Nothing for the empty vector" $ V.viewr V.empty `shouldBe` Nothing++    describe "take" $ do+        prop "takes the first n elements" $ \n xs -> V.take n (V.fromList xs) === V.fromList (take n xs)+        prop "returns the empty vector for non-positive n" $ \(NonPositive n) v -> V.take n v === V.empty+        prop "does nothing for the empty vector" $ \n -> V.take n V.empty === V.empty++    describe "lookup" $ do+        prop "returns the ith element" $ \i v -> V.lookup i v === toList v !? i+        prop "returns Nothing for negative indices" $ \(Negative i) v -> V.lookup i v === Nothing+        prop "returns Nothing for the empty vector" $ \i -> V.lookup i V.empty === Nothing

@@ -0,0 +1,47 @@+module Data.Heap.Spec+    ( spec+    ) where++import Data.Bifunctor (bimap)+import Data.Foldable (toList)+import Data.List (partition, sort, uncons)++import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck++import qualified Data.Heap as H++default (Int)++instance (Arbitrary a, Ord a) => Arbitrary (H.Heap a) where+    arbitrary = fmap H.fromList arbitrary++spec :: Spec+spec = describe "Data.Heap" $ do+        prop "satisfies `fromList . toList == id`" $ \h -> H.fromList (toList h) === h++        describe "size" $ do+            prop "returns the size" $ \h -> H.size h === length (toList h)+            it "returns 0 for the empty heap" $ H.size H.empty `shouldBe` 0++        describe "union" $ do+            prop "returns the union of two heaps" $ \xs ys -> H.union (H.fromList xs) (H.fromList ys) === H.fromList (xs ++ ys)+            prop "empty heap is neutral element" $ \h -> H.union h H.empty === h .&&. H.union H.empty h === h++        describe "insert" $ do+            prop "inserts an element" $ \xs x -> H.insert x (H.fromList xs) === H.fromList (x : xs)+            prop "works for the empty heap" $ \x -> H.insert x H.empty === H.singleton x++        describe "deleteMin" $ do+            prop "deletes the minimum element" $ \xs -> H.deleteMin (H.fromList xs) === maybe H.empty (H.fromList . snd) (uncons (sort xs))+            it "works for the empty heap" $ H.deleteMin H.empty `shouldBe` H.empty++        describe "filter" $ do+            prop "filters the elements that satisfy the predicate" $ \xs -> H.filter even (H.fromList xs) === H.fromList (filter even xs)++        describe "partition" $ do+            prop "partitions the elements based on the predicate" $ \xs -> H.partition even (H.fromList xs) === bimap H.fromList H.fromList (partition even xs)++        describe "heapsort" $ do+            prop "sorts a list" $ \ls -> H.heapsort ls === sort ls

@@ -0,0 +1,47 @@+module Data.PrioHeap.Spec+    ( spec+    ) where++import Data.Bifunctor (bimap)+import Data.Foldable (toList)+import Data.List (partition, sort, uncons)++import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck++import qualified Data.PrioHeap as P++default (Int)++instance (Arbitrary k, Arbitrary a, Ord k) => Arbitrary (P.PrioHeap k a) where+    arbitrary = fmap P.fromList arbitrary++fromList :: [(Int, ())] -> P.PrioHeap Int ()+fromList = P.fromList++spec :: Spec+spec = describe "Data.PrioHeap" $ do+        prop "satisfies `fromList . toList == id`" $ \h -> fromList (P.toList h) === h++        describe "size" $ do+            prop "returns the size" $ \h -> P.size h === length (toList h)+            it "returns 0 for the empty heap" $ P.size P.empty `shouldBe` 0++        describe "union" $ do+            prop "returns the union of two heaps" $ \xs ys -> P.union (fromList xs) (fromList ys) === fromList (xs ++ ys)+            prop "empty heap is neutral element" $ \h -> P.union h P.empty === h .&&. P.union P.empty h === h++        describe "insert" $ do+            prop "inserts an element" $ \xs x -> P.insert x () (fromList xs) === fromList ((x, ()) : xs)+            prop "works for the empty heap" $ \k v -> P.insert k v P.empty === P.singleton k v++        describe "deleteMin" $ do+            prop "deletes the minimum element" $ \xs -> P.deleteMin (fromList xs) === maybe P.empty (fromList . snd) (uncons (sort xs))+            it "works for the empty heap" $ P.deleteMin P.empty `shouldBe` P.empty++        describe "filterWithKey" $ do+            prop "filters the elements that satisfy the predicate" $ \xs -> P.filterWithKey (\k () -> even k) (fromList xs) === fromList (filter (even . fst) xs)++        describe "partitionWithKey" $ do+            prop "partitions the elements based on the predicate" $ \xs -> P.partitionWithKey (\k () -> even k) (fromList xs) === bimap fromList fromList (partition (even . fst) xs)

@@ -1,109 +1,11 @@-{-# LANGUAGE ScopedTypeVariables #-}--import Data.Bifunctor (bimap)-import Data.Foldable (toList)-import Data.List (partition, sort)--import Test.Hspec-import Test.QuickCheck--import Data.AMT (Vector)-import qualified Data.AMT as V-import Data.Heap (Heap)-import qualified Data.Heap as H-import Data.PrioHeap (PrioHeap)-import qualified Data.PrioHeap as P--instance Arbitrary a => Arbitrary (Vector a) where-    arbitrary = fmap V.fromList arbitrary--instance (Arbitrary a, Ord a) => Arbitrary (Heap a) where-    arbitrary = fmap H.fromList arbitrary--instance (Arbitrary k, Arbitrary a, Ord k) => Arbitrary (PrioHeap k a) where-    arbitrary = fmap P.fromList arbitrary--uncons :: [a] -> Maybe (a, [a])-uncons [] = Nothing-uncons (x : xs) = Just (x, xs)+import Test.Hspec (hspec) -unsnoc :: [a] -> Maybe ([a], a)-unsnoc [] = Nothing-unsnoc xs@(_ : _) = Just (init xs, last xs)+import qualified Data.AMT.Spec as AMT+import qualified Data.Heap.Spec as Heap+import qualified Data.PrioHeap.Spec as PrioHeap  main :: IO () main = hspec $ do-    describe "Data.AMT" $ do-        it "satisfies `fromList . toList == id`" $-            property $ \(v :: Vector Int) -> V.fromList (toList v) === v-        it "satisfies `toList . fromList == id`" $-            property $ \(ls :: [Int]) -> toList (V.fromList ls) === ls-        describe "length" $ do-            it "returns the length" $-                property $ \(v :: Vector Int) -> length v === length (toList v)-            it "returns 0 for the empty vector" $-                length V.empty `shouldBe` 0-        describe "snoc" $ do-            it "appends an element to the back" $-                property $ \(v :: Vector Int) x -> toList (v V.|> x) === toList v ++ [x]-            it "works for the empty vector" $-                property $ \(x :: Int) -> V.empty V.|> x `shouldBe` V.singleton x-        describe "unsnoc" $ do-            it "analyzes the back of the vector" $-                property $ \(v :: Vector Int) -> V.viewr v === fmap (\(xs, x) -> (V.fromList xs, x)) (unsnoc (toList v))-            it "returns Nothing for the empty vector" $-                V.viewr V.empty `shouldBe` (Nothing :: Maybe (Vector Int, Int))-        describe "take" $-            it "takes the first n elements" $-                property $ \n (xs :: [Int]) -> V.take n (V.fromList xs) === V.fromList (take n xs)--    describe "Data.Heap" $ do-        it "satisfies `fromList . toList == id`" $-            property $ \(h :: Heap Int) -> H.fromList (toList h) === h-        describe "size" $ do-            it "returns the size" $-                property $ \(h :: Heap Int) -> H.size h === length (toList h)-            it "returns 0 for the empty heap" $-                H.size H.empty `shouldBe` 0-        describe "union" $-            it "returns the union of two heaps" $-                property $ \(xs :: [Int]) (ys :: [Int]) -> H.fromList xs `H.union` H.fromList ys === H.fromList (xs ++ ys)-        describe "insert" $-            it "inserts an element" $-                property $ \(xs :: [Int]) (x :: Int) -> H.insert x (H.fromList xs) === H.fromList (x : xs)-        describe "deleteMin" $-            it "deletes the minimum element" $-                property $ \(xs :: [Int]) -> H.deleteMin (H.fromList xs) === maybe H.empty (H.fromList . snd) (uncons (sort xs))-        describe "filter" $-            it "filters the elements that satisfy the predicate" $-                property $ \(xs :: [Int]) -> H.filter even (H.fromList xs) === H.fromList (filter even xs)-        describe "partition" $-            it "partitions the elements based on the predicate" $-                property $ \(xs :: [Int]) -> H.partition even (H.fromList xs) === bimap H.fromList H.fromList (partition even xs)-        describe "heapsort" $-            it "sorts a list" $-                property $ \(ls :: [Int]) -> H.heapsort ls === sort ls--    describe "Data.PrioHeap" $ do-        it "satisfies `fromList . toList == id`" $-            property $ \(h :: PrioHeap Int ()) -> P.fromList (P.toList h) === h-        describe "size" $ do-            it "returns the size" $-                property $ \(h :: PrioHeap Int Int) -> P.size h === length (toList h)-            it "returns 0 for the empty heap" $-                P.size P.empty `shouldBe` 0-        describe "union" $-            it "returns the union of two heaps" $-                property $ \(xs :: [(Int, ())]) (ys :: [(Int, ())]) -> P.fromList xs `P.union` P.fromList ys === P.fromList (xs ++ ys)-        describe "insert" $-            it "inserts an element" $-                property $ \(xs :: [(Int, ())]) (x :: Int) -> P.insert x () (P.fromList xs) === P.fromList ((x, ()) : xs)-        describe "deleteMin" $-            it "deletes the minimum element" $-                property $ \(xs :: [(Int, ())]) -> P.deleteMin (P.fromList xs) === maybe P.empty (P.fromList . snd) (uncons (sort xs))-        describe "filterWithKey" $-            it "filters the elements that satisfy the predicate" $-                property $ \(xs :: [(Int, ())]) -> P.filterWithKey (const . even) (P.fromList xs) === P.fromList (filter (even . fst) xs)-        describe "partitionWithKey" $-            it "partitions the elements based on the predicate" $-                property $ \(xs :: [(Int, ())]) -> P.partitionWithKey (const . even) (P.fromList xs) === bimap P.fromList P.fromList (partition (even . fst) xs)+    AMT.spec+    Heap.spec+    PrioHeap.spec