packages feed

pqueue 1.4.3.0 → 1.5.0.0

raw patch · 21 files changed

+857/−336 lines, 21 filesdep ~basedep ~deepseq

Dependency ranges changed: base, deepseq

Files

CHANGELOG.md view
@@ -1,5 +1,36 @@ # Revision history for pqueue +## 1.5.0.0 -- 2023-08-08++  * Fix incorrect behavior of `mapMaybe` and `mapEither` for `MinQueue`. These+    previously worked only for monotonic functions.++  * Fix a performance bug that caused queue performance not to improve+    when the queue shrinks.+    ([#109](https://github.com/lspitzner/pqueue/pull/109))++  * Make `minView` more eager, improving performance in typical cases.+    ([#107](https://github.com/lspitzner/pqueue/pull/107))++  * Make mapping and traversal functions force the full data structure spine.+    This should make performance more predictable, and removes the last+    remaining reasons to use the `seqSpine` functions. As these are no longer+    useful, deprecate them.+    ([#103](https://github.com/lspitzner/pqueue/pull/103))++  * Deprecate `insertBehind`. This function does not play nicely with merges,+    we lack tests to verify it works properly without merges, it imposes a+    substantial maintenance burden on the rest of the package, and it is quite+    slow. ([#35](https://github.com/lspitzner/pqueue/issues/35))++  * Add pattern synonyms to work with `MinQueue` and `MinPQueue`.+    ([#92](http://github.com/lspitzner/pqueue/pull/92))++  * Make the `Data` instances respect the queue invariants. Make the+    `Constr`s match the pattern synonyms. Make the `Data` instance for+    `MinPQueue` work "incrementally", like the one for `MinQueue`.+    ([#92](http://github.com/lspitzner/pqueue/pull/92))+ ## 1.4.3.0 -- 2022-10-30    * Add instances for [indexed-traversable](https://hackage.haskell.org/package/indexed-traversable).
benchmarks/BenchMinPQueue.hs view
@@ -3,6 +3,7 @@  import qualified KWay.PrioMergeAlg as KWay import qualified PHeapSort as HS+import qualified Data.PQueue.Prio.Min as P  kWay :: Int -> Int -> Benchmark kWay i n = bench@@ -14,6 +15,17 @@   ("Heap sort with " ++ show n ++ " elements")   (nf (HS.heapSortRandoms n) $ mkStdGen (-7750349139967535027)) +filterQ :: Int -> Benchmark+filterQ n = bench+  ("filter with " ++ show n ++ " elements")+  (whnf (P.drop 1 . P.filterWithKey (>) . (P.fromList :: [(Int, Int)] -> P.MinPQueue Int Int) . take n . randoms) $ mkStdGen 977209486631198655)++partitionQ :: Int -> Benchmark+partitionQ n = bench+  ("partition with " ++ show n ++ " elements")+  (whnf (P.drop 1 . snd . P.partitionWithKey (>) . (P.fromList :: [(Int, Int)] -> P.MinPQueue Int Int) . take n . randoms) $ mkStdGen 781928047937198)++ main :: IO () main = defaultMain   [ bgroup "heapSort"@@ -34,5 +46,19 @@       , kWay (3*10^6) 1000       , kWay (2*10^6) 2000       , kWay (4*10^6) 100+      ]+  , bgroup "filter"+      [ filterQ (10^3)+      , filterQ (10^4)+      , filterQ (10^5)+      , filterQ (10^6)+      , filterQ (3*10^6)+      ]+  , bgroup "partition"+      [ partitionQ (10^3)+      , partitionQ (10^4)+      , partitionQ (10^5)+      , partitionQ (10^6)+      , partitionQ (3*10^6)       ]   ]
benchmarks/BenchMinQueue.hs view
@@ -3,6 +3,7 @@  import qualified KWay.MergeAlg as KWay import qualified HeapSort as HS+import qualified Data.PQueue.Min as P  kWay :: Int -> Int -> Benchmark kWay i n = bench@@ -14,9 +15,19 @@   ("Heap sort with " ++ show n ++ " elements")   (nf (HS.heapSortRandoms n) $ mkStdGen (-7750349139967535027)) +filterQ :: Int -> Benchmark+filterQ n = bench+  ("filter with " ++ show n ++ " elements")+  (whnf (P.drop 1 . P.filter (>0) . (P.fromList :: [Int] -> P.MinQueue Int) . take n . randoms) $ mkStdGen 977209486631198655)++partitionQ :: Int -> Benchmark+partitionQ n = bench+  ("partition with " ++ show n ++ " elements")+  (whnf (P.drop 1 . snd . P.partition (>0) . (P.fromList :: [Int] -> P.MinQueue Int) . take n . randoms) $ mkStdGen 781928047937198)+ main :: IO ()-main = defaultMain-  [ bgroup "heapSort"+main = defaultMain [+    bgroup "heapSort"       [ hSort (10^3)       , hSort (10^4)       , hSort (10^5)@@ -34,5 +45,19 @@       , kWay (3*10^6) 1000       , kWay (2*10^6) 2000       , kWay (4*10^6) 100+      ]+  , bgroup "filter"+      [ filterQ (10^3)+      , filterQ (10^4)+      , filterQ (10^5)+      , filterQ (10^6)+      , filterQ (3*10^6)+      ]+  , bgroup "partition"+      [ partitionQ (10^3)+      , partitionQ (10^4)+      , partitionQ (10^5)+      , partitionQ (10^6)+      , partitionQ (3*10^6)       ]   ]
pqueue.cabal view
@@ -1,5 +1,5 @@ name:               pqueue-version:            1.4.3.0+version:            1.5.0.0 category:           Data Structures author:             Louis Wasserman license:            BSD3@@ -15,7 +15,8 @@ bug-reports:        https://github.com/lspitzner/pqueue/issues build-type:         Simple cabal-version:      >= 1.10-tested-with:        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.4, GHC == 9.4.2+tested-with:        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.5, GHC == 9.6.2 extra-source-files:   CHANGELOG.md   README.md@@ -29,7 +30,7 @@   default-language:     Haskell2010   build-depends:-  { base >= 4.8 && < 4.18+  { base >= 4.8 && < 4.19   , deepseq >= 1.3 && < 1.5   , indexed-traversable >= 0.1 && < 0.2   }@@ -47,6 +48,7 @@     Data.PQueue.Internals.Down     Data.PQueue.Internals.Foldable     Data.PQueue.Prio.Max.Internals+    Nattish   if impl(ghc) {     default-extensions: DeriveDataTypeable   }@@ -65,16 +67,39 @@       -fno-warn-unused-imports  test-suite test-  hs-source-dirs: tests+  hs-source-dirs: src, tests   default-language: Haskell2010   type: exitcode-stdio-1.0   main-is: PQueueTests.hs   build-depends:-  { base >= 4.8 && < 4.18+  { base >= 4.8 && < 4.19   , deepseq >= 1.3 && < 1.5+  , indexed-traversable >= 0.1 && < 0.2   , tasty   , tasty-quickcheck-  , pqueue+  }+  other-modules:+    Data.PQueue.Prio.Min+    Data.PQueue.Prio.Max+    Data.PQueue.Min+    Data.PQueue.Max+    Data.PQueue.Prio.Internals+    Data.PQueue.Internals+    BinomialQueue.Internals+    BinomialQueue.Min+    BinomialQueue.Max+    Data.PQueue.Internals.Down+    Data.PQueue.Internals.Foldable+    Data.PQueue.Prio.Max.Internals+    Nattish++    Validity.BinomialQueue+    Validity.PQueue.Min+    Validity.PQueue.Prio.BinomialQueue+    Validity.PQueue.Prio.Min+    Validity.PQueue.Prio.Max+  if impl(ghc) {+    default-extensions: DeriveDataTypeable   }   ghc-options:     -Wall
src/BinomialQueue/Internals.hs view
@@ -19,6 +19,7 @@   minView,   singleton,   insert,+  insertEager,   union,   unionPlusOne,   mapMaybe,@@ -141,8 +142,9 @@ -- -- The Skip constructor must be lazy to obtain the desired amortized bounds. -- The forest field of the Cons constructor /could/ be made strict, but that--- would be worse for heavily persistent use and not obviously better--- otherwise.+-- would be worse for heavily persistent use. According to our benchmarks, it+-- doesn't make a significant or consistent difference even in non-persistent+-- code (heap sort and k-way merge). -- -- Debit invariant: --@@ -208,6 +210,14 @@ insert :: Ord a => a -> MinQueue a -> MinQueue a insert x (MinQueue ts) = MinQueue (incr (tip x) ts) +-- | \(O(\log n)\), but a fast \(O(1)\) average when inserting repeatedly in+-- an empty queue or at least around \(O(\log n)\) times into a nonempty one.+-- Insert an element into the priority queue. This is good for 'fromList'-like+-- operations.+insertEager :: Ord a => a -> MinQueue a -> MinQueue a+insertEager x (MinQueue ts) = MinQueue (incr' (tip x) ts)+{-# INLINE insertEager #-}+ -- | Amortized \(O(\log \min(n,m))\), worst-case \(O(\log \max(n,m))\). Take the union of two priority queues. union :: Ord a => MinQueue a -> MinQueue a -> MinQueue a union (MinQueue f1) (MinQueue f2) = MinQueue (merge f1 f2)@@ -218,11 +228,24 @@  -- | \(O(n)\). Map elements and collect the 'Just' results. mapMaybe :: Ord b => (a -> Maybe b) -> MinQueue a -> MinQueue b-mapMaybe f (MinQueue ts) = mapMaybeQueue f (const empty) empty ts+mapMaybe f = flip foldlU' empty $ \q a ->+  case f a of+    Nothing -> q+    Just b -> insertEager b q+-- This seems to be needed for specialization.+{-# INLINABLE mapMaybe #-}  -- | \(O(n)\). Map elements and separate the 'Left' and 'Right' results. mapEither :: (Ord b, Ord c) => (a -> Either b c) -> MinQueue a -> (MinQueue b, MinQueue c)-mapEither f (MinQueue ts) = mapEitherQueue f (const (empty, empty)) (empty, empty) ts+mapEither f = fromPartition .+  foldlU'+    (\(Partition ls rs) a ->+        case f a of+          Left b -> Partition (insertEager b ls) rs+          Right b -> Partition ls (insertEager b rs))+    (Partition empty empty)+-- This seems to be needed for specialization.+{-# INLINABLE mapEither #-}  -- | \(O(n)\). Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue, -- as in 'fmap'. If it is not, the result is undefined.@@ -331,9 +354,17 @@ incrExtract (Extract minKey (Succ kChild kChildren) ts)   = Extract minKey kChildren (Cons kChild ts) +-- Note: We used to apply Skip lazily here, and to use the lazy incr, for fear+-- that the potential cascade of carries would be more expensive than leaving+-- those carries suspended and letting subsequent operations force them.+-- However, our benchmarks indicated that doing these strictly was+-- faster. Note that even if we chose to go back to incr (rather than incr'),+-- it's even more clearly worse to apply Skip lazily— forcing the result of+-- incr in this context doesn't cause a cascade, because the child of any Cons+-- will come from an Extract, and therefore be in WHNF already. incrExtract' :: Ord a => BinomTree rk a -> Extract (Succ rk) a -> Extract rk a incrExtract' t (Extract minKey (Succ kChild kChildren) ts)-  = Extract minKey kChildren (Skip $ incr (t `joinBin` kChild) ts)+  = Extract minKey kChildren (Skip $! incr' (t `joinBin` kChild) ts)  -- | Walks backward from the biggest key in the forest, as far as rank @rk@. -- Returns its progress. Each successive application of @extractBin@ takes@@ -347,7 +378,7 @@       No     -> No       Yes ex -> Yes (incrExtract ex)     start (Cons t@(BinomTree x ts) f) = Yes $ case go x f of-      No -> Extract x ts (Skip f)+      No -> Extract x ts (skip f)       Yes ex -> incrExtract' t ex      go :: Ord a => a -> BinomForest rk a -> MExtract rk a@@ -360,31 +391,19 @@           No -> No           Yes ex -> Yes (incrExtract' t ex)       | otherwise = case go x f of-          No -> Yes (Extract x ts (Skip f))+          No -> Yes (Extract x ts (skip f))           Yes ex -> Yes (incrExtract' t ex) -mapMaybeQueue :: Ord b => (a -> Maybe b) -> (rk a -> MinQueue b) -> MinQueue b -> BinomForest rk a -> MinQueue b-mapMaybeQueue f fCh q0 forest = q0 `seq` case forest of-  Nil    -> q0-  Skip forest'  -> mapMaybeQueue f fCh' q0 forest'-  Cons t forest'  -> mapMaybeQueue f fCh' (union (mapMaybeT t) q0) forest'-  where fCh' (Succ t tss) = union (mapMaybeT t) (fCh tss)-        mapMaybeT (BinomTree x0 ts) = maybe (fCh ts) (\x -> insert x (fCh ts)) (f x0)--type Partition a b = (MinQueue a, MinQueue b)+-- | When the heap size is a power of two and we extract from it, we have+-- to shrink the spine by one. This function takes care of that.+skip :: BinomForest (Succ rk) a -> BinomForest rk a+skip Nil = Nil+skip f = Skip f+{-# INLINE skip #-} -mapEitherQueue :: (Ord b, Ord c) => (a -> Either b c) -> (rk a -> Partition b c) -> Partition b c ->-  BinomForest rk a -> Partition b c-mapEitherQueue f0 fCh (q00, q10) ts0 = q00 `seq` q10 `seq` case ts0 of-  Nil        -> (q00, q10)-  Skip ts'   -> mapEitherQueue f0 fCh' (q00, q10) ts'-  Cons t ts' -> mapEitherQueue f0 fCh' (both union union (partitionT t) (q00, q10)) ts'-  where  both f g (x1, x2) (y1, y2) = (f x1 y1, g x2 y2)-         fCh' (Succ t tss) = both union union (partitionT t) (fCh tss)-         partitionT (BinomTree x ts) = case fCh ts of-           (q0, q1) -> case f0 x of-             Left b  -> (insert b q0, q1)-             Right c  -> (q0, insert c q1)+data Partition a b = Partition !(MinQueue a) !(MinQueue b)+fromPartition :: Partition a b -> (MinQueue a, MinQueue b)+fromPartition (Partition p q) = (p, q)  {-# INLINE tip #-} -- | Constructs a binomial tree of rank 0.@@ -436,9 +455,7 @@ {-# INLINABLE fromList #-} -- | \(O(n)\). Constructs a priority queue from an unordered list. fromList :: Ord a => [a] -> MinQueue a-fromList xs = MinQueue (foldl' go Nil xs)-  where-    go fr x = incr' (tip x) fr+fromList xs = foldl' (flip insertEager) empty xs  -- | Given two binomial forests starting at rank @rk@, takes their union. -- Each successive application of this function costs \(O(1)\), so applying it@@ -536,8 +553,8 @@  instance Functor rk => Functor (BinomForest rk) where   fmap _ Nil = Nil-  fmap f (Skip ts) = Skip (fmap f ts)-  fmap f (Cons t ts) = Cons (fmap f t) (fmap f ts)+  fmap f (Skip ts) = Skip $! fmap f ts+  fmap f (Cons t ts) = Cons (fmap f t) $! fmap f ts  instance Foldr Zero where   foldr_ _ z ~Zero = z
src/BinomialQueue/Max.hs view
@@ -136,7 +136,7 @@ (!!) :: Ord a => MaxQueue a -> Int -> a q !! n  | n >= size q     = error "BinomialQueue.Max.!!: index too large"-q !! n = (List.!!) (toDescList q) n+q !! n = toDescList q List.!! n  {-# INLINE takeWhile #-} -- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the
src/BinomialQueue/Min.hs view
@@ -125,22 +125,13 @@ (!!) :: Ord a => MinQueue a -> Int -> a q !! n  | n >= size q     = error "Data.PQueue.Min.!!: index too large"-q !! n = (List.!!) (toAscList q) n+q !! n = toAscList q List.!! n  {-# INLINE takeWhile #-} -- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the -- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. takeWhile :: Ord a => (a -> Bool) -> MinQueue a -> [a]-takeWhile p = foldWhileFB p . toAscList--{-# INLINE foldWhileFB #-}--- | Equivalent to Data.List.takeWhile, but is a better producer.-foldWhileFB :: (a -> Bool) -> [a] -> [a]-foldWhileFB p xs0 = build (\c nil -> let-  consWhile x xs-    | p x    = x `c` xs-    | otherwise  = nil-  in foldr consWhile nil xs0)+takeWhile p = List.takeWhile p . toAscList  -- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. dropWhile :: Ord a => (a -> Bool) -> MinQueue a -> MinQueue a
src/Data/PQueue/Internals.hs view
@@ -37,7 +37,7 @@   foldlU', --   traverseU,   seqSpine,-  unions+  unions,   ) where  import BinomialQueue.Internals@@ -81,6 +81,11 @@   Nothing -> Empty  #ifdef __GLASGOW_HASKELL__++-- | Treats the priority queue as an empty queue or a minimal element and a+-- priority queue. The constructors, conceptually, are 'Data.PQueue.Min.Empty'+-- and '(Data.PQueue.Min.:<)'. All constructed queues maintain the queue+-- invariants. instance (Ord a, Data a) => Data (MinQueue a) where   gfoldl f z q = case minView q of     Nothing      -> z Empty@@ -88,8 +93,8 @@    gunfold k z c = case constrIndex c of     1 -> z Empty-    2 -> k (k (z insertMinQ))-    _ -> error "gunfold"+    2 -> k (k (z insert))+    _ -> error "gunfold: invalid constructor for MinQueue"    dataCast1 x = gcast1 x @@ -103,8 +108,8 @@ queueDataType = mkDataType "Data.PQueue.Min.MinQueue" [emptyConstr, consConstr]  emptyConstr, consConstr :: Constr-emptyConstr = mkConstr queueDataType "empty" [] Prefix-consConstr  = mkConstr queueDataType "<|" [] Infix+emptyConstr = mkConstr queueDataType "Empty" [] Prefix+consConstr  = mkConstr queueDataType ":<" [] Infix  #endif @@ -180,7 +185,7 @@ -- | \(O(n)\). Map elements and collect the 'Just' results. mapMaybe :: Ord b => (a -> Maybe b) -> MinQueue a -> MinQueue b mapMaybe _ Empty = Empty-mapMaybe f (MinQueue _ x ts) = fromBare $ maybe q' (`BQ.insert` q') (f x)+mapMaybe f (MinQueue _ x ts) = fromBare $ maybe q' (`BQ.insertEager` q') (f x)   where     q' = BQ.mapMaybe f ts @@ -190,8 +195,14 @@ mapEither f (MinQueue _ x ts)   | (l, r) <- BQ.mapEither f ts   = case f x of-      Left y -> (fromBare (BQ.insert y l), fromBare r)-      Right z -> (fromBare l, fromBare (BQ.insert z r))+      Left y ->+        let !l' = fromBare (BQ.insertEager y l)+            !r' = fromBare r+        in (l', r')+      Right z ->+        let !l' = fromBare l+            !r' = fromBare (BQ.insertEager z r)+        in (l', r')  -- | \(O(n)\). Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue, -- as in 'fmap'. If it is not, the result is undefined.@@ -284,6 +295,9 @@ -- comparison per element. fromList xs = fromBare (BQ.fromList xs) +-- | \(O(n)\). Assumes that the function it is given is (weakly) monotonic, and+-- applies this function to every element of the priority queue, as in 'fmap'.+-- If the function is not monotonic, the result is undefined. mapU :: (a -> b) -> MinQueue a -> MinQueue b mapU _ Empty = Empty mapU f (MinQueue n x ts) = MinQueue n (f x) (BQ.mapU f ts)@@ -336,11 +350,11 @@  -- | \(O(\log n)\). @seqSpine q r@ forces the spine of @q@ and returns @r@. ----- Note: The spine of a 'MinQueue' is stored somewhat lazily. Most operations--- take great care to prevent chains of thunks from accumulating along the--- spine to the detriment of performance. However, @mapU@ can leave expensive--- thunks in the structure and repeated applications of that function can--- create thunk chains.+-- Note: The spine of a 'MinQueue' is stored somewhat lazily. In earlier+-- versions of this package, some operations could produce chains of thunks+-- along the spine, occasionally necessitating manual forcing. Now, all+-- operations are careful to force enough to avoid this problem.+{-# DEPRECATED seqSpine "This function is no longer necessary or useful." #-} seqSpine :: MinQueue a -> b -> b seqSpine Empty z = z seqSpine (MinQueue _ _ ts) z = BQ.seqSpine ts z
src/Data/PQueue/Internals/Foldable.hs view
@@ -7,32 +7,16 @@   , Foldl (..)   , FoldMap (..)   , Foldl' (..)-  , IFoldr (..)-  , IFoldl (..)-  , IFoldMap (..)-  , IFoldl' (..)   ) where  class Foldr t where   foldr_ :: (a -> b -> b) -> b -> t a -> b -class IFoldr t where-  foldrWithKey_ :: (k -> a -> b -> b) -> b -> t k a -> b- class Foldl t where   foldl_ :: (b -> a -> b) -> b -> t a -> b -class IFoldl t where-  foldlWithKey_ :: (b -> k -> a -> b) -> b -> t k a -> b- class FoldMap t where   foldMap_ :: Monoid m => (a -> m) -> t a -> m -class IFoldMap t where-  foldMapWithKey_ :: Monoid m => (k -> a -> m) -> t k a -> m- class Foldl' t where   foldl'_ :: (b -> a -> b) -> b -> t a -> b--class IFoldl' t where-  foldlWithKey'_ :: (b -> k -> a -> b) -> b -> t k a -> b
src/Data/PQueue/Max.hs view
@@ -369,10 +369,10 @@  -- | \(O(\log n)\). @seqSpine q r@ forces the spine of @q@ and returns @r@. ----- Note: The spine of a 'MaxQueue' is stored somewhat lazily. Most operations--- take great care to prevent chains of thunks from accumulating along the--- spine to the detriment of performance. However, 'mapU' can leave expensive--- thunks in the structure and repeated applications of that function can--- create thunk chains.+-- Note: The spine of a 'MaxQueue' is stored somewhat lazily. In earlier+-- versions of this package, some operations could produce chains of thunks+-- along the spine, occasionally necessitating manual forcing. Now, all+-- operations are careful to force enough to avoid this problem.+{-# DEPRECATED seqSpine "This function is no longer necessary or useful." #-} seqSpine :: MaxQueue a -> b -> b seqSpine (MaxQ q) = Min.seqSpine q
src/Data/PQueue/Min.hs view
@@ -1,4 +1,8 @@ {-# LANGUAGE CPP #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+#endif  ----------------------------------------------------------------------------- -- |@@ -24,7 +28,13 @@ -- these functions. ----------------------------------------------------------------------------- module Data.PQueue.Min (+#if __GLASGOW_HASKELL__ >= 802+  MinQueue (Data.PQueue.Min.Empty, (:<)),+#elif defined (__GLASGOW_HASKELL__)   MinQueue,+  pattern Data.PQueue.Min.Empty,+  pattern (:<),+#endif   -- * Basic operations   empty,   null,@@ -92,7 +102,9 @@  import qualified Data.List as List -import Data.PQueue.Internals+import Data.PQueue.Internals hiding (MinQueue (..))+import Data.PQueue.Internals (MinQueue (MinQueue))+import qualified Data.PQueue.Internals as Internals import qualified BinomialQueue.Internals as BQ import qualified Data.PQueue.Prio.Internals as Prio @@ -103,6 +115,39 @@ build f = f (:) [] #endif +#ifdef __GLASGOW_HASKELL__+-- | A bidirectional pattern synonym for an empty priority queue.+--+-- @since 1.5.0+pattern Empty :: MinQueue a+pattern Empty = Internals.Empty+# if __GLASGOW_HASKELL__ >= 902+{-# INLINE CONLIKE Empty #-}+# endif++infixr 5 :<++-- | A bidirectional pattern synonym for working with the minimum view of a+-- 'MinQueue'.  Using @:<@ to construct a queue performs an insertion in+-- \(O(1)\) amortized time. When matching on @a :< q@, forcing @q@ takes+-- \(O(\log n)\) time.+--+-- @since 1.5.0+# if __GLASGOW_HASKELL__ >= 800+pattern (:<) :: Ord a => a -> MinQueue a -> MinQueue a+# else+pattern (:<) :: () => Ord a => a -> MinQueue a -> MinQueue a+# endif+pattern a :< q <- (minView -> Just (a, q))+  where+    a :< q = insert a q+# if __GLASGOW_HASKELL__ >= 902+{-# INLINE (:<) #-}+# endif++{-# COMPLETE Empty, (:<) #-}+#endif+ -- | \(O(1)\). Returns the minimum element. Throws an error on an empty queue. findMin :: MinQueue a -> a findMin = fromMaybe (error "Error: findMin called on empty queue") . getMin@@ -122,22 +167,13 @@ (!!) :: Ord a => MinQueue a -> Int -> a q !! n  | n >= size q     = error "Data.PQueue.Min.!!: index too large"-q !! n = (List.!!) (toAscList q) n+q !! n = toAscList q List.!! n  {-# INLINE takeWhile #-} -- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the -- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. takeWhile :: Ord a => (a -> Bool) -> MinQueue a -> [a]-takeWhile p = foldWhileFB p . toAscList--{-# INLINE foldWhileFB #-}--- | Equivalent to Data.List.takeWhile, but is a better producer.-foldWhileFB :: (a -> Bool) -> [a] -> [a]-foldWhileFB p xs0 = build (\c nil -> let-  consWhile x xs-    | p x    = x `c` xs-    | otherwise  = nil-  in foldr consWhile nil xs0)+takeWhile p = List.takeWhile p . toAscList  -- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. dropWhile :: Ord a => (a -> Bool) -> MinQueue a -> MinQueue a@@ -220,13 +256,13 @@  -- | Constructs a priority queue out of the keys of the specified 'Prio.MinPQueue'. keysQueue :: Prio.MinPQueue k a -> MinQueue k-keysQueue Prio.Empty = Empty+keysQueue Prio.Empty = Internals.Empty keysQueue (Prio.MinPQ n k _ ts) = MinQueue n k (BQ.MinQueue (keysF (const Zero) ts))  keysF :: (pRk k a -> rk k) -> Prio.BinomForest pRk k a -> BinomForest rk k keysF f ts0 = case ts0 of   Prio.Nil       -> Nil-  Prio.Skip ts'  -> Skip (keysF f' ts')-  Prio.Cons (Prio.BinomTree k _ ts) ts'-    -> Cons (BinomTree k (f ts)) (keysF f' ts')-  where  f' (Prio.Succ (Prio.BinomTree k _ ts) tss) = Succ (BinomTree k (f ts)) (f tss)+  Prio.Skip ts'  -> Skip $! keysF f' ts'+  Prio.Cons (Prio.BinomTree k ts) ts'+    -> Cons (BinomTree k (f ts)) $! keysF f' ts'+  where  f' (Prio.Succ (Prio.BinomTree k ts) tss) = Succ (BinomTree k (f ts)) (f tss)
src/Data/PQueue/Prio/Internals.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Data.PQueue.Prio.Internals (   MinPQueue(..),@@ -16,6 +18,7 @@   singleton,   insert,   insertBehind,+  insertEager,   union,   getMin,   adjustMinWithKey,@@ -46,26 +49,25 @@   mapMWithKey,   traverseWithKeyU,   seqSpine,-  mapForest,   unions   ) where -import Control.Applicative (liftA2, liftA3)+import Control.Applicative (liftA2, liftA3, Const (..)) import Control.DeepSeq (NFData(rnf), deepseq)+import Data.Coerce (coerce) import Data.Functor.Identity (Identity(Identity, runIdentity)) import qualified Data.List as List-import Data.PQueue.Internals.Foldable  #if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup(..), stimesMonoid)+import Data.Semigroup (Semigroup(..), stimesMonoid, Endo (..), Dual (..)) #else-import Data.Monoid ((<>))+import Data.Monoid ((<>), Endo (..), Dual (..)) #endif  import Prelude hiding (null, map) #ifdef __GLASGOW_HASKELL__ import Data.Data-import GHC.Exts (build)+import GHC.Exts (build, inline) import Text.Read (Lexeme(Ident), lexP, parens, prec,   readPrec, readListPrec, readListPrecDefault) #endif@@ -73,6 +75,7 @@ import Data.Functor.WithIndex import Data.Foldable.WithIndex import Data.Traversable.WithIndex+import Nattish (Nattish (..))  #ifndef __GLASGOW_HASKELL__ build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]@@ -80,22 +83,37 @@ #endif  #if __GLASGOW_HASKELL__-instance (Data k, Data a, Ord k) => Data (MinPQueue k a) where-  gfoldl f z m = z fromList `f` foldrWithKey (curry (:)) [] m-  toConstr _   = fromListConstr-  gunfold k z c  = case constrIndex c of-    1 -> k (z fromList)-    _ -> error "gunfold"++-- | Treats the priority queue as an empty queue or a minimal+-- key-value pair and a priority queue. The constructors, conceptually,+-- are 'Data.PQueue.Prio.Min.Empty' and '(Data.PQueue.Prio.Min.:<)'.+--+-- 'gfoldl' is nondeterministic; any minimal pair may be chosen as+-- the first. All constructed queues maintain the queue invariants.+instance (Ord k, Data k, Data a) => Data (MinPQueue k a) where+  gfoldl f z q = case minViewWithKey q of+    Nothing      -> z Empty+    Just (x, q') -> z (\(k, a) -> insert k a) `f` x `f` q'++  gunfold k z c = case constrIndex c of+    1 -> z Empty+    2 -> k (k (z (\(key, val) -> insert key val)))+    _ -> error "gunfold: invalid constructor for MinPQueue"++  toConstr q+    | null q = emptyConstr+    | otherwise = consConstr+   dataTypeOf _ = queueDataType   dataCast1 f  = gcast1 f   dataCast2 f  = gcast2 f  queueDataType :: DataType-queueDataType = mkDataType "Data.PQueue.Prio.Min.MinPQueue" [fromListConstr]--fromListConstr :: Constr-fromListConstr = mkConstr queueDataType "fromList" [] Prefix+queueDataType = mkDataType "Data.PQueue.Prio.Min.MinPQueue" [emptyConstr, consConstr] +emptyConstr, consConstr :: Constr+emptyConstr = mkConstr queueDataType "Empty" [] Prefix+consConstr  = mkConstr queueDataType ":<" [] Infix #endif  #if MIN_VERSION_base(4,9,0)@@ -139,16 +157,10 @@ (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d (f .: g) x y = f (g x y) -first' :: (a -> b) -> (a, c) -> (b, c)-first' f (a, c) = (f a, c)--second' :: (b -> c) -> (a, b) -> (a, c)-second' f (a, b) = (a, f b)- infixr 8 .: --- | A priority queue where values of type @a@ are annotated with keys of type @k@.--- The queue supports extracting the element with minimum key.+-- | A priority queue where keys of type @k@ are annotated with values of type+-- @a@.  The queue supports extracting the key-value pair with minimum key. data MinPQueue k a = Empty | MinPQ {-# UNPACK #-} !Int !k a !(BinomHeap k a)  data BinomForest rk k a =@@ -157,43 +169,9 @@   Cons {-# UNPACK #-} !(BinomTree rk k a) (BinomForest (Succ rk) k a) type BinomHeap = BinomForest Zero -data BinomTree rk k a = BinomTree !k a !(rk k a)-data Zero k a = Zero-data Succ rk k a = Succ {-# UNPACK #-} !(BinomTree rk k a) !(rk k a)--instance IFoldl' Zero where-  foldlWithKey'_ _ z ~Zero = z--instance IFoldMap Zero where-  foldMapWithKey_ _ ~Zero = mempty--instance IFoldl' t => IFoldl' (Succ t) where-  foldlWithKey'_ f z (Succ t rk) = foldlWithKey'_ f z' rk-    where-      !z' = foldlWithKey'_ f z t--instance IFoldMap t => IFoldMap (Succ t) where-  foldMapWithKey_ f (Succ t rk) = foldMapWithKey_ f t `mappend` foldMapWithKey_ f rk--instance IFoldl' rk => IFoldl' (BinomTree rk) where-  foldlWithKey'_ f !z (BinomTree k a rk) = foldlWithKey'_ f ft rk-    where-      !ft = f z k a--instance IFoldMap rk => IFoldMap (BinomTree rk) where-  foldMapWithKey_ f (BinomTree k a rk) = f k a `mappend` foldMapWithKey_ f rk--instance IFoldl' t => IFoldl' (BinomForest t) where-  foldlWithKey'_ _f z Nil = z-  foldlWithKey'_ f !z (Skip ts) = foldlWithKey'_ f z ts-  foldlWithKey'_ f !z (Cons t ts) = foldlWithKey'_ f ft ts-    where-      !ft = foldlWithKey'_ f z t--instance IFoldMap t => IFoldMap (BinomForest t) where-  foldMapWithKey_ _f Nil = mempty-  foldMapWithKey_ f (Skip ts) = foldMapWithKey_ f ts-  foldMapWithKey_ f (Cons t ts) = foldMapWithKey_ f t `mappend` foldMapWithKey_ f ts+data BinomTree rk k a = BinomTree !k (rk k a)+newtype Zero k a = Zero a+data Succ rk k a = Succ {-# UNPACK #-} !(BinomTree rk k a) (rk k a)  instance (Ord k, Eq a) => Eq (MinPQueue k a) where   MinPQ n1 k1 a1 ts1 == MinPQ n2 k2 a2 ts2 =@@ -201,11 +179,11 @@   Empty == Empty = True   _     == _     = False -eqExtract :: (Ord k, Eq a) => k -> a -> BinomForest rk k a -> k -> a -> BinomForest rk k a -> Bool+eqExtract :: (Ord k, Eq a) => k -> a -> BinomHeap k a -> k -> a -> BinomHeap k a -> Bool eqExtract k10 a10 ts10 k20 a20 ts20 =   k10 == k20 && a10 == a20 &&   case (extract ts10, extract ts20) of-    (Yes (Extract k1 a1 _ ts1'), Yes (Extract k2 a2 _ ts2'))+    (Yes (Extract k1 (Zero a1) ts1'), Yes (Extract k2 (Zero a2) ts2'))              -> eqExtract k1 a1 ts1' k2 a2 ts2'     (No, No) -> True     _        -> False@@ -217,11 +195,11 @@   Empty `compare` MinPQ{} = LT   MinPQ{} `compare` Empty = GT -cmpExtract :: (Ord k, Ord a) => k -> a -> BinomForest rk k a -> k -> a -> BinomForest rk k a -> Ordering+cmpExtract :: (Ord k, Ord a) => k -> a -> BinomHeap k a -> k -> a -> BinomHeap k a -> Ordering cmpExtract k10 a10 ts10 k20 a20 ts20 =   k10 `compare` k20 <> a10 `compare` a20 <>   case (extract ts10, extract ts20) of-    (Yes (Extract k1 a1 _ ts1'), Yes (Extract k2 a2 _ ts2'))+    (Yes (Extract k1 (Zero a1) ts1'), Yes (Extract k2 (Zero a2) ts2'))                 -> cmpExtract k1 a1 ts1' k2 a2 ts2'     (No, Yes{}) -> LT     (Yes{}, No) -> GT@@ -253,10 +231,17 @@   | k <= k' = MinPQ (n + 1) k  a  (incrMin (tip k' a') ts)   | otherwise = MinPQ (n + 1) k' a' (incr (tip k  a ) ts) +insertEager :: Ord k => k -> a -> MinPQueue k a -> MinPQueue k a+insertEager k a Empty = singleton k a+insertEager k a (MinPQ n k' a' ts)+  | k <= k' = MinPQ (n + 1) k a  (insertEagerHeap k' a' ts)+  | otherwise = MinPQ (n + 1) k' a' (insertEagerHeap k a ts)+ -- | \(O(n)\) (an earlier implementation had \(O(1)\) but was buggy). -- Insert an element with the specified key into the priority queue, -- putting it behind elements whose key compares equal to the -- inserted one.+{-# DEPRECATED insertBehind "This function is not reliable." #-} insertBehind :: Ord k => k -> a -> MinPQueue k a -> MinPQueue k a insertBehind k v q =   let (smaller, larger) = spanKey (<= k) q@@ -325,26 +310,80 @@  -- | \(O(n)\). Map a function over all values in the queue. mapWithKey :: (k -> a -> b) -> MinPQueue k a -> MinPQueue k b-mapWithKey f = runIdentity . traverseWithKeyU (Identity .: f)+mapWithKey f = runIdentity . traverseWithKeyU (coerce f) --- | \(O(n)\). @'mapKeysMonotonic' f q == 'mapKeys' f q@, but only works when @f@ is strictly--- monotonic. /The precondition is not checked./ This function has better performance than--- 'mapKeys'.+-- | \(O(n)\). @'mapKeysMonotonic' f q == 'mapKeys' f q@, but only works when+-- @f@ is (weakly) monotonic. /The precondition is not checked./ This function+-- has better performance than 'mapKeys'.+--+-- Note: if the given function returns bottom for any of the keys in the queue, then the+-- portion of the queue which is bottom is /unspecified/. mapKeysMonotonic :: (k -> k') -> MinPQueue k a -> MinPQueue k' a mapKeysMonotonic _ Empty = Empty-mapKeysMonotonic f (MinPQ n k a ts) = MinPQ n (f k) a (mapKeysMonoF f (const Zero) ts)+mapKeysMonotonic f (MinPQ n k a ts) = MinPQ n (f k) a $! mapKeysMonoHeap f ts +mapKeysMonoHeap :: forall k k' a. (k -> k') -> BinomHeap k a -> BinomHeap k' a+mapKeysMonoHeap f = mapKeysMonoForest Zeroy+  where+    mapKeysMonoForest :: Ranky rk -> BinomForest rk k a -> BinomForest rk k' a+    mapKeysMonoForest !_rky Nil = Nil+    mapKeysMonoForest !rky (Skip rest) = Skip $! mapKeysMonoForest (Succy rky) rest+    mapKeysMonoForest !rky (Cons t rest) = Cons (mapKeysMonoTree rky t) $! mapKeysMonoForest (Succy rky) rest++    {-# INLINE mapKeysMonoTree #-}+    mapKeysMonoTree :: Ranky rk -> BinomTree rk k a -> BinomTree rk k' a+    mapKeysMonoTree Zeroy (BinomTree k (Zero a)) =+      -- We've reached a value, which we must not force.+      BinomTree (f k) (Zero a)+      -- We're not at a value; we force the result.+    mapKeysMonoTree (Succy rky) (BinomTree k ts) = BinomTree (f k) $! mapKeysMonoTrees rky ts++    mapKeysMonoTrees :: Ranky rk -> Succ rk k a -> Succ rk k' a+    mapKeysMonoTrees Zeroy (Succ t (Zero a)) =+      -- Don't force the value!+      Succ (mapKeysMonoTree Zeroy t) (Zero a)+    mapKeysMonoTrees (Succy rky) (Succ t ts) =+      -- Whew, no values; force the trees.+      Succ (mapKeysMonoTree (Succy rky) t) $! mapKeysMonoTrees rky ts+ -- | \(O(n)\). Map values and collect the 'Just' results. mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> MinPQueue k a -> MinPQueue k b-mapMaybeWithKey _ Empty            = Empty-mapMaybeWithKey f (MinPQ _ k a ts) = maybe id (insert k) (f k a) (mapMaybeF f (const Empty) ts)+mapMaybeWithKey f = fromBare .+  foldlWithKeyU'+    (\q k a -> case f k a of+        Nothing -> q+        Just b -> insertEagerHeap k b q)+    Nil+{-# INLINABLE mapMaybeWithKey #-}  -- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. mapEitherWithKey :: Ord k => (k -> a -> Either b c) -> MinPQueue k a -> (MinPQueue k b, MinPQueue k c)-mapEitherWithKey _ Empty            = (Empty, Empty)-mapEitherWithKey f (MinPQ _ k a ts) = either (first' . insert k) (second' . insert k) (f k a)-  (mapEitherF f (const (Empty, Empty)) ts)+mapEitherWithKey f q+  | (l, r) <- mapEitherHeap f q+  , let+      !l' = fromBare l+      !r' = fromBare r+  = (l', r')+{-# INLINABLE mapEitherWithKey #-} +data Partition k a b = Partition !(BinomHeap k a) !(BinomHeap k b)++fromPartition :: Partition k a b -> (BinomHeap k a, BinomHeap k b)+fromPartition (Partition p q) = (p, q)++mapEitherHeap :: Ord k => (k -> a -> Either b c) -> MinPQueue k a -> (BinomHeap k b, BinomHeap k c)+mapEitherHeap f = fromPartition .+  foldlWithKeyU'+    (\(Partition ls rs) k a ->+         case f k a of+           Left b -> Partition (insertEagerHeap k b ls) rs+           Right b -> Partition ls (insertEagerHeap k b rs))+    (Partition Nil Nil)++insertEagerHeap :: Ord k => k -> a -> BinomHeap k a -> BinomHeap k a+insertEagerHeap k a h = incr' (tip k a) h+{-# INLINE insertEagerHeap #-}+ -- | \(O(n \log n)\). Fold the keys and values in the map, such that -- @'foldrWithKey' f z q == 'List.foldr' ('uncurry' f) z ('toAscList' q)@. --@@ -353,8 +392,8 @@ foldrWithKey _ z Empty = z foldrWithKey f z (MinPQ _ k0 a0 ts0) = f k0 a0 (foldF ts0) where   foldF ts = case extract ts of-    Yes (Extract k a _ ts') -> f k a (foldF ts')-    _                       -> z+    Yes (Extract k (Zero a) ts') -> f k a (foldF ts')+    No                           -> z  -- | \(O(n \log n)\). Fold the keys and values in the map, such that -- @'foldlWithKey' f z q == 'List.foldl' ('uncurry' . f) z ('toAscList' q)@.@@ -364,8 +403,8 @@ foldlWithKey _ z Empty = z foldlWithKey f z0 (MinPQ _ k0 a0 ts0) = foldF (f z0 k0 a0) ts0 where   foldF z ts = case extract ts of-    Yes (Extract k a _ ts') -> foldF (f z k a) ts'-    _                       -> z+    Yes (Extract k (Zero a) ts') -> foldF (f z k a) ts'+    No                           -> z  {-# INLINABLE [1] toAscList #-} -- | \(O(n \log n)\). Return all (key, value) pairs in ascending order by key.@@ -420,22 +459,25 @@ {-# INLINE fromList #-} -- | \(O(n)\). Constructs a priority queue from an unordered list. fromList :: Ord k => [(k, a)] -> MinPQueue k a--- We build a forest first and then extract its minimum at the end.--- Why not just build the 'MinQueue' directly? This way saves us one--- comparison per element.-fromList xs = case extract (fromListHeap xs) of+-- We build a forest first and then extract its minimum at the end.  Why not+-- just build the 'MinQueue' directly? This way typically saves us one+-- comparison per element, which roughly halves comparisons.+fromList xs = fromBare (fromListHeap xs)++fromBare :: Ord k => BinomHeap k a -> MinPQueue k a+fromBare xs = case extract xs of   No -> Empty   -- Should we track the size as we go instead? That saves O(log n)   -- at the end, but it needs an extra register all along the way.   -- The nodes should probably all be in L1 cache already thanks to the   -- extractHeap.-  Yes (Extract k v ~Zero f) -> MinPQ (sizeHeap f + 1) k v f+  Yes (Extract k (Zero v) f) -> MinPQ (sizeHeap f + 1) k v f  {-# INLINE fromListHeap #-} fromListHeap :: Ord k => [(k, a)] -> BinomHeap k a fromListHeap xs = List.foldl' go Nil xs   where-    go fr (k, a) = incr' (tip k a) fr+    go fr (k, a) = insertEagerHeap k a fr  sizeHeap :: BinomHeap k a -> Int sizeHeap = go 0 1@@ -448,13 +490,13 @@ -- | \(O(1)\). Returns a binomial tree of rank zero containing this -- key and value. tip :: k -> a -> BinomTree Zero k a-tip k a = BinomTree k a Zero+tip k a = BinomTree k (Zero a)  -- | \(O(1)\). Takes the union of two binomial trees of the same rank. meld :: Ord k => BinomTree rk k a -> BinomTree rk k a -> BinomTree (Succ rk) k a-meld t1@(BinomTree k1 v1 ts1) t2@(BinomTree k2 v2 ts2)-  | k1 <= k2 = BinomTree k1 v1 (Succ t2 ts1)-  | otherwise  = BinomTree k2 v2 (Succ t1 ts2)+meld t1@(BinomTree k1 ts1) t2@(BinomTree k2 ts2)+  | k1 <= k2 = BinomTree k1 (Succ t2 ts1)+  | otherwise  = BinomTree k2 (Succ t1 ts2)  -- | Takes the union of two binomial forests, starting at the same rank. Analogous to binary addition. mergeForest :: Ord k => BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a@@ -500,31 +542,31 @@ -- is less than all other roots. Analogous to binary incrementation. Equivalent to -- @'incr' (\_ _ -> True)@. incrMin :: BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a-incrMin t@(BinomTree k a ts) tss = case tss of+incrMin t@(BinomTree k ts) tss = case tss of   Nil          -> Cons t Nil   Skip tss'    -> Cons t tss'-  Cons t' tss' -> tss' `seq` Skip (incrMin (BinomTree k a (Succ t' ts)) tss')+  Cons t' tss' -> tss' `seq` Skip (incrMin (BinomTree k (Succ t' ts)) tss')  -- | Inserts a binomial tree into a binomial forest. Assumes that the root of this tree -- is less than all other roots. Analogous to binary incrementation. Equivalent to -- @'incr'' (\_ _ -> True)@. Forces the rebuilt portion of the spine. incrMin' :: BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a-incrMin' t@(BinomTree k a ts) tss = case tss of+incrMin' t@(BinomTree k ts) tss = case tss of   Nil          -> Cons t Nil   Skip tss'    -> Cons t tss'-  Cons t' tss' -> Skip $! incrMin' (BinomTree k a (Succ t' ts)) tss'+  Cons t' tss' -> Skip $! incrMin' (BinomTree k (Succ t' ts)) tss'  -- | See 'insertMax'' for invariant info. incrMax' :: BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a incrMax' t tss = t `seq` case tss of   Nil          -> Cons t Nil   Skip tss'    -> Cons t tss'-  Cons (BinomTree k a ts) tss' -> Skip $! incrMax' (BinomTree k a (Succ t ts)) tss'+  Cons (BinomTree k ts) tss' -> Skip $! incrMax' (BinomTree k (Succ t ts)) tss'  extractHeap :: Ord k => Int -> BinomHeap k a -> MinPQueue k a extractHeap n ts = n `seq` case extract ts of   No                      -> Empty-  Yes (Extract k a _ ts') -> MinPQ (n - 1) k a ts'+  Yes (Extract k (Zero a) ts') -> MinPQ (n - 1) k a ts'  -- | A specialized type intended to organize the return of extract-min queries -- from a binomial forest. We walk all the way through the forest, and then@@ -551,21 +593,16 @@ --     Note that @forest@ is lazy, so if we discover a smaller key --     than @minKey@ later, we haven't wasted significant work. -data Extract rk k a = Extract !k a !(rk k a) !(BinomForest rk k a)+data Extract rk k a = Extract !k (rk k a) !(BinomForest rk k a) data MExtract rk k a = No | Yes {-# UNPACK #-} !(Extract rk k a)  incrExtract :: Extract (Succ rk) k a -> Extract rk k a-incrExtract (Extract minKey minVal (Succ kChild kChildren) ts)-  = Extract minKey minVal kChildren (Cons kChild ts)+incrExtract (Extract minKey (Succ kChild kChildren) ts)+  = Extract minKey kChildren (Cons kChild ts) --- Why are we so lazy here? The idea, right or not, is to avoid a potentially--- expensive second pass to propagate carries. Instead, carry propagation gets--- fused (operationally) with successive operations. If the next operation is--- union or minView, this doesn't save anything, but if some insertions follow,--- it might be faster this way. incrExtract' :: Ord k => BinomTree rk k a -> Extract (Succ rk) k a -> Extract rk k a-incrExtract' t (Extract minKey minVal (Succ kChild kChildren) ts)-  = Extract minKey minVal kChildren (Skip $ incr (t `meld` kChild) ts)+incrExtract' t (Extract minKey (Succ kChild kChildren) ts)+  = Extract minKey kChildren (Skip $! incr' (t `meld` kChild) ts)  -- | Walks backward from the biggest key in the forest, as far as rank @rk@. -- Returns its progress. Each successive application of @extractBin@ takes@@ -578,8 +615,8 @@     start (Skip f) = case start f of       No     -> No       Yes ex -> Yes (incrExtract ex)-    start (Cons t@(BinomTree k v ts) f) = Yes $ case go k f of-      No -> Extract k v ts (Skip f)+    start (Cons t@(BinomTree k ts) f) = Yes $ case go k f of+      No -> Extract k ts (skip f)       Yes ex -> incrExtract' t ex      go :: Ord k => k -> BinomForest rk k a -> MExtract rk k a@@ -587,81 +624,64 @@     go min_above (Skip f) = case go min_above f of       No -> No       Yes ex -> Yes (incrExtract ex)-    go min_above (Cons t@(BinomTree k v ts) f)+    go min_above (Cons t@(BinomTree k ts) f)       | min_above <= k = case go min_above f of           No -> No           Yes ex -> Yes (incrExtract' t ex)       | otherwise = case go k f of-          No -> Yes (Extract k v ts (Skip f))+          No -> Yes (Extract k ts (skip f))           Yes ex -> Yes (incrExtract' t ex) --- | Utility function for mapping over a forest.-mapForest :: (k -> a -> b) -> (rk k a -> rk k b) -> BinomForest rk k a -> BinomForest rk k b-mapForest f fCh ts0 = case ts0 of-  Nil      -> Nil-  Skip ts' -> Skip (mapForest f fCh' ts')-  Cons (BinomTree k a ts) tss-           -> Cons (BinomTree k (f k a) (fCh ts)) (mapForest f fCh' tss)-  where fCh' (Succ (BinomTree k a ts) tss)-           = Succ (BinomTree k (f k a) (fCh ts)) (fCh tss)---- | Utility function for mapping a 'Maybe' function over a forest.-mapMaybeF :: Ord k => (k -> a -> Maybe b) -> (rk k a -> MinPQueue k b) ->-  BinomForest rk k a -> MinPQueue k b-mapMaybeF f fCh ts0 = case ts0 of-  Nil    -> Empty-  Skip ts'  -> mapMaybeF f fCh' ts'-  Cons (BinomTree k a ts) ts'-      -> insF k a (fCh ts) (mapMaybeF f fCh' ts')-  where  insF k a = maybe id (insert k) (f k a) .: union-         fCh' (Succ (BinomTree k a ts) tss) =-           insF k a (fCh ts) (fCh tss)---- | Utility function for mapping an 'Either' function over a forest.-mapEitherF :: Ord k => (k -> a -> Either b c) -> (rk k a -> (MinPQueue k b, MinPQueue k c)) ->-  BinomForest rk k a -> (MinPQueue k b, MinPQueue k c)-mapEitherF f0 fCh ts0 = case ts0 of-  Nil    -> (Empty, Empty)-  Skip ts'  -> mapEitherF f0 fCh' ts'-  Cons (BinomTree k a ts) ts'-      -> insF k a (fCh ts) (mapEitherF f0 fCh' ts')-  where-    insF k a = either (first' . insert k) (second' . insert k) (f0 k a) .:-      (union `both` union)-    fCh' (Succ (BinomTree k a ts) tss) =-      insF k a (fCh ts) (fCh tss)-    both f g (x1, x2) (y1, y2) = (f x1 y1, g x2 y2)+skip :: BinomForest (Succ rk) k a -> BinomForest rk k a+skip Nil = Nil+skip f = Skip f+{-# INLINE skip #-}  -- | \(O(n)\). An unordered right fold over the elements of the queue, in no particular order. foldrWithKeyU :: (k -> a -> b -> b) -> b -> MinPQueue k a -> b-foldrWithKeyU _ z Empty            = z-foldrWithKeyU f z (MinPQ _ k a ts) = f k a (foldrWithKeyF_ f (const id) ts z)+foldrWithKeyU c n = flip appEndo n . inline foldMapWithKeyU (coerce c)  -- | \(O(n)\). An unordered monoidal fold over the elements of the queue, in no particular order. -- -- @since 1.4.2-foldMapWithKeyU :: Monoid m => (k -> a -> m) -> MinPQueue k a -> m-foldMapWithKeyU _ Empty            = mempty-foldMapWithKeyU f (MinPQ _ k a ts) = f k a `mappend` foldMapWithKey_ f ts+foldMapWithKeyU :: forall m k a. Monoid m => (k -> a -> m) -> MinPQueue k a -> m+foldMapWithKeyU = coerce+  (inline traverseWithKeyU :: (k -> a -> Const m ()) -> MinPQueue k a -> Const m (MinPQueue k ()))  -- | \(O(n)\). An unordered left fold over the elements of the queue, in no -- particular order. This is rarely what you want; 'foldrWithKeyU' and -- 'foldlWithKeyU'' are more likely to perform well. foldlWithKeyU :: (b -> k -> a -> b) -> b -> MinPQueue k a -> b-foldlWithKeyU _ z Empty = z-foldlWithKeyU f z0 (MinPQ _ k0 a0 ts) = foldlWithKeyF_ (\k a z -> f z k a) (const id) ts (f z0 k0 a0)+foldlWithKeyU f b = flip appEndo b . getDual .+  foldMapWithKeyU (\k a -> Dual $ Endo $ \r -> f r k a)  -- | \(O(n)\). An unordered strict left fold over the elements of the queue, in no particular order. -- -- @since 1.4.2 foldlWithKeyU' :: (b -> k -> a -> b) -> b -> MinPQueue k a -> b-foldlWithKeyU' _ z Empty = z-foldlWithKeyU' f !z0 (MinPQ _ k0 a0 ts) = foldlWithKey'_ f (f z0 k0 a0) ts+foldlWithKeyU' f !b q =+  case q of+    Empty -> b+    MinPQ _n k a ts -> foldlHeapU' f (f b k a) ts --- | \(O(n)\). Map a function over all values in the queue.-map :: (a -> b) -> MinPQueue k a -> MinPQueue k b-map = mapWithKey . const+foldlHeapU' :: forall k a b. (b -> k -> a -> b) -> b -> BinomHeap k a -> b+foldlHeapU' f = \b -> foldlForest' Zeroy b+  where+    foldlForest' :: Ranky rk -> b -> BinomForest rk k a -> b+    foldlForest' !_rky !acc Nil = acc+    foldlForest' !rky !acc (Skip rest) = foldlForest' (Succy rky) acc rest+    foldlForest' !rky !acc (Cons t rest) =+      foldlForest' (Succy rky) (foldlTree' rky acc t) rest +    {-# INLINE foldlTree' #-}+    foldlTree' :: Ranky rk -> b -> BinomTree rk k a -> b+    foldlTree' !rky !acc (BinomTree k ts) = foldlTrees' rky acc k ts++    foldlTrees' :: Ranky rk -> b -> k -> rk k a -> b+    foldlTrees' Zeroy !acc !k (Zero a) = f acc k a+    foldlTrees' (Succy rky) !acc !k (Succ t ts) =+      foldlTrees' rky (foldlTree' rky acc t) k ts+ -- | \(O(n \log n)\). Traverses the elements of the queue in ascending order by key. -- (@'traverseWithKey' f q == 'fromAscList' <$> 'traverse' ('uncurry' f) ('toAscList' q)@) --@@ -687,65 +707,51 @@           let !acc' = insertMax' k b acc           go acc' q' +-- | Natural numbers revealing whether something is 'Zero' or 'Succ'.+type Ranky = Nattish Zero Succ+ -- | \(O(n)\). An unordered traversal over a priority queue, in no particular order. -- While there is no guarantee in which order the elements are traversed, the resulting -- priority queue will be perfectly valid.-traverseWithKeyU :: Applicative f => (k -> a -> f b) -> MinPQueue k a -> f (MinPQueue k b)+{-# INLINABLE traverseWithKeyU #-}+traverseWithKeyU :: forall f k a b. Applicative f => (k -> a -> f b) -> MinPQueue k a -> f (MinPQueue k b) traverseWithKeyU _ Empty = pure Empty-traverseWithKeyU f (MinPQ n k a ts) = liftA2 (MinPQ n k) (f k a) (traverseForest f (const (pure Zero)) ts)--{-# SPECIALIZE traverseForest :: (k -> a -> Identity b) -> (rk k a -> Identity (rk k b)) -> BinomForest rk k a ->-  Identity (BinomForest rk k b) #-}-traverseForest :: (Applicative f) => (k -> a -> f b) -> (rk k a -> f (rk k b)) -> BinomForest rk k a -> f (BinomForest rk k b)-traverseForest f fCh ts0 = case ts0 of-  Nil       -> pure Nil-  Skip ts'  -> Skip <$> traverseForest f fCh' ts'-  Cons (BinomTree k a ts) tss-    -> liftA3 (\p q -> Cons (BinomTree k p q)) (f k a) (fCh ts) (traverseForest f fCh' tss)-  where-    fCh' (Succ (BinomTree k a ts) tss)-      = Succ <$> (BinomTree k <$> f k a <*> fCh ts) <*> fCh tss+traverseWithKeyU f (MinPQ n k a ts) = liftA2 (\a' !ts' -> MinPQ n k a' ts') (f k a) (traverseHeapU f ts) --- | Unordered right fold on a binomial forest.-foldrWithKeyF_ :: (k -> a -> b -> b) -> (rk k a -> b -> b) -> BinomForest rk k a -> b -> b-foldrWithKeyF_ f fCh ts0 z0 = case ts0 of-  Nil    -> z0-  Skip ts'  -> foldrWithKeyF_ f fCh' ts' z0-  Cons (BinomTree k a ts) ts'-    -> f k a (fCh ts (foldrWithKeyF_ f fCh' ts' z0))+{-# INLINABLE traverseHeapU #-}+traverseHeapU :: forall f k a b. Applicative f => (k -> a -> f b) -> BinomHeap k a -> f (BinomHeap k b)+traverseHeapU f = traverseForest Zeroy   where-    fCh' (Succ (BinomTree k a ts) tss) z =-      f k a (fCh ts (fCh tss z))+    traverseForest :: Ranky rk -> BinomForest rk k a -> f (BinomForest rk k b)+    traverseForest !_rky Nil = pure Nil+    traverseForest !rky (Skip rest) = (Skip $!) <$> traverseForest (Succy rky) rest+    traverseForest !rky (Cons t rest) =+      liftA2 (\ !t' !rest' -> Cons t' rest') (traverseTree rky t) (traverseForest (Succy rky) rest) --- | Unordered left fold on a binomial forest.-foldlWithKeyF_ :: (k -> a -> b -> b) -> (rk k a -> b -> b) -> BinomForest rk k a -> b -> b-foldlWithKeyF_ f fCh ts0 = case ts0 of-  Nil    -> id-  Skip ts'  -> foldlWithKeyF_ f fCh' ts'-  Cons (BinomTree k a ts) ts'-    -> foldlWithKeyF_ f fCh' ts' . fCh ts . f k a-  where-    fCh' (Succ (BinomTree k a ts) tss) =-      fCh tss . fCh ts . f k a+    {-# INLINE traverseTree #-}+    traverseTree :: Ranky rk -> BinomTree rk k a -> f (BinomTree rk k b)+    traverseTree Zeroy (BinomTree k (Zero a)) =+      -- We've reached a value, so we don't force the result.+      BinomTree k . Zero <$> f k a+    traverseTree (Succy rky) (BinomTree k ts) =+      -- We're not at a value, so we force the tree list.+      (BinomTree k $!) <$> traverseTrees rky k ts --- | Maps a monotonic function over the keys in a binomial forest.-mapKeysMonoF :: (k -> k') -> (rk k a -> rk k' a) -> BinomForest rk k a -> BinomForest rk k' a-mapKeysMonoF f fCh ts0 = case ts0 of-  Nil    -> Nil-  Skip ts'  -> Skip (mapKeysMonoF f fCh' ts')-  Cons (BinomTree k a ts) ts'-    -> Cons (BinomTree (f k) a (fCh ts)) (mapKeysMonoF f fCh' ts')-  where-    fCh' (Succ (BinomTree k a ts) tss) =-      Succ (BinomTree (f k) a (fCh ts)) (fCh tss)+    traverseTrees :: Ranky rk -> k -> Succ rk k a -> f (Succ rk k b)+    traverseTrees Zeroy !k2 (Succ (BinomTree k1 (Zero a1)) (Zero a2)) =+      -- The right subtree is a value, so we don't force it.+      liftA2 (\b1 b2 -> Succ (BinomTree k1 (Zero b1)) (Zero b2)) (f k1 a1) (f k2 a2)+    traverseTrees (Succy rky) !k (Succ t ts) =+      -- Whew; no values. We're safe to force.+      liftA2 (\ !t' !ts' -> Succ t' ts') (traverseTree (Succy rky) t) (traverseTrees rky k ts)  -- | \(O(\log n)\). @seqSpine q r@ forces the spine of @q@ and returns @r@. ----- Note: The spine of a 'MinPQueue' is stored somewhat lazily. Most operations--- take great care to prevent chains of thunks from accumulating along the--- spine to the detriment of performance. However, 'mapKeysMonotonic' can leave--- expensive thunks in the structure and repeated applications of that function--- can create thunk chains.+-- Note: The spine of a 'MinPQueue' is stored somewhat lazily. In earlier+-- versions of this package, some operations could produce chains of thunks+-- along the spine, occasionally necessitating manual forcing. Now, all+-- operations are careful to force enough to avoid this problem.+{-# DEPRECATED seqSpine "This function is no longer necessary or useful." #-} seqSpine :: MinPQueue k a -> b -> b seqSpine Empty z0 = z0 seqSpine (MinPQ _ _ _ ts0) z0 = ts0 `seqSpineF` z0 where@@ -759,13 +765,13 @@   rnfRk :: (NFData k, NFData a) => rk k a -> ()  instance NFRank Zero where-  rnfRk _ = ()+  rnfRk (Zero a) = rnf a  instance NFRank rk => NFRank (Succ rk) where   rnfRk (Succ t ts) = t `deepseq` rnfRk ts  instance (NFData k, NFData a, NFRank rk) => NFData (BinomTree rk k a) where-  rnf (BinomTree k a ts) = k `deepseq` a `deepseq` rnfRk ts+  rnf (BinomTree k ts) = k `deepseq` rnfRk ts  instance (NFData k, NFData a, NFRank rk) => NFData (BinomForest rk k a) where   rnf Nil = ()@@ -777,10 +783,11 @@   rnf (MinPQ _ k a ts) = k `deepseq` a `deepseq` rnf ts  instance Functor (MinPQueue k) where-  fmap = map+  fmap = imap . const  instance FunctorWithIndex k (MinPQueue k) where-  imap = mapWithKey+  imap = coerce+    (traverseWithKeyU :: (k -> a -> Identity b) -> MinPQueue k a -> Identity (MinPQueue k b))  instance Ord k => Foldable (MinPQueue k) where   foldr   = foldrWithKey . const
src/Data/PQueue/Prio/Max/Internals.hs view
@@ -226,6 +226,7 @@ -- Insert an element with the specified key into the priority queue, -- putting it behind elements whose key compares equal to the -- inserted one.+{-# DEPRECATED insertBehind "This function is not reliable." #-} insertBehind :: Ord k => k -> a -> MaxPQueue k a -> MaxPQueue k a insertBehind k a (MaxPQ q) = MaxPQ (Q.insertBehind (Down k) a q) @@ -577,10 +578,10 @@  -- | \(O(\log n)\). @seqSpine q r@ forces the spine of @q@ and returns @r@. ----- Note: The spine of a 'MaxPQueue' is stored somewhat lazily. Most operations--- take great care to prevent chains of thunks from accumulating along the--- spine to the detriment of performance. However, 'mapKeysMonotonic' can leave--- expensive thunks in the structure and repeated applications of that function--- can create thunk chains.+-- Note: The spine of a 'MaxPQueue' is stored somewhat lazily. In earlier+-- versions of this package, some operations could produce chains of thunks+-- along the spine, occasionally necessitating manual forcing. Now, all+-- operations are careful to force enough to avoid this problem.+{-# DEPRECATED seqSpine "This function is no longer necessary or useful." #-} seqSpine :: MaxPQueue k a -> b -> b seqSpine (MaxPQ q) = Q.seqSpine q
src/Data/PQueue/Prio/Min.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}  ----------------------------------------------------------------------------- -- |@@ -29,7 +31,13 @@ -- these functions. ----------------------------------------------------------------------------- module Data.PQueue.Prio.Min (+#if __GLASGOW_HASKELL__ >= 802+  MinPQueue (Data.PQueue.Prio.Min.Empty, (:<)),+#elif defined (__GLASGOW_HASKELL__)   MinPQueue,+  pattern Data.PQueue.Prio.Min.Empty,+  pattern (:<),+#endif   -- * Construction   empty,   singleton,@@ -128,15 +136,43 @@ import Data.Semigroup (Semigroup((<>))) #endif -import Data.PQueue.Prio.Internals+import Data.PQueue.Prio.Internals hiding (MinPQueue (..))+import Data.PQueue.Prio.Internals (MinPQueue)+import qualified Data.PQueue.Prio.Internals as Internals  import Prelude hiding (map, filter, break, span, takeWhile, dropWhile, splitAt, take, drop, (!!), null)  #ifdef __GLASGOW_HASKELL__-import GHC.Exts (build)-#else-build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]-build f = f (:) []+-- | A bidirectional pattern synonym for an empty priority queue.+--+-- @since 1.5.0+pattern Empty :: MinPQueue k a+pattern Empty = Internals.Empty+# if __GLASGOW_HASKELL__ >= 902+{-# INLINE CONLIKE Empty #-}+# endif++infixr 5 :<++-- | A bidirectional pattern synonym for working with the minimum view of a+-- 'MinPQueue'. Using @:<@ to construct a queue performs an insertion in+-- \(O(1)\) amortized time. When matching on @(k, a) :< q@, forcing @q@ takes+-- \(O(\log n)\) time.+--+-- @since 1.5.0+# if __GLASGOW_HASKELL__ >= 800+pattern (:<) :: Ord k => (k, a) -> MinPQueue k a -> MinPQueue k a+# else+pattern (:<) :: () => Ord k => (k, a) -> MinPQueue k a -> MinPQueue k a+# endif+pattern ka :< q <- (minViewWithKey -> Just (ka, q))+  where+    (k, a) :< q = insert k a q+# if __GLASGOW_HASKELL__ >= 902+{-# INLINE (:<) #-}+# endif++{-# COMPLETE Empty, (:<) #-} #endif  (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d@@ -273,8 +309,7 @@ -- | Takes the longest possible prefix of elements satisfying the predicate. -- (@'takeWhile' p q == 'List.takeWhile' (uncurry p) ('toAscList' q)@) takeWhileWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> [(k, a)]-takeWhileWithKey p0 = takeWhileFB (uncurry' p0) . toAscList where-  takeWhileFB p xs = build (\c n -> foldr (\x z -> if p x then x `c` z else n) n xs)+takeWhileWithKey p0 = List.takeWhile (uncurry' p0) . toAscList  -- | Removes the longest possible prefix of elements satisfying the predicate. dropWhile :: Ord k => (a -> Bool) -> MinPQueue k a -> MinPQueue k a
+ src/Nattish.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE CPP #-}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+#if __GLASGOW_HASKELL__ >= 904+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE ViewPatterns #-}+#endif++-- | A facility for faking GADTs that work sufficiently similarly+-- to unary natural numbers.+module Nattish+  ( Nattish (Zeroy, Succy)+  )+  where+import Unsafe.Coerce (unsafeCoerce)+#if __GLASGOW_HASKELL__ >= 800+import Data.Kind (Type)+#endif++-- | Conceptually,+--+-- @+-- data Nattish :: forall k. k -> (k -> k) -> k -> Type where+--   Zeroy :: Nattish zero succ zero+--   Succy :: !(Nattish zero succ n) -> Nattish zero succ (succ n)+-- @+--+-- This abstracts over the zero and successor constructors, so it can be used+-- in any sufficiently Nat-like context. In our case, we can use it for the @Zero@+-- and @Succ@ constructors of both @MinQueue@ and @MinPQueue@. With recent+-- versions of GHC, @Nattish@ is actually represented as a machine integer, so+-- it is very fast to work with.++#if __GLASGOW_HASKELL__ < 904+data Nattish :: k -> (k -> k) -> k -> * where+  Zeroy :: Nattish zero succ zero+  Succy :: !(Nattish zero succ n) -> Nattish zero succ (succ n)++toWord :: Nattish zero succ n -> Word+toWord = go 0+  where+    go :: Word -> Nattish zero succ n -> Word+    go !acc Zeroy = acc+    go !acc (Succy n) = go (acc + 1) n++instance Show (Nattish zero succ n) where+  showsPrec p n = showParen (p > 10) $+    showString "Nattish " . showsPrec 11 (toWord n)+#else++type Nattish :: forall k. k -> (k -> k) -> k -> Type+newtype Nattish zero succ n = Nattish Word+  deriving (Show)+type role Nattish nominal nominal nominal++data Res zero succ n where+  ResZero :: Res zero succ zero+  ResSucc :: !(Nattish zero succ n) -> Res zero succ (succ n)++check :: Nattish zero succ n -> Res zero succ n+check (Nattish 0) = unsafeCoerce ResZero+check (Nattish n) = unsafeCoerce $ ResSucc (Nattish (n - 1))++pattern Zeroy :: forall {k} zero succ (n :: k). () => n ~ zero => Nattish zero succ n+pattern Zeroy <- (check -> ResZero)+  where+    Zeroy = Nattish 0+{-# INLINE Zeroy #-}++pattern Succy :: forall {k} zero succ (n :: k). () => forall (n' :: k). n ~ succ n' => Nattish zero succ n' -> Nattish zero succ n+pattern Succy n <- (check -> ResSucc n)+  where+    Succy (Nattish n) = Nattish (n + 1)+{-# INLINE Succy #-}++{-# COMPLETE Zeroy, Succy #-}++#endif
tests/PQueueTests.hs view
@@ -1,13 +1,19 @@+{-# language CPP #-}++{-# language BangPatterns #-} {-# language ExtendedDefaultRules #-} {-# language ScopedTypeVariables #-} {-# language TupleSections #-}+{-# language ViewPatterns #-}  module Main (main) where  import Data.Bifunctor (bimap, first, second)+import qualified Data.Either as Either import Data.Function (on) import Data.Functor.Identity import qualified Data.List as List+import qualified Data.Maybe as Maybe import Data.Ord (Down(..))  import Test.Tasty@@ -17,9 +23,21 @@ import qualified Data.PQueue.Min as Min import qualified Data.PQueue.Prio.Max as PMax import qualified Data.PQueue.Prio.Min as PMin+import qualified Validity.PQueue.Min as VMin+import qualified Validity.PQueue.Prio.Min as VPMin+import qualified Validity.PQueue.Prio.Max as VPMax  default (Int) +validMinQueue :: Ord a => Min.MinQueue a -> Property+validMinQueue q = VMin.validShape q .&&. VMin.validSize q .&&. VMin.validOrder q++validPMinQueue :: Ord k => PMin.MinPQueue k a -> Property+validPMinQueue q = VPMin.validShape q .&&. VPMin.validSize q .&&. VPMin.validOrder q++validPMaxQueue :: Ord k => PMax.MaxPQueue k a -> Property+validPMaxQueue q = VPMax.validShape q .&&. VPMax.validSize q .&&. VPMax.validOrder q+ main :: IO () main = defaultMain $ testGroup "pqueue"   [ testGroup "Data.PQueue.Min"@@ -28,11 +46,33 @@       [ testProperty "empty" $ Min.getMin Min.empty === Nothing       , testProperty "non-empty" $ \(NonEmpty xs) -> Min.getMin (Min.fromList xs) === Just (minimum xs)       ]-    , testProperty "minView" $ \xs -> Min.minView (Min.fromList xs) === fmap (second Min.fromList) (List.uncons (List.sort xs))+    , testProperty "minView" $ \xs -> case Min.minView (Min.fromList xs) of+        Nothing -> xs === []+        Just (the_min, xs') ->+           validMinQueue xs' .&&.+           the_min : Min.toList xs' === List.sort xs     , testProperty "insert" $ \x xs -> Min.insert x (Min.fromList xs) === Min.fromList (x : xs)     , testProperty "union" $ \xs ys -> Min.union (Min.fromList xs) (Min.fromList ys) === Min.fromList (xs ++ ys)-    , testProperty "filter" $ \xs -> Min.filter even (Min.fromList xs) === Min.fromList (List.filter even xs)-    , testProperty "partition" $ \xs -> Min.partition even (Min.fromList xs) === bimap Min.fromList Min.fromList (List.partition even xs)+    , testProperty "filter" $ \xs ->+        let xs' = Min.filter even (Min.fromList xs)+        in validMinQueue xs' .&&.+           Min.toList xs' === List.sort (List.filter even xs)+    , testProperty "partition" $ \xs ->+        let xs' = Min.fromList xs+            (ys, zs) = Min.partition even xs'+        in validMinQueue ys .&&.+           validMinQueue zs .&&.+           (Min.toList ys, Min.toList zs) === bimap List.sort List.sort (List.partition even xs)+    , testProperty "mapMaybe" $ \(Fn f) xs ->+        let xs' :: Min.MinQueue Char+            xs' = Min.mapMaybe f (Min.fromList xs)+        in validMinQueue xs' .&&.+           Min.toList xs' === List.sort (Maybe.mapMaybe f xs)+    , testProperty "mapEither" $ \(Fn f) xs ->+        let (ys, zs) = Min.mapEither f (Min.fromList xs)+        in validMinQueue ys .&&.+           validMinQueue zs .&&.+           (Min.toList ys, Min.toList zs) === bimap List.sort List.sort (Either.partitionEithers . List.map f $ xs)     , testProperty "map" $ \xs -> Min.map negate (Min.fromList xs) === Min.fromList (List.map negate xs)     , testProperty "take" $ \n xs -> Min.take n (Min.fromList xs) === List.take n (List.sort xs)     , testProperty "drop" $ \n xs -> Min.drop n (Min.fromList xs) === Min.fromList (List.drop n (List.sort xs))@@ -48,7 +88,14 @@     , testProperty "toDescList" $ \xs -> Min.toDescList (Min.fromList xs) === List.sortOn Down xs     , testProperty "fromAscList" $ \xs -> Min.fromAscList (List.sort xs) === Min.fromList xs     , testProperty "fromDescList" $ \xs -> Min.fromDescList (List.sortOn Down xs) === Min.fromList xs-    , testProperty "mapU" $ \xs -> Min.mapU (+ 1) (Min.fromList xs) === Min.fromList (List.map (+ 1) xs)+    , testProperty "mapU" $ \xs ->+        let+          -- Monotonic, but not strictly so+          fun x+            | even x = x+            | otherwise = x + 1+          res = Min.mapU fun (Min.fromList xs)+        in validMinQueue res .&&. Min.toList res === List.map fun (List.sort xs)     , testProperty "foldrU" $ \xs -> Min.foldrU (+) 0 (Min.fromList xs) === sum xs     , testProperty "foldlU" $ \xs -> Min.foldlU (+) 0 (Min.fromList xs) === sum xs     , testProperty "foldlU'" $ \xs -> Min.foldlU' (+) 0 (Min.fromList xs) === sum xs@@ -106,9 +153,20 @@       [ testProperty "Just" $ \xs -> PMin.updateMinA (Identity . Just) (PMin.fromList xs) === Identity (PMin.fromList xs)       , testProperty "Nothing" $ \(NonEmpty (xs :: [(Int, ())])) -> PMin.updateMinA (Identity . const Nothing) (PMin.fromList xs) === Identity (PMin.fromList (tail (List.sort xs)))       ]-    , testProperty "minViewWithKey" $ \(xs :: [(Int, ())]) -> PMin.minViewWithKey (PMin.fromList xs) === fmap (second PMin.fromList) (List.uncons (List.sort xs))+    , testProperty "minViewWithKey" $ \(xs :: [(Int, Int)]) -> case PMin.minViewWithKey (PMin.fromList xs) of+        Nothing -> xs === []+        Just ((the_min, the_min_val), xs') ->+           validPMinQueue xs' .&&.+           List.sort ((the_min, the_min_val) : PMin.toList xs') === List.sort xs     , testProperty "map" $ \(xs :: [(Int, ())]) -> PMin.map id (PMin.fromList xs) === PMin.fromList xs-    , testProperty "mapKeysMonotonic" $ \xs -> PMin.mapKeysMonotonic (+ 1) (PMin.fromList xs) === PMin.fromList (List.map (first (+ 1)) xs)+    , testProperty "mapKeysMonotonic" $ \xs ->+        let+          -- Monotonic, but not strictly so+          fun x+            | even x = x+            | otherwise = x + 1+          res = PMin.mapKeysMonotonic fun (PMin.fromList xs)+        in validPMinQueue res .&&. List.sort (PMin.toList res) === List.sort (List.map (first fun) xs)     , testProperty "take" $ \n (xs :: [(Int, ())]) -> PMin.take n (PMin.fromList xs) === List.take n (List.sort xs)     , testProperty "drop" $ \n (xs :: [(Int, ())]) -> PMin.drop n (PMin.fromList xs) === PMin.fromList (List.drop n (List.sort xs))     , testProperty "splitAt" $ \n (xs :: [(Int, ())]) -> PMin.splitAt n (PMin.fromList xs) === second PMin.fromList (List.splitAt n (List.sort xs))@@ -123,10 +181,35 @@       \(Fn2 (f :: Int -> () -> Maybe ())) (xs :: [(Int, ())]) -> PMin.mapMWithKey f (PMin.fromList xs) === fmap PMin.fromList (traverse (\(k, x) -> fmap (k,) (f k x)) xs)     , testProperty "insert" $ \k xs -> PMin.insert k () (PMin.fromList xs) === PMin.fromList ((k, ()) : xs)     , testProperty "union" $ \(xs :: [(Int, ())]) ys -> PMin.union (PMin.fromList xs) (PMin.fromList ys) === PMin.fromList (xs ++ ys)-    , testProperty "filter" $-      \(xs :: [(Int, ())]) -> PMin.filterWithKey (\k _ -> even k) (PMin.fromList xs) === PMin.fromList (List.filter (even . fst) xs)-    , testProperty "partition" $-      \(xs :: [(Int, ())]) -> PMin.partitionWithKey (\k _ -> even k) (PMin.fromList xs) === bimap PMin.fromList PMin.fromList (List.partition (even . fst) xs)+    , testProperty "filter" $ \(xs :: [(Int, Int)]) ->+        let+          -- The probability of a number not being divisible by 3 is 2/3.+          -- The probability of a number not being divisible by 4 is 3/4.+          -- So the probability of a number being divisible by neither is+          -- 1/2.+          f x y = x `rem` 3 == 0 || y `rem` 4 == 0+          xs' = PMin.filterWithKey f (PMin.fromList xs)+        in validPMinQueue xs' .&&.+           List.sort (PMin.toList xs') === List.sort (List.filter (uncurry f) xs)+    , testProperty "partition" $ \(xs :: [(Int, Int)]) ->+        let+          f x y = x `rem` 3 == 0 || y `rem` 4 == 0+          (ys, zs) = PMin.partitionWithKey f (PMin.fromList xs)+        in validPMinQueue ys .&&.+           validPMinQueue zs .&&.+           (List.sort (PMin.toList ys), List.sort (PMin.toList zs)) ===+             bimap List.sort List.sort (List.partition (uncurry f) xs)+    , testProperty "mapMaybe" $ \(Fn2 f) (xs :: [(Int, Int)]) ->+        let+          xs' = PMin.mapMaybeWithKey f (PMin.fromList xs)+        in validPMinQueue xs' .&&.+           List.sort (PMin.toList xs') === List.sort (Maybe.mapMaybe (\(k,v) -> fmap (k,) (f k v)) xs)+    , testProperty "mapEither" $ \(Fn2 f) (xs :: [(Int, Int)]) ->+        let (ys, zs) = PMin.mapEitherWithKey f (PMin.fromList xs)+        in validPMinQueue ys .&&.+           validPMinQueue zs .&&.+           (List.sort (PMin.toList ys), List.sort (PMin.toList zs)) ===+             bimap List.sort List.sort (Either.partitionEithers . List.map (\(k,v) -> bimap (k,) (k,) (f k v)) $ xs)     , testProperty "toAscList" $ \(xs :: [(Int, ())]) -> PMin.toAscList (PMin.fromList xs) === List.sort xs     , testProperty "toDescList" $ \(xs :: [(Int, ())]) -> PMin.toDescList (PMin.fromList xs) === List.sortOn Down xs     , testProperty "fromAscList" $ \(xs :: [(Int, ())]) -> PMin.fromAscList (List.sort xs) === PMin.fromList xs@@ -158,7 +241,14 @@       ]     , testProperty "minViewWithKey" $ \(xs :: [(Int, ())]) -> PMax.maxViewWithKey (PMax.fromList xs) === fmap (second PMax.fromList) (List.uncons (List.sortOn Down xs))     , testProperty "map" $ \(xs :: [(Int, ())]) -> PMax.map id (PMax.fromList xs) === PMax.fromList xs-    , testProperty "mapKeysMonotonic" $ \xs -> PMax.mapKeysMonotonic (+ 1) (PMax.fromList xs) === PMax.fromList (List.map (first (+ 1)) xs)+    , testProperty "mapKeysMonotonic" $ \xs ->+        let+          -- Monotonic, but not strictly so+          fun x+            | even x = x+            | otherwise = x + 1+          res = PMax.mapKeysMonotonic fun (PMax.fromList xs)+        in validPMaxQueue res .&&. List.sort (PMax.toList res) === List.sort (List.map (first fun) xs)     , testProperty "take" $ \n (xs :: [(Int, ())]) -> PMax.take n (PMax.fromList xs) === List.take n (List.sortOn Down xs)     , testProperty "drop" $ \n (xs :: [(Int, ())]) -> PMax.drop n (PMax.fromList xs) === PMax.fromList (List.drop n (List.sortOn Down xs))     , testProperty "splitAt" $ \n (xs :: [(Int, ())]) -> PMax.splitAt n (PMax.fromList xs) === second PMax.fromList (List.splitAt n (List.sortOn Down xs))
+ tests/Validity/BinomialQueue.hs view
@@ -0,0 +1,49 @@+-- | Validity testing+module Validity.BinomialQueue+  ( validShape+  , precedesProperly+  ) where++import BinomialQueue.Internals++-- | Does the heap have a valid shape?+validShape :: MinQueue a -> Bool+validShape (MinQueue f) = validShapeF f+  +validShapeF :: BinomForest rk a -> Bool+validShapeF (Cons _ f) = validShapeF f+validShapeF (Skip Nil) = False+validShapeF (Skip _f) = True+validShapeF Nil = True+  +-- | Takes an element and a priority queue. Checks that the queue is in heap+-- order and that the element is less than or equal to all elements of the+-- queue.+precedesProperly :: Ord a => a -> MinQueue a -> Bool+precedesProperly a (MinQueue q) = precedesProperlyF a q+  +-- | Takes an element and a forest. Checks that the forest is in heap order+-- and that the element is less than or equal to all elements of the forest.+precedesProperlyF :: (Ord a, TreeValidity rk) => a -> BinomForest rk a -> Bool+precedesProperlyF _ Nil = True+precedesProperlyF the_min (Skip f) = precedesProperlyF the_min f+precedesProperlyF the_min (Cons t ts) = precedesProperlyTree the_min t+  && precedesProperlyF the_min ts+  +-- | Takes an element and a tree. Checks that the tree is in heap order+-- and that the element is less than or equal to all elements of the tree.+precedesProperlyTree :: (Ord a, TreeValidity rk) => a -> BinomTree rk a -> Bool+precedesProperlyTree the_min (BinomTree a ts) = the_min <= a && precedesProperlyRk a ts+  +-- | A helper class for order validity checking+class TreeValidity rk where+  -- | Takes an element and a collection of trees. Checks that the collection+  -- is in heap order and that the element is less than or equal to all+  -- elements of the collection.+  precedesProperlyRk :: Ord a => a -> rk a -> Bool+instance TreeValidity Zero where+  precedesProperlyRk _ ~Zero = True+instance TreeValidity rk => TreeValidity (Succ rk) where+  precedesProperlyRk the_min (Succ t q) =+    precedesProperlyTree the_min t &&+    precedesProperlyRk the_min q
+ tests/Validity/PQueue/Min.hs view
@@ -0,0 +1,21 @@+module Validity.PQueue.Min+  ( validShape+  , validSize+  , validOrder+  ) where++import Data.PQueue.Internals+import qualified BinomialQueue.Internals as BQ+import qualified Validity.BinomialQueue as VBQ++validShape :: MinQueue a -> Bool+validShape Empty = True+validShape (MinQueue _ _ f) = VBQ.validShape f++validSize :: MinQueue a -> Bool+validSize Empty = True+validSize (MinQueue sz _ f) = sz == BQ.size f + 1++validOrder :: Ord a => MinQueue a -> Bool+validOrder Empty = True+validOrder (MinQueue _sz a f) = VBQ.precedesProperly a f
+ tests/Validity/PQueue/Prio/BinomialQueue.hs view
@@ -0,0 +1,40 @@+-- | Validity testing+module Validity.PQueue.Prio.BinomialQueue+  ( validShapeF+  , precedesProperlyF+  ) where++import Data.PQueue.Prio.Internals++-- | Does the heap have a valid shape?+validShapeF :: BinomForest rk k a -> Bool+validShapeF (Cons _ f) = validShapeF f+validShapeF (Skip Nil) = False+validShapeF (Skip _f) = True+validShapeF Nil = True+  +-- | Takes an element and a forest. Checks that the forest is in heap order+-- and that the element is less than or equal to all elements of the forest.+precedesProperlyF :: (Ord k, TreeValidity rk) => k -> BinomForest rk k a -> Bool+precedesProperlyF _ Nil = True+precedesProperlyF the_min (Skip f) = precedesProperlyF the_min f+precedesProperlyF the_min (Cons t ts) = precedesProperlyTree the_min t+  && precedesProperlyF the_min ts+  +-- | Takes an element and a tree. Checks that the tree is in heap order+-- and that the element is less than or equal to all elements of the tree.+precedesProperlyTree :: (Ord k, TreeValidity rk) => k -> BinomTree rk k a -> Bool+precedesProperlyTree the_min (BinomTree k ts) = the_min <= k && precedesProperlyRk k ts+  +-- | A helper class for order validity checking+class TreeValidity rk where+  -- | Takes an element and a collection of trees. Checks that the collection+  -- is in heap order and that the element is less than or equal to all+  -- elements of the collection.+  precedesProperlyRk :: Ord k => k -> rk k a -> Bool+instance TreeValidity Zero where+  precedesProperlyRk _ (Zero _) = True+instance TreeValidity rk => TreeValidity (Succ rk) where+  precedesProperlyRk the_min (Succ t q) =+    precedesProperlyTree the_min t &&+    precedesProperlyRk the_min q
+ tests/Validity/PQueue/Prio/Max.hs view
@@ -0,0 +1,17 @@+module Validity.PQueue.Prio.Max+  ( validShape+  , validSize+  , validOrder+  ) where++import Data.PQueue.Prio.Max.Internals as PQM+import qualified Validity.PQueue.Prio.Min as VMin++validShape :: MaxPQueue k a -> Bool+validShape (MaxPQ q) = VMin.validShape q++validSize :: MaxPQueue k a -> Bool+validSize (MaxPQ q) = VMin.validSize q++validOrder :: Ord k => MaxPQueue k a -> Bool+validOrder (MaxPQ q) = VMin.validOrder q
+ tests/Validity/PQueue/Prio/Min.hs view
@@ -0,0 +1,28 @@+module Validity.PQueue.Prio.Min+  ( validShape+  , validSize+  , validOrder+  ) where++import Data.PQueue.Prio.Internals as BQ+import qualified Validity.PQueue.Prio.BinomialQueue as VBQ++validShape :: MinPQueue k a -> Bool+validShape Empty = True+validShape (MinPQ _ _ _ f) = VBQ.validShapeF f++validSize :: MinPQueue k a -> Bool+validSize Empty = True+validSize (MinPQ sz _ _ f) = sz == sizeH f + 1++validOrder :: Ord k => MinPQueue k a -> Bool+validOrder Empty = True+validOrder (MinPQ _sz k _ f) = VBQ.precedesProperlyF k f++sizeH :: BinomHeap k a -> Int+sizeH = go 0 1+  where+    go :: Int -> Int -> BinomForest rk k a -> Int+    go acc rk Nil = rk `seq` acc+    go acc rk (Skip f) = go acc (2 * rk) f+    go acc rk (Cons _t f) = go (acc + rk) (2 * rk) f