{-# 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 { forall m n. (m :+. n) -> NonEmpty (Either m n)
unSCo :: NonEmpty (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, Semigroup m, Semigroup n) => Eq (m :+. n) where
  == :: (m :+. n) -> (m :+. n) -> Bool
(==) = NonEmpty (Either m n) -> NonEmpty (Either m n) -> Bool
forall a. Eq a => a -> a -> Bool
(==) (NonEmpty (Either m n) -> NonEmpty (Either m n) -> Bool)
-> ((m :+. n) -> NonEmpty (Either m n))
-> (m :+. n)
-> (m :+. n)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (NonEmpty (Either m n) -> NonEmpty (Either m n)
forall m n.
(Semigroup m, Semigroup n) =>
NonEmpty (Either m n) -> NonEmpty (Either m n)
normalize (NonEmpty (Either m n) -> NonEmpty (Either m n))
-> ((m :+. n) -> NonEmpty (Either m n))
-> (m :+. n)
-> NonEmpty (Either m n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m :+. n) -> NonEmpty (Either m n)
forall m n. (m :+. n) -> NonEmpty (Either m n)
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 :: forall m n.
(Semigroup m, Semigroup n) =>
(m :+. n) -> NonEmpty (Either m n)
toAltList (SCo NonEmpty (Either m n)
ms) = NonEmpty (Either m n) -> NonEmpty (Either m n)
forall m n.
(Semigroup m, Semigroup n) =>
NonEmpty (Either m n) -> NonEmpty (Either m n)
normalize NonEmpty (Either m n)
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 :: forall m n.
(Semigroup m, Semigroup n) =>
NonEmpty (Either m n) -> NonEmpty (Either m n)
normalize = \case
  Left m
e1 :| Left m
e2 : [Either m n]
es -> NonEmpty (Either m n) -> NonEmpty (Either m n)
forall m n.
(Semigroup m, Semigroup n) =>
NonEmpty (Either m n) -> NonEmpty (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] -> NonEmpty (Either m n)
forall a. a -> [a] -> NonEmpty a
:| [Either m n]
es)
  Right n
e1 :| Right n
e2 : [Either m n]
es -> NonEmpty (Either m n) -> NonEmpty (Either m n)
forall m n.
(Semigroup m, Semigroup n) =>
NonEmpty (Either m n) -> NonEmpty (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] -> NonEmpty (Either m n)
forall a. a -> [a] -> NonEmpty a
:| [Either m n]
es)
  Either m n
e1 :| [Either m n]
es1 -> case [Either m n]
es1 of
    Either m n
e2 : [Either m n]
es2 -> (Either m n
e1 Either m n -> [Either m n] -> NonEmpty (Either m n)
forall a. a -> [a] -> NonEmpty a
:| []) NonEmpty (Either m n)
-> NonEmpty (Either m n) -> NonEmpty (Either m n)
forall a. Semigroup a => a -> a -> a
<> NonEmpty (Either m n) -> NonEmpty (Either m n)
forall m n.
(Semigroup m, Semigroup n) =>
NonEmpty (Either m n) -> NonEmpty (Either m n)
normalize (Either m n
e2 Either m n -> [Either m n] -> NonEmpty (Either m n)
forall a. a -> [a] -> NonEmpty a
:| [Either m n]
es2)
    [] -> Either m n
e1 Either m n -> [Either m n] -> NonEmpty (Either m n)
forall a. a -> [a] -> NonEmpty a
:| []

-- | 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
m -> k
f cop :: forall k m n. Semigroup k => (m -> k) -> (n -> k) -> (m :+. n) -> k
`cop` n -> k
g = (Either m n -> k) -> NonEmpty (Either m n) -> k
forall m a. Semigroup m => (a -> m) -> NonEmpty a -> m
forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 ((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) (NonEmpty (Either m n) -> k)
-> ((m :+. n) -> NonEmpty (Either m n)) -> (m :+. n) -> k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m :+. n) -> NonEmpty (Either m n)
forall m n. (m :+. n) -> NonEmpty (Either m n)
unSCo

-- | Injection from the left semigroup into a coproduct.
inL :: m -> m :+. n
inL :: forall m n. m -> m :+. n
inL m
m = NonEmpty (Either m n) -> m :+. n
forall m n. NonEmpty (Either m n) -> m :+. n
SCo (m -> Either m n
forall a b. a -> Either a b
Left m
m Either m n -> [Either m n] -> NonEmpty (Either m n)
forall a. a -> [a] -> NonEmpty a
:| [])

-- | Injection from the right semigroup into a coproduct.
inR :: n -> m :+. n
inR :: forall n m. n -> m :+. n
inR n
n = NonEmpty (Either m n) -> m :+. n
forall m n. NonEmpty (Either m n) -> m :+. n
SCo (n -> Either m n
forall a b. b -> Either a b
Right n
n Either m n -> [Either m n] -> NonEmpty (Either m n)
forall a. a -> [a] -> NonEmpty a
:| [])

-- | 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 :: forall m n. (Monoid m, Monoid n) => (m :+. n) -> m :+: n
toMonoid = m -> m :+: n
forall m n. m -> m :+: n
M.inL (m -> m :+: n) -> (n -> m :+: n) -> (m :+. n) -> m :+: n
forall k m n. Semigroup k => (m -> k) -> (n -> k) -> (m :+. n) -> k
`cop` n -> m :+: n
forall n m. n -> m :+: n
M.inR

instance Semigroup (m :+. n) where
  (SCo NonEmpty (Either m n)
es1) <> :: (m :+. n) -> (m :+. n) -> m :+. n
<> (SCo NonEmpty (Either m n)
es2) = NonEmpty (Either m n) -> m :+. n
forall m n. NonEmpty (Either m n) -> m :+. n
SCo (NonEmpty (Either m n)
es1 NonEmpty (Either m n)
-> NonEmpty (Either m n) -> NonEmpty (Either m n)
forall a. Semigroup a => a -> a -> a
<> NonEmpty (Either m n)
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 :: (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. Semigroup 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))