{- | Actions of [semigroup](https://en.wikipedia.org/wiki/Semigroup_action) (SSet). -} module Data.Semigroup.SSet ( SSet (..) , rep , fact , S (..) ) where import Data.Semigroup (Endo (..), Sum (..)) 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 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 = fact 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 (Endo f) a = f a -- | -- A newtype wrapper to avoid overlapping instances. newtype S s = S { runS :: s } instance Semigroup m => Semigroup (S m) where S s <> S s' = S $ s <> s' instance Monoid m => Monoid (S m) where mempty = S mempty instance {-# OVERLAPPABLE #-} SSet m a => SSet (S m) a where act (S m) a = act m a instance {-# OVERLAPPABLE #-} SSet s a => SSet (S s) (Endo a) where act s (Endo f) = Endo $ act s . f instance Monoid s => SSet (Sum Natural) s where act (Sum 0) _ = mempty act (Sum n) s = s <> act (Sum (n - 1)) s instance Group g => SSet (Sum Integer) g where act (Sum n) g | n < 0 = invert g <> act (Sum (n + 1)) g | n > 0 = g <> 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