{-# LANGUAGE DeriveFunctor #-}
{- |
    Monoid and [group actions](https://en.wikipedia.org/wiki/Group_action) (M-Sets and G-Sets).
    The category of @MSet@s (and @GSet@s) is monadic (unlike the category of @SSet@s).
 -}
module Data.Monoid.MSet
    ( MSet
    , SSet (..)
    , Endo (..)
    , rep
    , fact
    , FreeMSet (..)
    , hoistFreeMSet
    , foldrMSet
    , S (..)
    ) where

import           Control.Monad (ap)
import           Data.Constraint (Dict (..))
import           Data.Functor.Const (Const (..))
import           Data.Functor.Identity (Identity (..))
import qualified Data.Functor.Product as Functor (Product)
import qualified Data.Functor.Sum as Functor (Sum)
import           Data.List.NonEmpty (NonEmpty)
import           Data.Monoid (Monoid, Endo (..), Sum (..))
import           Data.Natural (Natural)
import           Data.Ord (Down)
import           Data.Set (Set)

import           Data.Semigroup.SSet (SSet (..), S (..), fact, rep)
import           Data.Algebra.Free
    ( AlgebraType
    , AlgebraType0
    , FreeAlgebra (..)
    , Proof (..)
    , bindFree
    , foldrFree
    )

-- |
-- Lawful instance should satisfy:
--
-- prop> act mempty = id
-- prop> g `act` h `act` a = g <> h `act` a
--
-- This is the same as to say that `act` is a monoid homomorphism from @m@ to
-- the monoid of endomorphisms of @a@ (i.e. maps from @a@ to @a@).
--
-- Note that if @g@ is a @'Group'@ then an @MSet@ is simply a @GSet@, this
-- is because monoids and groups share the same morphisms (a monoid homomorphis
-- between groups necessarily preserves inverses).
class (Monoid m, SSet m a) => MSet m a

instance Monoid m => MSet m m

instance (MSet m a, MSet m b) => MSet m (a, b)

instance (MSet m a, MSet m b, MSet m c) => MSet m (a, b, c)

instance (MSet m a, MSet m b, MSet m c, MSet m d) => MSet m (a, b, c, d)

instance (MSet m a, MSet m b, MSet m c, MSet m d, MSet m e) => MSet m (a, b, c, d, e)

instance (MSet m a, MSet m b, MSet m c, MSet m d, MSet m e, MSet m f) => MSet m (a, b, c, d, e, f)

instance (MSet m a, MSet m b, MSet m c, MSet m d, MSet m e, MSet m f, MSet m h) => MSet m (a, b, c, d, e, f, h)

instance (MSet m a, MSet m b, MSet m c, MSet m d, MSet m e, MSet m f, MSet m h, MSet m i) => MSet m (a, b, c, d, e, f, h, i)

instance MSet m a => MSet m [a]

instance MSet m a => MSet m (NonEmpty a)

instance (MSet m a, Ord a) => MSet m (Set a)

{--
  - instance {-# OVERLAPPABLE #-} (Functor f, MSet m a) => MSet m (f a) where
  -     act m fa = fmap (act m) fa
  --}

instance MSet m a => MSet m (Identity a)

instance MSet m a => MSet (Identity m) a

instance MSet m a => MSet m (Maybe a)

instance MSet m b => MSet m (Either a b)

instance MSet m a => MSet m (Down a)

instance MSet m a => MSet m (IO a)

instance MSet m b => MSet m (a -> b)

instance MSet (Endo a) a

instance {-# OVERLAPPABLE #-} MSet m a => MSet (S m) a

instance {-# OVERLAPPING #-} MSet m b => MSet (S m) (Endo b)

instance Monoid m => MSet (Sum Natural) m

instance MSet m a => MSet m (Const a b)

instance (Functor f, Functor h, MSet m a) => MSet m (Functor.Product f h a)

instance (Functor f, Functor h, MSet m a) => MSet m (Functor.Sum f h a)

newtype FreeMSet m a = FreeMSet { runFreeMSet :: (m, a) }
    deriving (Show, Ord, Eq, Functor)

hoistFreeMSet
    :: (m -> n)       -- ^ monoid homomorphism
    -> FreeMSet m a
    -> FreeMSet n a
hoistFreeMSet f (FreeMSet (m, a)) = FreeMSet (f m, a)

instance Monoid m => Applicative (FreeMSet m) where
    pure  = returnFree
    (<*>) = ap

instance Monoid m => Monad (FreeMSet m) where
    return = returnFree
    (>>=)  = bindFree

instance Semigroup m => SSet m (FreeMSet m a) where
    act m (FreeMSet (h, a)) = FreeMSet $ (m <> h, a)

instance Monoid m => MSet m (FreeMSet m a)

-- |
-- @'foldrFree'@ for @'FreeMSet'@
foldrMSet :: forall m a b . MSet m b => (a -> b -> b) -> b -> (m, a) -> b
foldrMSet f b (m, a) = foldrFree f b (FreeMSet (S m, a))

type instance AlgebraType0 (FreeMSet m) a = ()
type instance AlgebraType  (FreeMSet m) a = MSet m a
instance Monoid m => FreeAlgebra (FreeMSet m) where
    returnFree a = FreeMSet (mempty, a)
    foldMapFree f (FreeMSet (m, a)) = act m (f a)
    proof  = Proof Dict
    forget = Proof Dict