{-# 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 (..))
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 {-# OVERLAPPING #-} 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 }
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__ <= 822
S s `mappend` S s' = S $ s `mappend` s'
#endif
-- 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 {-# OVERLAPPABLE #-} SSet s a => SSet 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 `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