{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE LambdaCase #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Monoid.Coproduct
-- Copyright   :  (c) 2011-2015 diagrams-core team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- The coproduct of two monoids.
--
-----------------------------------------------------------------------------

module Data.Monoid.Coproduct
       ( (:+:)
       , inL, inR
       , mappendL, mappendR
       , cop
       , killL, killR
       , toAltList
       , toReducedAltList
       , untangle
       , untangleSemi
       ) where

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
--   concatenation, with appropriate combining of adjacent elements
--   and removing identities when possible.
newtype m :+: n = MCo { forall m n. (m :+: n) -> [Either m n]
unMCo :: [Either m n] }
  deriving (Typeable, Int -> (m :+: n) -> ShowS
[m :+: n] -> ShowS
(m :+: n) -> String
(Int -> (m :+: n) -> ShowS)
-> ((m :+: n) -> String) -> ([m :+: n] -> ShowS) -> Show (m :+: n)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall m n. (Show m, Show n) => Int -> (m :+: n) -> ShowS
forall m n. (Show m, Show n) => [m :+: n] -> ShowS
forall m n. (Show m, Show n) => (m :+: n) -> String
$cshowsPrec :: forall m n. (Show m, Show n) => Int -> (m :+: n) -> ShowS
showsPrec :: Int -> (m :+: n) -> ShowS
$cshow :: forall m n. (Show m, Show n) => (m :+: n) -> String
show :: (m :+: n) -> String
$cshowList :: forall m n. (Show m, Show n) => [m :+: n] -> ShowS
showList :: [m :+: n] -> ShowS
Show)

instance (Eq m, Eq n, Monoid m, Monoid n) => Eq (m :+: n) where
  == :: (m :+: n) -> (m :+: n) -> Bool
(==) = [Either m n] -> [Either m n] -> Bool
forall a. Eq a => a -> a -> Bool
(==) ([Either m n] -> [Either m n] -> Bool)
-> ((m :+: n) -> [Either m n]) -> (m :+: n) -> (m :+: n) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ([Either m n] -> [Either m n]
forall m n.
(Eq m, Eq n, Monoid m, Monoid n) =>
[Either m n] -> [Either m n]
normalizeEq ([Either m n] -> [Either m n])
-> ((m :+: n) -> [Either m n]) -> (m :+: n) -> [Either m n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m :+: n) -> [Either m n]
forall m n. (m :+: n) -> [Either m n]
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 :: forall m n. (Semigroup m, Semigroup n) => (m :+: n) -> [Either m n]
toAltList (MCo [Either m n]
ms) = [Either m n] -> [Either m n]
forall m n.
(Semigroup m, Semigroup n) =>
[Either m n] -> [Either m n]
normalize [Either m n]
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 :: forall m n.
(Eq m, Eq n, Monoid m, Monoid n) =>
(m :+: n) -> [Either m n]
toReducedAltList (MCo [Either m n]
ms) = [Either m n] -> [Either m n]
forall m n.
(Eq m, Eq n, Monoid m, Monoid n) =>
[Either m n] -> [Either m n]
normalizeEq [Either m n]
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 :: forall m n.
(Semigroup m, Semigroup n) =>
[Either m n] -> [Either m n]
normalize = \case
  (Left m
e1:Left m
e2 : [Either m n]
es) -> [Either m n] -> [Either m n]
forall m n.
(Semigroup m, Semigroup n) =>
[Either m n] -> [Either m n]
normalize (m -> Either m n
forall a b. a -> Either a b
Left (m
e1 m -> m -> m
forall a. Semigroup a => a -> a -> a
<> m
e2) Either m n -> [Either m n] -> [Either m n]
forall a. a -> [a] -> [a]
: [Either m n]
es)
  (Right n
e1:Right n
e2:[Either m n]
es) -> [Either m n] -> [Either m n]
forall m n.
(Semigroup m, Semigroup n) =>
[Either m n] -> [Either m n]
normalize (n -> Either m n
forall a b. b -> Either a b
Right (n
e1 n -> n -> n
forall a. Semigroup a => a -> a -> a
<> n
e2) Either m n -> [Either m n] -> [Either m n]
forall a. a -> [a] -> [a]
: [Either m n]
es)
  []  -> []
  (Either m n
e:[Either m n]
es) -> Either m n
e Either m n -> [Either m n] -> [Either m n]
forall a. a -> [a] -> [a]
: [Either m n] -> [Either m n]
forall m n.
(Semigroup m, Semigroup n) =>
[Either m n] -> [Either m n]
normalize [Either m n]
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 :: forall m n.
(Eq m, Eq n, Monoid m, Monoid n) =>
[Either m n] -> [Either m n]
normalizeEq [Either m n]
es = ([Either m n] -> Bool)
-> ([Either m n] -> [Either m n]) -> [Either m n] -> [Either m n]
forall a. (a -> Bool) -> (a -> a) -> a -> a
until ((Either m n -> Bool) -> [Either m n] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Either m n -> Bool
forall {a} {b}.
(Eq a, Eq b, Monoid a, Monoid b) =>
Either a b -> Bool
nonIdentity) [Either m n] -> [Either m n]
reduce ([Either m n] -> [Either m n]
forall m n.
(Semigroup m, Semigroup n) =>
[Either m n] -> [Either m n]
normalize [Either m n]
es)
  where
    reduce :: [Either m n] -> [Either m n]
reduce = [Either m n] -> [Either m n]
forall m n.
(Semigroup m, Semigroup n) =>
[Either m n] -> [Either m n]
normalize ([Either m n] -> [Either m n])
-> ([Either m n] -> [Either m n]) -> [Either m n] -> [Either m n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either m n -> Bool) -> [Either m n] -> [Either m n]
forall a. (a -> Bool) -> [a] -> [a]
filter Either m n -> Bool
forall {a} {b}.
(Eq a, Eq b, Monoid a, Monoid b) =>
Either a b -> Bool
nonIdentity
    nonIdentity :: Either a b -> Bool
nonIdentity Either a b
e = Either a b
e Either a b -> Either a b -> Bool
forall a. Eq a => a -> a -> Bool
/= a -> Either a b
forall a b. a -> Either a b
Left a
forall a. Monoid a => a
mempty Bool -> Bool -> Bool
&& Either a b
e Either a b -> Either a b -> Bool
forall a. Eq a => a -> a -> Bool
/= b -> Either a b
forall a b. b -> Either a b
Right b
forall a. Monoid a => a
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
m -> k
f cop :: forall k m n. Monoid k => (m -> k) -> (n -> k) -> (m :+: n) -> k
`cop` n -> k
g = (Either m n -> k) -> [Either m n] -> k
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((m -> k) -> (n -> k) -> Either m n -> k
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either m -> k
f n -> k
g) ([Either m n] -> k)
-> ((m :+: n) -> [Either m n]) -> (m :+: n) -> k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m :+: n) -> [Either m n]
forall m n. (m :+: n) -> [Either m n]
unMCo

-- | Injection from the left monoid into a coproduct.
inL :: m -> m :+: n
inL :: forall m n. m -> m :+: n
inL m
m = [Either m n] -> m :+: n
forall m n. [Either m n] -> m :+: n
MCo [m -> Either m n
forall a b. a -> Either a b
Left m
m]

-- | Injection from the right monoid into a coproduct.
inR :: n -> m :+: n
inR :: forall n m. n -> m :+: n
inR n
n = [Either m n] -> m :+: n
forall m n. [Either m n] -> m :+: n
MCo [n -> Either m n
forall a b. b -> Either a b
Right n
n]

-- | Prepend a value from the left monoid.
mappendL :: m -> m :+: n -> m :+: n
mappendL :: forall m n. m -> (m :+: n) -> m :+: n
mappendL = (m :+: n) -> (m :+: n) -> m :+: n
forall a. Monoid a => a -> a -> a
mappend ((m :+: n) -> (m :+: n) -> m :+: n)
-> (m -> m :+: n) -> m -> (m :+: n) -> m :+: n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m -> m :+: n
forall m n. m -> m :+: n
inL

-- | Prepend a value from the right monoid.
mappendR :: n -> m :+: n -> m :+: n
mappendR :: forall n m. n -> (m :+: n) -> m :+: n
mappendR = (m :+: n) -> (m :+: n) -> m :+: n
forall a. Monoid a => a -> a -> a
mappend ((m :+: n) -> (m :+: n) -> m :+: n)
-> (n -> m :+: n) -> n -> (m :+: n) -> m :+: n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> m :+: n
forall n m. n -> m :+: n
inR

instance Semigroup (m :+: n) where
  (MCo [Either m n]
es1) <> :: (m :+: n) -> (m :+: n) -> m :+: n
<> (MCo [Either m n]
es2) = [Either m n] -> m :+: n
forall m n. [Either m n] -> m :+: n
MCo ([Either m n]
es1 [Either m n] -> [Either m n] -> [Either m n]
forall a. [a] -> [a] -> [a]
++ [Either m n]
es2)

-- | The coproduct of two monoids is itself a monoid.
instance Monoid (m :+: n) where
  mempty :: m :+: n
mempty = [Either m n] -> m :+: n
forall m n. [Either m n] -> m :+: n
MCo []
  mappend :: (m :+: n) -> (m :+: n) -> m :+: n
mappend = (m :+: n) -> (m :+: n) -> m :+: n
forall a. Semigroup a => a -> a -> a
(<>)

-- | @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 :: forall m n. Monoid m => (m :+: n) -> m
killR = m -> m
forall a. a -> a
id (m -> m) -> (n -> m) -> (m :+: n) -> m
forall k m n. Monoid k => (m -> k) -> (n -> k) -> (m :+: n) -> k
`cop` m -> n -> m
forall a b. a -> b -> a
const m
forall a. Monoid a => a
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 :: forall n m. Monoid n => (m :+: n) -> n
killL = n -> m -> n
forall a b. a -> b -> a
const n
forall a. Monoid a => a
mempty (m -> n) -> (n -> n) -> (m :+: n) -> n
forall k m n. Monoid k => (m -> k) -> (n -> k) -> (m :+: n) -> k
`cop` n -> n
forall a. a -> a
id

-- | 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 :: forall m n.
(Action m n, Monoid m, Monoid n) =>
(m :+: n) -> Semi n m
untangleSemi = m -> Semi n m
forall s m. Monoid s => m -> Semi s m
embed (m -> Semi n m) -> (n -> Semi n m) -> (m :+: n) -> Semi n m
forall k m n. Monoid k => (m -> k) -> (n -> k) -> (m :+: n) -> k
`cop` n -> Semi n m
forall m s. Monoid m => s -> Semi s m
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,
--
-- > m1 <> n1 <> m2 <> n2 <> m3 <> n3 <> ...
--
--   is sent to
--
-- > (m1 <> m2 <> m3 <> ..., (act m1 n1) <> (act (m1 <> m2) n2) <> (act (m1 <> m2 <> m3) n3) <> ...)
--
--   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 :: forall m n. (Action m n, Monoid m, Monoid n) => (m :+: n) -> (m, n)
untangle = (n, m) -> (m, n)
forall a b. (a, b) -> (b, a)
swap ((n, m) -> (m, n)) -> ((m :+: n) -> (n, m)) -> (m :+: n) -> (m, n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Semi n m -> (n, m)
forall s m. Semi s m -> (s, m)
unSemi (Semi n m -> (n, m))
-> ((m :+: n) -> Semi n m) -> (m :+: n) -> (n, m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m :+: n) -> Semi n m
forall m n.
(Action m n, Monoid m, Monoid n) =>
(m :+: n) -> Semi n m
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 :: (m :+: n) -> r -> r
act = Endo r -> r -> r
forall a. Endo a -> a -> a
appEndo (Endo r -> r -> r) -> ((m :+: n) -> Endo r) -> (m :+: n) -> r -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((r -> r) -> Endo r
forall a. (a -> a) -> Endo a
Endo ((r -> r) -> Endo r) -> (m -> r -> r) -> m -> Endo r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m -> r -> r
forall m s. Action m s => m -> s -> s
act) (m -> Endo r) -> (n -> Endo r) -> (m :+: n) -> Endo r
forall k m n. Monoid k => (m -> k) -> (n -> k) -> (m :+: n) -> k
`cop` ((r -> r) -> Endo r
forall a. (a -> a) -> Endo a
Endo ((r -> r) -> Endo r) -> (n -> r -> r) -> n -> Endo r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> r -> r
forall m s. Action m s => m -> s -> s
act))