pqueue 1.4.3.0 → 1.7.0.0

raw patch · 27 files changed

Files

• CHANGELOG.md +97/−46
• benchmarks/BenchMinPQueue.hs +26/−0
• benchmarks/BenchMinQueue.hs +27/−2
• benchmarks/HeapSort.hs +0/−1
• benchmarks/KWay/PrioMergeAlg.hs +0/−1
• benchmarks/KWay/RandomIncreasing.hs +0/−1
• benchmarks/PHeapSort.hs +0/−1
• pqueue.cabal +62/−30
• src/BinomialQueue/Internals.hs +73/−61
• src/BinomialQueue/Max.hs +38/−62
• src/BinomialQueue/Min.hs +10/−29
• src/Data/PQueue/Internals.hs +39/−35
• src/Data/PQueue/Internals/Classes.hs +26/−0
• src/Data/PQueue/Internals/Foldable.hs +0/−38
• src/Data/PQueue/Max.hs +62/−63
• src/Data/PQueue/Min.hs +64/−31
• src/Data/PQueue/Prio/Internals.hs +224/−235
• src/Data/PQueue/Prio/Max.hs +0/−1
• src/Data/PQueue/Prio/Max/Internals.hs +63/−92
• src/Data/PQueue/Prio/Min.hs +47/−15
• src/Nattish.hs +84/−0
• tests/PQueueTests.hs +104/−12
• tests/Validity/BinomialQueue.hs +49/−0
• tests/Validity/PQueue/Min.hs +21/−0
• tests/Validity/PQueue/Prio/BinomialQueue.hs +40/−0
• tests/Validity/PQueue/Prio/Max.hs +17/−0
• tests/Validity/PQueue/Prio/Min.hs +28/−0

@@ -1,93 +1,144 @@ # Revision history for pqueue +## 1.7.0.0 -- 2026-04-16++* Remove `insertBehind` ([#145](https://github.com/lspitzner/pqueue/pull/145))++* Change `Read` and `Show` instances to use `fromList`+  ([#144](https://github.com/lspitzner/pqueue/issues/144))++## 1.6.0.0 -- 2025-10-11++* Deprecate `mapU` and replace it by `mapMonotonic` in `Data.PQeueu.Min` and `Data.PQueue.Max`+  ([#129](https://github.com/lspitzner/pqueue/pull/129))++* Add ghc-9.8, ghc-9.10 & ghc-9.12 support+  ([#133](https://github.com/lspitzner/pqueue/pull/133), [#135](https://github.com/lspitzner/pqueue/pull/135), [#139](https://github.com/lspitzner/pqueue/pull/139))++* Drop ghc-7.10 support ([#142](https://github.com/lspitzner/pqueue/pull/142))++* Fix typo in `Data.PQueue.Max.toList` documentation+  ([#131](https://github.com/lspitzner/pqueue/pull/131))++## 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](https://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](https://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).-    ([#85](https://github.com/lspitzner/pqueue/pull/85))-  * Add ghc-9.4 support. ([#86](https://github.com/lspitzner/pqueue/pull/86))+* Add instances for [indexed-traversable](https://hackage.haskell.org/package/indexed-traversable).+  ([#85](https://github.com/lspitzner/pqueue/pull/85))+* Add ghc-9.4 support. ([#86](https://github.com/lspitzner/pqueue/pull/86))  ## 1.4.2.0 -- 2022-06-19 -  * Overall performance has improved greatly, especially when there are many-    insertions and/or merges in a row. Insertion, deletion, and merge are now-    *worst case* logarithmic, while maintaining their previous amortized-    bounds. ([#26](https://github.com/lspitzner/pqueue/pull/26))+* Overall performance has improved greatly, especially when there are many+  insertions and/or merges in a row. Insertion, deletion, and merge are now+  *worst case* logarithmic, while maintaining their previous amortized+  bounds. ([#26](https://github.com/lspitzner/pqueue/pull/26)) -  * New `mapMWithKey` functions optimized for working in strict monads. These-    are used to implement the `mapM` and `sequence` methods of `Traversable`.-    ([#46](https://github.com/lspitzner/pqueue/pull/46))+* New `mapMWithKey` functions optimized for working in strict monads. These+  are used to implement the `mapM` and `sequence` methods of `Traversable`.+  ([#46](https://github.com/lspitzner/pqueue/pull/46)) -  * Define `stimes` in the `Semigroup` instances.-    ([#57](https://github.com/lspitzner/pqueue/pull/57))+* Define `stimes` in the `Semigroup` instances.+  ([#57](https://github.com/lspitzner/pqueue/pull/57)) -  * Add strict left unordered folds (`foldlU'`, `foldlWithKeyU'`)-    and monoidal unordered folds (`foldMapU`, `foldMapWithKeyU`).-    ([#59](https://github.com/lspitzner/pqueue/pull/59))+* Add strict left unordered folds (`foldlU'`, `foldlWithKeyU'`)+  and monoidal unordered folds (`foldMapU`, `foldMapWithKeyU`).+  ([#59](https://github.com/lspitzner/pqueue/pull/59)) -  * New functions for adjusting and updating the min/max of a key-value-    priority queue in an `Applicative` context.-    ([#66](https://github.com/lspitzner/pqueue/pull/66))+* New functions for adjusting and updating the min/max of a key-value+  priority queue in an `Applicative` context.+  ([#66](https://github.com/lspitzner/pqueue/pull/66)) -  * Fixed `Data.PQueue.Max.map` to work on `MaxQueue`s.-    ([#76](https://github.com/lspitzner/pqueue/pull/76))+* Fixed `Data.PQueue.Max.map` to work on `MaxQueue`s.+  ([#76](https://github.com/lspitzner/pqueue/pull/76))  ## 1.4.1.4 -- 2021-12-04 -  * Maintenance release for ghc-9.0 & ghc-9.2 support-  * Change nix-setup to use the seaaye tool+* Maintenance release for ghc-9.0 & ghc-9.2 support+* Change nix-setup to use the seaaye tool  ## 1.4.1.3 -- 2020-06-06 -  * Maintenance release-  * Add missing documentation-  * Add nix-expressions for testing against different compilers/package sets+* Maintenance release+* Add missing documentation+* Add nix-expressions for testing against different compilers/package sets  ## 1.4.1.2 -- 2018-09-26 -  * Maintenance release for ghc-8.6-  * Drop support for ghc<7.10+* Maintenance release for ghc-8.6+* Drop support for ghc<7.10  ## 1.4.1.1 -- 2018-02-11 -  * Remove/replace buggy `insertBehind` implementation.+* Remove/replace buggy `insertBehind` implementation. -    The existing implementation did not always insert behind. As a fix,-    the function was removed from Data.PQueue.Max/Min and was rewritten-    with a O(n) complexity (!) for Data.PQueue.Prio.Max/Min.+  The existing implementation did not always insert behind. As a fix,+  the function was removed from Data.PQueue.Max/Min and was rewritten+  with a O(n) complexity (!) for Data.PQueue.Prio.Max/Min. -  * Adapt for ghc-8.4, based on the ghc-8.4.1-alpha1 release-  * Drop support for ghc<7.4+* Adapt for ghc-8.4, based on the ghc-8.4.1-alpha1 release+* Drop support for ghc<7.4  ## 1.3.2.3 -- 2017-08-01 -  * Maintenance release for ghc-8.2+* Maintenance release for ghc-8.2  ## 1.3.2.2 -- 2017-03-12 -  * Add test-suite from darcs repository for pqueue-1.0.1.+* Add test-suite from darcs repository for pqueue-1.0.1.  ## 1.3.2.1 -- 2017-03-11 -  * Fix documentation errors-    - complexity on `toList`, `toListU`-    - `PQueue.Prio.Max` had "ascending" instead of "descending" in some places+* Fix documentation errors+  - complexity on `toList`, `toListU`+  - `PQueue.Prio.Max` had "ascending" instead of "descending" in some places  ## 1.3.2   -- 2016-09-28 -  * Add function `insertBehind` as a slight variation of `insert` which differs-    in behaviour for elements the compare equal.+* Add function `insertBehind` as a slight variation of `insert` which differs+  in behaviour for elements the compare equal.  ## 1.3.1.1 -- 2016-05-21 -  * Ensure compatibility with ghc-8-  * Minor internal refactors+* Ensure compatibility with ghc-8+* Minor internal refactors  ## 1.3.1   -- 2015-10-03 -  * Add `Monoid` instance for `MaxPQueue`+* Add `Monoid` instance for `MaxPQueue`  ## 1.3.0   -- 2015-06-23 -  * Lennart Spitzner starts co-maintaining-  * new git repository at github.com:lspitzner/pqueue-  * Ensure compatibility with ghc-7.10+* Lennart Spitzner starts co-maintaining+* new git repository at github.com:lspitzner/pqueue+* Ensure compatibility with ghc-7.10

@@ -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)       ]   ]

@@ -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)       ]   ]

@@ -1,6 +1,5 @@ module HeapSort where -import Data.PQueue.Min (MinQueue) import qualified Data.PQueue.Min as P import System.Random 

@@ -7,7 +7,6 @@   ) where  import qualified Data.PQueue.Prio.Min as P-import System.Random (StdGen) import Data.Word import Data.List (unfoldr) import KWay.RandomIncreasing

@@ -5,7 +5,6 @@  import System.Random import Data.Word-import Data.List (unfoldr)  data Stream = Stream !Word64 {-# UNPACK #-} !StdGen 

@@ -1,6 +1,5 @@ module PHeapSort where -import Data.PQueue.Prio.Min (MinPQueue) import qualified Data.PQueue.Prio.Min as P import System.Random 

@@ -1,8 +1,9 @@+cabal-version:      2.2 name:               pqueue-version:            1.4.3.0+version:            1.7.0.0 category:           Data Structures author:             Louis Wasserman-license:            BSD3+license:            BSD-3-Clause license-file:       LICENSE stability:          experimental synopsis:           Reliable, persistent, fast priority queues.@@ -14,9 +15,23 @@ homepage:           https://github.com/lspitzner/pqueue 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-extra-source-files:+tested-with:+  GHC == 9.14.1+  GHC == 9.12.2+  GHC == 9.10.3+  GHC == 9.8.4+  GHC == 9.6.7+  GHC == 9.4.8+  GHC == 9.2.8+  GHC == 9.0.2+  GHC == 8.10.7+  GHC == 8.8.4+  GHC == 8.6.5+  GHC == 8.4.4+  GHC == 8.2.2+  GHC == 8.0.2++extra-doc-files:   CHANGELOG.md   README.md @@ -29,10 +44,9 @@   default-language:     Haskell2010   build-depends:-  { base >= 4.8 && < 4.18-  , deepseq >= 1.3 && < 1.5-  , indexed-traversable >= 0.1 && < 0.2-  }+    , base >= 4.9 && < 4.23+    , deepseq >= 1.3 && < 1.6+    , indexed-traversable >= 0.1 && < 0.2   exposed-modules:     Data.PQueue.Prio.Min     Data.PQueue.Prio.Max@@ -44,12 +58,12 @@     BinomialQueue.Internals     BinomialQueue.Min     BinomialQueue.Max+    Data.PQueue.Internals.Classes     Data.PQueue.Internals.Down-    Data.PQueue.Internals.Foldable     Data.PQueue.Prio.Max.Internals-  if impl(ghc) {+    Nattish+  if impl(ghc)     default-extensions: DeriveDataTypeable-  }   other-extensions:       BangPatterns     , CPP@@ -60,22 +74,40 @@     -fspec-constr     -fdicts-strict     -Wall-  if impl(ghc >= 8.0)-    ghc-options:-      -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-  , deepseq >= 1.3 && < 1.5-  , tasty-  , tasty-quickcheck-  , pqueue-  }+    , base >= 4.9 && < 4.23+    , deepseq >= 1.3 && < 1.6+    , indexed-traversable >= 0.1 && < 0.2+    , tasty+    , tasty-quickcheck+  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.Classes+    Data.PQueue.Internals.Down+    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     -fno-warn-type-defaults@@ -91,11 +123,11 @@     KWay.RandomIncreasing   ghc-options:      -O2   build-depends:-      base          >= 4.8 && < 5+    , base          >= 4.9 && < 5     , pqueue-    , deepseq       >= 1.3 && < 1.5-    , random        >= 1.2 && < 1.3-    , tasty-bench   >= 0.3 && < 0.4+    , deepseq       >= 1.3 && < 1.6+    , random        >= 1.2 && < 1.4+    , tasty-bench   >= 0.3 && < 0.6  benchmark minpqueue-benchmarks   default-language: Haskell2010@@ -108,8 +140,8 @@     KWay.RandomIncreasing   ghc-options:      -O2   build-depends:-      base          >= 4.8 && < 5+    , base          >= 4.9 && < 5     , pqueue-    , deepseq       >= 1.3 && < 1.5-    , random        >= 1.2 && < 1.3-    , tasty-bench   >= 0.3 && < 0.4+    , deepseq       >= 1.3 && < 1.6+    , random        >= 1.2 && < 1.4+    , tasty-bench   >= 0.3 && < 0.6

@@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE StandaloneDeriving #-}  module BinomialQueue.Internals (   MinQueue (..),@@ -19,6 +18,7 @@   minView,   singleton,   insert,+  insertEager,   union,   unionPlusOne,   mapMaybe,@@ -36,7 +36,6 @@   toDescList,   toListU,   fromList,-  mapU,   fromAscList,   foldMapU,   foldrU,@@ -47,13 +46,13 @@   ) where  import Control.DeepSeq (NFData(rnf), deepseq)+#if !MIN_VERSION_base(4,20,0) import Data.Foldable (foldl')+#endif import Data.Function (on)-#if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup(..), stimesMonoid)-#endif -import Data.PQueue.Internals.Foldable+import Data.PQueue.Internals.Classes #ifdef __GLASGOW_HASKELL__ import Data.Data import Text.Read (Lexeme(Ident), lexP, parens, prec,@@ -141,8 +140,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 +208,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,16 +226,31 @@  -- | \(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.+-- | \(O(n)\). Assumes that the function it is given is (weakly) monotonic+-- (meaning that @x <= y@ implies @f x <= f y@), and+-- applies this function to every element of the priority queue, as in 'fmap'.+-- If the function is not monotonic, the result is undefined. mapMonotonic :: (a -> b) -> MinQueue a -> MinQueue b-mapMonotonic = mapU+mapMonotonic f (MinQueue ts) = MinQueue (fmap_ f ts)  {-# INLINABLE [0] foldrAsc #-} -- | \(O(n \log n)\). Performs a right fold on the elements of a priority queue in@@ -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@@ -525,19 +542,19 @@   | otherwise  = BinomTree x2 (Succ t1 ts2)  -instance Functor Zero where-  fmap _ _ = Zero+instance Fmap Zero where+  fmap_ _ _ = Zero -instance Functor rk => Functor (Succ rk) where-  fmap f (Succ t ts) = Succ (fmap f t) (fmap f ts)+instance Fmap rk => Fmap (Succ rk) where+  fmap_ f (Succ t ts) = Succ (fmap_ f t) (fmap_ f ts) -instance Functor rk => Functor (BinomTree rk) where-  fmap f (BinomTree x ts) = BinomTree (f x) (fmap f ts)+instance Fmap rk => Fmap (BinomTree rk) where+  fmap_ f (BinomTree x ts) = BinomTree (f x) (fmap_ f ts) -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)+instance Fmap rk => Fmap (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  instance Foldr Zero where   foldr_ _ z ~Zero = z@@ -631,9 +648,6 @@ --   traverse f (Skip tss) = Skip <$> traverse f tss --   traverse f (Cons t tss) = Cons <$> traverse f t <*> traverse f tss -mapU :: (a -> b) -> MinQueue a -> MinQueue b-mapU f (MinQueue ts) = MinQueue (f <$> ts)- {-# NOINLINE [0] foldrU #-} -- | \(O(n)\). Unordered right fold on a priority queue. foldrU :: (a -> b -> b) -> b -> MinQueue a -> b@@ -679,7 +693,7 @@ -- -- 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+-- spine to the detriment of performance. However, @mapMonotonic@ can leave expensive -- thunks in the structure and repeated applications of that function can -- create thunk chains. seqSpine :: MinQueue a -> b -> b@@ -712,29 +726,27 @@  instance (Ord a, Show a) => Show (MinQueue a) where   showsPrec p xs = showParen (p > 10) $-    showString "fromAscList " . shows (toAscList xs)+    showString "fromList " . shows (toAscList xs) -instance Read a => Read (MinQueue a) where+instance (Ord a, Read a) => Read (MinQueue a) where #ifdef __GLASGOW_HASKELL__   readPrec = parens $ prec 10 $ do-    Ident "fromAscList" <- lexP+    Ident "fromList" <- lexP     xs <- readPrec-    return (fromAscList xs)+    return (fromList xs)    readListPrec = readListPrecDefault #else   readsPrec p = readParen (p > 10) $ \r -> do-    ("fromAscList",s) <- lex r+    ("fromList",s) <- lex r     (xs,t) <- reads s-    return (fromAscList xs,t)+    return (fromList xs,t) #endif -#if MIN_VERSION_base(4,9,0) instance Ord a => Semigroup (MinQueue a) where   (<>) = union   stimes = stimesMonoid   {-# INLINABLE stimes #-}-#endif  instance Ord a => Monoid (MinQueue a) where   mempty = empty

@@ -87,26 +87,13 @@  import Prelude hiding (null, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), filter, map) -import Data.Foldable (foldl')-import Data.Maybe (fromMaybe)-import Data.Bifunctor (bimap)--#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup((<>)))-#endif-+import Data.Coerce (coerce) import qualified Data.List as List+import Data.Maybe (fromMaybe)  import qualified BinomialQueue.Min as MinQ import Data.PQueue.Internals.Down -#ifdef __GLASGOW_HASKELL__-import GHC.Exts (build)-#else-build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]-build f = f (:) []-#endif- newtype MaxQueue a = MaxQueue { unMaxQueue :: MinQ.MinQueue (Down a) }  -- | \(O(\log n)\). Returns the minimum element. Throws an error on an empty queue.@@ -115,11 +102,11 @@  -- | \(O(1)\). The top (maximum) element of the queue, if there is one. getMax :: Ord a => MaxQueue a -> Maybe a-getMax (MaxQueue q) = unDown <$> MinQ.getMin q+getMax = coerce MinQ.getMin  -- | \(O(\log n)\). Deletes the maximum element. If the queue is empty, does nothing. deleteMax :: Ord a => MaxQueue a -> MaxQueue a-deleteMax = MaxQueue . MinQ.deleteMin . unMaxQueue+deleteMax = coerce MinQ.deleteMin  -- | \(O(\log n)\). Extracts the maximum element. Throws an error on an empty queue. deleteFindMax :: Ord a => MaxQueue a -> (a, MaxQueue a)@@ -127,34 +114,30 @@  -- | \(O(\log n)\). Extract the top (maximum) element of the sequence, if there is one. maxView :: Ord a => MaxQueue a -> Maybe (a, MaxQueue a)-maxView (MaxQueue q) = case MinQ.minView q of-  Just (Down a, q') -> Just (a, MaxQueue q')-  Nothing -> Nothing+maxView = coerce MinQ.minView --- | \(O(k \log n)\)/. Index (subscript) operator, starting from 0. @queue !! k@ returns the @(k+1)@th largest+-- | \(O(k \log n)\). Index (subscript) operator, starting from 0. @queue !! k@ returns the @(k+1)@th largest -- element in the queue. Equivalent to @toDescList queue !! k@. (!!) :: 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 -- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. takeWhile :: Ord a => (a -> Bool) -> MaxQueue a -> [a]-takeWhile p = fmap unDown . MinQ.takeWhile (p . unDown) . unMaxQueue+takeWhile = coerce MinQ.takeWhile  -- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. dropWhile :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a-dropWhile p = MaxQueue . MinQ.dropWhile (p . unDown) . unMaxQueue+dropWhile = coerce MinQ.dropWhile  -- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where -- first element is longest prefix (possibly empty) of @queue@ of elements that -- satisfy @p@ and second element is the remainder of the queue. span :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a)-span p (MaxQueue queue)-  | (front, rear) <- MinQ.span (p . unDown) queue-  = (fmap unDown front, MaxQueue rear)+span = coerce MinQ.span  -- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where -- first element is longest prefix (possibly empty) of @queue@ of elements that@@ -163,81 +146,75 @@ break p = span (not . p)  {-# INLINE take #-}--- | \(O(k \log n)\)/. 'take' @k@, applied to a queue @queue@, returns a list of the greatest @k@ elements of @queue@,+-- | \(O(k \log n)\). 'take' @k@, applied to a queue @queue@, returns a list of the greatest @k@ elements of @queue@, -- or all elements of @queue@ itself if @k >= 'size' queue@. take :: Ord a => Int -> MaxQueue a -> [a] take n = List.take n . toDescList --- | \(O(k \log n)\)/. 'drop' @k@, applied to a queue @queue@, returns @queue@ with the greatest @k@ elements deleted,--- or an empty queue if @k >= size 'queue'@.+-- | \(O(k \log n)\). 'drop' @k@, applied to a queue @queue@, returns @queue@ with the greatest @k@ elements deleted,+-- or an empty queue if @k >= 'size' queue@. drop :: Ord a => Int -> MaxQueue a -> MaxQueue a-drop n (MaxQueue queue) = MaxQueue (MinQ.drop n queue)+drop = coerce MinQ.drop --- | \(O(k \log n)\)/. Equivalent to @('take' k queue, 'drop' k queue)@.+-- | \(O(k \log n)\). Equivalent to @('take' k queue, 'drop' k queue)@. splitAt :: Ord a => Int -> MaxQueue a -> ([a], MaxQueue a)-splitAt n (MaxQueue queue)-  | (l, r) <- MinQ.splitAt n queue-  = (fmap unDown l, MaxQueue r)+splitAt = coerce MinQ.splitAt  -- | \(O(n)\). Returns the queue with all elements not satisfying @p@ removed. filter :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a-filter p = MaxQueue . MinQ.filter (p . unDown) . unMaxQueue+filter = coerce MinQ.filter  -- | \(O(n)\). Returns a pair where the first queue contains all elements satisfying @p@, and the second queue -- contains all elements not satisfying @p@. partition :: Ord a => (a -> Bool) -> MaxQueue a -> (MaxQueue a, MaxQueue a)-partition p = go . unMaxQueue-  where-    go queue-      | (l, r) <- MinQ.partition (p . unDown) queue-      = (MaxQueue l, MaxQueue r)+partition = coerce MinQ.partition  -- | \(O(n)\). Creates a new priority queue containing the images of the elements of this queue. -- Equivalent to @'fromList' . 'Data.List.map' f . toList@. map :: Ord b => (a -> b) -> MaxQueue a -> MaxQueue b-map f = MaxQueue . MinQ.map (fmap f) . unMaxQueue+map = coerce MinQ.map  {-# INLINE toList #-} -- | \(O(n \log n)\). Returns the elements of the priority queue in descending order. Equivalent to 'toDescList'. -- -- If the order of the elements is irrelevant, consider using 'toListU'. toList :: Ord a => MaxQueue a -> [a]-toList = fmap unDown . MinQ.toAscList . unMaxQueue+toList = coerce MinQ.toAscList  toAscList :: Ord a => MaxQueue a -> [a]-toAscList = fmap unDown . MinQ.toDescList . unMaxQueue+toAscList = coerce MinQ.toDescList  toDescList :: Ord a => MaxQueue a -> [a]-toDescList = fmap unDown . MinQ.toAscList . unMaxQueue+toDescList = coerce MinQ.toAscList  -- | \(O(n \log n)\). Performs a right fold on the elements of a priority queue in descending order. foldrDesc :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b-foldrDesc f z (MaxQueue q) = MinQ.foldrAsc (flip (foldr f)) z q+foldrDesc f z (MaxQueue q) = MinQ.foldrAsc (coerce f) z q  -- | \(O(n \log n)\). Performs a right fold on the elements of a priority queue in ascending order. foldrAsc :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b-foldrAsc f z (MaxQueue q) = MinQ.foldrDesc (flip (foldr f)) z q+foldrAsc f z (MaxQueue q) = MinQ.foldrDesc (coerce f) z q  -- | \(O(n \log n)\). Performs a left fold on the elements of a priority queue in ascending order. foldlAsc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b-foldlAsc f z (MaxQueue q) = MinQ.foldlDesc (foldl f) z q+foldlAsc f z (MaxQueue q) = MinQ.foldlDesc (coerce f) z q  -- | \(O(n \log n)\). Performs a left fold on the elements of a priority queue in descending order. foldlDesc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b-foldlDesc f z (MaxQueue q) = MinQ.foldlAsc (foldl f) z q+foldlDesc f z (MaxQueue q) = MinQ.foldlAsc (coerce f) z q  {-# INLINE fromAscList #-} -- | \(O(n)\). Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. fromAscList :: [a] -> MaxQueue a-fromAscList = MaxQueue . MinQ.fromDescList . fmap Down+fromAscList = coerce MinQ.fromDescList  {-# INLINE fromDescList #-} -- | \(O(n)\). Constructs a priority queue from a descending list. /Warning/: Does not check the precondition. fromDescList :: [a] -> MaxQueue a-fromDescList = MaxQueue . MinQ.fromAscList . fmap Down+fromDescList = coerce MinQ.fromAscList  fromList :: Ord a => [a] -> MaxQueue a-fromList = MaxQueue . MinQ.fromList . fmap Down+fromList = coerce MinQ.fromList  -- | Equivalent to 'toListU'. elemsU :: MaxQueue a -> [a]@@ -245,7 +222,7 @@  -- | Convert to a list in an arbitrary order. toListU :: MaxQueue a -> [a]-toListU = fmap unDown . MinQ.toListU . unMaxQueue+toListU = coerce MinQ.toListU  -- | Get the number of elements in a 'MaxQueue'. size :: MaxQueue a -> Int@@ -255,35 +232,34 @@ empty = MaxQueue MinQ.empty  foldMapU :: Monoid m => (a -> m) -> MaxQueue a -> m-foldMapU f = MinQ.foldMapU (f . unDown) . unMaxQueue+foldMapU f = MinQ.foldMapU (coerce f) . unMaxQueue  seqSpine :: MaxQueue a -> b -> b seqSpine = MinQ.seqSpine . unMaxQueue  foldlU :: (b -> a -> b) -> b -> MaxQueue a -> b-foldlU f b = MinQ.foldlU (\acc (Down a) -> f acc a) b . unMaxQueue+foldlU f b = MinQ.foldlU (coerce f) b . unMaxQueue  foldlU' :: (b -> a -> b) -> b -> MaxQueue a -> b-foldlU' f b = MinQ.foldlU' (\acc (Down a) -> f acc a) b . unMaxQueue+foldlU' f b = MinQ.foldlU' (coerce f) b . unMaxQueue  foldrU :: (a -> b -> b) -> b -> MaxQueue a -> b-foldrU c n = MinQ.foldrU (c . unDown) n . unMaxQueue+foldrU c n = MinQ.foldrU (coerce c) n . unMaxQueue  null :: MaxQueue a -> Bool null = MinQ.null . unMaxQueue  singleton :: a -> MaxQueue a-singleton = MaxQueue . MinQ.singleton . Down+singleton = coerce MinQ.singleton  mapMaybe :: Ord b => (a -> Maybe b) -> MaxQueue a -> MaxQueue b-mapMaybe f = MaxQueue . MinQ.mapMaybe (fmap Down . f . unDown) . unMaxQueue+mapMaybe = coerce MinQ.mapMaybe  insert :: Ord a => a -> MaxQueue a -> MaxQueue a-insert a (MaxQueue q) = MaxQueue (MinQ.insert (Down a) q)+insert = coerce MinQ.insert  mapEither :: (Ord b, Ord c) => (a -> Either b c) -> MaxQueue a -> (MaxQueue b, MaxQueue c)-mapEither f (MaxQueue q) = case MinQ.mapEither (bimap Down Down . f . unDown) q of-  (l, r) -> (MaxQueue l, MaxQueue r)+mapEither = coerce MinQ.mapEither  union :: Ord a => MaxQueue a -> MaxQueue a -> MaxQueue a union (MaxQueue a) (MaxQueue b) = MaxQueue (MinQ.union a b)

@@ -62,6 +62,7 @@   mapEither,   -- * Fold\/Functor\/Traversable variations   map,+  mapMonotonic,   foldrAsc,   foldlAsc,   foldrDesc,@@ -74,7 +75,6 @@   fromAscList,   fromDescList,   -- * Unordered operations-  mapU,   foldrU,   foldlU,   foldlU',@@ -88,24 +88,14 @@  import Prelude hiding (null, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), filter, map) +#if !MIN_VERSION_base(4,20,0) import Data.Foldable (foldl')-import Data.Maybe (fromMaybe)--#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup((<>))) #endif- import qualified Data.List as List+import Data.Maybe (fromMaybe)  import BinomialQueue.Internals -#ifdef __GLASGOW_HASKELL__-import GHC.Exts (build)-#else-build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]-build f = f (:) []-#endif- -- | \(O(\log n)\). Returns the minimum element. Throws an error on an empty queue. findMin :: Ord a => MinQueue a -> a findMin = fromMaybe (error "Error: findMin called on empty queue") . getMin@@ -120,27 +110,18 @@ deleteFindMin :: Ord a => MinQueue a -> (a, MinQueue a) deleteFindMin = fromMaybe (error "Error: deleteFindMin called on empty queue") . minView --- | \(O(k \log n)\)/. Index (subscript) operator, starting from 0. @queue !! k@ returns the @(k+1)@th smallest+-- | \(O(k \log n)\). Index (subscript) operator, starting from 0. @queue !! k@ returns the @(k+1)@th smallest -- element in the queue. Equivalent to @toAscList queue !! k@. (!!) :: 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@@ -165,20 +146,20 @@ break p = span (not . p)  {-# INLINE take #-}--- | \(O(k \log n)\)/. 'take' @k@, applied to a queue @queue@, returns a list of the smallest @k@ elements of @queue@,+-- | \(O(k \log n)\). 'take' @k@, applied to a queue @queue@, returns a list of the smallest @k@ elements of @queue@, -- or all elements of @queue@ itself if @k >= 'size' queue@. take :: Ord a => Int -> MinQueue a -> [a] take n = List.take n . toAscList --- | \(O(k \log n)\)/. 'drop' @k@, applied to a queue @queue@, returns @queue@ with the smallest @k@ elements deleted,--- or an empty queue if @k >= size 'queue'@.+-- | \(O(k \log n)\). 'drop' @k@, applied to a queue @queue@, returns @queue@ with the smallest @k@ elements deleted,+-- or an empty queue if @k >= 'size' queue@. drop :: Ord a => Int -> MinQueue a -> MinQueue a drop n queue = n `seq` case minView queue of   Just (_, queue')     | n > 0  -> drop (n - 1) queue'   _          -> queue --- | \(O(k \log n)\)/. Equivalent to @('take' k queue, 'drop' k queue)@.+-- | \(O(k \log n)\). Equivalent to @('take' k queue, 'drop' k queue)@. splitAt :: Ord a => Int -> MinQueue a -> ([a], MinQueue a) splitAt n queue = n `seq` case minView queue of   Just (x, queue')

@@ -29,7 +29,6 @@   toDescList,   toListU,   fromList,-  mapU,   fromAscList,   foldMapU,   foldrU,@@ -37,7 +36,7 @@   foldlU', --   traverseU,   seqSpine,-  unions+  unions,   ) where  import BinomialQueue.Internals@@ -46,17 +45,14 @@   , BinomTree (..)   , Succ (..)   , Zero (..)-  , Extract (..)-  , MExtract (..)   ) import qualified BinomialQueue.Internals as BQ import Control.DeepSeq (NFData(rnf), deepseq)+#if !MIN_VERSION_base(4,20,0) import Data.Foldable (foldl')-#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup(..), stimesMonoid) #endif+import Data.Semigroup (Semigroup(..), stimesMonoid) -import Data.PQueue.Internals.Foldable #ifdef __GLASGOW_HASKELL__ import Data.Data import Text.Read (Lexeme(Ident), lexP, parens, prec,@@ -81,6 +77,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 +89,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 +104,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 +181,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,13 +191,22 @@ 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.+-- | \(O(n)\). Assumes that the function it is given is (weakly) monotonic+-- (meaning that @x <= y@ implies @f x <= f y@), and+-- applies this function to every element of the priority queue, as in 'fmap'.+-- If the function is not monotonic, the result is undefined. mapMonotonic :: (a -> b) -> MinQueue a -> MinQueue b-mapMonotonic = mapU+mapMonotonic _ Empty = Empty+mapMonotonic f (MinQueue n x ts) = MinQueue n (f x) (BQ.mapMonotonic f ts)  {-# INLINABLE [0] foldrAsc #-} -- | \(O(n \log n)\). Performs a right fold on the elements of a priority queue in@@ -269,7 +279,7 @@  -- | @insertMaxQ' x h@ assumes that @x@ compares as greater -- than or equal to every element of @h@. It also assumes,--- and preserves, an extra invariant. See 'insertMax'' for details.+-- and preserves, an extra invariant. See 'BQ.insertMax'' for details. -- tldr: this function can be used safely to build a queue from an -- ascending list/array/whatever, but that's about it. insertMaxQ' :: a -> MinQueue a -> MinQueue a@@ -284,10 +294,6 @@ -- comparison per element. fromList xs = fromBare (BQ.fromList xs) -mapU :: (a -> b) -> MinQueue a -> MinQueue b-mapU _ Empty = Empty-mapU f (MinQueue n x ts) = MinQueue n (f x) (BQ.mapU f ts)- {-# NOINLINE [0] foldrU #-} -- | \(O(n)\). Unordered right fold on a priority queue. foldrU :: (a -> b -> b) -> b -> MinQueue a -> b@@ -336,11 +342,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@@ -351,29 +357,27 @@  instance (Ord a, Show a) => Show (MinQueue a) where   showsPrec p xs = showParen (p > 10) $-    showString "fromAscList " . shows (toAscList xs)+    showString "fromList " . shows (toAscList xs) -instance Read a => Read (MinQueue a) where+instance (Ord a, Read a) => Read (MinQueue a) where #ifdef __GLASGOW_HASKELL__   readPrec = parens $ prec 10 $ do-    Ident "fromAscList" <- lexP+    Ident "fromList" <- lexP     xs <- readPrec-    return (fromAscList xs)+    return (fromList xs)    readListPrec = readListPrecDefault #else   readsPrec p = readParen (p > 10) $ \r -> do-    ("fromAscList",s) <- lex r+    ("fromList",s) <- lex r     (xs,t) <- reads s-    return (fromAscList xs,t)+    return (fromList xs,t) #endif -#if MIN_VERSION_base(4,9,0) instance Ord a => Semigroup (MinQueue a) where   (<>) = union   stimes = stimesMonoid   {-# INLINABLE stimes #-}-#endif  instance Ord a => Monoid (MinQueue a) where   mempty = empty

@@ -0,0 +1,26 @@+-- | Writing `Foldable`/`Functor` instances for non-regular (AKA, nested) types in the+-- natural manner leads to full dictionaries being constructed on+-- each recursive call. This is pretty inefficient. It's better to construct+-- exactly what we need instead.+module Data.PQueue.Internals.Classes+  ( Foldr(..)+  , Foldl(..)+  , FoldMap(..)+  , Foldl'(..)+  , Fmap(..)+  ) where++class Foldr t where+  foldr_ :: (a -> b -> b) -> b -> t a -> b++class Foldl t where+  foldl_ :: (b -> a -> b) -> b -> t a -> b++class FoldMap t where+  foldMap_ :: Monoid m => (a -> m) -> t a -> m++class Foldl' t where+  foldl'_ :: (b -> a -> b) -> b -> t a -> b++class Fmap f where+  fmap_ :: (a -> b) -> f a -> f b

@@ -1,38 +0,0 @@--- | Writing 'Foldable' instances for non-regular (AKA, nested) types in the--- natural manner leads to full `Foldable` dictionaries being constructed on--- each recursive call. This is pretty inefficient. It's better to construct--- exactly what we need instead.-module Data.PQueue.Internals.Foldable-  ( Foldr (..)-  , 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

@@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-deprecations #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Data.PQueue.Max@@ -59,6 +61,7 @@   mapEither,   -- * Fold\/Functor\/Traversable variations   map,+  mapMonotonic,   foldrAsc,   foldlAsc,   foldrDesc,@@ -84,14 +87,13 @@  import Control.DeepSeq (NFData(rnf)) +import Data.Coerce (coerce)+#if !MIN_VERSION_base(4,20,0)+import Data.Foldable (foldl')+#endif import Data.Maybe (fromMaybe)--#if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup(..), stimesMonoid)-#endif -import Data.Foldable (foldl')- import qualified Data.PQueue.Min as Min import qualified Data.PQueue.Prio.Max.Internals as Prio import Data.PQueue.Internals.Down (Down(..))@@ -122,29 +124,27 @@  instance (Ord a, Show a) => Show (MaxQueue a) where   showsPrec p xs = showParen (p > 10) $-    showString "fromDescList " . shows (toDescList xs)+    showString "fromList " . shows (toDescList xs) -instance Read a => Read (MaxQueue a) where+instance (Ord a, Read a) => Read (MaxQueue a) where #ifdef __GLASGOW_HASKELL__   readPrec = parens $ prec 10 $ do-    Ident "fromDescList" <- lexP+    Ident "fromList" <- lexP     xs <- readPrec-    return (fromDescList xs)+    return (fromList xs)    readListPrec = readListPrecDefault #else   readsPrec p = readParen (p > 10) $ \r -> do-    ("fromDescList",s) <- lex r+    ("fromList",s) <- lex r     (xs,t) <- reads s-    return (fromDescList xs,t)+    return (fromList xs,t) #endif -#if MIN_VERSION_base(4,9,0) instance Ord a => Semigroup (MaxQueue a) where   (<>) = union   stimes = stimesMonoid   {-# INLINABLE stimes #-}-#endif  instance Ord a => Monoid (MaxQueue a) where   mempty = empty@@ -171,11 +171,11 @@  -- | \(O(1)\). The top (maximum) element of the queue, if there is one. getMax :: MaxQueue a -> Maybe a-getMax (MaxQ q) = unDown <$> Min.getMin q+getMax = coerce Min.getMin  -- | \(O(\log n)\). Deletes the maximum element of the queue. Does nothing on an empty queue. deleteMax :: Ord a => MaxQueue a -> MaxQueue a-deleteMax (MaxQ q) = MaxQ (Min.deleteMin q)+deleteMax = coerce Min.deleteMin  -- | \(O(\log n)\). Extracts the maximum element of the queue. Throws an error on an empty queue. deleteFindMax :: Ord a => MaxQueue a -> (a, MaxQueue a)@@ -183,10 +183,7 @@  -- | \(O(\log n)\). Extract the top (maximum) element of the sequence, if there is one. maxView :: Ord a => MaxQueue a -> Maybe (a, MaxQueue a)-maxView (MaxQ q) = case Min.minView q of-  Nothing -> Nothing-  Just (Down x, q')-          -> Just (x, MaxQ q')+maxView = coerce Min.minView  -- | \(O(\log n)\). Delete the top (maximum) element of the sequence, if there is one. delete :: Ord a => MaxQueue a -> Maybe (MaxQueue a)@@ -194,11 +191,11 @@  -- | \(O(1)\). Construct a priority queue with a single element. singleton :: a -> MaxQueue a-singleton = MaxQ . Min.singleton . Down+singleton = coerce Min.singleton  -- | \(O(1)\). Insert an element into the priority queue. insert :: Ord a => a -> MaxQueue a -> MaxQueue a-x `insert` MaxQ q = MaxQ (Down x `Min.insert` q)+insert = coerce Min.insert  -- | \(O(\log min(n_1,n_2))\). Take the union of two priority queues. union :: Ord a => MaxQueue a -> MaxQueue a -> MaxQueue a@@ -206,43 +203,41 @@  -- | Takes the union of a list of priority queues. Equivalent to @'foldl' 'union' 'empty'@. unions :: Ord a => [MaxQueue a] -> MaxQueue a-unions qs = MaxQ (Min.unions [q | MaxQ q <- qs])+unions = coerce Min.unions --- | \(O(k \log n)\)/. Returns the @(k+1)@th largest element of the queue.+-- | \(O(k \log n)\). Returns the @(k+1)@th largest element of the queue. (!!) :: Ord a => MaxQueue a -> Int -> a-MaxQ q !! n = unDown ((Min.!!) q n)+(!!) = coerce (Min.!!)  {-# INLINE take #-}--- | \(O(k \log n)\)/. Returns the list of the @k@ largest elements of the queue, in descending order, or+-- | \(O(k \log n)\). Returns the list of the @k@ largest elements of the queue, in descending order, or -- all elements of the queue, if @k >= n@. take :: Ord a => Int -> MaxQueue a -> [a]-take k (MaxQ q) = [a | Down a <- Min.take k q]+take = coerce Min.take --- | \(O(k \log n)\)/. Returns the queue with the @k@ largest elements deleted, or the empty queue if @k >= n@.+-- | \(O(k \log n)\). Returns the queue with the @k@ largest elements deleted, or the empty queue if @k >= n@. drop :: Ord a => Int -> MaxQueue a -> MaxQueue a-drop k (MaxQ q) = MaxQ (Min.drop k q)+drop = coerce Min.drop --- | \(O(k \log n)\)/. Equivalent to @(take k queue, drop k queue)@.+-- | \(O(k \log n)\). Equivalent to @(take k queue, drop k queue)@. splitAt :: Ord a => Int -> MaxQueue a -> ([a], MaxQueue a)-splitAt k (MaxQ q) = (fmap unDown xs, MaxQ q') where-  (xs, q') = Min.splitAt k q+splitAt = coerce Min.splitAt  -- | '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) -> MaxQueue a -> [a]-takeWhile p (MaxQ q) = fmap unDown (Min.takeWhile (p . unDown) q)+takeWhile = coerce Min.takeWhile  -- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. dropWhile :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a-dropWhile p (MaxQ q) = MaxQ (Min.dropWhile (p . unDown) q)+dropWhile = coerce Min.dropWhile  -- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where -- first element is longest prefix (possibly empty) of @queue@ of elements that -- satisfy @p@ and second element is the remainder of the queue. -- span :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a)-span p (MaxQ q) = (fmap unDown xs, MaxQ q') where-  (xs, q') = Min.span (p . unDown) q+span = coerce Min.span  -- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where -- first element is longest prefix (possibly empty) of @queue@ of elements that@@ -252,54 +247,58 @@  -- | \(O(n)\). Returns a queue of those elements which satisfy the predicate. filter :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a-filter p (MaxQ q) = MaxQ (Min.filter (p . unDown) q)+filter = coerce Min.filter  -- | \(O(n)\). Returns a pair of queues, where the left queue contains those elements that satisfy the predicate, -- and the right queue contains those that do not. partition :: Ord a => (a -> Bool) -> MaxQueue a -> (MaxQueue a, MaxQueue a)-partition p (MaxQ q) = (MaxQ q0, MaxQ q1)-  where  (q0, q1) = Min.partition (p . unDown) q+partition = coerce Min.partition  -- | \(O(n)\). Maps a function over the elements of the queue, and collects the 'Just' values. mapMaybe :: Ord b => (a -> Maybe b) -> MaxQueue a -> MaxQueue b-mapMaybe f (MaxQ q) = MaxQ (Min.mapMaybe (\(Down x) -> Down <$> f x) q)+mapMaybe = coerce Min.mapMaybe  -- | \(O(n)\). Maps a function over the elements of the queue, and separates the 'Left' and 'Right' values. mapEither :: (Ord b, Ord c) => (a -> Either b c) -> MaxQueue a -> (MaxQueue b, MaxQueue c)-mapEither f (MaxQ q) = (MaxQ q0, MaxQ q1)-  where  (q0, q1) = Min.mapEither (either (Left . Down) (Right . Down) . f . unDown) q+mapEither = coerce Min.mapEither  -- | \(O(n)\). Creates a new priority queue containing the images of the elements of this queue. -- Equivalent to @'fromList' . 'Data.List.map' f . toList@. map :: Ord b => (a -> b) -> MaxQueue a -> MaxQueue b-map f (MaxQ q) = MaxQ (Min.map (\(Down x) -> Down (f x)) q)+map = coerce Min.map --- | \(O(n)\). Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue.--- /Does not check the precondition/.+-- | \(O(n)\). Assumes that the function it is given is (weakly) monotonic+-- (meaning that @x <= y@ implies @f x <= f y@), and+-- applies this function to every element of the priority queue, as in 'fmap'.+-- If the function is not monotonic, the result is undefined.+mapMonotonic :: (a -> b) -> MaxQueue a -> MaxQueue b+mapMonotonic f (MaxQ q) = MaxQ (Min.mapMonotonic (\(Down a) -> Down (f a)) q)++{-# DEPRECATED mapU "use mapMonotonic instead" #-} mapU :: (a -> b) -> MaxQueue a -> MaxQueue b-mapU f (MaxQ q) = MaxQ (Min.mapU (\(Down a) -> Down (f a)) q)+mapU = mapMonotonic  -- | \(O(n)\). Unordered right fold on a priority queue. foldrU :: (a -> b -> b) -> b -> MaxQueue a -> b-foldrU f z (MaxQ q) = Min.foldrU (flip (foldr f)) z q+foldrU f z (MaxQ q) = Min.foldrU (coerce f) z q  -- | \(O(n)\). Unordered monoidal fold on a priority queue. -- -- @since 1.4.2 foldMapU :: Monoid m => (a -> m) -> MaxQueue a -> m-foldMapU f (MaxQ q) = Min.foldMapU (f . unDown) q+foldMapU f (MaxQ q) = Min.foldMapU (coerce f) q  -- | \(O(n)\). Unordered left fold on a priority queue. This is rarely -- what you want; 'foldrU' and 'foldlU'' are more likely to perform -- well. foldlU :: (b -> a -> b) -> b -> MaxQueue a -> b-foldlU f z (MaxQ q) = Min.foldlU (foldl f) z q+foldlU f z (MaxQ q) = Min.foldlU (coerce f) z q  -- | \(O(n)\). Unordered strict left fold on a priority queue. -- -- @since 1.4.2 foldlU' :: (b -> a -> b) -> b -> MaxQueue a -> b-foldlU' f z (MaxQ q) = Min.foldlU' (foldl' f) z q+foldlU' f z (MaxQ q) = Min.foldlU' (coerce f) z q  {-# INLINE elemsU #-} -- | Equivalent to 'toListU'.@@ -309,7 +308,7 @@ {-# INLINE toListU #-} -- | \(O(n)\). Returns a list of the elements of the priority queue, in no particular order. toListU :: MaxQueue a -> [a]-toListU (MaxQ q) = fmap unDown (Min.toListU q)+toListU = coerce Min.toListU  -- | \(O(n \log n)\). Performs a right-fold on the elements of a priority queue in ascending order. -- @'foldrAsc' f z q == 'foldlDesc' (flip f) z q@.@@ -323,11 +322,11 @@  -- | \(O(n \log n)\). Performs a right-fold on the elements of a priority queue in descending order. foldrDesc :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b-foldrDesc f z (MaxQ q) = Min.foldrAsc (flip (foldr f)) z q+foldrDesc f z (MaxQ q) = Min.foldrAsc (coerce f) z q  -- | \(O(n \log n)\). Performs a left-fold on the elements of a priority queue in descending order. foldlDesc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b-foldlDesc f z (MaxQ q) = Min.foldlAsc (foldl f) z q+foldlDesc f z (MaxQ q) = Min.foldlAsc (coerce f) z q  {-# INLINE toAscList #-} -- | \(O(n \log n)\). Extracts the elements of the priority queue in ascending order.@@ -342,37 +341,37 @@ -- I can see no particular reason this does not simply forward to Min.toAscList. (lsp, 2016)  {-# INLINE toList #-}--- | \(O(n \log n)\). Returns the elements of the priority queue in ascending order. Equivalent to 'toDescList'.+-- | \(O(n \log n)\). Returns the elements of the priority queue in descending order. Equivalent to 'toDescList'. -- -- If the order of the elements is irrelevant, consider using 'toListU'. toList :: Ord a => MaxQueue a -> [a]-toList (MaxQ q) = fmap unDown (Min.toList q)+toList = coerce Min.toList  {-# INLINE fromAscList #-} -- | \(O(n)\). Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. fromAscList :: [a] -> MaxQueue a-fromAscList = MaxQ . Min.fromDescList . fmap Down+fromAscList = coerce Min.fromDescList  {-# INLINE fromDescList #-} -- | \(O(n)\). Constructs a priority queue from a descending list. /Warning/: Does not check the precondition. fromDescList :: [a] -> MaxQueue a-fromDescList = MaxQ . Min.fromAscList . fmap Down+fromDescList = coerce Min.fromAscList  {-# INLINE fromList #-} -- | \(O(n \log n)\). Constructs a priority queue from an unordered list. fromList :: Ord a => [a] -> MaxQueue a-fromList = MaxQ . Min.fromList . fmap Down+fromList = coerce Min.fromList  -- | \(O(n)\). Constructs a priority queue from the keys of a 'Prio.MaxPQueue'. keysQueue :: Prio.MaxPQueue k a -> MaxQueue k-keysQueue (Prio.MaxPQ q) = MaxQ (Min.keysQueue q)+keysQueue = coerce Min.keysQueue  -- | \(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

@@ -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,@@ -58,6 +68,7 @@   mapEither,   -- * Fold\/Functor\/Traversable variations   map,+  mapMonotonic,   foldrAsc,   foldlAsc,   foldrDesc,@@ -83,24 +94,51 @@  import Prelude hiding (null, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), filter, map) +#if !MIN_VERSION_base(4,20,0) import Data.Foldable (foldl')-import Data.Maybe (fromMaybe)--#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup((<>))) #endif- import qualified Data.List as List+import Data.Maybe (fromMaybe) -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  #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 :: 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++# if __GLASGOW_HASKELL__ >= 820+{-# COMPLETE Empty, (:<) #-}+# endif #endif  -- | \(O(1)\). Returns the minimum element. Throws an error on an empty queue.@@ -117,27 +155,18 @@ deleteFindMin :: Ord a => MinQueue a -> (a, MinQueue a) deleteFindMin = fromMaybe (error "Error: deleteFindMin called on empty queue") . minView --- | \(O(k \log n)\)/. Index (subscript) operator, starting from 0. @queue !! k@ returns the @(k+1)@th smallest+-- | \(O(k \log n)\). Index (subscript) operator, starting from 0. @queue !! k@ returns the @(k+1)@th smallest -- element in the queue. Equivalent to @toAscList queue !! k@. (!!) :: 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@@ -162,20 +191,20 @@ break p = span (not . p)  {-# INLINE take #-}--- | \(O(k \log n)\)/. 'take' @k@, applied to a queue @queue@, returns a list of the smallest @k@ elements of @queue@,+-- | \(O(k \log n)\). 'take' @k@, applied to a queue @queue@, returns a list of the smallest @k@ elements of @queue@, -- or all elements of @queue@ itself if @k >= 'size' queue@. take :: Ord a => Int -> MinQueue a -> [a] take n = List.take n . toAscList --- | \(O(k \log n)\)/. 'drop' @k@, applied to a queue @queue@, returns @queue@ with the smallest @k@ elements deleted,--- or an empty queue if @k >= size 'queue'@.+-- | \(O(k \log n)\). 'drop' @k@, applied to a queue @queue@, returns @queue@ with the smallest @k@ elements deleted,+-- or an empty queue if @k >= 'size' queue@. drop :: Ord a => Int -> MinQueue a -> MinQueue a drop n queue = n `seq` case minView queue of   Just (_, queue')     | n > 0  -> drop (n - 1) queue'   _          -> queue --- | \(O(k \log n)\)/. Equivalent to @('take' k queue, 'drop' k queue)@.+-- | \(O(k \log n)\). Equivalent to @('take' k queue, 'drop' k queue)@. splitAt :: Ord a => Int -> MinQueue a -> ([a], MinQueue a) splitAt n queue = n `seq` case minView queue of   Just (x, queue')@@ -196,6 +225,10 @@ map :: Ord b => (a -> b) -> MinQueue a -> MinQueue b map f = foldrU (insert . f) empty +{-# DEPRECATED mapU "use mapMonotonic instead" #-}+mapU :: (a -> b) -> MinQueue a -> MinQueue b+mapU = mapMonotonic+ {-# INLINE toList #-} -- | \(O(n \log n)\). Returns the elements of the priority queue in ascending order. Equivalent to 'toAscList'. --@@ -220,13 +253,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)

@@ -1,7 +1,9 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Data.PQueue.Prio.Internals (   MinPQueue(..),@@ -15,7 +17,7 @@   size,   singleton,   insert,-  insertBehind,+  insertEager,   union,   getMin,   adjustMinWithKey,@@ -46,26 +48,25 @@   mapMWithKey,   traverseWithKeyU,   seqSpine,-  mapForest,   unions   ) where -import Control.Applicative (liftA2, liftA3)+#if MIN_VERSION_base(4,18,0)+import Control.Applicative (Const (..))+#else+import Control.Applicative (liftA2, Const (..))+#endif 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)-#else-import Data.Monoid ((<>))-#endif+import Data.Semigroup (Semigroup(..), stimesMonoid, Endo (..), Dual (..))  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 +74,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,30 +82,43 @@ #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) instance Ord k => Semigroup (MinPQueue k a) where   (<>) = union   stimes = stimesMonoid   {-# INLINABLE stimes #-}-#endif  instance Ord k => Monoid (MinPQueue k a) where   mempty = empty@@ -114,21 +129,21 @@  instance (Ord k, Show k, Show a) => Show (MinPQueue k a) where   showsPrec p xs = showParen (p > 10) $-    showString "fromAscList " . shows (toAscList xs)+    showString "fromList " . shows (toAscList xs) -instance (Read k, Read a) => Read (MinPQueue k a) where+instance (Ord k, Read k, Read a) => Read (MinPQueue k a) where #ifdef __GLASGOW_HASKELL__   readPrec = parens $ prec 10 $ do-    Ident "fromAscList" <- lexP+    Ident "fromList" <- lexP     xs <- readPrec-    return (fromAscList xs)+    return (fromList xs)    readListPrec = readListPrecDefault #else   readsPrec p = readParen (p > 10) $ \r -> do-    ("fromAscList",s) <- lex r+    ("fromList",s) <- lex r     (xs,t) <- reads s-    return (fromAscList xs,t)+    return (fromList xs,t) #endif  -- | The union of a list of queues: (@'unions' == 'List.foldl' 'union' 'empty'@).@@ -139,16 +154,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 +166,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 +176,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 +192,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,20 +228,11 @@   | k <= k' = MinPQ (n + 1) k  a  (incrMin (tip k' a') ts)   | otherwise = MinPQ (n + 1) k' a' (incr (tip 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.-insertBehind :: Ord k => k -> a -> MinPQueue k a -> MinPQueue k a-insertBehind k v q =-  let (smaller, larger) = spanKey (<= k) q-  in  foldr (uncurry insert) (insert k v larger) smaller--spanKey :: Ord k => (k -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a)-spanKey p q = case minViewWithKey q of-  Just (t@(k, _), q') | p k ->-    let (kas, q'') = spanKey p q' in (t : kas, q'')-  _ -> ([], q)+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)  -- | Amortized \(O(\log \min(n_1,n_2))\), worst-case \(O(\log \max(n_1,n_2))\). Returns the union -- of the two specified queues.@@ -325,26 +291,81 @@  -- | \(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 == 'Data.PQueue.Prio.Min.mapKeys' f q@,+-- but only works when @f@ is (weakly) monotonic (meaning that @x <= y@ implies+-- @f x <= f y@). /The precondition is not checked./ This function has better+-- performance than 'Data.PQueue.Prio.Min.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 +374,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 +385,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 +441,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 +472,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 +524,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 +575,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 +597,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 +606,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 +689,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 +747,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 +765,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

@@ -32,7 +32,6 @@   empty,   singleton,   insert,-  insertBehind,   union,   unions,   -- * Query

@@ -3,6 +3,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -Wno-deprecations #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Data.PQueue.Prio.Max@@ -18,7 +20,6 @@   empty,   singleton,   insert,-  insertBehind,   union,   unions,   -- * Query@@ -105,15 +106,14 @@   )   where +import Data.Coerce import Data.Maybe (fromMaybe) import Data.PQueue.Internals.Down import Data.PQueue.Prio.Internals (MinPQueue) import qualified Data.PQueue.Prio.Internals as PrioInternals import Control.DeepSeq (NFData(rnf)) -#if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup(..), stimesMonoid)-#endif  import Prelude hiding (map, filter, break, span, takeWhile, dropWhile, splitAt, take, drop, (!!), null) import qualified Data.Foldable as F@@ -147,15 +147,10 @@ instance (NFData k, NFData a) => NFData (MaxPQueue k a) where   rnf (MaxPQ q) = rnf q -first' :: (a -> b) -> (a, c) -> (b, c)-first' f (a, c) = (f a, c)--#if MIN_VERSION_base(4,9,0) instance Ord k => Semigroup (MaxPQueue k a) where   (<>) = union   stimes = stimesMonoid   {-# INLINABLE stimes #-}-#endif  instance Ord k => Monoid (MaxPQueue k a) where   mempty = empty@@ -166,21 +161,21 @@  instance (Ord k, Show k, Show a) => Show (MaxPQueue k a) where   showsPrec p xs = showParen (p > 10) $-    showString "fromDescList " . shows (toDescList xs)+    showString "fromList " . shows (toDescList xs) -instance (Read k, Read a) => Read (MaxPQueue k a) where+instance (Ord k, Read k, Read a) => Read (MaxPQueue k a) where #ifdef __GLASGOW_HASKELL__   readPrec = parens $ prec 10 $ do-    Ident "fromDescList" <- lexP+    Ident "fromList" <- lexP     xs <- readPrec-    return (fromDescList xs)+    return (fromList xs)    readListPrec = readListPrecDefault #else   readsPrec p = readParen (p > 10) $ \r -> do-    ("fromDescList",s) <- lex r+    ("fromList",s) <- lex r     (xs,t) <- reads s-    return (fromDescList xs,t)+    return (fromList xs,t) #endif  instance Functor (MaxPQueue k) where@@ -215,28 +210,21 @@  -- | \(O(1)\). Constructs a singleton priority queue. singleton :: k -> a -> MaxPQueue k a-singleton k a = MaxPQ (Q.singleton (Down k) a)+singleton = coerce Q.singleton  -- | Amortized \(O(1)\), worst-case \(O(\log n)\). Inserts -- an element with the specified key into the queue. insert :: Ord k => k -> a -> MaxPQueue k a -> MaxPQueue k a-insert k a (MaxPQ q) = MaxPQ (Q.insert (Down k) a q)---- | \(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.-insertBehind :: Ord k => k -> a -> MaxPQueue k a -> MaxPQueue k a-insertBehind k a (MaxPQ q) = MaxPQ (Q.insertBehind (Down k) a q)+insert = coerce Q.insert  -- | Amortized \(O(\log \min(n_1,n_2))\), worst-case \(O(\log \max(n_1,n_2))\). Returns the union -- of the two specified queues. union :: Ord k => MaxPQueue k a -> MaxPQueue k a -> MaxPQueue k a-MaxPQ q1 `union` MaxPQ q2 = MaxPQ (q1 `Q.union` q2)+union = coerce Q.union  -- | The union of a list of queues: (@'unions' == 'List.foldl' 'union' 'empty'@). unions :: Ord k => [MaxPQueue k a] -> MaxPQueue k a-unions qs = MaxPQ (Q.unions [q | MaxPQ q <- qs])+unions = coerce Q.unions  -- | \(O(1)\). Checks if this priority queue is empty. null :: MaxPQueue k a -> Bool@@ -252,13 +240,11 @@  -- | \(O(1)\). The maximal (key, element) in the queue, if the queue is nonempty. getMax :: MaxPQueue k a -> Maybe (k, a)-getMax (MaxPQ q) = do-  (Down k, a) <- Q.getMin q-  return (k, a)+getMax = coerce Q.getMin  -- | \(O(\log n)\). Delete and find the element with the maximum key. Calls 'error' if empty. deleteMax :: Ord k => MaxPQueue k a -> MaxPQueue k a-deleteMax (MaxPQ q) = MaxPQ (Q.deleteMin q)+deleteMax = coerce Q.deleteMin  -- | \(O(\log n)\). Delete and find the element with the maximum key. Calls 'error' if empty. deleteFindMax :: Ord k => MaxPQueue k a -> ((k, a), MaxPQueue k a)@@ -277,14 +263,14 @@  -- | \(O(1)\). Alter the value at the maximum key. If the queue is empty, does nothing. adjustMaxWithKey :: (k -> a -> a) -> MaxPQueue k a -> MaxPQueue k a-adjustMaxWithKey f (MaxPQ q) = MaxPQ (Q.adjustMinWithKey (f . unDown) q)+adjustMaxWithKey = coerce Q.adjustMinWithKey  -- | \(O(1)\) per operation. Alter the value at the maximum key in an -- 'Applicative' context. If the queue is empty, does nothing. -- -- @since 1.4.2 adjustMaxWithKeyA :: Applicative f => (k -> a -> f a) -> MaxPQueue k a -> f (MaxPQueue k a)-adjustMaxWithKeyA f (MaxPQ q) = PrioInternals.adjustMinWithKeyA' MaxPQ (f . unDown) q+adjustMaxWithKeyA f (MaxPQ q) = PrioInternals.adjustMinWithKeyA' MaxPQ (coerce f) q  -- | \(O(\log n)\). (Actually \(O(1)\) if there's no deletion.) Update the value at the maximum key. -- If the queue is empty, does nothing.@@ -302,7 +288,7 @@ -- | \(O(\log n)\). (Actually \(O(1)\) if there's no deletion.) Update the value at the maximum key. -- If the queue is empty, does nothing. updateMaxWithKey :: Ord k => (k -> a -> Maybe a) -> MaxPQueue k a -> MaxPQueue k a-updateMaxWithKey f (MaxPQ q) = MaxPQ (Q.updateMinWithKey (f . unDown) q)+updateMaxWithKey = coerce Q.updateMinWithKey  -- | \(O(\log n)\) per operation. (Actually \(O(1)\) if there's no deletion.) Update -- the value at the maximum key in an 'Applicative' context. If the queue is@@ -310,7 +296,7 @@ -- -- @since 1.4.2 updateMaxWithKeyA :: (Applicative f, Ord k) => (k -> a -> f (Maybe a)) -> MaxPQueue k a -> f (MaxPQueue k a)-updateMaxWithKeyA f (MaxPQ q) = PrioInternals.updateMinWithKeyA' MaxPQ (f . unDown) q+updateMaxWithKeyA f (MaxPQ q) = PrioInternals.updateMinWithKeyA' MaxPQ (coerce f) q  -- | \(O(\log n)\). Retrieves the value associated with the maximum key of the queue, and the queue -- stripped of that element, or 'Nothing' if passed an empty queue.@@ -322,9 +308,7 @@ -- | \(O(\log n)\). Retrieves the maximal (key, value) pair of the map, and the map stripped of that -- element, or 'Nothing' if passed an empty map. maxViewWithKey :: Ord k => MaxPQueue k a -> Maybe ((k, a), MaxPQueue k a)-maxViewWithKey (MaxPQ q) = do-  ((Down k, a), q') <- Q.minViewWithKey q-  return ((k, a), MaxPQ q')+maxViewWithKey = coerce Q.minViewWithKey  -- | \(O(n)\). Map a function over all values in the queue. map :: (a -> b) -> MaxPQueue k a -> MaxPQueue k b@@ -332,31 +316,34 @@  -- | \(O(n)\). Map a function over all values in the queue. mapWithKey :: (k -> a -> b) -> MaxPQueue k a -> MaxPQueue k b-mapWithKey f (MaxPQ q) = MaxPQ (Q.mapWithKey (f . unDown) q)+mapWithKey = coerce Q.mapWithKey  -- | \(O(n)\). Map a function over all values in the queue. mapKeys :: Ord k' => (k -> k') -> MaxPQueue k a -> MaxPQueue k' a-mapKeys f (MaxPQ q) = MaxPQ (Q.mapKeys (fmap f) q)+mapKeys = coerce Q.mapKeys --- | \(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 (meaning that @x <= y@ implies @f x <= f y@).+-- /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') -> MaxPQueue k a -> MaxPQueue k' a-mapKeysMonotonic f (MaxPQ q) = MaxPQ (Q.mapKeysMonotonic (fmap f) q)+mapKeysMonotonic = coerce Q.mapKeysMonotonic  -- | \(O(n \log n)\). Fold the keys and values in the map, such that -- @'foldrWithKey' f z q == 'List.foldr' ('uncurry' f) z ('toDescList' q)@. -- -- If you do not care about the traversal order, consider using 'foldrWithKeyU'. foldrWithKey :: Ord k => (k -> a -> b -> b) -> b -> MaxPQueue k a -> b-foldrWithKey f z (MaxPQ q) = Q.foldrWithKey (f . unDown) z q+foldrWithKey f z (MaxPQ q) = Q.foldrWithKey (coerce f) z q  -- | \(O(n \log n)\). Fold the keys and values in the map, such that -- @'foldlWithKey' f z q == 'List.foldl' ('uncurry' . f) z ('toDescList' q)@. -- -- If you do not care about the traversal order, consider using 'foldlWithKeyU'. foldlWithKey :: Ord k => (b -> k -> a -> b) -> b -> MaxPQueue k a -> b-foldlWithKey f z0 (MaxPQ q) = Q.foldlWithKey (\z -> f z . unDown) z0 q+foldlWithKey f z0 (MaxPQ q) = Q.foldlWithKey (coerce f) z0 q  -- | \(O(n \log n)\). Traverses the elements of the queue in descending order by key. -- (@'traverseWithKey' f q == 'fromDescList' <$> 'traverse' ('uncurry' f) ('toDescList' q)@)@@ -365,38 +352,26 @@ -- -- If you are working in a strict monad, consider using 'mapMWithKey'. traverseWithKey :: (Ord k, Applicative f) => (k -> a -> f b) -> MaxPQueue k a -> f (MaxPQueue k b)-traverseWithKey f (MaxPQ q) = MaxPQ <$> Q.traverseWithKey (f . unDown) q+traverseWithKey f (MaxPQ q) = MaxPQ <$> Q.traverseWithKey (coerce f) q  -- | A strictly accumulating version of 'traverseWithKey'. This works well in -- 'IO' and strict @State@, and is likely what you want for other "strict" monads, -- where @⊥ >>= pure () = ⊥@. mapMWithKey :: (Ord k, Monad m) => (k -> a -> m b) -> MaxPQueue k a -> m (MaxPQueue k b)-mapMWithKey f = go empty-  where-    go !acc q =-      case maxViewWithKey q of-        Nothing           -> pure acc-        Just ((k, a), q') -> do-          b <- f k a-          let !acc' = insertMin' k b acc-          go acc' q'--insertMin' :: k -> a -> MaxPQueue k a -> MaxPQueue k a-insertMin' k a (MaxPQ q) = MaxPQ (PrioInternals.insertMax' (Down k) a q)+mapMWithKey f (MaxPQ q) = MaxPQ <$> Q.mapMWithKey (coerce f) q --- | \(O(k \log n)\)/. Takes the first @k@ (key, value) pairs in the queue, or the first @n@ if @k >= n@.+-- | \(O(k \log n)\). Takes the first @k@ (key, value) pairs in the queue, or the first @n@ if @k >= n@. -- (@'take' k q == 'List.take' k ('toDescList' q)@) take :: Ord k => Int -> MaxPQueue k a -> [(k, a)]-take k (MaxPQ q) = fmap (first' unDown) (Q.take k q)+take = coerce Q.take --- | \(O(k \log n)\)/. Deletes the first @k@ (key, value) pairs in the queue, or returns an empty queue if @k >= n@.+-- | \(O(k \log n)\). Deletes the first @k@ (key, value) pairs in the queue, or returns an empty queue if @k >= n@. drop :: Ord k => Int -> MaxPQueue k a -> MaxPQueue k a-drop k (MaxPQ q) = MaxPQ (Q.drop k q)+drop = coerce Q.drop --- | \(O(k \log n)\)/. Equivalent to @('take' k q, 'drop' k q)@.+-- | \(O(k \log n)\). Equivalent to @('take' k q, 'drop' k q)@. splitAt :: Ord k => Int -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a)-splitAt k (MaxPQ q) = case Q.splitAt k q of-  (xs, q') -> (fmap (first' unDown) xs, MaxPQ q')+splitAt = coerce Q.splitAt  -- | Takes the longest possible prefix of elements satisfying the predicate. -- (@'takeWhile' p q == 'List.takeWhile' (p . 'snd') ('toDescList' q)@)@@ -406,7 +381,7 @@ -- | Takes the longest possible prefix of elements satisfying the predicate. -- (@'takeWhile' p q == 'List.takeWhile' (uncurry p) ('toDescList' q)@) takeWhileWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> [(k, a)]-takeWhileWithKey p (MaxPQ q) = fmap (first' unDown) (Q.takeWhileWithKey (p . unDown) q)+takeWhileWithKey = coerce Q.takeWhileWithKey  -- | Removes the longest possible prefix of elements satisfying the predicate. dropWhile :: Ord k => (a -> Bool) -> MaxPQueue k a -> MaxPQueue k a@@ -414,7 +389,7 @@  -- | Removes the longest possible prefix of elements satisfying the predicate. dropWhileWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> MaxPQueue k a-dropWhileWithKey p (MaxPQ q) = MaxPQ (Q.dropWhileWithKey (p . unDown) q)+dropWhileWithKey = coerce Q.dropWhileWithKey  -- | Equivalent to @('takeWhile' p q, 'dropWhile' p q)@. span :: Ord k => (a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a)@@ -426,13 +401,11 @@  -- | Equivalent to @'spanWithKey' (\k a -> 'not' (p k a)) q@. spanWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a)-spanWithKey p (MaxPQ q) = case Q.spanWithKey (p . unDown) q of-  (xs, q') -> (fmap (first' unDown) xs, MaxPQ q')+spanWithKey = coerce Q.spanWithKey  -- | Equivalent to @'spanWithKey' (\k a -> 'not' (p k a)) q@. breakWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a)-breakWithKey p (MaxPQ q) = case Q.breakWithKey (p . unDown) q of-  (xs, q') -> (fmap (first' unDown) xs, MaxPQ q')+breakWithKey = coerce Q.breakWithKey  -- | \(O(n)\). Filter all values that satisfy the predicate. filter :: Ord k => (a -> Bool) -> MaxPQueue k a -> MaxPQueue k a@@ -440,7 +413,7 @@  -- | \(O(n)\). Filter all values that satisfy the predicate. filterWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> MaxPQueue k a-filterWithKey p (MaxPQ q) = MaxPQ (Q.filterWithKey (p . unDown) q)+filterWithKey = coerce Q.filterWithKey  -- | \(O(n)\). Partition the queue according to a predicate. The first queue contains all elements -- which satisfy the predicate, the second all elements that fail the predicate.@@ -450,8 +423,7 @@ -- | \(O(n)\). Partition the queue according to a predicate. The first queue contains all elements -- which satisfy the predicate, the second all elements that fail the predicate. partitionWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> (MaxPQueue k a, MaxPQueue k a)-partitionWithKey p (MaxPQ q) = case Q.partitionWithKey (p . unDown) q of-  (q1, q0) -> (MaxPQ q1, MaxPQ q0)+partitionWithKey = coerce Q.partitionWithKey  -- | \(O(n)\). Map values and collect the 'Just' results. mapMaybe :: Ord k => (a -> Maybe b) -> MaxPQueue k a -> MaxPQueue k b@@ -459,7 +431,7 @@  -- | \(O(n)\). Map values and collect the 'Just' results. mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> MaxPQueue k a -> MaxPQueue k b-mapMaybeWithKey f (MaxPQ q) = MaxPQ (Q.mapMaybeWithKey (f . unDown) q)+mapMaybeWithKey = coerce Q.mapMaybeWithKey  -- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. mapEither :: Ord k => (a -> Either b c) -> MaxPQueue k a -> (MaxPQueue k b, MaxPQueue k c)@@ -467,20 +439,19 @@  -- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. mapEitherWithKey :: Ord k => (k -> a -> Either b c) -> MaxPQueue k a -> (MaxPQueue k b, MaxPQueue k c)-mapEitherWithKey f (MaxPQ q) = case Q.mapEitherWithKey (f . unDown) q of-  (qL, qR) -> (MaxPQ qL, MaxPQ qR)+mapEitherWithKey = coerce Q.mapEitherWithKey  -- | \(O(n)\). Build a priority queue from the list of (key, value) pairs. fromList :: Ord k => [(k, a)] -> MaxPQueue k a-fromList = MaxPQ . Q.fromList . fmap (first' Down)+fromList = coerce Q.fromList  -- | \(O(n)\). Build a priority queue from an ascending list of (key, value) pairs. /The precondition is not checked./ fromAscList :: [(k, a)] -> MaxPQueue k a-fromAscList = MaxPQ . Q.fromDescList . fmap (first' Down)+fromAscList = coerce Q.fromDescList  -- | \(O(n)\). Build a priority queue from a descending list of (key, value) pairs. /The precondition is not checked./ fromDescList :: [(k, a)] -> MaxPQueue k a-fromDescList = MaxPQ . Q.fromAscList . fmap (first' Down)+fromDescList = coerce Q.fromAscList  -- | \(O(n \log n)\). Return all keys of the queue in descending order. keys :: Ord k => MaxPQueue k a -> [k]@@ -496,11 +467,11 @@  -- | \(O(n \log n)\). Return all (key, value) pairs in ascending order by key. toAscList :: Ord k => MaxPQueue k a -> [(k, a)]-toAscList (MaxPQ q) = fmap (first' unDown) (Q.toDescList q)+toAscList = coerce Q.toDescList  -- | \(O(n \log n)\). Return all (key, value) pairs in descending order by key. toDescList :: Ord k => MaxPQueue k a -> [(k, a)]-toDescList (MaxPQ q) = fmap (first' unDown) (Q.toAscList q)+toDescList = coerce Q.toAscList  -- | \(O(n \log n)\). Equivalent to 'toDescList'. --@@ -514,13 +485,13 @@  -- | \(O(n)\). An unordered right fold over the elements of the queue, in no particular order. foldrWithKeyU :: (k -> a -> b -> b) -> b -> MaxPQueue k a -> b-foldrWithKeyU f z (MaxPQ q) = Q.foldrWithKeyU (f . unDown) z q+foldrWithKeyU f z (MaxPQ q) = Q.foldrWithKeyU (coerce f) z q  -- | \(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) -> MaxPQueue k a -> m-foldMapWithKeyU f (MaxPQ q) = Q.foldMapWithKeyU (f . unDown) q+foldMapWithKeyU f (MaxPQ q) = Q.foldMapWithKeyU (coerce f) q  -- | \(O(n)\). An unordered left fold over the elements of the queue, in no -- particular order. This is rarely what you want; 'foldrU' and 'foldlU'' are@@ -539,13 +510,13 @@ -- particular order. This is rarely what you want; 'foldrWithKeyU' and -- 'foldlWithKeyU'' are more likely to perform well. foldlWithKeyU :: (b -> k -> a -> b) -> b -> MaxPQueue k a -> b-foldlWithKeyU f z0 (MaxPQ q) = Q.foldlWithKeyU (\z -> f z . unDown) z0 q+foldlWithKeyU f z0 (MaxPQ q) = Q.foldlWithKeyU (coerce f) z0 q  -- | \(O(n)\). An unordered left fold over the elements of the queue, in no particular order. -- -- @since 1.4.2 foldlWithKeyU' :: (b -> k -> a -> b) -> b -> MaxPQueue k a -> b-foldlWithKeyU' f z0 (MaxPQ q) = Q.foldlWithKeyU' (\z -> f z . unDown) z0 q+foldlWithKeyU' f z0 (MaxPQ q) = Q.foldlWithKeyU' (coerce f) z0 q  -- | \(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@@ -557,7 +528,7 @@ -- 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) -> MaxPQueue k a -> f (MaxPQueue k b)-traverseWithKeyU f (MaxPQ q) = MaxPQ <$> Q.traverseWithKeyU (f . unDown) q+traverseWithKeyU f (MaxPQ q) = MaxPQ <$> Q.traverseWithKeyU (coerce f) q  -- | \(O(n)\). Return all keys of the queue in no particular order. keysU :: MaxPQueue k a -> [k]@@ -573,14 +544,14 @@  -- | \(O(n)\). Returns all (key, value) pairs in the queue in no particular order. toListU :: MaxPQueue k a -> [(k, a)]-toListU (MaxPQ q) = fmap (first' unDown) (Q.toListU q)+toListU = coerce Q.toListU  -- | \(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

@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}  ----------------------------------------------------------------------------- -- |@@ -29,12 +31,17 @@ -- 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,   insert,-  insertBehind,   union,   unions,   -- * Query@@ -124,19 +131,45 @@ import qualified Data.List as List import Data.Maybe (fromMaybe) -#if MIN_VERSION_base(4,9,0)-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++# if __GLASGOW_HASKELL__ >= 820+{-# COMPLETE Empty, (:<) #-}+# endif #endif  (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d@@ -239,12 +272,12 @@ partitionWithKey p = mapEitherWithKey (\k a -> if p k a then Left a else Right a)  {-# INLINE take #-}--- | \(O(k \log n)\)/. Takes the first @k@ (key, value) pairs in the queue, or the first @n@ if @k >= n@.+-- | \(O(k \log n)\). Takes the first @k@ (key, value) pairs in the queue, or the first @n@ if @k >= n@. -- (@'take' k q == 'List.take' k ('toAscList' q)@) take :: Ord k => Int -> MinPQueue k a -> [(k, a)] take n = List.take n . toAscList --- | \(O(k \log n)\)/. Deletes the first @k@ (key, value) pairs in the queue, or returns an empty queue if @k >= n@.+-- | \(O(k \log n)\). Deletes the first @k@ (key, value) pairs in the queue, or returns an empty queue if @k >= n@. drop :: Ord k => Int -> MinPQueue k a -> MinPQueue k a drop n0 q0   | n0 <= 0  = q0@@ -255,7 +288,7 @@       | n == 0    = q       | otherwise = drop' (n - 1) (deleteMin q) --- | \(O(k \log n)\)/. Equivalent to @('take' k q, 'drop' k q)@.+-- | \(O(k \log n)\). Equivalent to @('take' k q, 'drop' k q)@. splitAt :: Ord k => Int -> MinPQueue k a -> ([(k, a)], MinPQueue k a) splitAt n q   | n <= 0     = ([], q)@@ -273,8 +306,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

@@ -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+#if __GLASGOW_HASKELL__ >= 904+import Unsafe.Coerce (unsafeCoerce)+#endif+import Data.Kind (Type)++-- | 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 -> Type 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

@@ -1,13 +1,21 @@+{-# language CPP #-}++{-# language BangPatterns #-} {-# language ExtendedDefaultRules #-} {-# language ScopedTypeVariables #-} {-# language TupleSections #-}+{-# language ViewPatterns #-} +{-# options_ghc -Wno-x-partial #-}+ 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 +25,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,12 +48,42 @@       [ 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 "mapMonotonic" $ \xs ->+        let+          -- Monotonic, but not strictly so+          fun x+            | even x = x+            | otherwise = x + 1+          res = Min.mapMonotonic fun (Min.fromList xs)+        in validMinQueue res .&&. Min.toList res === List.map fun (List.sort 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))     , testProperty "splitAt" $ \n xs -> Min.splitAt n (Min.fromList xs) === second Min.fromList (List.splitAt n (List.sort xs))@@ -48,7 +98,6 @@     , 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 "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@@ -68,6 +117,7 @@     , testProperty "filter" $ \xs -> Max.filter even (Max.fromList xs) === Max.fromList (List.filter even xs)     , testProperty "partition" $ \xs -> Max.partition even (Max.fromList xs) === bimap Max.fromList Max.fromList (List.partition even xs)     , testProperty "map" $ \xs -> Max.map negate (Max.fromList xs) === Max.fromList (List.map negate xs)+    , testProperty "mapMonotonic" $ \xs -> Max.mapMonotonic (+ 1) (Max.fromList xs) === Max.fromList (List.map (+ 1) xs)     , testProperty "take" $ \n xs -> Max.take n (Max.fromList xs) === List.take n (List.sortOn Down xs)     , testProperty "drop" $ \n xs -> Max.drop n (Max.fromList xs) === Max.fromList (List.drop n (List.sortOn Down xs))     , testProperty "splitAt" $ \n xs -> Max.splitAt n (Max.fromList xs) === second Max.fromList (List.splitAt n (List.sortOn Down xs))@@ -82,7 +132,6 @@     , testProperty "toDescList" $ \xs -> Max.toDescList (Max.fromList xs) === List.sortOn Down xs     , testProperty "fromAscList" $ \xs -> Max.fromAscList (List.sort xs) === Max.fromList xs     , testProperty "fromDescList" $ \xs -> Max.fromDescList (List.sortOn Down xs) === Max.fromList xs-    , testProperty "mapU" $ \xs -> Max.mapU (+ 1) (Max.fromList xs) === Max.fromList (List.map (+ 1) xs)     , testProperty "foldrU" $ \xs -> Max.foldrU (+) 0 (Max.fromList xs) === sum xs     , testProperty "foldlU" $ \xs -> Max.foldlU (+) 0 (Max.fromList xs) === sum xs     , testProperty "foldlU'" $ \xs -> Max.foldlU' (+) 0 (Max.fromList xs) === sum xs@@ -106,9 +155,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 +183,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 +243,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))

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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