monoid-extras 0.4.4 → 0.7.0.2
raw patch · 13 files changed
Files
- CHANGES +92/−0
- monoid-extras.cabal +14/−11
- src/Data/Monoid/Action.hs +85/−8
- src/Data/Monoid/Coproduct.hs +66/−23
- src/Data/Monoid/Cut.hs +3/−0
- src/Data/Monoid/Deletable.hs +7/−0
- src/Data/Monoid/Inf.hs +2/−2
- src/Data/Monoid/MList.hs +10/−11
- src/Data/Monoid/Recommend.hs +6/−1
- src/Data/Monoid/SemiDirectProduct.hs +12/−0
- src/Data/Monoid/Split.hs +4/−0
- src/Data/Monoid/WithSemigroup.hs +16/−15
- src/Data/Semigroup/Coproduct.hs +85/−0
CHANGES view
@@ -1,3 +1,95 @@+* 0.7.0.1: 29 January 2026++ - Add some cautionary comments to `Regular` and `Semi`. In+ particular, `Regular` cannot be used to create a lawful semidirect+ product of a monoid/semigroup with itself. ([#63](https://github.com/diagrams/monoid-extras/issues/63))++* 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))+- New function `toAltList :: (m :+: n) -> [Either m n]`++* 0.6.4: 10 February 2025++- New instance `Action m a => Action [m] a` (thanks to Manuel Bärenz for the suggestion)++* 0.6.3: 8 August 2024++- New instances (thanks to Clinton Mead):+ - `Action (First a) a`+ - `Action Void a`+ - `Action m a => Action (Identity m) a`++- r1 (27 Jan 2025):+ - Allow `base-4.21` and test on GHC 9.12.++* 0.6.2: 20 Dec 2022++- New class and newtypes in `Data.Monoid.Action` (thanks to Manuel Bärenz):+ - `Torsor` class for transitive group actions+ - `Regular` and `Conjugate` newtypes for groups acting on themselves++- r1 (27 March 2023):+ - allow `semigroupoids-6.0`+ - allow `base-4.18` and test on GHC 9.6.++- r2 (17 Oct 2023):+ - allow `base-4.19` and test on GHC 9.8.++- r3 (15 May 2024):+ - allow `base-4.20` and test on GHC 9.10.++* 0.6.1: 16 Nov 2021++- Add more efficient `stimes` implementations for several `Semigroup`+ instances. Thanks to BlackCapCoder for the patch!+- Allow `base-4.16` and test on GHC 9.2.1.++- r1: allow `base-4.16` in benchmarks+- r2 (15 August 2022): allow `base-4.17` and test with GHC 9.4.++* 0.6: 8 May 2021++- Updates for GHC 8.10 and 9.0.+- Drop support for GHC 8.2 or older.+- Replace deprecated `Option` type with `Maybe`.++* 0.5.1: 19 Oct 2019++- New module Data.Monoid.Coproduct.Strict for a more efficient coproduct in+ some use cases.+- Update for GHC 8.8.+- Drop support for GHC 7.8.++* 0.5: 14 May 2018++- Modernize Data.Monoid.WithSemigroup++ It used to export a type class Monoid' with no methods and a single+ instance, for use as a "poor man's constraint synonym" for the+ combination of Monoid and Semigroup. Now Monoid':++ - Is a real constraint synonym, using ConstraintKinds.+ - Is simply a synonym for Monoid under base-4.11 and later, in+ which case Semigroup is already a superclass of Monoid.++ This technically necessitates a major version bump but should not+ cause any issues for packages that depend on monoid-extras, other+ than potentially requiring the addition of a ConstraintKinds pragma+ under GHC 7.8.+ * 0.4.4: 8 April 2018 - Fix build on older (< 7.10) GHCs (thanks to George Wilson for the fix)
monoid-extras.cabal view
@@ -1,5 +1,5 @@ name: monoid-extras-version: 0.4.4+version: 0.7.0.2 synopsis: Various extra monoid-related definitions and utilities description: Various extra monoid-related definitions and utilities, such as monoid actions, monoid coproducts, semi-direct@@ -14,7 +14,7 @@ category: Data build-type: Simple cabal-version: >=1.10-tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.1, GHC == 8.2.2, GHC == 8.4.1+tested-with: GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.2 || ==9.10.1 || ==9.12.1 || ==9.14.1 source-repository head type: git@@ -33,25 +33,28 @@ Data.Monoid.MList, Data.Monoid.Recommend, Data.Monoid.Split,- Data.Monoid.WithSemigroup+ Data.Monoid.WithSemigroup,+ Data.Semigroup.Coproduct - build-depends: base >= 4.3 && < 4.12,- groups < 0.5,- semigroups >= 0.8 && < 0.19,- semigroupoids >= 4.0 && < 5.3+ build-depends: base >= 4.11 && < 4.23,+ groups < 0.6,+ semigroupoids >= 4.0 && < 6.1 hs-source-dirs: src - other-extensions: DeriveFunctor,- FlexibleInstances,- MultiParamTypeClasses,+ ghc-options: -Wall++ other-extensions: DeriveFunctor+ FlexibleInstances+ MultiParamTypeClasses TypeOperators+ ConstraintKinds benchmark semi-direct-product default-language: Haskell2010 hs-source-dirs: benchmarks main-is: SemiDirectProduct.hs type: exitcode-stdio-1.0- build-depends: base >= 4.3 && < 4.12+ build-depends: base >= 4.3 && < 4.23 , criterion , monoid-extras
src/Data/Monoid/Action.hs view
@@ -14,9 +14,17 @@ module Data.Monoid.Action ( Action(..)+ , Regular(..)+ , Conjugate(..)+ , Torsor(..) ) where +import Data.Functor.Identity (Identity(Identity)) import Data.Semigroup+import qualified Data.Semigroup as Semigroup+import Data.Group+import qualified Data.Monoid as Monoid+import Data.Void (Void, absurd) ------------------------------------------------------------ -- Monoid and semigroup actions@@ -31,12 +39,16 @@ -- * @act (m1 \`mappend\` m2) = act m1 . act m2@ -- -- Semigroup instances are required to satisfy the second law but with--- ('<>') instead of 'mappend'. Additionally, if the type @s@ has--- any algebraic structure, @act m@ should be a homomorphism. For--- example, if @s@ is also a monoid we should have @act m mempty =--- mempty@ and @act m (s1 \`mappend\` s2) = (act m s1) \`mappend\`--- (act m s2)@.+-- ('<>') instead of 'mappend'. --+-- Additionally, if the type @s@ has any algebraic structure, @act+-- m@ should typically be a homomorphism. For example, if @s@ is+-- also a monoid we should have @act m mempty = mempty@ and @act m+-- (s1 \`mappend\` s2) = (act m s1) \`mappend\` (act m s2)@. In+-- particular, these laws are necessary for the semidirect product+-- @Semi s m@ to be a valid semigroup/monoid. For a more+-- fine-grained treatment of these ideas, see the @lr-acts@ package.+-- -- By default, @act = const id@, so for a type @M@ which should have -- no action on anything, it suffices to write --@@ -64,10 +76,14 @@ act () = id -- | @Nothing@ acts as the identity; @Just m@ acts as @m@.-instance Action m s => Action (Option m) s where- act (Option Nothing) s = s- act (Option (Just m)) s = act m s+instance Action m s => Action (Maybe m) s where+ act Nothing s = s+ act (Just m) s = act m s +-- | @act [a,b,c,...] = act a . act b . act c . ...@+instance Action m s => Action [m] s where+ act = flip (foldr act)+ -- | @Endo@ acts by application. -- -- Note that in order for this instance to satisfy the @Action@@@ -81,3 +97,64 @@ instance Action (Endo a) a where act = appEndo +instance Num a => Action Integer (Sum a) where+ n `act` a = fromInteger n <> a++instance Num a => Action Integer (Product a) where+ n `act` a = fromInteger n <> a++instance Fractional a => Action Rational (Sum a) where+ n `act` a = Sum (fromRational n) <> a++instance Fractional a => Action Rational (Product a) where+ n `act` a = Product (fromRational n) <> a++-- | An action of a group is "free transitive", "regular", or a "torsor"+-- iff it is invertible.+--+-- Given an original value `sOrig`, and a value `sActed` that is the result+-- of acting on `sOrig` by some `m`,+-- it is possible to recover this `m`.+-- This is encoded in the laws:+--+-- * @(m `'act'` s) `'difference'` s = m@+-- * @(sActed `'difference'` sOrig) `'act'` sOrig = sActed@+class Group m => Torsor m s where++ -- | @'difference' sActed sOrig@ is the element @m@ such that @sActed = m `'act'` sOrig@.+ difference :: s -> s -> m++-- | Any monoid acts on itself by left multiplication.+-- This newtype witnesses this action:+-- @'getRegular' $ 'Regular' m1 `'act'` 'Regular' m2 = m1 '<>' m2@+--+-- Note that this typically does NOT satisfy the distributivity law+-- @m `act` (m1 <> m2) = (m `act` m1) <> (m `act` m2)@, and hence+-- cannot be used to form a lawful semidirect product of a monoid with itself.+newtype Regular m = Regular {getRegular :: m}++instance Semigroup m => Action m (Regular m) where+ m1 `act` Regular m2 = Regular $ m1 <> m2++instance Group m => Torsor m (Regular m) where+ Regular m1 `difference` Regular m2 = m1 ~~ m2++-- | Any group acts on itself by conjugation.+newtype Conjugate m = Conjugate { getConjugate :: m }++instance Group m => Action m (Conjugate m) where+ m1 `act` Conjugate m2 = Conjugate $ m1 <> m2 ~~ m1++instance Action (Semigroup.First a) a where+ act (Semigroup.First m) _ = m++instance Action (Monoid.First a) a where + act (Monoid.First m) s = case m of+ Nothing -> s+ Just m' -> m'++instance Action Void a where+ act = absurd++instance Action m s => Action (Identity m) s where+ act (Identity m) = act m
src/Data/Monoid/Coproduct.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- |@@ -18,30 +19,79 @@ ( (:+:) , 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, 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+-- it will strictly alternate between @Left@ and @Right@.+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]+normalize = \case+ (Left e1:Left e2 : es) -> normalize (Left (e1 <> e2) : es)+ (Right e1:Right e2:es) -> normalize (Right (e1 <> e2) : es)+ [] -> []+ (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]@@ -58,17 +108,6 @@ mappendR :: n -> m :+: n -> m :+: n mappendR = mappend . inR -{--normalize :: (Monoid m, Monoid n) => m :+: n -> m :+: n-normalize (MCo es) = MCo (normalize' es)- where normalize' [] = []- normalize' [e] = [e]- normalize' (Left e1:Left e2 : es) = normalize' (Left (e1 <> e2) : es)- normalize' (Left e1:es) = Left e1 : normalize' es- normalize' (Right e1:Right e2:es) = normalize' (Right (e1 <> e2) : es)- normalize' (Right e1:es) = Right e1 : normalize' es--}- instance Semigroup (m :+: n) where (MCo es1) <> (MCo es2) = MCo (es1 ++ es2) @@ -80,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, --@@ -100,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))
src/Data/Monoid/Cut.hs view
@@ -61,6 +61,9 @@ (m1 :||: m2) <> (Uncut m2') = m1 :||: m2 <> m2' (m11 :||: _) <> (_ :||: m22) = m11 :||: m22 + stimes n (Uncut m) = Uncut (stimes n m)+ stimes _ (m ) = m+ instance (Semigroup m, Monoid m) => Monoid (Cut m) where mempty = Uncut mempty mappend = (<>)
src/Data/Monoid/Deletable.hs view
@@ -77,6 +77,13 @@ | l1 < r2 = Deletable (r1 + r2 - l1) m2 l2 | otherwise = Deletable r1 m1 (l2 + l1 - r2) + stimes n (Deletable r m l)+ | r == l = Deletable r (stimes n m) l+ | l < r = Deletable (i*(r-l) + l) m l+ | otherwise = Deletable r m (i*(l-r) + r)+ where+ i = fromIntegral n :: Int+ instance (Semigroup m, Monoid m) => Monoid (Deletable m) where mempty = Deletable 0 mempty 0 mappend = (<>)
src/Data/Monoid/Inf.hs view
@@ -16,8 +16,8 @@ -- -- Make semigroups under 'min' or 'max' into monoids by adjoining an -- element corresponding to infinity (positive or negative,--- respectively). These types are similar to @Option (Min a)@ and--- @Option (Max a)@ respectively, except that the 'Ord' instance+-- respectively). These types are similar to @Maybe (Min a)@ and+-- @Maybe (Max a)@ respectively, except that the 'Ord' instance -- matches the 'Monoid' instance. -- -----------------------------------------------------------------------------
src/Data/Monoid/MList.hs view
@@ -44,7 +44,6 @@ import Control.Arrow import Data.Monoid.Action-import Data.Semigroup -- $mlist --@@ -58,10 +57,10 @@ infixr 5 ::: infixr 5 *: -type a ::: l = (Option a, l)+type a ::: l = (Maybe a, l) (*:) :: a -> l -> a ::: l-a *: l = (Option (Just a), l)+a *: l = (Just a, l) -- MList ----------------------------------- @@ -77,7 +76,7 @@ empty = () instance MList l => MList (a ::: l) where- empty = (Option Nothing, empty)+ empty = (Nothing, empty) -- Embedding ------------------------------------------- @@ -89,22 +88,22 @@ -- | Get the value of type @a@ from a heterogeneous list, if there -- is one.- get :: l -> Option a+ get :: l -> Maybe a -- | Alter the value of type @a@ by applying the given function to it.- alt :: (Option a -> Option a) -> l -> l+ alt :: (Maybe a -> Maybe a) -> l -> l #if __GLASGOW_HASKELL__ >= 710 instance {-# OVERLAPPING #-} MList t => (:>:) (a ::: t) a where #else instance MList t => (:>:) (a ::: t) a where #endif- inj a = (Option (Just a), empty)+ inj a = (Just a, empty) get = fst alt = first instance (t :>: a) => (:>:) (b ::: t) a where- inj a = (Option Nothing, inj a)+ inj a = (Nothing, inj a) get = get . snd alt = second . alt @@ -129,6 +128,6 @@ instance Action (SM a) () where act _ _ = () -instance (Action a a', Action (SM a) l) => Action (SM a) (Option a', l) where- act (SM a) (Option Nothing, l) = (Option Nothing, act (SM a) l)- act (SM a) (Option (Just a'), l) = (Option (Just (act a a')), act (SM a) l)+instance (Action a a', Action (SM a) l) => Action (SM a) (Maybe a', l) where+ act (SM a) (Nothing, l) = (Nothing, act (SM a) l)+ act (SM a) (Just a', l) = (Just (act a a'), act (SM a) l)
src/Data/Monoid/Recommend.hs view
@@ -3,6 +3,8 @@ {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-}++{-# OPTIONS_GHC -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Monoid.Recommend@@ -12,7 +14,7 @@ -- -- A type for representing values with an additional bit saying -- whether the value is \"just a recommendation\" (to be used only if--- nothing better comes along) or a \"committment\" (to certainly be+-- nothing better comes along) or a \"commitment\" (to certainly be -- used, overriding merely recommended values), along with -- corresponding @Semigroup@ and @Monoid@ instances. --@@ -55,6 +57,9 @@ Recommend _ <> Commit b = Commit b Commit a <> Recommend _ = Commit a Commit a <> Commit b = Commit (a <> b)++ stimes n (Recommend m) = Recommend (stimes n m)+ stimes n (Commit m) = Commit (stimes n m) instance (Semigroup a, Monoid a) => Monoid (Recommend a) where mappend = (<>)
src/Data/Monoid/SemiDirectProduct.hs view
@@ -24,6 +24,18 @@ -- We think of the @m@ values as a "tag" decorating the @s@ values, -- which also affect the way the @s@ values combine. --+-- NOTE: this is only a valid semigroup/monoid if the action of @m@+-- on @s@ satisfies BOTH:+--+-- 1. @act@ is a monoid/semigroup homomorphism from @m@ to @(s ->+-- s)@, that is, @act mempty = id@ and @act (m1 <> m2) = act m1+-- . act m2@+-- 2. @act m@ is a monoid/semigroup homomorphism for any @m@, that is,+-- @act m mempty = mempty@ and @act m (s1 <> s2) = act m s1 <> act m s2@.+--+-- For a more fine-grained treatment of these ideas, see the+-- @lr-acts@ package.+-- -- We call the monoid @m@ the quotient monoid and the monoid @s@ the -- sub-monoid of the semi-direct product. The semi-direct product -- @Semi s m@ is an extension of the monoid @s@ with @m@ being the
src/Data/Monoid/Split.hs view
@@ -67,6 +67,10 @@ (m1 :| m2) <> (M m2') = m1 :| m2 <> m2' (m11 :| m12) <> (m21 :| m22) = m11 <> m12 <> m21 :| m22 + stimes n (M m ) = M (stimes n m)+ stimes 1 (m ) = m+ stimes n (m1 :| m2) = m1 <> stimes (pred n) (m2 <> m1) :| m2+ instance (Semigroup m, Monoid m) => Monoid (Split m) where mempty = M mempty mappend = (<>)
src/Data/Monoid/WithSemigroup.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE FlexibleInstances- , UndecidableInstances- #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Monoid.WithSemigroup@@ -17,16 +19,15 @@ ( Monoid' ) where -import Data.Semigroup---- Poor man's constraint synonym. Eventually, once it becomes--- standard, we can make this a real constraint synonym and get rid of--- the UndecidableInstances flag. Better yet, hopefully the Monoid--- class will eventually have a Semigroup superclass.+import Data.Semigroup --- | The @Monoid'@ class is a synonym for things which are instances--- of both 'Semigroup' and 'Monoid'. Ideally, the 'Monoid' class--- itself will eventually include a 'Semigroup' superclass and we--- can get rid of this.-class (Semigroup m, Monoid m) => Monoid' m-instance (Semigroup m, Monoid m) => Monoid' m+-- | For base < 4.11, the @Monoid'@ constraint is a synonym for things+-- which are instances of both 'Semigroup' and 'Monoid'. For base+-- version 4.11 and onwards, @Monoid@ has @Semigroup@ as a+-- superclass already, so for backwards compatibility @Monoid'@ is+-- provided as a synonym for @Monoid@.+#if MIN_VERSION_base(4,11,0)+type Monoid' = Monoid+#else+type Monoid' m = (Semigroup m, Monoid m)+#endif
+ src/Data/Semigroup/Coproduct.hs view
@@ -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))