stable-heap 0.1.0.0 → 0.2.1.0

raw patch · 4 files changed

+620/−96 lines, 4 filesdep +QuickCheckdep +tastydep +tasty-quickcheckdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, tasty, tasty-quickcheck, transformers

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• bench/Bench.hs +1/−1
• src/Data/Heap/Stable.hs +454/−86
• stable-heap.cabal +33/−9
• test/Test.hs +132/−0

@@ -27,7 +27,7 @@       , create "heap" (map (Heap.priority &&& Heap.payload) . Foldable.toList) (\h k v -> Heap.insert (Heap.Entry k v) h) Heap.empty       ]     , bgroup "stable"-      [ create "stable-heap" Stable.toListAsc Stable.snoc Stable.empty+      [ create "stable-heap" Stable.toAscList Stable.snoc Stable.empty       , create "fingertree" (unfoldr FingerTree.minViewWithKey) (\q k v -> FingerTree.add k v q) FingerTree.empty       ]     ]

@@ -1,177 +1,509 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Trustworthy #-}  -- |+-- -- Module      :  Data.Heap.Stable--- Copyright   :  (C) Jake McArthur 2015+-- Copyright   :  (C) 2015-2016 Jake McArthur -- License     :  MIT -- Maintainer  :  Jake.McArthur@gmail.com -- Stability   :  experimental ----- This module provides an implementation of stable heaps, or fair--- priority queues. The data structure is a fairly simple tweak to add--- stability to the lazy pairing heaps described in--- /Purely Functional Data Structures/, by Chris Okasaki.+-- A simple implementation of stable heaps (fair priority queues), modeled as a+-- sequence of key-value pairs, allowing duplicates, with efficient access to+-- the leftmost key-value pair having the smallest key. ----- Unless stated otherwise, the documented asymptotic efficiencies of--- functions on 'Heap' assume that arguments are already in WHNF and--- that the result is to be evaluated to WHNF.+-- The data structure is a modification of the lazy pairing heaps described in+-- Chris Okasaki's /Purely Functional Data Structures/.+--+-- A 'Heap' has both heap-like and sequence-like properties. Most of the+-- traversals defined in this module work in sequence order; those that work in+-- key order are explicitly documented as such.+--+-- Unless stated otherwise, the documented asymptotic efficiencies of functions+-- on 'Heap' assume that arguments are already in WHNF and that the result is to+-- be evaluated to WHNF. module Data.Heap.Stable-       ( Heap ()+       ( -- $setup+         Heap ()+         -- * Query+       , Data.Heap.Stable.null+       , size+         -- * Construction        , empty        , singleton-       , union-       , minViewWithKey+       , append+       , appends        , cons        , snoc-       , foldrWithKey-       , toList-       , toListAsc-       , fromList+         -- * Minimum view+       , MinView (..)+       , minView+         -- * Traversal+         -- ** Map        , bimap        , mapKeys+       , mapWithKey+       , traverseKeys+       , traverseWithKey+         -- ** Fold+       , foldrWithKey+       , foldMapWithKey+         -- * List operations+         -- ** Conversion from lists+       , fromList+         -- ** Conversion to lists+       , toList+       , toAscList        ) where +import Prelude hiding (null)+ import qualified Control.Applicative as Applicative+import Control.Applicative hiding (Alternative (..)) import Control.Monad import Data.List (foldl', unfoldr)-import Data.Monoid+import qualified Data.List+import Data.Foldable (Foldable)+import Data.Traversable (Traversable)  import qualified GHC.Exts --- | Semantically, @Heap k a@ is equivalent to @[(k, a)]@, but its--- operations have different efficiencies.+#if MIN_VERSION_base(4,9,0)+-- Data.Semigroup was added in base-4.9+import Data.Semigroup as Sem+#endif+#if !(MIN_VERSION_base(4,8,0))+-- starting with base-4.8, Monoid is rexported from Prelude+import Data.Monoid+#endif++-- |+--+-- @Heap k a@ is equivalent to @[(k, a)]@, but its operations have different+-- efficiencies. data Heap k a-  = Heap !(Heap k a) (Heap k a) !k a (Heap k a) !(Heap k a)+  = Heap !Int !(Heap k a) (Heap k a) !k a (Heap k a) !(Heap k a)   | Empty   deriving (Functor, Foldable, Traversable) --- | @toList empty = []@+-- |+--+-- 'True' if the 'Heap' is empty and 'False' otherwise.+--+-- /O(1)/.+--+-- >>> any null [the, quick, brown, fox]+-- False+--+-- >>> null empty+-- True+--+-- prop> null xs == Data.List.null (toList xs)+null :: Heap k a -> Bool+null Empty = True+null Heap {} = False++-- |+--+-- The number of key-value pairs in the heap.+--+-- /O(1)/.+--+-- >>> map size [the, quick, brown, fox]+-- [3,5,5,3]+--+-- >>> size empty+-- 0+--+-- prop> size xs == length (toList xs)+size :: Heap k a -> Int+size Empty = 0+size (Heap s _ _ _ _ _ _) = s++-- |+-- An empty heap.+--+-- >>> empty+-- fromList [] empty :: Heap k a empty = Empty --- | /O(1)/.+-- | ----- > toList (singleton k v) = [(k, v)]+-- Construct a heap containing a single key-value pair.+--+-- /O(1)/.+--+-- >>> singleton "foo" 42+-- fromList [("foo",42)]+--+-- prop> toList (singleton k v) == [(k, v)] singleton :: k -> a -> Heap k a-singleton k v = Heap empty empty k v empty empty+singleton k v = Heap 1 empty empty k v empty empty --- | /O(1)/.+-- | ----- > toList (xs `union` ys) = toList xs ++ toList ys-union :: Ord k => Heap k a -> Heap k a -> Heap k a-Empty `union` ys = ys-xs `union` Empty = xs-xs@(Heap l1 ls1 k1 v1 rs1 r1) `union` ys@(Heap l2 ls2 k2 v2 rs2 r2)+-- Append two heaps, preserving sequential ordering.+--+-- /O(1)/.+--+-- >>> append empty the+-- fromList [('t',0),('h',1),('e',2)]+--+-- >>> append the empty+-- fromList [('t',0),('h',1),('e',2)]+--+-- >>> append the fox+-- fromList [('t',0),('h',1),('e',2),('f',0),('o',1),('x',2)]+--+-- prop> toList (xs `append` ys) == toList xs ++ toList ys+append :: Ord k => Heap k a -> Heap k a -> Heap k a+Empty `append` ys = ys+xs `append` Empty = xs+xs@(Heap sx l1 ls1 k1 v1 rs1 r1) `append` ys@(Heap sy l2 ls2 k2 v2 rs2 r2)   | k1 <= k2 =       case r1 of-        Empty            -> Heap l1 ls1 k1 v1  rs1                     ys-        Heap _ _ _ _ _ _ -> Heap l1 ls1 k1 v1 (rs1 `union` (r1 `union` ys)) Empty+        Empty   -> Heap (sx+sy) l1 ls1 k1 v1  rs1                     ys+        Heap {} -> Heap (sx+sy) l1 ls1 k1 v1 (rs1 `append` (r1 `append` ys)) Empty   | otherwise =       case l2 of-        Empty            -> Heap         xs                     ls2  k2 v2 rs2 r2-        Heap _ _ _ _ _ _ -> Heap Empty ((xs `union` l2) `union` ls2) k2 v2 rs2 r2+        Empty   -> Heap (sx+sy)        xs                        ls2  k2 v2 rs2 r2+        Heap {} -> Heap (sx+sy) Empty ((xs `append` l2) `append` ls2) k2 v2 rs2 r2 --- | Split the 'Heap' at the leftmost occurrence of the smallest key--- contained in the 'Heap'.+-- | ----- When the 'Heap' is empty, /O(1)/. When the 'Heap' is not empty,--- finding the key and value is /O(1)/, and evaluating the remainder--- of the heap to the left or right of the key-value pair is amortized--- /O(log n)/.+-- Sequentially append an arbitrary number of heaps. ----- > toList xs =--- > case minViewWithKey xs of--- >   Nothing -> []--- >   Just (l, kv, r) -> toList l ++ [kv] ++ toList r-minViewWithKey :: Ord k => Heap k a -> Maybe (Heap k a, (k, a), Heap k a)-minViewWithKey Empty = Nothing-minViewWithKey (Heap l ls k v rs r) = Just (l `union` ls, (k, v), rs `union` r)+-- /O(m)/, where /m/ is the length of the input list.+--+-- >>> appends [the, quick, fox]+-- fromList [('t',0),('h',1),('e',2),('q',0),('u',1),('i',2),('c',3),('k',4),('f',0),('o',1),('x',2)]+--+-- prop> toList (appends xss) == concatMap toList xss+appends :: Ord k => [Heap k a] -> Heap k a+appends = foldl' append empty  -- |--- > mempty  = empty--- > mappend = union+--+-- View of the minimum key of a heap, split out from everything occurring to its+-- left and to its right in the sequence.+data MinView k v+  = EmptyView+  | MinView (Heap k v) k v (Heap k v)+  deriving (Eq, Show)++-- |+--+-- Split the 'Heap' at the /leftmost/ occurrence of the smallest key contained+-- in the 'Heap'.+--+-- When the 'Heap' is empty, /O(1)/. When the 'Heap' is not empty, finding the+-- key and value is /O(1)/, and evaluating the remainder of the heap to the left+-- or right of the key-value pair is amortized /O(log n)/.+--+-- >>> minView empty+-- EmptyView+--+-- >>> minView the+-- MinView (fromList [('t',0),('h',1)]) 'e' 2 (fromList [])+--+-- >>> minView (append the the)+-- MinView (fromList [('t',0),('h',1)]) 'e' 2 (fromList [('t',0),('h',1),('e',2)])+--+-- >>> minView quick+-- MinView (fromList [('q',0),('u',1),('i',2)]) 'c' 3 (fromList [('k',4)])+--+-- >>> minView brown+-- MinView (fromList []) 'b' 0 (fromList [('r',1),('o',2),('w',3),('n',4)])+--+-- >>> minView fox+-- MinView (fromList []) 'f' 0 (fromList [('o',1),('x',2)])+--+-- Here is a model implementation of 'minView':+--+-- >>> :{+-- let { minViewModel xs =+--         case toList xs of+--           []        -> EmptyView+--           keyValues ->+--             let minKey          = minimum (map fst keyValues)+--                 (l, (k, v) : r) = break (\(key, _) -> key == minKey) keyValues+--             in MinView (fromList l) k v (fromList r)+--     }+-- :}+--+-- The following property looks different from the others in this module due to+-- working around a limitation of doctest.+--+-- >>> quickCheck $ \xs -> minView (xs :: Heap Integer Integer) == minViewModel xs+-- +++ OK, passed 100 tests.+minView :: Ord k => Heap k a -> MinView k a+minView Empty = EmptyView+minView (Heap _ l ls k v rs r) = MinView (l `append` ls) k v (rs `append` r)++#if MIN_VERSION_base(4,9,0)+instance Ord k => Sem.Semigroup (Heap k a) where+  (<>) = append+#endif++-- |+--+-- Formed from 'empty' and 'append' instance Ord k => Monoid (Heap k a) where   mempty = empty-  mappend = union --- | /O(1)/.+#if MIN_VERSION_base(4,11,0)+  -- starting with base-4.11, mappend definitions are redundant;+  -- at some point `mappend` will be removed from `Monoid`+#elif MIN_VERSION_base(4,9,0)+  mappend = (Sem.<>)+#else+  -- prior to GHC 8.0 / base-4.9 where no `Semigroup` class existed+  mappend = append+#endif++-- | ----- > toList (cons k v xs) = (k, v) : toList xs+-- Prepend a key-value pair to the beginning of a 'Heap'.+--+-- /O(1)/.+--+-- >>> cons 'a' 0 fox+-- fromList [('a',0),('f',0),('o',1),('x',2)]+--+-- prop> toList (cons k v xs) == (k, v) : toList xs cons :: Ord k => k -> a -> Heap k a -> Heap k a-cons k v = (singleton k v <>)+cons k v = (singleton k v `append`) --- | /O(1)/.+-- | ----- > toList (snoc xs k v) = toList xs ++ [(k, v)]+-- Append a key-value pair to the end of a 'Heap'.+--+-- /O(1)/.+--+-- >>> snoc fox 'y' 0+-- fromList [('f',0),('o',1),('x',2),('y',0)]+--+-- prop> toList (snoc xs k v) == toList xs ++ [(k, v)] snoc :: Ord k => Heap k a -> k -> a -> Heap k a-snoc xs k v = xs <> singleton k v+snoc xs k v = xs `append` singleton k v --- | > foldrWithKey f z xs = foldr (uncurry f) z (toList xs)+-- |+--+-- Like 'foldr', but provides access to the key for each value in the folding+-- function.+--+-- >>> foldrWithKey (\k v kvs -> (k, v) : kvs) [] fox+-- [('f',0),('o',1),('x',2)]+--+-- prop> let f k v acc = g `apply` k `apply` v `apply` acc in foldrWithKey f z xs == foldr (uncurry f) z (toList xs) foldrWithKey :: (k -> a -> b -> b) -> b -> Heap k a -> b foldrWithKey f = flip go   where     go Empty z = z-    go (Heap l ls k v rs r) z = go l (go ls (f k v (go rs (go r z))))+    go (Heap _ l ls k v rs r) z = go l (go ls (f k v (go rs (go r z)))) --- | List the key-value pairs in a 'Heap' in occurrence order. This is the semantic+-- |+--+-- List the key-value pairs in a 'Heap' in sequence order. This is the semantic -- function for 'Heap'. --+-- >>> toList empty+-- []+--+-- >>> toList the+-- [('t',0),('h',1),('e',2)]+--+-- >>> toList quick+-- [('q',0),('u',1),('i',2),('c',3),('k',4)]+--+-- >>> toList brown+-- [('b',0),('r',1),('o',2),('w',3),('n',4)]+--+-- >>> toList fox+-- [('f',0),('o',1),('x',2)]+-- -- /O(n)/ when the spine of the result is evaluated fully.+--+-- prop> toList (fromList xs) == xs+-- prop> fromList (toList xs) == xs toList :: Heap k a -> [(k, a)] toList = foldrWithKey (\k v xs -> (k, v) : xs) [] --- | List the key-value pairs in a 'Heap' in key order.+-- | --+-- List the key-value pairs in a 'Heap' in key order.+-- -- /O(n log n)/ when the spine of the result is evaluated fully.-toListAsc :: Ord k => Heap k a -> [(k, a)]-toListAsc = unfoldr f+--+-- >>> toAscList empty+-- []+--+-- >>> toAscList the+-- [('e',2),('h',1),('t',0)]+--+-- >>> toAscList quick+-- [('c',3),('i',2),('k',4),('q',0),('u',1)]+--+-- >>> toAscList brown+-- [('b',0),('n',4),('o',2),('r',1),('w',3)]+--+-- >>> toAscList fox+-- [('f',0),('o',1),('x',2)]+--+-- prop> toAscList xs == Data.List.sortOn fst (toList xs)+toAscList :: Ord k => Heap k a -> [(k, a)]+toAscList = unfoldr f   where     f xs =-      case minViewWithKey xs of-        Nothing -> Nothing-        Just (l, kv, r) -> Just (kv, l <> r)+      case minView xs of+        EmptyView -> Nothing+        MinView l k v r -> Just ((k, v), l `append` r) --- | Construct a 'Heap' from a list of key-value pairs.+-- | --+-- Construct a 'Heap' from a list of key-value pairs.+-- -- /O(n)/.+--+-- >>> fromList (zip [0..3] [4..])+-- fromList [(0,4),(1,5),(2,6),(3,7)]+--+-- prop> toList (fromList xs) == xs+-- prop> fromList (toList xs) == xs fromList :: Ord k => [(k, a)] -> Heap k a fromList = foldl' (\acc (k, v) -> snoc acc k v) empty --- | > toList (bimap f g xs) = map (f *** g) (toList xs)+-- |+--+-- >>> bimap succ (*10) fox+-- fromList [('g',0),('p',10),('y',20)]+--+-- prop> toList (bimap (apply f) (apply g) xs) == map (\(k, v) -> (apply f k, apply g v)) (toList xs) bimap :: Ord k2 => (k1 -> k2) -> (a -> b) -> Heap k1 a -> Heap k2 b bimap f g = go   where     go Empty = Empty-    go (Heap l ls k v rs r) = go l <> go ls <> singleton (f k) (g v) <> go rs <> go r+    go (Heap _ l ls k v rs r) =+      go l `append` go ls `append` singleton (f k) (g v) `append` go rs `append` go r --- | > toList (mapKeys f xs) = map (first f) (toList xs)+-- |+--+-- >>> mapKeys succ fox+-- fromList [('g',0),('p',1),('y',2)]+--+-- prop> toList (mapKeys (apply f) xs) == map (\(k, v) -> (apply f k, v)) (toList xs) mapKeys :: Ord k2 => (k1 -> k2) -> Heap k1 a -> Heap k2 a mapKeys f = bimap f id --- | Same semantics as @WriterT k []@+-- |+--+-- Map a function over all values in a heap.+--+-- /O(1)/ when evaluating to WHNF. /O(n)/ when evaluating to NF.+--+-- >>> mapWithKey (\k v -> (k,v)) fox+-- fromList [('f',('f',0)),('o',('o',1)),('x',('x',2))]+--+-- prop> let f k v = g `apply` k `apply` v in mapWithKey f xs == fromList (map (\(k, v) -> (k, f k v)) (toList xs))+mapWithKey :: (k -> a -> b) -> Heap k a -> Heap k b+mapWithKey f = go+  where+    go Empty = Empty+    go (Heap n l ls k v rs r) = Heap n (go l) (go ls) k (f k v) (go rs) (go r)++-- |+--+-- Fold the keys and values in the heap using the given monoid, such that+--+-- /O(n)/.+--+-- >>> foldMapWithKey (\k v -> [(k,v)]) fox+-- [('f',0),('o',1),('x',2)]+--+-- prop> let f k v = g `apply` k `apply` v :: [Integer] in foldMapWithKey f xs == Data.Foldable.fold (mapWithKey f xs)+foldMapWithKey :: Monoid b => (k -> a -> b) -> Heap k a -> b+foldMapWithKey f = go+  where+    go Empty = mempty+    go (Heap _ l ls k v rs r) =+      go l `mappend` go ls `mappend` f k v `mappend` go rs `mappend` go r++-- |+--+-- Behaves exactly like a regular traverse except that the traversing function+-- also has access to the key associated with a value, such that+--+-- /O(n)/.+--+-- >>> traverseWithKey (\k v -> print (k, v) >> return (succ k, v)) fox+-- ('f',0)+-- ('o',1)+-- ('x',2)+-- fromList [('f',('g',0)),('o',('p',1)),('x',('y',2))]+--+-- prop> let f k v = g `apply` k `apply` v :: ([Integer], Integer) in traverseWithKey f xs == (fromList <$> traverse (\(k, v) -> (,) k <$> f k v) (toList xs))++-- > traverseWithKey f = fromList . traverse ((k, v) -> (,) k $ f k v) . toList+traverseWithKey :: Applicative f => (k -> a -> f b) -> Heap k a -> f (Heap k b)+traverseWithKey f = go+  where+    go Empty = pure Empty+    go (Heap n l ls k v rs r) = Heap n <$> go l <*> go ls <*> pure k <*> f k v <*> go rs <*> go r++-- |+--+-- Behaves exactly like a regular traverse except that it's over the keys+-- instead of the values.+--+-- /O(n)/.+--+-- >>> traverseKeys (\k -> print k >> return (succ k)) fox+-- 'f'+-- 'o'+-- 'x'+-- fromList [('g',0),('p',1),('y',2)]+--+-- prop> traverseKeys (apply f) xs == (fromList <$> traverse (\(k, v) -> flip (,) v <$> (apply f k :: ([Integer], Integer))) (toList xs))+traverseKeys :: (Applicative f, Ord k2) => (k1 -> f k2) -> Heap k1 a -> f (Heap k2 a)+traverseKeys f = go+  where+    go Empty = pure Empty+    go (Heap _ l ls k v rs r) = go l <.> go ls <.> ((`singleton` v) <$> f k) <.> go rs <.> go r+    (<.>) = liftA2 append++-- |+--+-- Equivalent to @WriterT k []@ instance (Monoid k, Ord k) => Applicative (Heap k) where   pure = singleton mempty   Empty <*> _ = Empty   _ <*> Empty = Empty-  (Heap fl fls fk f frs fr) <*> xs+  Heap _ fl fls fk f frs fr <*> xs     =  (fl  <*>         xs)-    <> (fls <*>         xs)-    <> (bimap (fk <>) f xs)-    <> (frs <*>         xs)-    <> (fr  <*>         xs)+    `append` (fls <*> xs)+    `append` bimap (fk `mappend`) f xs+    `append` (frs <*> xs)+    `append` (fr  <*> xs) --- | Same semantics as @WriterT k []@+-- |+--+-- Equivalent to @WriterT k []@ instance (Monoid k, Ord k) => Monad (Heap k) where   return = pure   Empty >>= _ = Empty-  Heap xl xls xk x xrs xr >>= f+  Heap _ xl xls xk x xrs xr >>= f     =  (xl  >>= f)-    <> (xls >>= f)-    <> (mapKeys (xk <>) (f x))-    <> (xrs >>= f)-    <> (xr  >>= f)+    `append` (xls >>= f)+    `append` mapKeys (xk `mappend`) (f x)+    `append` (xrs >>= f)+    `append` (xr  >>= f)  instance (Show k, Show a) => Show (Heap k a) where   showsPrec d h = showParen (d > 10) $ showString "fromList " . shows (toList h)@@ -187,24 +519,60 @@   fromList = fromList   toList   = toList --- | > xs == ys = toList xs == toList ys+-- |+--+-- prop> (xs == ys) == (toList xs == toList ys) instance (Eq k, Eq a) => Eq (Heap k a) where   xs == ys = toList xs == toList ys --- | > compare xs ys = compare (toList xs) (toList ys)+-- |+--+-- prop> compare xs ys == compare (toList xs) (toList ys) instance (Ord k, Ord a) => Ord (Heap k a) where   compare xs ys = compare (toList xs) (toList ys)  -- |--- > empty = empty--- > (<|>) = union+--+-- Formed from 'empty' and 'append' instance (Monoid k, Ord k) => Applicative.Alternative (Heap k) where   empty = mempty   (<|>) = mappend  -- |--- > mzero = empty--- > mplus = union+--+-- Formed from 'empty' and 'append' instance (Monoid k, Ord k) => MonadPlus (Heap k) where   mzero = mempty   mplus = mappend++-- $setup+--+-- We use QuickCheck to verify the properties given in this documentation. Here+-- is the necessary setup code:+--+-- >>> import Test.QuickCheck+-- >>> import Test.QuickCheck.Function+-- >>> :{+-- instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (Heap k v) where+--   arbitrary = fromList <$> arbitrary+--   shrink = map fromList . shrink . toList+-- :}+--+-- Here are some example values used in the documentation for this module:+--+-- >>> let the   = fromList (zip "the"   [0..])+-- >>> let quick = fromList (zip "quick" [0..])+-- >>> let brown = fromList (zip "brown" [0..])+-- >>> let fox   = fromList (zip "fox"   [0..])+--+-- >>> the+-- fromList [('t',0),('h',1),('e',2)]+--+-- >>> quick+-- fromList [('q',0),('u',1),('i',2),('c',3),('k',4)]+--+-- >>> brown+-- fromList [('b',0),('r',1),('o',2),('w',3),('n',4)]+--+-- >>> fox+-- fromList [('f',0),('o',1),('x',2)]

@@ -1,5 +1,5 @@ name:                stable-heap-version:             0.1.0.0+version:             0.2.1.0 synopsis:            Purely functional stable heaps (fair priority queues) description:         This library provides a purely functional implementation of@@ -15,25 +15,49 @@ license-file:        LICENSE author:              Jake McArthur maintainer:          Jake.McArthur@gmail.com-copyright:           Copyright (C) 2015 Jake McArthur+copyright:           Copyright (C) 2015-2016 Jake McArthur homepage:            http://hub.darcs.net/jmcarthur/stable-heap bug-reports:         http://hub.darcs.net/jmcarthur/stable-heap/issues category:            Data Structures build-type:          Simple cabal-version:       >=1.10 stability:           experimental+tested-with:         GHC ==7.8.4,+                     GHC ==7.10.3,+                     GHC ==8.0.2,+                     GHC ==8.2.2,+                     GHC ==8.4.4,+                     GHC ==8.6.5,+                     GHC ==8.8.4,+                     GHC ==8.10.7,+                     GHC ==9.0.2,+                     GHC ==9.2.7,+                     GHC ==9.4.4,+                     GHC ==9.6.1  library   exposed-modules:     Data.Heap.Stable-  build-depends:       base >=4.8 && <4.9+  build-depends:       base >=4.7 && <4.19   hs-source-dirs:      src   default-language:    Haskell2010   other-extensions:    DeriveTraversable, Trustworthy, TypeFamilies +test-suite test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  build-depends:       base,+                       QuickCheck,+                       stable-heap,+                       tasty,+                       tasty-quickcheck,+                       transformers+  main-is:             Test.hs+  default-language:    Haskell2010+ benchmark bench   type:                exitcode-stdio-1.0   hs-source-dirs:      bench-  build-depends:       base >=4.8 && <4.9,+  build-depends:       base >=4.7 && <4.19,                        criterion >= 1.1,                        fingertree >= 0.1,                        heaps >= 0.3,@@ -45,10 +69,10 @@   default-language:    Haskell2010  source-repository head-  type:     darcs-  location: http://hub.darcs.net/jmcarthur/stable-heap+  type:     git+  location: https://github.com/jmcarthur/stable-heap.git  source-repository this-  type:     darcs-  location: http://hub.darcs.net/jmcarthur/stable-heap-  tag:      v0.1.0.0+  type:     git+  location: https://github.com/jmcarthur/stable-heap.git+  tag:      v0.2.1.0

@@ -0,0 +1,132 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++import Control.Arrow+import Control.Applicative+import Control.Monad.Trans.Writer+import Data.Heap.Stable (Heap)+import qualified Data.Heap.Stable as Heap+import Data.Foldable (foldMap)+import Data.List+import Data.Ord+import Data.Traversable (traverse)+import Data.Tuple+import Test.QuickCheck.Function+import Test.Tasty+import Test.Tasty.QuickCheck++main :: IO ()+main = defaultMain tests++-- TODO Many of these tests are now redundant with doctests.+tests :: TestTree+tests =+  testGroup "toList"+  [ testProperty "null" $+    \(H h :: H Int Int) ->+      Heap.null h == (null . Heap.toList) h+  , testProperty "size" $+    \(H h :: H Int Int) ->+      Heap.size h == (length . Heap.toList) h+  , testProperty "empty" $+    (null . Heap.toList) Heap.empty+  , testProperty "singleton" $+    \(k :: Int) (v :: Int) ->+      Heap.toList (Heap.singleton k v) == [(k, v)]+  , testProperty "append" $+    \(H a :: H Int Int) (H b) ->+      Heap.toList (Heap.append a b) == Heap.toList a ++ Heap.toList b+  , testProperty "appends" $+    \(map toHeap -> hs :: [Heap Int Int]) ->+      (Heap.toList . Heap.appends) hs == concatMap Heap.toList hs+  , testProperty "minView" $+    \(H h :: H Int Int) ->+      (minViewToSemantics . Heap.minView) h+      == (minViewSemantics . Heap.toList) h+  , testProperty "cons" $+    \k v (H h :: H Int Int) ->+      (Heap.toList . Heap.cons k v) h == (k, v) : Heap.toList h+  , testProperty "snoc" $+    \(H h :: H Int Int) k v ->+      Heap.toList (Heap.snoc h k v) == Heap.toList h ++ [(k, v)]+  , testProperty "foldrWithKey" $+    \f (z :: Int) (H h :: H Int Int) ->+      let+        g k v acc = f `apply` k `apply` v `apply` acc+      in+        Heap.foldrWithKey g z h == foldr (\(k, v) acc -> g k v acc) z (Heap.toList h)+  , testProperty "toAscList" $+    \(H h :: H Int Int) ->+      Heap.toAscList h == sortBy (comparing fst) (Heap.toList h)+  , testProperty "fromList" $+    \(kvs :: [(Int, Int)]) ->+      (Heap.toList . Heap.fromList) kvs == kvs+  , testProperty "bimap" $+    \(f :: Fun Int Int) (g :: Fun Int Int) (H h) ->+      (Heap.toList . Heap.bimap (apply f) (apply g)) h+      == (map (apply f *** apply g) . Heap.toList) h+  , testProperty "mapKeys" $+    \(f :: Fun Int Int) (H h :: H Int Int) ->+      (Heap.toList . Heap.mapKeys (apply f)) h+      == ((map . first . apply) f . Heap.toList) h+  , testProperty "mapWithKey" $+    \f (H h :: H Int Int) ->+      let+        g k v = f `apply` k `apply` v :: Int+      in+        (Heap.toList . Heap.mapWithKey g) h+        == (map (\(k, v) -> (k, g k v)) . Heap.toList) h+  , testProperty "foldMapWithKey" $+    \f (H h :: H Int Int) ->+      let+        g k v = f `apply` k `apply` v :: [Int]+      in+        Heap.foldMapWithKey g h == ((foldMap . uncurry) g . Heap.toList) h+  , testProperty "traverseWithKey" $+    \f (H h :: H Int Int) ->+      let+        g k v = f `apply` k `apply` v :: ([Int], Int)+      in+        (fmap Heap.toList . Heap.traverseWithKey g) h+        == (traverse (\(k, v) -> (,) k <$> g k v) . Heap.toList) h+  , testProperty "traverseKeys" $+    \f (H h :: H Int Int) ->+      let+        g k = f `apply` k :: ([Int], Int)+      in+        (fmap Heap.toList . Heap.traverseKeys g) h+        == (traverse (\(k, v) -> flip (,) v <$> g k) . Heap.toList) h+  , testProperty "pure" $+    \(x :: Int) ->+      ((Heap.toList . pure) x :: [([Int], Int)]) == (fromWriterT . pure) x+  , testProperty "(<*>)" $+    \(H (fmap apply -> a) :: H [Int] (Fun Int Int)) (H b :: H [Int] Int) ->+      Heap.toList (a <*> b) == fromWriterT (toWriterT a <*> toWriterT b)+  , testProperty "(>>=)" $+    \(H a :: H [Int] Int) (fmap toHeap . apply -> f :: Int -> Heap [Int] Int) ->+      Heap.toList (a >>= f) == fromWriterT (toWriterT a >>= toWriterT . f)+  ]++minViewToSemantics :: Heap.MinView k a -> Maybe ([(k, a)], (k, a), [(k, a)])+minViewToSemantics Heap.EmptyView = Nothing+minViewToSemantics (Heap.MinView l k v r) = Just (Heap.toList l, (k, v), Heap.toList r)++minViewSemantics :: Ord k => [(k, a)] -> Maybe ([(k, a)], (k, a), [(k, a)])+minViewSemantics [] = Nothing+minViewSemantics kvs = Just (l, kv, r)+  where+    minKey = (minimum . map fst) kvs+    (l, kv : r) = break ((== minKey) . fst) kvs++fromWriterT :: WriterT k [] v -> [(k, v)]+fromWriterT = map swap . runWriterT++toWriterT :: Heap k v -> WriterT k [] v+toWriterT = WriterT . map swap . Heap.toList++newtype H k v = H { toHeap :: Heap k v }+  deriving Show++instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (H k v) where+  arbitrary = H . Heap.fromList <$> arbitrary+  shrink = map (H . Heap.fromList . shrink) . Heap.toList . toHeap