module Data.Monoid.RightAction.Coproduct where

-- base
import Data.Foldable (Foldable (foldl'), toList)
import Data.Typeable (Typeable)
import Prelude hiding (Foldable (..))

-- containers
import Data.Sequence (Seq)

-- changeset
import Data.Monoid.RightAction

{- | The coproduct of two monoids is a monoid that can contain values of either constituent.

This is useful if you have two different actions on the same state type,
and want to combine them.

Note: The multiplication of this monoid is formal, so the same semantic values may have differing representations.
Therefore it's not advised to inspect the contents of a coproduct.
You should usually want to use 'normaliseCoproduct'.
-}
newtype (:+:) m n = Coproduct {forall m n. (m :+: n) -> Seq (Either m n)
getCoproduct :: Seq (Either m n)}
  deriving (Typeable, NonEmpty (m :+: n) -> m :+: n
(m :+: n) -> (m :+: n) -> m :+: n
((m :+: n) -> (m :+: n) -> m :+: n)
-> (NonEmpty (m :+: n) -> m :+: n)
-> (forall b. Integral b => b -> (m :+: n) -> m :+: n)
-> Semigroup (m :+: n)
forall b. Integral b => b -> (m :+: n) -> m :+: n
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall m n. NonEmpty (m :+: n) -> m :+: n
forall m n. (m :+: n) -> (m :+: n) -> m :+: n
forall m n b. Integral b => b -> (m :+: n) -> m :+: n
$c<> :: forall m n. (m :+: n) -> (m :+: n) -> m :+: n
<> :: (m :+: n) -> (m :+: n) -> m :+: n
$csconcat :: forall m n. NonEmpty (m :+: n) -> m :+: n
sconcat :: NonEmpty (m :+: n) -> m :+: n
$cstimes :: forall m n b. Integral b => b -> (m :+: n) -> m :+: n
stimes :: forall b. Integral b => b -> (m :+: n) -> m :+: n
Semigroup, Semigroup (m :+: n)
m :+: n
Semigroup (m :+: n) =>
(m :+: n)
-> ((m :+: n) -> (m :+: n) -> m :+: n)
-> ([m :+: n] -> m :+: n)
-> Monoid (m :+: n)
[m :+: n] -> m :+: n
(m :+: n) -> (m :+: n) -> m :+: n
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall m n. Semigroup (m :+: n)
forall m n. m :+: n
forall m n. [m :+: n] -> m :+: n
forall m n. (m :+: n) -> (m :+: n) -> m :+: n
$cmempty :: forall m n. m :+: n
mempty :: m :+: n
$cmappend :: forall m n. (m :+: n) -> (m :+: n) -> m :+: n
mappend :: (m :+: n) -> (m :+: n) -> m :+: n
$cmconcat :: forall m n. [m :+: n] -> m :+: n
mconcat :: [m :+: n] -> m :+: n
Monoid)

{- | Construct a coproduct value from the left constituent monoid.

Semantically, this is a monoid homomorphism: @inL m1 <> inL m2@ acts the same as @inL (m1 <> m2).@
-}
inL :: m -> m :+: n
inL :: forall m n. m -> m :+: n
inL = Seq (Either m n) -> m :+: n
forall m n. Seq (Either m n) -> m :+: n
Coproduct (Seq (Either m n) -> m :+: n)
-> (m -> Seq (Either m n)) -> m -> m :+: n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either m n -> Seq (Either m n)
forall a. a -> Seq a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either m n -> Seq (Either m n))
-> (m -> Either m n) -> m -> Seq (Either m n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m -> Either m n
forall a b. a -> Either a b
Left

{- | Construct a coproduct value from the right constituent monoid.

Semantically, this is a monoid homomorphism: @inR m1 <> inR m2@ acts the same as @inR (m1 <> m2).@
-}
inR :: n -> m :+: n
inR :: forall n m. n -> m :+: n
inR = Seq (Either m n) -> m :+: n
forall m n. Seq (Either m n) -> m :+: n
Coproduct (Seq (Either m n) -> m :+: n)
-> (n -> Seq (Either m n)) -> n -> m :+: n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either m n -> Seq (Either m n)
forall a. a -> Seq a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either m n -> Seq (Either m n))
-> (n -> Either m n) -> n -> Seq (Either m n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> Either m n
forall a b. b -> Either a b
Right

{- | Brings a coproduct into a canonical form, which is an alternating list of 'Left's and 'Right's.

(The list may start with a 'Left' or a 'Right', or be empty.)
-}
normaliseCoproduct :: (Semigroup m, Semigroup n) => m :+: n -> [Either m n]
normaliseCoproduct :: forall m n. (Semigroup m, Semigroup n) => (m :+: n) -> [Either m n]
normaliseCoproduct = [Either m n] -> [Either m n]
forall {a} {b}.
(Semigroup a, Semigroup b) =>
[Either a b] -> [Either a b]
normaliseCoproduct' ([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
. Seq (Either m n) -> [Either m n]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq (Either m n) -> [Either m n])
-> ((m :+: n) -> Seq (Either m n)) -> (m :+: n) -> [Either m n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m :+: n) -> Seq (Either m n)
forall m n. (m :+: n) -> Seq (Either m n)
getCoproduct
  where
    normaliseCoproduct' :: [Either a b] -> [Either a b]
normaliseCoproduct' (Left a
m1 : Left a
m2 : [Either a b]
emns) = [Either a b] -> [Either a b]
normaliseCoproduct' ([Either a b] -> [Either a b]) -> [Either a b] -> [Either a b]
forall a b. (a -> b) -> a -> b
$ a -> Either a b
forall a b. a -> Either a b
Left (a
m1 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
m2) Either a b -> [Either a b] -> [Either a b]
forall a. a -> [a] -> [a]
: [Either a b]
emns
    normaliseCoproduct' (Right b
n1 : Right b
n2 : [Either a b]
emns) = [Either a b] -> [Either a b]
normaliseCoproduct' ([Either a b] -> [Either a b]) -> [Either a b] -> [Either a b]
forall a b. (a -> b) -> a -> b
$ b -> Either a b
forall a b. b -> Either a b
Right (b
n1 b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
n2) Either a b -> [Either a b] -> [Either a b]
forall a. a -> [a] -> [a]
: [Either a b]
emns
    normaliseCoproduct' [] = []
    normaliseCoproduct' (Either a b
emn : [Either a b]
emns) = Either a b
emn Either a b -> [Either a b] -> [Either a b]
forall a. a -> [a] -> [a]
: [Either a b] -> [Either a b]
normaliseCoproduct' [Either a b]
emns

-- | Coproducts are compared after normalising
instance (Eq m, Eq n, Semigroup m, Semigroup n) => Eq (m :+: n) where
  m :+: n
mns1 == :: (m :+: n) -> (m :+: n) -> Bool
== m :+: n
mns2 = (m :+: n) -> [Either m n]
forall m n. (Semigroup m, Semigroup n) => (m :+: n) -> [Either m n]
normaliseCoproduct m :+: n
mns1 [Either m n] -> [Either m n] -> Bool
forall a. Eq a => a -> a -> Bool
== (m :+: n) -> [Either m n]
forall m n. (Semigroup m, Semigroup n) => (m :+: n) -> [Either m n]
normaliseCoproduct m :+: n
mns2

instance (RightAction m s, RightAction n s) => RightAction (m :+: n) s where
  actRight :: s -> (m :+: n) -> s
actRight s
s m :+: n
mns = (s -> Either m n -> s) -> s -> Seq (Either m n) -> s
forall b a. (b -> a -> b) -> b -> Seq a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Either m n -> s -> s) -> s -> Either m n -> s
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Either m n -> s -> s) -> s -> Either m n -> s)
-> (Either m n -> s -> s) -> s -> Either m n -> s
forall a b. (a -> b) -> a -> b
$ (m -> s -> s) -> (n -> s -> s) -> Either m n -> s -> s
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((s -> m -> s) -> m -> s -> s
forall a b c. (a -> b -> c) -> b -> a -> c
flip s -> m -> s
forall m s. RightAction m s => s -> m -> s
actRight) ((s -> n -> s) -> n -> s -> s
forall a b c. (a -> b -> c) -> b -> a -> c
flip s -> n -> s
forall m s. RightAction m s => s -> m -> s
actRight)) s
s ((m :+: n) -> Seq (Either m n)
forall m n. (m :+: n) -> Seq (Either m n)
getCoproduct m :+: n
mns)