monoid-extras 0.6.5 → 0.7

raw patch · 5 files changed

+147/−185 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES +12/−0
• monoid-extras.cabal +3/−3
• src/Data/Monoid/Coproduct.hs +47/−14
• src/Data/Monoid/Coproduct/Strict.hs +0/−168
• src/Data/Semigroup/Coproduct.hs +85/−0

@@ -1,3 +1,15 @@+* 0.7: 12 May 2025++  - Updates to `Data.Monoid.Coproduct`:+    - Fix `Eq` instance for monoid coproducts to take `mempty` into account+    - `cop` implements coproduct universal map+    - `untangleSemi`, like `untangle` but as a monoid homomorphism to semidirect product+    - `toReducedAltList`, like `toAltList` but also gets rid of `mempty`+  - New module `Data.Semigroup.Coproduct` with semigroup coproducts+  - Remove `Data.Monoid.Coproduct.Strict`++  Thanks to Sonat Süer (@sonatsuer) for the updates!+ * 0.6.5: 22 February 2025  - New instance `Eq (m :+: n)` ([#59](https://github.com/diagrams/monoid-extras/issues/59))

@@ -1,5 +1,5 @@ name:                monoid-extras-version:             0.6.5+version:             0.7 synopsis:            Various extra monoid-related definitions and utilities description:         Various extra monoid-related definitions and utilities,                      such as monoid actions, monoid coproducts, semi-direct@@ -26,7 +26,6 @@                      Data.Monoid.SemiDirectProduct,                      Data.Monoid.SemiDirectProduct.Strict                      Data.Monoid.Coproduct,-                     Data.Monoid.Coproduct.Strict,                      Data.Monoid.Cut,                      Data.Monoid.Deletable,                      Data.Monoid.Endomorphism,@@ -34,7 +33,8 @@                      Data.Monoid.MList,                      Data.Monoid.Recommend,                      Data.Monoid.Split,-                     Data.Monoid.WithSemigroup+                     Data.Monoid.WithSemigroup,+                     Data.Semigroup.Coproduct    build-depends:     base >= 4.11 && < 4.22,                      groups < 0.6,

@@ -19,29 +19,32 @@        ( (:+:)        , inL, inR        , mappendL, mappendR+       , cop        , killL, killR        , toAltList+       , toReducedAltList        , untangle-+       , untangleSemi        ) where -import Data.Either        (lefts, rights) import Data.Function      (on) import Data.Semigroup import Data.Typeable  import Data.Monoid.Action+import Data.Monoid.SemiDirectProduct ( embed, inject, Semi, unSemi )+import Data.Tuple (swap)  -- | @m :+: n@ is the coproduct of monoids @m@ and @n@.  Values of --   type @m :+: n@ consist of alternating lists of @m@ and @n@---   values.  The empty list is the identity, and composition is list+--   values. The empty list is the identity, and composition is list --   concatenation, with appropriate combining of adjacent elements---   when possible.+--   and removing identities when possible. newtype m :+: n = MCo { unMCo :: [Either m n] }   deriving (Typeable, Show) -instance (Eq m, Eq n, Semigroup m, Semigroup n) => Eq (m :+: n) where-  (==) = (==) `on` (normalize . unMCo)+instance (Eq m, Eq n, Monoid m, Monoid n) => Eq (m :+: n) where+  (==) = (==) `on` (normalizeEq . unMCo)  -- | Extract a monoid coproduct to a list of @Either@ values.  The --   resulting list is guaranteed to be normalized, in the sense that@@ -49,6 +52,13 @@ toAltList :: (Semigroup m, Semigroup n) => (m :+: n) -> [Either m n] toAltList (MCo ms) = normalize ms +-- | Extract a monoid coproduct to a list of @Either@ values.  The+--   resulting list is guaranteed to be normalized, in the sense that+--   it will strictly alternate between @Left@ and @Right@ and no identity+--   element from @m@ or @n@ will occur in the list.+toReducedAltList :: (Eq m, Eq n, Monoid m, Monoid n) => (m :+: n) -> [Either m n]+toReducedAltList (MCo ms) = normalizeEq ms+ -- Normalize a list of @Either@ values by combining any consecutive -- values of the same type. normalize :: (Semigroup m, Semigroup n) => [Either m n] -> [Either m n]@@ -58,11 +68,30 @@   []  -> []   (e:es) -> e : normalize es ++-- Similar to @normalize@. In addition to combining consecutive values of the same+-- type it also removes the identities.+normalizeEq :: (Eq m, Eq n, Monoid m, Monoid n) => [Either m n] -> [Either m n]+normalizeEq es = until (all nonIdentity) reduce (normalize es)+  where+    reduce = normalize . filter nonIdentity+    nonIdentity e = e /= Left mempty && e /= Right mempty+ -- For efficiency and simplicity, we implement it just as [Either m -- n]: of course, this does not preserve the invariant of strictly -- alternating types, but it doesn't really matter as long as we don't -- let anyone inspect the internal representation. +-- | Universal map of the coproduct. The name @cop@ is an abbreviation+--   for copairing. Both functions in the signature should be monoid+--   homomorphisms. If they are general functions then the copairing may+--   not be well defined in the sense that it may send equal elements to+--   unequal elements. This is also the reason why @cop@ is not the+--   @Data.Bifoldable.bifoldMap@ function even though they have the same+--   signature.+cop :: Monoid k => (m -> k) -> (n -> k) -> (m :+: n) -> k+f `cop` g = foldMap (either f g) . unMCo+ -- | Injection from the left monoid into a coproduct. inL :: m -> m :+: n inL m = MCo [Left m]@@ -90,14 +119,21 @@ -- | @killR@ takes a value in a coproduct monoid and sends all the --   values from the right monoid to the identity. killR :: Monoid m => m :+: n -> m-killR = mconcat . lefts . unMCo+killR = id `cop` const mempty  -- | @killL@ takes a value in a coproduct monoid and sends all the --   values from the left monoid to the identity. killL :: Monoid n => m :+: n -> n-killL = mconcat . rights . unMCo+killL = const mempty `cop` id --- | Take a value from a coproduct monoid where the left monoid has an+-- | The copairing of @embed@ and @inject@ homomorphisms into the+--   semidirect product. Note that @embed@ and @inject@ are monoid+--   homomorphisms. Therefore @untangleSemi@ is also a monoid homomorphism.+untangleSemi :: (Action m n, Monoid m, Monoid n) => m :+: n -> Semi n m+untangleSemi = embed `cop` inject++-- | Same as @untangleSemi@ but the result is uwrapped. Concretely, given+--   a value from a coproduct monoid where the left monoid has an --   action on the right, and \"untangle\" it into a pair of values.  In --   particular, --@@ -110,12 +146,9 @@ --   That is, before combining @n@ values, every @n@ value is acted on --   by all the @m@ values to its left. untangle :: (Action m n, Monoid m, Monoid n) => m :+: n -> (m,n)-untangle (MCo elts) = untangle' mempty elts-  where untangle' cur [] = cur-        untangle' (curM, curN) (Left m : elts')  = untangle' (curM `mappend` m, curN) elts'-        untangle' (curM, curN) (Right n : elts') = untangle' (curM, curN `mappend` act curM n) elts'+untangle = swap . unSemi . untangleSemi  -- | Coproducts act on other things by having each of the components --   act individually. instance (Action m r, Action n r) => Action (m :+: n) r where-  act = appEndo . mconcat . map (Endo . either act act) . unMCo+  act = appEndo . ((Endo . act) `cop` (Endo . act))

@@ -1,168 +0,0 @@-{-# LANGUAGE BangPatterns          #-}-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MonoLocalBinds        #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE TypeOperators         #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Monoid.Coproduct.Strict--- Copyright   :  (c) 2015 diagrams-core team (see LICENSE)--- License     :  BSD-style (see LICENSE)--- Maintainer  :  diagrams-discuss@googlegroups.com------ A strict coproduct of two monoids.-----------------------------------------------------------------------------------module Data.Monoid.Coproduct.Strict-  (-    -- * Coproduct-    (:+:)-  , inL, inR-  , prependL, prependR-  , killL, killR-  , untangle--  -- ** Lenses-  , untangled-  , _L-  , _R--  ) where--import           Data.Monoid.Action-import           Data.Monoid.WithSemigroup-import           Data.Semigroup-import           Prelude---- Internal strict version of Maybe-data Possible a = Only !a | Nought--instance Semigroup a => Semigroup (Possible a) where-  Only a <> Only b = Only (a <> b)-  Nought <> b      = b-  a      <> _      = a-  {-# INLINE (<>) #-}--instance Semigroup a => Monoid (Possible a) where-  mempty = Nought-  {-# INLINE mempty #-}-  mappend = (<>)-  {-# INLINE mappend #-}---- | @m :+: n@ is the coproduct of monoids @m@ and @n@. Concatentation---   is equivilent to------ @--- (m1 :+: n1) <> (m2 :+: n2) = (m1 <> m2) :+: (n1 <> act m1 n2)@--- @------   but has a more efficient internal implimentation.-data m :+: n = C !(Possible n) !(Possible m) !(Possible n)--- The left n already has the action m applied. The right n still needs--- m applied, but it kept there incase more n comes to reduce the number--- of actions that need to be applied.--instance (Action m n, Monoid m, Monoid' n, Show m, Show n) => Show (m :+: n) where-  showsPrec p c = showParen (p > 5) $-    showsPrec 11 m . showString " :+: " . showsPrec 11 n-    where (m,n) = untangle c--instance (Action m n, Semigroup m, Semigroup n) => Semigroup (m :+: n) where-  C n1 m1 o1 <> C n2 m2 o2 = C (n1 <> act' m1 (o1 <> n2)) (m1 <> m2) o2-  {-# INLINE (<>) #-}--instance (Action m n, Semigroup m, Semigroup n) => Monoid (m :+: n) where-  mempty  = C Nought Nought Nought-  {-# INLINE mempty #-}-  mappend = (<>)-  {-# INLINE mappend #-}---- | Coproducts act on other things by having each of the components---   act individually.-instance (Action m n, Action m r, Action n r, Semigroup n) => Action (m :+: n) r where-  act (C n m o) = act'' n' . act'' m-    where !n' = n <> act' m o-  {-# INLINE act #-}---- | Construct a coproduct with a left value.-inL :: m -> m :+: n-inL m = C Nought (Only m) Nought-{-# INLINE inL #-}---- | Construct a coproduct with a right value.-inR :: n -> m :+: n-inR r = C (Only r) Nought Nought-{-# INLINE inR #-}---- | Prepend a value from the left.-prependL :: Semigroup m => m -> m :+: n -> m :+: n-prependL m' (C n m o) = C n (Only m' <> m) o-{-# INLINE prependL #-}---- | Prepend a value from the right.-prependR :: Semigroup n => n -> m :+: n -> m :+: n-prependR n' (C n m o) = C (Only n' <> n) m o-{-# INLINE prependR #-}---- | Extract @m@ from a coproduct.-killR :: Monoid m => m :+: n -> m-killR (C _ m _) = get m-{-# INLINE killR #-}---- | Extract @n@ from a coproduct.-killL :: (Action m n, Monoid' n) => m :+: n -> n-killL (C n m o) = get $ n <> act' m o-{-# INLINE killL #-}--untangle :: (Action m n, Monoid m, Monoid' n) => m :+: n -> (m,n)-untangle (C n m o) = (get m, get n')-  where !n' = n <> act' m o-{-# INLINE untangle #-}---- Lenses ----------------------------------------------------------------type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t---- | Lens onto the both @m@ and @n@.-untangled :: (Action m n, Monoid m, Monoid' n) => Lens (m :+: n) (m' :+: n') (m,n) (m',n')-untangled f c = f (untangle c) <&> \(m',n') -> C (Only n') (Only m') Nought-{-# INLINE untangled #-}--- this could be an iso if we depended on profunctors---- | Lens onto the left value of a coproduct.-_L :: (Action m n, Monoid m, Semigroup n) => Lens (m :+: n) (m' :+: n) m m'-_L f (C n m o) = f (get m) <&> \m' -> C (n <> act' m o) (Only m') Nought-{-# INLINE _L #-}--- this could be a prism if we depended on profunctors---- | Lens onto the right value of a coproduct.-_R :: (Action m n, Monoid' n) => Lens (m :+: n) (m :+: n') n n'-_R f (C n m o) = f (get $ n `mappend` act' m o) <&> \n' -> C (Only n') m Nought-{-# INLINE _R #-}---- Internal utilities ----------------------------------------------------get :: Monoid a => Possible a -> a-get (Only a) = a-get _        = mempty-{-# INLINE get #-}--(<&>) :: Functor f => f a -> (a -> b) -> f b-(<&>) = flip fmap-{-# INLINE (<&>) #-}---- Act on a possible with a possible-act' :: Action m n => Possible m -> Possible n -> Possible n-act' (Only m) (Only n) = Only (act m n)-act' _        n        = n-{-# INLINE act' #-}---- Act with a possible-act'' :: Action m n => Possible m -> n -> n-act'' (Only m) = act m-act'' _        = id-{-# INLINE act'' #-}

@@ -0,0 +1,85 @@+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE LambdaCase #-}++module Data.Semigroup.Coproduct+       ( (:+.)+       , inL, inR+       , cop+       , toAltList+       , toMonoid+       ) where++import Data.Function (on)+import Data.List.NonEmpty (NonEmpty(..))+import Data.Typeable (Typeable)+import Data.Semigroup (Endo(Endo, appEndo))+import Data.Semigroup.Foldable (foldMap1)++import Data.Monoid.Action (Action(..))+import Data.Monoid.Coproduct ((:+:))+import qualified Data.Monoid.Coproduct as M++-- | @m :+. n@ is the coproduct of semigroups @m@ and @n@.  Values of+--   type @m :+. n@ consist of alternating non-empty lists of @m@ and @n@+--   values. Composition is list concatenation, with appropriate+--   combining of adjacent elements+newtype m :+. n = SCo { unSCo :: NonEmpty (Either m n) }+  deriving (Typeable, Show)++instance (Eq m, Eq n, Semigroup m, Semigroup n) => Eq (m :+. n) where+  (==) = (==) `on` (normalize . unSCo)++-- | Extract a semigroup coproduct to a non-empty list of @Either@ values.+--   The resulting list is guaranteed to be normalized, in the sense that+--   it will strictly alternate between @Left@ and @Right@.+toAltList :: (Semigroup m, Semigroup n) => (m :+. n) -> NonEmpty (Either m n)+toAltList (SCo ms) = normalize ms++-- Normalize a list of @Either@ values by combining any consecutive+-- values of the same type.+normalize :: (Semigroup m, Semigroup n) => NonEmpty (Either m n) -> NonEmpty (Either m n)+normalize = \case+  Left e1 :| Left e2 : es -> normalize (Left (e1 <> e2) :| es)+  Right e1 :| Right e2 : es -> normalize (Right (e1 <> e2) :| es)+  e1 :| es1 -> case es1 of+    e2 : es2 -> (e1 :| []) <> normalize (e2 :| es2)+    [] -> e1 :| []++-- | Universal map of the coproduct. The name @cop@ is an abbreviation+--   for copairing. Both functions in the signature should be semigroup+--   homomorphisms. If they are general functions then the copairing may+--   not be well defined in the sense that it may send equal elements to+--   unequal elements. This is also the reason why @cop@ is not the+--   @Data.Bifoldable1.bifoldMap1@ function even though they have the same+--   signature.+cop :: Semigroup k => (m -> k) -> (n -> k) -> (m :+. n) -> k+f `cop` g = foldMap1 (either f g) . unSCo++-- | Injection from the left semigroup into a coproduct.+inL :: m -> m :+. n+inL m = SCo (Left m :| [])++-- | Injection from the right semigroup into a coproduct.+inR :: n -> m :+. n+inR n = SCo (Right n :| [])++-- | Given monoids @m@ and @n@, we can form their semigroup coproduct+--   @m :+. n@. Every monoid homomorphism is a semigroup homomorphism.+--   In particular the canonical inections of the monoid coproduct from+--   @m@ and @n@ into @m :+: n@ are semigroup homomorphisms. By pairing+--   them using the universal property of the semigroup coproduct we+--   obtain a canonical semigroup homomorphism `toMonoid` from @m :+. n@+--   to @m :+: n@.+toMonoid :: (Monoid m, Monoid n) => m :+. n -> m :+: n+toMonoid = M.inL `cop` M.inR++instance Semigroup (m :+. n) where+  (SCo es1) <> (SCo es2) = SCo (es1 <> es2)++-- | Coproducts act on other things by having each of the components+--   act individually.+instance (Action m r, Action n r) => Action (m :+. n) r where+  act = appEndo . ((Endo . act) `cop` (Endo . act))