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

-----------------------------------------------------------------------------
-- |
-- 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
       , killL, killR
       , untangle

       ) where

import Data.Either        (lefts, rights)
import Data.Semigroup
import Data.Typeable

import Data.Monoid.Action

-- | @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
--   when possible.
newtype m :+: n = MCo { (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
showList :: [m :+: n] -> ShowS
$cshowList :: forall m n. (Show m, Show n) => [m :+: n] -> ShowS
show :: (m :+: n) -> String
$cshow :: forall m n. (Show m, Show n) => (m :+: n) -> String
showsPrec :: Int -> (m :+: n) -> ShowS
$cshowsPrec :: forall m n. (Show m, Show n) => Int -> (m :+: n) -> ShowS
Show)

-- 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.

-- | Injection from the left monoid into a coproduct.
inL :: m -> m :+: n
inL :: 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 :: 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 :: 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 :: 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

{-
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 [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 :: (m :+: n) -> m
killR = [m] -> m
forall a. Monoid a => [a] -> a
mconcat ([m] -> m) -> ((m :+: n) -> [m]) -> (m :+: n) -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either m n] -> [m]
forall a b. [Either a b] -> [a]
lefts ([Either m n] -> [m])
-> ((m :+: n) -> [Either m n]) -> (m :+: n) -> [m]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m :+: n) -> [Either m n]
forall m n. (m :+: n) -> [Either m n]
unMCo

-- | @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 :: (m :+: n) -> n
killL = [n] -> n
forall a. Monoid a => [a] -> a
mconcat ([n] -> n) -> ((m :+: n) -> [n]) -> (m :+: n) -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either m n] -> [n]
forall a b. [Either a b] -> [b]
rights ([Either m n] -> [n])
-> ((m :+: n) -> [Either m n]) -> (m :+: n) -> [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

-- | Take 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 :: (m :+: n) -> (m, n)
untangle (MCo [Either m n]
elts) = (m, n) -> [Either m n] -> (m, n)
forall m a.
(Monoid m, Monoid a, Action m a) =>
(m, a) -> [Either m a] -> (m, a)
untangle' (m, n)
forall a. Monoid a => a
mempty [Either m n]
elts
  where untangle' :: (m, a) -> [Either m a] -> (m, a)
untangle' (m, a)
cur [] = (m, a)
cur
        untangle' (m
curM, a
curN) (Left m
m : [Either m a]
elts')  = (m, a) -> [Either m a] -> (m, a)
untangle' (m
curM m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` m
m, a
curN) [Either m a]
elts'
        untangle' (m
curM, a
curN) (Right a
n : [Either m a]
elts') = (m, a) -> [Either m a] -> (m, a)
untangle' (m
curM, a
curN a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` m -> a -> a
forall m s. Action m s => m -> s -> s
act m
curM a
n) [Either m a]
elts'

-- | 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
. [Endo r] -> Endo r
forall a. Monoid a => [a] -> a
mconcat ([Endo r] -> Endo r)
-> ((m :+: n) -> [Endo r]) -> (m :+: n) -> Endo r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either m n -> Endo r) -> [Either m n] -> [Endo r]
forall a b. (a -> b) -> [a] -> [b]
map ((r -> r) -> Endo r
forall a. (a -> a) -> Endo a
Endo ((r -> r) -> Endo r)
-> (Either m n -> r -> r) -> Either m n -> Endo r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m -> r -> r) -> (n -> r -> r) -> Either m n -> r -> r
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either m -> r -> r
forall m s. Action m s => m -> s -> s
act n -> r -> r
forall m s. Action m s => m -> s -> s
act) ([Either m n] -> [Endo r])
-> ((m :+: n) -> [Either m n]) -> (m :+: n) -> [Endo r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m :+: n) -> [Either m n]
forall m n. (m :+: n) -> [Either m n]
unMCo