    {-# 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))