diff --git a/TypeCompose.cabal b/TypeCompose.cabal index cea3f1a..1b8aa89 100644 --- a/TypeCompose.cabal +++ b/TypeCompose.cabal @@ -1,5 +1,5 @@ Name: TypeCompose -Version: 0.9.11 +Version: 0.9.12 Synopsis: Type composition classes & instances Category: Composition, Control Cabal-Version: >= 1.6 diff --git a/src/Control/Compose.hs b/src/Control/Compose.hs index 264e8fc..4d4a5fb 100644 --- a/src/Control/Compose.hs +++ b/src/Control/Compose.hs @@ -87,6 +87,7 @@ import Control.Arrow import Data.Orphans () import Data.Monoid +import qualified Data.Semigroup as Sem import Data.Foldable import Data.Traversable import Control.Applicative @@ -592,10 +593,12 @@ inFlip3 f (Flip ar) = inFlip2 (f ar) instance Arrow arr => ContraFunctor (Flip arr b) where contraFmap h (Flip f) = Flip (arr h >>> f) +instance (Applicative (j a), Sem.Semigroup o) => Sem.Semigroup (Flip j o a) where + (<>) = inFlip2 (liftA2 (Sem.<>)) + -- Useful for (~>) = (->). Maybe others. instance (Applicative (j a), Monoid o) => Monoid (Flip j o a) where mempty = Flip (pure mempty) - mappend = inFlip2 (liftA2 mappend) -- TODO: generalize (->) to (~>) with Applicative_f (~>) instance Monoid o => Monoid_f (Flip (->) o) where @@ -642,9 +645,11 @@ inApp2 :: (f a -> f' a' -> f'' a'') -> (App f a -> App f' a' -> App f'' a'') inApp2 h (App fa) = inApp (h fa) -- Example: App IO () +instance (Applicative f, Sem.Semigroup m) => Sem.Semigroup (App f m) where + (<>) = inApp2 (liftA2 (Sem.<>)) + instance (Applicative f, Monoid m) => Monoid (App f m) where mempty = App (pure mempty ) - mappend = inApp2 (liftA2 mappend) -- App a `mappend` App b = App (liftA2 mappend a b) @@ -848,6 +853,7 @@ newtype Arrw j f g a = Arrw { unArrw :: f a `j` g a } -- deriving Monoid -- For ghc-6.6, use the "deriving" above, but for 6.8 use the "deriving" below. +deriving instance Sem.Semigroup (f a `j` g a) => Sem.Semigroup (Arrw j f g a) deriving instance Monoid (f a `j` g a) => Monoid (Arrw j f g a) -- Replace with generalized bijection? diff --git a/src/Data/CxMonoid.hs b/src/Data/CxMonoid.hs index 8758449..79fcbb9 100644 --- a/src/Data/CxMonoid.hs +++ b/src/Data/CxMonoid.hs @@ -16,6 +16,7 @@ module Data.CxMonoid (MonoidDict, CxMonoid(..), biCxMonoid) where import Data.Monoid (Monoid(..)) +import qualified Data.Semigroup as Sem import Data.Bijection import Data.Title @@ -30,10 +31,12 @@ newtype CxMonoid a = CxMonoid { unCxMonoid :: MonoidDict a -> a } biCxMonoid :: (MonoidDict a -> a) :<->: CxMonoid a biCxMonoid = Bi CxMonoid unCxMonoid +instance Sem.Semigroup (CxMonoid a) where + CxMonoid f <> CxMonoid g = + CxMonoid (\ md@(_,op) -> f md `op` g md) + instance Monoid (CxMonoid a) where mempty = CxMonoid (\ (e,_) -> e) - CxMonoid f `mappend` CxMonoid g = - CxMonoid (\ md@(_,op) -> f md `op` g md) -- Exploit the function instance of 'Title' instance Title a => Title (CxMonoid a) where