SSet.hs

{-# LANGUAGE CPP #-}
{- |
    Actions of [semigroup](https://en.wikipedia.org/wiki/Semigroup_action) (SSet).
 -}
module Data.Semigroup.SSet
    ( SSet (..)
    , rep
    , fact
    , S (..)
    ) where

import           Data.Semigroup (Semigroup (..), Endo (..), Sum (..), Product (..))
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.Group (Group (..))
import           Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import           Data.Natural (Natural)
import           Data.Ord (Down (..))
import           Data.Set (Set)
import qualified Data.Set as Set

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

rep :: SSet s a => s -> Endo a
rep s = Endo (act s)

instance {-# OVERLAPPABLE #-} Semigroup s => SSet (s) (s) where
    act = (<>)

instance (SSet s a, SSet s b) => SSet s (a, b) where
    act s (a, b) = (act s a, act s b)

instance (SSet s a, SSet s b, SSet s c) => SSet s (a, b, c) where
    act s (a, b, c) = (act s a, act s b, act s c)

instance (SSet s a, SSet s b, SSet s c, SSet s d) => SSet s (a, b, c, d) where
    act s (a, b, c, d) = (act s a, act s b, act s c, act s d)

instance (SSet s a, SSet s b, SSet s c, SSet s d, SSet s e) => SSet s (a, b, c, d, e) where
    act s (a, b, c, d, e) = (act s a, act s b, act s c, act s d, act s e)

instance (SSet s a, SSet s b, SSet s c, SSet s d, SSet s e, SSet s f) => SSet s (a, b, c, d, e, f) where
    act s (a, b, c, d, e, f) = (act s a, act s b, act s c, act s d, act s e, act s f)

instance (SSet s a, SSet s b, SSet s c, SSet s d, SSet s e, SSet s f, SSet s h) => SSet s (a, b, c, d, e, f, h) where
    act s (a, b, c, d, e, f, h) = (act s a, act s b, act s c, act s d, act s e, act s f, act s h)

instance (SSet s a, SSet s b, SSet s c, SSet s d, SSet s e, SSet s f, SSet s h, SSet s i) => SSet s (a, b, c, d, e, f, h, i) where
    act s (a, b, c, d, e, f, h, i) = (act s a, act s b, act s c, act s d, act s e, act s f, act s h, act s i)

instance SSet s a => SSet s [a] where
    act s = map (act s)

instance SSet s a => SSet s (NonEmpty a) where
    act s as = NE.map (act s) as

instance (SSet s a, Ord a) => SSet s (Set a) where
    act s as = Set.map (act s) as

-- |
-- Any @'SSet'@ wrapped in a functor is a valid @'SSet'@.
fact :: (Functor f, SSet s a) => s -> f a -> f a
fact s = fmap (act s)

instance SSet s a => SSet s (Identity a) where
    act = fact

instance SSet s a => SSet (Identity s) a where
    act (Identity f) a = f `act` a

instance SSet s a => SSet s (Maybe a) where
    act = fact

instance SSet s b => SSet s (Either a b) where
    act = fact

instance SSet s a => SSet s (Down a) where
    act s (Down a) =  Down (act s a)

instance SSet s a => SSet s (IO a) where
    act = fact

instance SSet s b => SSet s (a -> b) where
    act = fact

instance SSet (Endo a) a where
    act = appEndo

-- |
-- A newtype wrapper to avoid overlapping instances.
newtype S s = S { runS :: s }
  deriving (Eq, Show, Ord)

instance Semigroup m => Semigroup (S m) where
    S s <> S s' = S $ s <> s'

instance Monoid m => Monoid (S m) where
    mempty = S mempty
#if __GLASGOW_HASKELL__ < 804
    S s `mappend` S s' = S $ s `mappend` s'
#endif

instance SSet s a => SSet (S s) (Endo a) where
    act (S s) (Endo f) = Endo $ act s . f

instance Monoid s => SSet (Sum Natural) s where
    act (Sum 0) _ = mempty
    act (Sum n) s = s `mappend` act (Sum (n - 1)) s

instance Group g => SSet (Sum Integer) g where
    act (Sum n) g | n < 0      = invert g `mappend` act (Sum (n + 1)) g
                  | n > 0      = g `mappend` act (Sum (n - 1)) g
                  | otherwise  = mempty

instance SSet s a => SSet s (Const a b) where
    act s (Const a) = Const $ s `act` a

instance (Functor f, Functor h, SSet s a) => SSet s (Functor.Product f h a) where
    act = fact

instance (Functor f, Functor h, SSet s a) => SSet s (Functor.Sum f h a) where
    act = fact

instance Num s => SSet (Sum s) s where
    act (Sum n) s = n + s

instance Num s => SSet (Product s) s where
    act (Product n) s = n * s