{-# LANGUAGE CPP                   #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections         #-}

module Data.Monoid.SemiDirectProduct
       ( Semi, unSemi, tag, inject, untag, embed, quotient
       ) where

#if !MIN_VERSION_base(4,8,0)
import           Data.Monoid        (Monoid(..))
#endif
import           Data.Semigroup     (Semigroup(..))

import           Data.Monoid.Action

-- | The semi-direct product of monoids @s@ and @m@, which is a monoid
--   when @m@ acts on @s@. Structurally, the semi-direct product is
--   just a pair @(s,m)@.  However, the monoid instance is different.
--   In particular, we have
--
-- > (s1,m1) <> (s2,m2) = (s1 <> (m1 `act` s2), m1 <> m2)
--
--   We think of the @m@ values as a "tag" decorating the @s@ values,
--   which also affect the way the @s@ values combine.
--
--   We call the monoid @m@ the quotient monoid and the monoid @s@ the
--   sub-monoid of the semi-direct product. The semi-direct product
--   @Semi s m@ is an extension of the monoid @s@ with @m@ being the
--   quotient.
newtype Semi s m = Semi { Semi s m -> (s, m)
unSemi :: (s,m) }

instance (Semigroup m, Semigroup s, Action m s) => Semigroup (Semi s m) where
  Semi s m
x <> :: Semi s m -> Semi s m -> Semi s m
<> Semi s m
y = (s, m) -> Semi s m
forall s m. (s, m) -> Semi s m
Semi (s
xs s -> s -> s
forall a. Semigroup a => a -> a -> a
<> (m
xm m -> s -> s
forall m s. Action m s => m -> s -> s
`act` s
ys), m
xm m -> m -> m
forall a. Semigroup a => a -> a -> a
<> m
ym)
    where (s
xs, m
xm) = Semi s m -> (s, m)
forall s m. Semi s m -> (s, m)
unSemi Semi s m
x
          (s
ys, m
ym) = Semi s m -> (s, m)
forall s m. Semi s m -> (s, m)
unSemi Semi s m
y
  {-# INLINE (<>) #-}

#if MIN_VERSION_base(4,8,0)
  sconcat :: NonEmpty (Semi s m) -> Semi s m
sconcat = (Semi s m -> Semi s m -> Semi s m)
-> NonEmpty (Semi s m) -> Semi s m
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Semi s m -> Semi s m -> Semi s m
forall a. Semigroup a => a -> a -> a
(<>)
  {-# INLINE sconcat #-}
#endif

instance (Monoid m, Monoid s, Action m s) => Monoid (Semi s m) where
  mempty :: Semi s m
mempty      = (s, m) -> Semi s m
forall s m. (s, m) -> Semi s m
Semi (s
forall a. Monoid a => a
mempty, m
forall a. Monoid a => a
mempty)
  {-# INLINE mempty #-}

#if !MIN_VERSION_base(4,11,0)
  mappend x y = Semi (xs `mappend` (xm `act` ys), xm `mappend` ym)
    where (xs, xm) = unSemi x
          (ys, ym) = unSemi y

  {-# INLINE mappend #-}
#endif

  mconcat :: [Semi s m] -> Semi s m
mconcat     = (Semi s m -> Semi s m -> Semi s m)
-> Semi s m -> [Semi s m] -> Semi s m
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Semi s m -> Semi s m -> Semi s m
forall a. Monoid a => a -> a -> a
mappend Semi s m
forall a. Monoid a => a
mempty
  {-# INLINE mconcat #-}

-- | Tag an @s@ value with an @m@ value to create an element of the
--   semi-direct product.
tag :: s -> m -> Semi s m
tag :: s -> m -> Semi s m
tag s
s m
m = (s, m) -> Semi s m
forall s m. (s, m) -> Semi s m
Semi (s
s,m
m)

-- | The injection map, /i.e./ give an @s@ value a trivial tag.
inject :: Monoid m => s -> Semi s m
inject :: s -> Semi s m
inject = (s, m) -> Semi s m
forall s m. (s, m) -> Semi s m
Semi ((s, m) -> Semi s m) -> (s -> (s, m)) -> s -> Semi s m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,m
forall a. Monoid a => a
mempty)

-- | Forget the monoidal tag.  Of course, @untag . inject = id@, and
--   @untag (tag s m) = s@.
untag :: Semi s m -> s
untag :: Semi s m -> s
untag = (s, m) -> s
forall a b. (a, b) -> a
fst ((s, m) -> s) -> (Semi s m -> (s, m)) -> Semi s m -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Semi s m -> (s, m)
forall s m. Semi s m -> (s, m)
unSemi

-- | Embed a "tag" value as a value of type @Semi s m@.  Note that
--
--   @inject s <> embed m = tag s m@
--
--   and
--
--   @embed m <> inject s@ = tag (act m s) m@
--
--   The semi-direct product gives a split extension of @s@ by
--   @m@. This allows us to embed @m@ into the semi-direct
--   product. This is the embedding map. The quotient and embed maps
--   should satisfy the equation @quotient . embed = id@.
embed :: Monoid s => m -> Semi s m
embed :: m -> Semi s m
embed = (s, m) -> Semi s m
forall s m. (s, m) -> Semi s m
Semi ((s, m) -> Semi s m) -> (m -> (s, m)) -> m -> Semi s m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s
forall a. Monoid a => a
mempty,)

-- | The quotient map, /i.e./ retrieve the monoidal tag value.
quotient :: Semi s m -> m
quotient :: Semi s m -> m
quotient = (s, m) -> m
forall a b. (a, b) -> b
snd ((s, m) -> m) -> (Semi s m -> (s, m)) -> Semi s m -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Semi s m -> (s, m)
forall s m. Semi s m -> (s, m)
unSemi