{-# 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 { forall m n. (m :+: n) -> [Either m n]
unMCo :: [Either m n] }
  deriving (Typeable, Int -> (m :+: n) -> ShowS
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 :: forall m n. m -> m :+: n
inL m
m = forall m n. [Either m n] -> m :+: n
MCo [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 = forall m n. [Either m n] -> m :+: n
MCo [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 = forall a. Monoid a => a -> a -> a
mappend forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. Monoid a => a -> a -> a
mappend forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall m n. [Either m n] -> m :+: n
MCo ([Either m n]
es1 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 = forall m n. [Either m n] -> m :+: n
MCo []
  mappend :: (m :+: n) -> (m :+: n) -> m :+: n
mappend = 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 = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [Either a b] -> [a]
lefts forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall n m. Monoid n => (m :+: n) -> n
killL = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [Either a b] -> [b]
rights forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall m n. (Action m n, Monoid m, Monoid n) => (m :+: n) -> (m, n)
untangle (MCo [Either m n]
elts) = forall {m} {b}.
(Monoid m, Monoid b, Action m b) =>
(m, b) -> [Either m b] -> (m, b)
untangle' forall a. Monoid a => a
mempty [Either m n]
elts
  where untangle' :: (m, b) -> [Either m b] -> (m, b)
untangle' (m, b)
cur [] = (m, b)
cur
        untangle' (m
curM, b
curN) (Left m
m : [Either m b]
elts')  = (m, b) -> [Either m b] -> (m, b)
untangle' (m
curM forall a. Monoid a => a -> a -> a
`mappend` m
m, b
curN) [Either m b]
elts'
        untangle' (m
curM, b
curN) (Right b
n : [Either m b]
elts') = (m, b) -> [Either m b] -> (m, b)
untangle' (m
curM, b
curN forall a. Monoid a => a -> a -> a
`mappend` forall m s. Action m s => m -> s -> s
act m
curM b
n) [Either m b]
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 = forall a. Endo a -> a -> a
appEndo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> a) -> Endo a
Endo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall m s. Action m s => m -> s -> s
act forall m s. Action m s => m -> s -> s
act) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m n. (m :+: n) -> [Either m n]
unMCo