From 7a112d351f4d57e70eee50d507f22316f511a158 Mon Sep 17 00:00:00 2001
From: Jack Kelly <jack@jackkelly.name>
Date: Sun, 29 Sep 2024 18:01:24 +1000
Subject: [PATCH 1/2] Implement `foldlWithKey'`

---
 ChangeLog.md              | 3 ++-
 dependent-map.cabal       | 2 +-
 src/Data/Dependent/Map.hs | 6 ++----
 3 files changed, 5 insertions(+), 6 deletions(-)

diff --git a/ChangeLog.md b/ChangeLog.md
index 85e463c..0fd872f 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,7 +1,8 @@
 # Revision history for dependent-map
 
-## Unreleased (0.4.0.1)
+## Unreleased (0.4.1.0)
 
+* Provide `foldlWithKey'`.
 * Minimum `base` version is now `4.11` (GHC 8.4.x).
 * Use canonical `mappend`/`(<>)` definitions.
 
diff --git a/dependent-map.cabal b/dependent-map.cabal
index bfe3e45..31be330 100644
--- a/dependent-map.cabal
+++ b/dependent-map.cabal
@@ -1,5 +1,5 @@
 name:                   dependent-map
-version:                0.4.0.1
+version:                0.4.1.0
 stability:              provisional
 
 cabal-version:          >= 1.8
diff --git a/src/Data/Dependent/Map.hs b/src/Data/Dependent/Map.hs
index a9c4f15..c5e032f 100644
--- a/src/Data/Dependent/Map.hs
+++ b/src/Data/Dependent/Map.hs
@@ -82,7 +82,7 @@ module Data.Dependent.Map
     , foldWithKey
     , foldrWithKey
     , foldlWithKey
-    -- , foldlWithKey'
+    , foldlWithKey'
 
     -- * Conversion
     , keys
@@ -964,14 +964,12 @@ foldlWithKey f = go
     go z Tip              = z
     go z (Bin _ kx x l r) = go (f (go z l) kx x) r
 
-{-
 -- | /O(n)/. A strict version of 'foldlWithKey'.
-foldlWithKey' :: (b -> k -> a -> b) -> b -> DMap k -> b
+foldlWithKey' :: (forall v. b -> k v -> f v -> b) -> b -> DMap k f -> b
 foldlWithKey' f = go
   where
     go z Tip              = z
     go z (Bin _ kx x l r) = z `seq` go (f (go z l) kx x) r
--}
 
 {--------------------------------------------------------------------
   List variations

From 83efd65dfb78256c97a3a76dd4c66a891eee9fbc Mon Sep 17 00:00:00 2001
From: Jack Kelly <jack@jackkelly.name>
Date: Sun, 29 Sep 2024 18:01:35 +1000
Subject: [PATCH 2/2] Implement instances for `monoid-subclasses`

The implementations of these instances are inspired by the ones from
`Data.Map.Lazy`.
---
 ChangeLog.md              |  9 +++++++
 dependent-map.cabal       |  3 ++-
 src/Data/Dependent/Map.hs | 54 +++++++++++++++++++++++++++++++++++++++
 3 files changed, 65 insertions(+), 1 deletion(-)

diff --git a/ChangeLog.md b/ChangeLog.md
index 0fd872f..9b4bf2b 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -2,6 +2,15 @@
 
 ## Unreleased (0.4.1.0)
 
+* Now depends on `monoid-subclasses`.
+* New instances `monoid-subclasses`:
+  - `instance GCompare k => Factorial (DMap k f)`
+  - `instance GCompare k => FactorialMonoid (DMap k f)`
+  - `instance GCompare k => OverlappingGCDMonoid (DMap k f)`
+  - `instance GCompare k => PositiveMonoid (DMap k f)`
+  - `instance GCompare k => MonoidNull (DMap k f)`
+  - `instance (GCompare k, Has' Eq k f) => LeftReductive (DMap k f)`
+  - `instance (GCompare k, Has' Eq k f) => RightReductive (DMap k f)`
 * Provide `foldlWithKey'`.
 * Minimum `base` version is now `4.11` (GHC 8.4.x).
 * Use canonical `mappend`/`(<>)` definitions.
diff --git a/dependent-map.cabal b/dependent-map.cabal
index 31be330..4689ef7 100644
--- a/dependent-map.cabal
+++ b/dependent-map.cabal
@@ -45,4 +45,5 @@ Library
   build-depends:        base >= 4.11 && < 5,
                         containers >= 0.5.7.1 && <0.8,
                         dependent-sum >= 0.6.1 && < 0.8,
-                        constraints-extras >= 0.2.3.0 && < 0.5
+                        constraints-extras >= 0.2.3.0 && < 0.5,
+                        monoid-subclasses >= 1.0 && < 1.3
diff --git a/src/Data/Dependent/Map.hs b/src/Data/Dependent/Map.hs
index c5e032f..f9446d2 100644
--- a/src/Data/Dependent/Map.hs
+++ b/src/Data/Dependent/Map.hs
@@ -149,7 +149,12 @@ import Data.Constraint.Extras (Has', has')
 import Data.Dependent.Sum (DSum((:=>)))
 import Data.GADT.Compare (GCompare, GEq, GOrdering(..), gcompare, geq)
 import Data.GADT.Show (GRead, GShow)
+import qualified Data.List as List
 import Data.Maybe (isJust)
+import qualified Data.Monoid.Factorial as Factorial
+import qualified Data.Monoid.Null as Null
+import qualified Data.Monoid.Monus as Monus
+import qualified Data.Semigroup.Cancellative as Cancellative
 import Data.Some (Some, mkSome)
 import Data.Typeable ((:~:)(Refl))
 import Text.Read (Lexeme(Ident), lexP, parens, prec, readListPrec,
@@ -158,6 +163,55 @@ import Text.Read (Lexeme(Ident), lexP, parens, prec, readListPrec,
 import Data.Dependent.Map.Internal
 import Data.Dependent.Map.PtrEquality (ptrEq)
 
+instance GCompare k => Factorial.Factorial (DMap k f) where
+   factors = List.map (\(k :=> fv) -> singleton k fv) . toAscList
+   primePrefix map = case lookupMin map of
+     Nothing -> map
+     Just (k :=> fv) -> singleton k fv
+   primeSuffix map = case lookupMax map of
+     Nothing -> map
+     Just (k :=> fv) -> singleton k fv
+   foldl f a m = foldlWithKey (\x k fv -> f x (singleton k fv)) a m
+   foldl' f a m = foldlWithKey' (\x k fv -> f x (singleton k fv)) a m
+   foldr f a m = foldrWithKey (\k fv x -> f (singleton k fv) a) a m
+   length = size
+   reverse = id
+
+instance GCompare k => Factorial.FactorialMonoid (DMap k f) where
+  splitPrimePrefix = fmap singularize . minViewWithKey
+    where singularize (k :=> fv, rest) = (singleton k fv, rest)
+  splitPrimeSuffix = fmap singularize . maxViewWithKey
+    where singularize (k :=> fv, rest) = (singleton k fv, rest)
+
+instance (GCompare k, Has' Eq k f) => Monus.OverlappingGCDMonoid (DMap k f) where
+  overlap = flip intersection
+  stripOverlap a b =
+    (Monus.stripSuffixOverlap a b, Monus.overlap a b, Monus.stripPrefixOverlap a b)
+  stripPrefixOverlap = flip difference
+  stripSuffixOverlap = differenceWithKey
+    (\k x y -> has' @Eq @f k $ if x == y then Nothing else Just x)
+
+instance GCompare k => Null.PositiveMonoid (DMap k f)
+
+instance GCompare k => Null.MonoidNull (DMap k f) where
+  null = null
+
+instance (GCompare k, Has' Eq k f) => Cancellative.LeftReductive (DMap k f) where
+  isPrefixOf = isSubmapOf
+  stripPrefix a b
+    | a `isSubmapOf` b = Just (b \\ a)
+    | otherwise = Nothing
+
+instance (GCompare k, Has' Eq k f) => Cancellative.RightReductive (DMap k f) where
+  isSuffixOf = isSubmapOfBy $ const $ const $ const $ const True
+  stripSuffix a b
+    | a `Cancellative.isSuffixOf` b = Just $
+      differenceWithKey
+        (\k x y -> has' @Eq @f k $ if x == y then Nothing else Just x)
+        b
+        a
+    | otherwise = Nothing
+
 instance (GCompare k) => Monoid (DMap k f) where
     mempty  = empty
     mconcat = unions