monoid-extras 0.3.3.5 → 0.7.0.2
raw patch · 17 files changed
Files
- CHANGES +140/−1
- LICENSE +4/−1
- benchmarks/SemiDirectProduct.hs +40/−0
- monoid-extras.cabal +27/−11
- src/Data/Monoid/Action.hs +86/−9
- src/Data/Monoid/Coproduct.hs +73/−29
- src/Data/Monoid/Cut.hs +13/−3
- src/Data/Monoid/Deletable.hs +17/−5
- src/Data/Monoid/Endomorphism.hs +10/−6
- src/Data/Monoid/Inf.hs +72/−14
- src/Data/Monoid/MList.hs +18/−12
- src/Data/Monoid/Recommend.hs +22/−5
- src/Data/Monoid/SemiDirectProduct.hs +104/−0
- src/Data/Monoid/SemiDirectProduct/Strict.hs +87/−0
- src/Data/Monoid/Split.hs +19/−7
- src/Data/Monoid/WithSemigroup.hs +16/−15
- src/Data/Semigroup/Coproduct.hs +85/−0
CHANGES view
@@ -1,4 +1,143 @@-* 0.3.3.5 03 Dec 2014+* 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)++* 0.4.3: 3 April 2018++- Allow base-4.11+- Fix compilation on GHC 8.4+- Add more instances for Inf++* 0.4.2: 16 July 2016++- Additions to Data.Monoid.SemiDirectProduct (unSemi, tag, untag)++- Hackage revision 1: allow semigroupoids-5.2+- Hackage revision 2: allow base-4.10++* 0.4.1.2: 16 June 2016++- allow semigroupoids-5.1++* 0.4.1: 8 June 2016++- new modules Data.Monoid.SemiDirectProduct[.Strict].++* 0.4.0.4: 14 February 2016++- allow base-4.9 for GHC-8++* 0.4.0.3: 10 November 2015++- allow semigroups-0.18++* 0.4.0.2: 16 September 2015++- allow semigroups-0.17++* v0.4.0.1++- allow semigroupoids-5.0++* 0.4: 19 April 2015++ - add derived instances where possible:+ Typeable, Data, Read, Eq, Ord, Functor, Foldable, Traversable+ - allow base-4.8++* 0.3.3.5: 03 Dec 2014 - allow semigroups-0.15
LICENSE view
@@ -1,9 +1,12 @@-Copyright (c) 2012-2013, monoid-extras team:+Copyright (c) 2012-2015, monoid-extras team: Daniel Bergey <bergey@alum.mit.edu>+ Christopher Chalmers <c.chalmers@me.com> Nathan van Doorn <nvd1234@gmail.com> Daniil Frumin <difrumin@gmail.com> Hans Höglund <hans@hanshoglund.se>+ Moritz Kiefer <moritz.kiefer@purelyfunctional.org>+ Piyush P Kurur <ppk@cse.iitk.ac.in> Daniel Wagner <daniel@wagner-home.com> Ryan Yates <fryguybob@gmail.com> Brent Yorgey <byorgey@gmail.com>
+ benchmarks/SemiDirectProduct.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Main where++import Criterion.Main++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+import Data.Word+#else+import Data.Monoid (Sum(..))+#endif+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup)+#endif++import Data.Monoid.Action+import qualified Data.Monoid.SemiDirectProduct as L+import qualified Data.Monoid.SemiDirectProduct.Strict as S++newtype MyMonoid = MyMonoid (Sum Word) deriving (Semigroup, Monoid)++instance Action MyMonoid () where+ act _ = id+ {-# NOINLINE act #-}++main :: IO ()+main = defaultMain+ [ bench "mconcat/strict" $ whnf mconcat strict+ , bench "mconcat/lazy" $ whnf mconcat lazy+ , bench "strict/quotient" $ whnf (S.quotient . mconcat) strict+ , bench "lazy/quotient" $ whnf (L.quotient . mconcat) lazy+ ]+ where strict :: [S.Semi () MyMonoid]+ strict = map (S.embed . MyMonoid . Sum) $ take 1000 [1..]+ lazy :: [L.Semi () (MyMonoid)]+ lazy = map (L.embed . MyMonoid . Sum) $ take 1000 [1..]
monoid-extras.cabal view
@@ -1,9 +1,10 @@ name: monoid-extras-version: 0.3.3.5+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, \"deletable\"- monoids, \"split\" monoids, and \"cut\" monoids.+ such as monoid actions, monoid coproducts, semi-direct+ products, \"deletable\" monoids, \"split\" monoids,+ and \"cut\" monoids. license: BSD3 license-file: LICENSE extra-source-files: CHANGES@@ -13,6 +14,7 @@ category: Data build-type: Simple cabal-version: >=1.10+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@@ -21,6 +23,8 @@ library default-language: Haskell2010 exposed-modules: Data.Monoid.Action,+ Data.Monoid.SemiDirectProduct,+ Data.Monoid.SemiDirectProduct.Strict Data.Monoid.Coproduct, Data.Monoid.Cut, Data.Monoid.Deletable,@@ -29,16 +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.8,- groups < 0.5,- semigroups >= 0.8 && < 0.17,- semigroupoids >= 4.0 && < 5+ 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.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@@ -28,15 +36,19 @@ -- -- * @act mempty = id@ ----- * @act (m1 ``mappend`` m2) = act m1 . act m2@+-- * @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
@@ -1,12 +1,13 @@-{-# LANGUAGE TypeOperators- , FlexibleInstances- , MultiParamTypeClasses- #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Monoid.Coproduct--- Copyright : (c) 2011 diagrams-core team (see LICENSE)+-- Copyright : (c) 2011-2015 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com --@@ -18,29 +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 Show+ 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]@@ -57,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) @@ -79,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, --@@ -99,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
@@ -1,8 +1,12 @@-+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Monoid.Cut--- Copyright : (c) 2012 diagrams-core team (see LICENSE)+-- Copyright : (c) 2012-2015 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com --@@ -18,7 +22,10 @@ ) where +import Data.Data import Data.Semigroup+import Data.Foldable+import Data.Traversable infix 5 :||: @@ -38,7 +45,7 @@ -- the outermost splits and throws away everything in between. data Cut m = Uncut m | m :||: m- deriving (Show)+ deriving (Data, Typeable, Show, Read, Functor, Foldable, Traversable) -- | If @m@ is a @Semigroup@, then @Cut m@ is a semigroup which -- contains @m@ as a sub-semigroup, but also contains elements of@@ -53,6 +60,9 @@ (Uncut m1) <> (m1' :||: m2) = m1 <> m1' :||: m2 (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
src/Data/Monoid/Deletable.hs view
@@ -1,10 +1,12 @@-{-# LANGUAGE DeriveFunctor- #-}-+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Monoid.Deletable--- Copyright : (c) 2011 diagrams-core team (see LICENSE)+-- Copyright : (c) 2011-2015 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com --@@ -22,6 +24,9 @@ ) where +import Data.Data+import Data.Foldable+import Data.Traversable import Data.Semigroup -- | If @m@ is a 'Monoid', then @Deletable m@ (intuitively speaking)@@ -52,7 +57,7 @@ -- * The remaining case is symmetric with the second. data Deletable m = Deletable Int m Int- deriving (Functor, Show)+ deriving (Data, Typeable, Show, Read, Functor, Foldable, Traversable) -- | Project the wrapped value out of a `Deletable` value. unDelete :: Deletable m -> m@@ -71,6 +76,13 @@ | l1 == r2 = Deletable r1 (m1 <> m2) l2 | 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
src/Data/Monoid/Endomorphism.hs view
@@ -1,10 +1,11 @@-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Monoid.Endomorphism--- Copyright : (c) 2013 diagrams-core team (see LICENSE)+-- Copyright : (c) 2013-2015 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com --@@ -20,7 +21,8 @@ import Control.Category import Data.Group import Data.Groupoid-import Data.Semigroup+import Data.Monoid (Monoid(..))+import Data.Semigroup (Semigroup(..)) import Data.Semigroupoid import Prelude (Show) @@ -30,14 +32,16 @@ -- and the identity morphism as the identity element. newtype Endomorphism k a = Endomorphism {getEndomorphism :: k a a} -deriving instance Show (k a a) => Show (Endomorphism k a)+deriving instance Show (k a a) => Show (Endomorphism k a) instance Semigroupoid k => Semigroup (Endomorphism k a) where Endomorphism a <> Endomorphism b = Endomorphism (a `o` b) -instance Category k => Monoid (Endomorphism k a) where+instance (Semigroupoid k, Category k) => Monoid (Endomorphism k a) where mempty = Endomorphism id+#if !MIN_VERSION_base(4,11,0) Endomorphism a `mappend` Endomorphism b = Endomorphism (a . b)+#endif instance (Category k, Groupoid k) => Group (Endomorphism k a) where invert (Endomorphism a) = Endomorphism (inv a)
src/Data/Monoid/Inf.hs view
@@ -1,19 +1,23 @@-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+ ----------------------------------------------------------------------------- -- | -- Module : Data.Monoid.Inf--- Copyright : (c) 2012 diagrams-core team (see LICENSE)+-- Copyright : (c) 2012-2015 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com ----- Make semigroup under 'min' or 'max' into monoids by adjoining an+-- 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. -- -----------------------------------------------------------------------------@@ -28,57 +32,111 @@ , posFinite, negFinite ) where +import Control.Applicative (Applicative(..), liftA2)+import Data.Data import Data.Semigroup-import Prelude hiding (maximum, minimum)-import qualified Prelude as P+import Prelude hiding (maximum, minimum)+import qualified Prelude as P -import Data.Foldable (Foldable)-import Data.Traversable (Traversable)+import Data.Foldable (Foldable)+import Data.Traversable (Traversable) +-- | Type index indicating positive infinity. data Pos+-- | Type index indicating negative infinity. data Neg +-- | @Inf p a@ represents the type 'a' extended with a new "infinite"+-- value, which is treated as either positive or negative infinity+-- depending on the type index 'p'. This type exists mostly for its+-- 'Ord', 'Semigroup', and 'Monoid' instances. data Inf p a = Infinity | Finite a- deriving (Eq, Show, Read, Functor, Foldable, Traversable)+ deriving (Data, Typeable, Show, Read, Eq, Functor, Foldable,+ Traversable) +-- | The type 'a' extended with positive infinity. type PosInf a = Inf Pos a++-- | The type 'a' extended with negative infinity. type NegInf a = Inf Neg a +-- | Positive infinity is greater than any finite value. instance Ord a => Ord (Inf Pos a) where compare Infinity Infinity = EQ compare Infinity Finite{} = GT compare Finite{} Infinity = LT compare (Finite a) (Finite b) = compare a b +-- | Negative infinity is less than any finite value. instance Ord a => Ord (Inf Neg a) where compare Infinity Infinity = EQ compare Infinity Finite{} = LT compare Finite{} Infinity = GT compare (Finite a) (Finite b) = compare a b +-- | An ordered type extended with positive infinity is a semigroup+-- under 'min'. instance Ord a => Semigroup (Inf Pos a) where (<>) = min +-- | An ordered type extended with negative infinity is a semigroup+-- under 'max'. instance Ord a => Semigroup (Inf Neg a) where (<>) = max +-- | An ordered type extended with positive infinity is a monoid under+-- 'min', with positive infinity as the identity element. instance Ord a => Monoid (Inf Pos a) where mempty = Infinity mappend = (<>) +-- | An ordered type extended with negative infinity is a monoid under+-- 'max', with negative infinity as the identity element. instance Ord a => Monoid (Inf Neg a) where mempty = Infinity mappend = (<>) +instance Applicative (Inf p) where+ pure = Finite+ Infinity <*> _ = Infinity+ _ <*> Infinity = Infinity+ Finite f <*> Finite x = Finite $ f x++instance Monad (Inf p) where+ Infinity >>= _ = Infinity+ Finite x >>= f = f x+ return = pure++instance Bounded a => Bounded (NegInf a) where+ minBound = Infinity+ maxBound = Finite maxBound++instance Bounded a => Bounded (PosInf a) where+ minBound = Finite minBound+ maxBound = Infinity++-- | Find the minimum of a list of values. Returns positive infinity+-- iff the list is empty. minimum :: Ord a => [a] -> PosInf a minimum xs = P.minimum (Infinity : map Finite xs) +-- | Find the maximum of a list of values. Returns negative infinity+-- iff the list is empty. maximum :: Ord a => [a] -> NegInf a maximum xs = P.maximum (Infinity : map Finite xs) +-- | Positive infinity. posInfty :: PosInf a++-- | Negative infinity. negInfty :: NegInf a++-- | Embed a finite value into the space of such values extended with+-- positive infinity. posFinite :: a -> PosInf a++-- | Embed a finite value into the space of such values extended with+-- negative infinity. negFinite :: a -> NegInf a posInfty = Infinity
src/Data/Monoid/MList.hs view
@@ -1,12 +1,15 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-}+#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE OverlappingInstances #-}+#endif {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -41,7 +44,6 @@ import Control.Arrow import Data.Monoid.Action-import Data.Semigroup -- $mlist --@@ -55,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 ----------------------------------- @@ -74,7 +76,7 @@ empty = () instance MList l => MList (a ::: l) where- empty = (Option Nothing, empty)+ empty = (Nothing, empty) -- Embedding ------------------------------------------- @@ -86,18 +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- inj a = (Option (Just a), empty)+#endif+ 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 @@ -122,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
@@ -1,24 +1,38 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}++{-# OPTIONS_GHC -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Monoid.Recommend--- Copyright : (c) 2012 diagrams-core team (see LICENSE)+-- Copyright : (c) 2012-2015 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- 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. -- ----------------------------------------------------------------------------- module Data.Monoid.Recommend- ( Recommend(..), getRecommend+ ( Recommend(..)+ , getRecommend ) where -import Data.Semigroup+#if __GLASGOW_HASKELL__ < 710+import Data.Foldable+import Data.Traversable+#endif +import Data.Data+import Data.Semigroup+ -- | A value of type @Recommend a@ consists of a value of type @a@ -- wrapped up in one of two constructors. The @Recommend@ -- constructor indicates a \"non-committal recommendation\"---that@@ -28,7 +42,7 @@ -- overriding any @Recommend@ed values. data Recommend a = Recommend a | Commit a- deriving Show+ deriving (Show, Read, Functor, Eq, Ord, Typeable, Data, Foldable, Traversable) -- | Extract the value of type @a@ wrapped in @Recommend a@. getRecommend :: Recommend a -> a@@ -43,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
@@ -0,0 +1,104 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-}++module Data.Monoid.SemiDirectProduct+ ( Semi, unSemi, tag, inject, untag, embed, quotient+ ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid(..))+#endif+import Data.Semigroup (Semigroup(..))++import Data.Monoid.Action++-- | The semi-direct product of monoids @s@ and @m@, which is a monoid+-- when @m@ acts on @s@. Structurally, the semi-direct product is+-- just a pair @(s,m)@. However, the monoid instance is different.+-- In particular, we have+--+-- > (s1,m1) <> (s2,m2) = (s1 <> (m1 `act` s2), m1 <> m2)+--+-- 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+-- quotient.+newtype Semi s m = Semi { unSemi :: (s,m) }++instance (Semigroup m, Semigroup s, Action m s) => Semigroup (Semi s m) where+ x <> y = Semi (xs <> (xm `act` ys), xm <> ym)+ where (xs, xm) = unSemi x+ (ys, ym) = unSemi y+ {-# INLINE (<>) #-}++#if MIN_VERSION_base(4,8,0)+ sconcat = foldr1 (<>)+ {-# INLINE sconcat #-}+#endif++instance (Monoid m, Monoid s, Action m s) => Monoid (Semi s m) where+ mempty = Semi (mempty, mempty)+ {-# INLINE mempty #-}++#if !MIN_VERSION_base(4,11,0)+ mappend x y = Semi (xs `mappend` (xm `act` ys), xm `mappend` ym)+ where (xs, xm) = unSemi x+ (ys, ym) = unSemi y++ {-# INLINE mappend #-}+#endif++ mconcat = foldr mappend mempty+ {-# INLINE mconcat #-}++-- | Tag an @s@ value with an @m@ value to create an element of the+-- semi-direct product.+tag :: s -> m -> Semi s m+tag s m = Semi (s,m)++-- | The injection map, /i.e./ give an @s@ value a trivial tag.+inject :: Monoid m => s -> Semi s m+inject = Semi . (,mempty)++-- | Forget the monoidal tag. Of course, @untag . inject = id@, and+-- @untag (tag s m) = s@.+untag :: Semi s m -> s+untag = fst . unSemi++-- | Embed a "tag" value as a value of type @Semi s m@. Note that+--+-- @inject s <> embed m = tag s m@+--+-- and+--+-- @embed m <> inject s@ = tag (act m s) m@+--+-- The semi-direct product gives a split extension of @s@ by+-- @m@. This allows us to embed @m@ into the semi-direct+-- product. This is the embedding map. The quotient and embed maps+-- should satisfy the equation @quotient . embed = id@.+embed :: Monoid s => m -> Semi s m+embed = Semi . (mempty,)++-- | The quotient map, /i.e./ retrieve the monoidal tag value.+quotient :: Semi s m -> m+quotient = snd . unSemi++
+ src/Data/Monoid/SemiDirectProduct/Strict.hs view
@@ -0,0 +1,87 @@+-- | A strict version of the semi-direct product. If a monoid m acts+-- on s then this version of the semi-direct product is strict in+-- the m-portion of the semi-direct product.++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-}++module Data.Monoid.SemiDirectProduct.Strict+ ( Semi, unSemi, tag, inject, untag, embed, quotient+ ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid(..))+#endif+import Data.Semigroup (Semigroup(..))++import Data.Monoid.Action++-- | The semi-direct product of monoids @s@ and @m@, which is a monoid+-- when @m@ acts on @s@. Structurally, the semi-direct product is+-- just a pair @(s,m)@. However, the monoid instance is different.+-- In particular, we have+--+-- > (s1,m1) <> (s2,m2) = (s1 <> (m1 `act` s2), m1 <> m2)+--+-- 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+-- quotient.+data Semi s m = Semi s !m++unSemi :: Semi s m -> (s,m)+unSemi (Semi s m) = (s,m)++instance (Semigroup m, Semigroup s, Action m s) => Semigroup (Semi s m) where+ Semi xs xm <> Semi ys ym = Semi (xs <> (xm `act` ys)) (xm <> ym)+ {-# INLINE (<>) #-}++#if MIN_VERSION_base(4,8,0)+ sconcat = foldr1 (<>)+ {-# INLINE sconcat #-}+#endif++instance (Monoid m, Monoid s, Action m s) => Monoid (Semi s m) where+ mempty = Semi mempty mempty+ {-# INLINE mempty #-}+#if !MIN_VERSION_base(4,11,0)+ mappend (Semi xs xm) (Semi ys ym) = Semi (xs `mappend` (xm `act` ys)) (xm `mappend` ym)+ {-# INLINE mappend #-}+#endif+ mconcat = foldr mappend mempty+ {-# INLINE mconcat #-}++-- | Tag an @s@ value with an @m@ value to create an element of the+-- semi-direct product.+tag :: s -> m -> Semi s m+tag = Semi++-- | The injection map, /i.e./ give an @s@ value a trivial tag.+inject :: Monoid m => s -> Semi s m+inject = flip Semi mempty++-- | Forget the monoidal tag. Of course, @untag . inject = id@, and+-- @untag (tag s m) = s@.+untag :: Semi s m -> s+untag (Semi s _) = s++-- | Embed a "tag" value as a value of type @Semi s m@. Note that+--+-- @inject s <> embed m = tag s m@+--+-- and+--+-- @embed m <> inject s@ = tag (act m s) m@+--+-- The semi-direct product gives a split extension of @s@ by+-- @m@. This allows us to embed @m@ into the semi-direct+-- product. This is the embedding map. The quotient and embed maps+-- should satisfy the equation @quotient . embed = id@.+embed :: Monoid s => m -> Semi s m+embed = Semi mempty++-- | The quotient map, /i.e./ retrieve the monoidal tag value.+quotient :: Semi s m -> m+quotient (Semi _ m) = m
src/Data/Monoid/Split.hs view
@@ -1,11 +1,14 @@-{-# LANGUAGE FlexibleInstances- , MultiParamTypeClasses- #-}-+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Monoid.Split--- Copyright : (c) 2011 diagrams-core team (see LICENSE)+-- Copyright : (c) 2011-2015 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com --@@ -23,11 +26,16 @@ ----------------------------------------------------------------------------- module Data.Monoid.Split- ( Split(..), split, unsplit+ ( Split(..)+ , split+ , unsplit ) where +import Data.Data+import Data.Foldable import Data.Semigroup+import Data.Traversable import Data.Monoid.Action @@ -48,7 +56,7 @@ -- keeps the outermost splits and throws away everything in between. data Split m = M m | m :| m- deriving (Show)+ deriving (Data, Typeable, Show, Read, Eq, Functor, Foldable, Traversable) -- | If @m@ is a @Semigroup@, then @Split m@ is a semigroup which -- combines values on either side of a split, keeping only the@@ -58,6 +66,10 @@ (M m1) <> (m1' :| m2) = m1 <> m1' :| m2 (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
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))