From 98af9b2bf8ea2205c168044f7a235bfa56bf5159 Mon Sep 17 00:00:00 2001
From: konsumlamm <konsumlamm@gmail.com>
Date: Fri, 28 Feb 2025 15:29:04 +0100
Subject: [PATCH] Optimize `mapMonotonic` by using an `Fmap` class instead of
 `Functor`

---
 pqueue.cabal                                  |  4 ++--
 src/BinomialQueue/Internals.hs                | 24 +++++++++----------
 .../Internals/{Foldable.hs => Classes.hs}     | 18 ++++++++------
 3 files changed, 25 insertions(+), 21 deletions(-)
 rename src/Data/PQueue/Internals/{Foldable.hs => Classes.hs} (54%)

diff --git a/pqueue.cabal b/pqueue.cabal
index 3a63787..1515997 100644
--- a/pqueue.cabal
+++ b/pqueue.cabal
@@ -58,8 +58,8 @@ library
     BinomialQueue.Internals
     BinomialQueue.Min
     BinomialQueue.Max
+    Data.PQueue.Internals.Classes
     Data.PQueue.Internals.Down
-    Data.PQueue.Internals.Foldable
     Data.PQueue.Prio.Max.Internals
     Nattish
   if impl(ghc) {
@@ -98,8 +98,8 @@ test-suite test
     BinomialQueue.Internals
     BinomialQueue.Min
     BinomialQueue.Max
+    Data.PQueue.Internals.Classes
     Data.PQueue.Internals.Down
-    Data.PQueue.Internals.Foldable
     Data.PQueue.Prio.Max.Internals
     Nattish
 
diff --git a/src/BinomialQueue/Internals.hs b/src/BinomialQueue/Internals.hs
index 0168c70..27da76c 100644
--- a/src/BinomialQueue/Internals.hs
+++ b/src/BinomialQueue/Internals.hs
@@ -54,7 +54,7 @@ import Data.Function (on)
 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,
@@ -252,7 +252,7 @@ mapEither f = fromPartition .
 -- 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 f (MinQueue ts) = MinQueue (f <$> ts)
+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
@@ -544,19 +544,19 @@ joinBin t1@(BinomTree x1 ts1) t2@(BinomTree x2 ts2)
   | 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
diff --git a/src/Data/PQueue/Internals/Foldable.hs b/src/Data/PQueue/Internals/Classes.hs
similarity index 54%
rename from src/Data/PQueue/Internals/Foldable.hs
rename to src/Data/PQueue/Internals/Classes.hs
index 8060e88..09fab38 100644
--- a/src/Data/PQueue/Internals/Foldable.hs
+++ b/src/Data/PQueue/Internals/Classes.hs
@@ -1,12 +1,13 @@
--- | Writing 'Foldable' instances for non-regular (AKA, nested) types in the
--- natural manner leads to full `Foldable` dictionaries being constructed on
+-- | 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.Foldable
-  ( Foldr (..)
-  , Foldl (..)
-  , FoldMap (..)
-  , Foldl' (..)
+module Data.PQueue.Internals.Classes
+  ( Foldr(..)
+  , Foldl(..)
+  , FoldMap(..)
+  , Foldl'(..)
+  , Fmap(..)
   ) where
 
 class Foldr t where
@@ -20,3 +21,6 @@ class FoldMap t where
 
 class Foldl' t where
   foldl'_ :: (b -> a -> b) -> b -> t a -> b
+
+class Fmap f where
+  fmap_ :: (a -> b) -> f a -> f b