lr-acts 0.0 → 0.0.1
raw patch · 14 files changed
+2132/−2092 lines, 14 filessetup-changedPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +21/−17
- LICENSE +28/−28
- README.md +107/−107
- Setup.hs +2/−2
- benchmark/Main.hs +37/−37
- lr-acts.cabal +2/−2
- src/Data/Act.hs +79/−79
- src/Data/Act/Act.hs +773/−773
- src/Data/Act/Cyclic.hs +494/−494
- src/Data/Act/Torsor.hs +210/−184
- src/Data/Semidirect.hs +15/−15
- src/Data/Semidirect/Lazy.hs +144/−144
- src/Data/Semidirect/Strict.hs +144/−144
- test/Spec.hs +76/−66
CHANGELOG.md view
@@ -1,17 +1,21 @@-# Changelog for `lr-acts`--All notable changes to this project will be documented in this file.--The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),-and this project adheres to the-[Haskell Package Versioning Policy](https://pvp.haskell.org/).--## 0.0 - 2025-05-22--### Added--- Left and right actions-- Semigroup, monoid and group actions-- Cyclic and generated actions-- Torsors-- Semidirect products+# Changelog for `lr-acts` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## 0.0 - 2025-05-22 + +### Added + +- Left and right actions +- Semigroup, monoid and group actions +- Cyclic and generated actions +- Torsors +- Semidirect products + +## 0.0.1 - 2024-05-24 + +- Fix deriving mechanism for Torsor instances
LICENSE view
@@ -1,28 +1,28 @@-BSD 3-Clause License--Copyright (c) 2024, Alice Rixte--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--1. Redistributions of source code must retain the above copyright notice, this- list of conditions and the following disclaimer.--2. Redistributions in binary form must reproduce the above copyright notice,- this list of conditions and the following disclaimer in the documentation- and/or other materials provided with the distribution.--3. Neither the name of the copyright holder nor the names of its- contributors may be used to endorse or promote products derived from- this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"-AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR-SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER-CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,-OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+BSD 3-Clause License + +Copyright (c) 2024, Alice Rixte + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.md view
@@ -1,107 +1,107 @@-# lr-acts--[](https://haskell.org) [](https://hackage.haskell.org/package/lr-acts) [](https://github.com/AliceRixte/lr-acts/LICENSE)---## Features--* Left and right actions of- * sets- * semigroup- * monoids- * groups-* Semidirect product-* Group torsors-* Cyclic actions-* Generated actions---### Fine-grained class hierarchy--Left and right actions with a fine-grained class hierarchy for action properties. For left actions, here are the provided classes :--``` haskell-class LAct -- Set action- => LActSg -- Semigroup action- => LActMn -- Monoid action- => LTorsor -- Torsor- => LActDistrib -- Distributive action- => LActNeutral -- Neutral preserving action- => LActGen -- Action generated by a set- => LActCyclic -- Cyclic action (generated by a single element)--```--### Derive most of you action instances--The acting type is always the second parameter. Use this with `DerivingVia` language extension to derive action instances :--``` haskell-import Data.Act-import Data.Semigroup--newtype Seconds = Seconds Float-newtype Duration = Duration Seconds- deriving (Semigroup, Monoid) via (Sum Float)-- deriving (LAct Seconds, RAct Seconds) via (ActSelf' (Sum Float))- -- derives LAct Second Duration-- deriving (LAct [Seconds], RAct [Seconds]) via (ActMap (ActSelf' (Sum Float)))- -- derives LAct [Second] Duration--newtype Durations = Durations [Duration]- deriving (LAct Seconds, RAct Seconds) via (ActFold [Duration])- -- derives LAct Second Durations--```--``` haskell-ghci> Duration 2 `lact` Seconds 3-Seconds 5.0--ghci> Duration 2 `lact` [Seconds 3, Seconds 4]-[Seconds 5.0,Seconds 6.0]--ghci> [Duration 2, Duration 3] `lact` Seconds 4-[Seconds 5.0,Seconds 6.0]--ghci> Durations [Duration 2, Duration 3] `lact` Seconds 4-Seconds 9.0-```--### Semidirect products--This fine-grained hierarchy allows to check for associativity and existence of neutral elements using _semidirect products_.--``` haskell->>> import Data.Semigroup->>> LSemidirect (Sum 1) (Product 2) <> LSemidirect (Sum (3 :: Int)) (Product (4 :: Int))-LSemidirect {lactee = Sum {getSum = 7}, lactor = Product {getProduct = 8}}-```--GHC will complain when using a semigroup action that is not distributive :--```haskell->>> LSemidirect (Sum 1) (Sum 2) <> LSemidirect (Sum (3 :: Int)) (Sum (4 :: Int))-No instance for `LActDistrib (Sum Int) (Sum Int)'- arising from a use of `<>'-```--## Comparison with other action libraries--Here is a list of action libraries on hackage :--- [monoid-extra](https://github.com/diagrams/monoid-extras)-- [acts](https://hackage.haskell.org/package/acts)-- [semigroup-actions](https://hackage.haskell.org/package/semigroups-actions)-- [raaz](https://hackage.haskell.org/package/raaz-0.0.1/docs/Raaz-Core-MonoidalAction.html)---In comparison with these libraries, `lr-acts`is the only library that :-- Implements right actions-- Implements cyclic actions and generated actions-- Ensures the associativity and the neutrality of `mempty` in semidirect products-- Proposes several newtypes for deriving instances (note that [acts](https://hackage.haskell.org/package/acts) proposes a deriving mechanism, but centered around the actee type, not the actor type as in this library)--The main drawback of providing right actions and checking properties for semidirect products is that the number of instances can quickly be overwhelming. It can be a lot of boiler plate to declare them all, especially when the acting semigroup is commutative.+# lr-acts + +[](https://haskell.org) [](https://hackage.haskell.org/package/lr-acts) [](https://github.com/AliceRixte/lr-acts/LICENSE) + + +## Features + +* Left and right actions of + * sets + * semigroup + * monoids + * groups +* Semidirect product +* Group torsors +* Cyclic actions +* Generated actions + + +### Fine-grained class hierarchy + +Left and right actions with a fine-grained class hierarchy for action properties. For left actions, here are the provided classes : + +``` haskell +class LAct -- Set action + => LActSg -- Semigroup action + => LActMn -- Monoid action + => LTorsor -- Torsor + => LActDistrib -- Distributive action + => LActNeutral -- Neutral preserving action + => LActGen -- Action generated by a set + => LActCyclic -- Cyclic action (generated by a single element) + +``` + +### Derive most of you action instances + +The acting type is always the second parameter. Use this with `DerivingVia` language extension to derive action instances : + +``` haskell +import Data.Act +import Data.Semigroup + +newtype Seconds = Seconds Float +newtype Duration = Duration Seconds + deriving (Semigroup, Monoid) via (Sum Float) + + deriving (LAct Seconds, RAct Seconds) via (ActSelf' (Sum Float)) + -- derives LAct Second Duration + + deriving (LAct [Seconds], RAct [Seconds]) via (ActMap (ActSelf' (Sum Float))) + -- derives LAct [Second] Duration + +newtype Durations = Durations [Duration] + deriving (LAct Seconds, RAct Seconds) via (ActFold [Duration]) + -- derives LAct Second Durations + +``` + +``` haskell +ghci> Duration 2 `lact` Seconds 3 +Seconds 5.0 + +ghci> Duration 2 `lact` [Seconds 3, Seconds 4] +[Seconds 5.0,Seconds 6.0] + +ghci> [Duration 2, Duration 3] `lact` Seconds 4 +[Seconds 5.0,Seconds 6.0] + +ghci> Durations [Duration 2, Duration 3] `lact` Seconds 4 +Seconds 9.0 +``` + +### Semidirect products + +This fine-grained hierarchy allows to check for associativity and existence of neutral elements using _semidirect products_. + +``` haskell +>>> import Data.Semigroup +>>> LSemidirect (Sum 1) (Product 2) <> LSemidirect (Sum (3 :: Int)) (Product (4 :: Int)) +LSemidirect {lactee = Sum {getSum = 7}, lactor = Product {getProduct = 8}} +``` + +GHC will complain when using a semigroup action that is not distributive : + +```haskell +>>> LSemidirect (Sum 1) (Sum 2) <> LSemidirect (Sum (3 :: Int)) (Sum (4 :: Int)) +No instance for `LActDistrib (Sum Int) (Sum Int)' + arising from a use of `<>' +``` + +## Comparison with other action libraries + +Here is a list of action libraries on hackage : + +- [monoid-extra](https://github.com/diagrams/monoid-extras) +- [acts](https://hackage.haskell.org/package/acts) +- [semigroup-actions](https://hackage.haskell.org/package/semigroups-actions) +- [raaz](https://hackage.haskell.org/package/raaz-0.0.1/docs/Raaz-Core-MonoidalAction.html) + + +In comparison with these libraries, `lr-acts`is the only library that : +- Implements right actions +- Implements cyclic actions and generated actions +- Ensures the associativity and the neutrality of `mempty` in semidirect products +- Proposes several newtypes for deriving instances (note that [acts](https://hackage.haskell.org/package/acts) proposes a deriving mechanism, but centered around the actee type, not the actor type as in this library) + +The main drawback of providing right actions and checking properties for semidirect products is that the number of instances can quickly be overwhelming. It can be a lot of boiler plate to declare them all, especially when the acting semigroup is commutative.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple +main = defaultMain
benchmark/Main.hs view
@@ -1,38 +1,38 @@-module Main (main) where--import Criterion.Main--import Data.Semidirect.Lazy as L-import Data.Semidirect.Strict as S--import Data.Monoid-import Data.Semigroup--stimesLSemiLazy :: Int -> Sum Int-stimesLSemiLazy n = L.lactee $ stimes n- (L.LSemidirect (Sum 1) (Product 2) :: L.LSemidirect (Sum Int) (Product Int))--stimesLSemiStrict :: Int -> Sum Int-stimesLSemiStrict n =- S.lactee $ stimes n- (S.LSemidirect (Sum 1) (Product 2) :: S.LSemidirect (Sum Int) (Product Int))--sumProduct :: Int -> (Sum Int, Product Int)-sumProduct n = stimes n (Sum 1, Product 2)--mkBench f n = bench (show n) $ nf f n--pow10list :: Int -> Int -> [Int]-pow10list a b = [10 ^n | n <- [a..b]]--nlist :: [Int]-nlist = pow10list 1 4---main :: IO ()-main =- defaultMain [- bgroup "Lazy pair (,)" (fmap (mkBench sumProduct) nlist)- , bgroup "Lazy LSemidirect" (fmap (mkBench stimesLSemiLazy) nlist)- , bgroup "Strict LSemidirect" (fmap (mkBench stimesLSemiStrict) nlist)+module Main (main) where + +import Criterion.Main + +import Data.Semidirect.Lazy as L +import Data.Semidirect.Strict as S + +import Data.Monoid +import Data.Semigroup + +stimesLSemiLazy :: Int -> Sum Int +stimesLSemiLazy n = L.lactee $ stimes n + (L.LSemidirect (Sum 1) (Product 2) :: L.LSemidirect (Sum Int) (Product Int)) + +stimesLSemiStrict :: Int -> Sum Int +stimesLSemiStrict n = + S.lactee $ stimes n + (S.LSemidirect (Sum 1) (Product 2) :: S.LSemidirect (Sum Int) (Product Int)) + +sumProduct :: Int -> (Sum Int, Product Int) +sumProduct n = stimes n (Sum 1, Product 2) + +mkBench f n = bench (show n) $ nf f n + +pow10list :: Int -> Int -> [Int] +pow10list a b = [10 ^n | n <- [a..b]] + +nlist :: [Int] +nlist = pow10list 1 4 + + +main :: IO () +main = + defaultMain [ + bgroup "Lazy pair (,)" (fmap (mkBench sumProduct) nlist) + , bgroup "Lazy LSemidirect" (fmap (mkBench stimesLSemiLazy) nlist) + , bgroup "Strict LSemidirect" (fmap (mkBench stimesLSemiStrict) nlist) ]
lr-acts.cabal view
@@ -1,11 +1,11 @@-cabal-version: 2.2+cabal-version: 2.2 -- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack name: lr-acts-version: 0.0+version: 0.0.1 synopsis: Left and right actions, semidirect products and torsors description: Please see the README on GitHub at <https://github.com/AliceRixte/lr-acts/blob/main/README.md> category: Algebra, Math, Data
src/Data/Act.hs view
@@ -1,80 +1,80 @@-------------------------------------------------------------------------------------- |------ Module : Data.Act--- Description : Actions of sets, semigroups, monoids or groups.--- Copyright : (c) Alice Rixte 2024--- License : BSD 3--- Maintainer : alice.rixte@u-bordeaux.fr--- Stability : unstable--- Portability : non-portable (GHC extensions)------ == Presentation------ An action lifts an element (the "/actor/") of some type @s@, the /acting/--- type, into a function of another type @x@ which we call the "/actee/".------ The class hierarchy for actions is fine-grained, which means it is flexible--- but sometimes cumbersome to deal with. In particular, this allows to specify--- specific properties on the action for a semidirect product to be a semigroup--- or a monoid (see @'Data.Semidirect'@). Here is a tree summarizing the class--- hierarchy and their laws:------ @--- 'LAct' /Set action/--- => 'LActSg' /Semigroup action/--- => 'LActMn' /Monoid action/--- => 'LTorsor' /Torsor/--- => 'LActDistrib' /Distributive action/--- => 'LActNeutral' /Neutral preserving action/--- => 'LActGen' /Action generated by a set/--- => 'LActCyclic' /Cyclic action (generated by a single element)/--- @--------- == Instances driven by the acting type------ The action classes do not have functional dependencies, which can make it--- awkward to work with them. To avoid overlapping issues, this library chooses--- to drive instances by the second parameter, i.e. to _never_ write instances--- of the form------ @--- instance LAct SomeType s--- instance RAct SomeType s--- @--------- If you need such an instance, you should make a newtype. This library already--- provides some, such as @'ActSelf'@, @'ActTrivial'@, @'ActSelf''@, @'ActFold''@--- and @'ActMap'@.------ == Design choices compared to existing libraries------ This library is inspired by the already existing action libraries.------ * The deriving mechanism is inspired by the one from the @acts@ library. The--- main difference between this library and the @acts@ library is that @acts@--- drives its instances by the actee parameter.------ * The @monoid-extras@ library drives its instances by the acting type, but--- does not provide a deriving mechanism. This library started as an extension--- of @monoid-extras@, but the design choices made it diverge from it.------ * The idea of specifying action properties using empty classes comes from the--- @semigroups-actions@ library, which inspired some design of this library.--- This library offers everything @semigroups-actions@ offers, and more.--------------------------------------------------------------------------------------module Data.Act- ( module Data.Act.Act- , module Data.Act.Torsor- , module Data.Act.Cyclic- ) where--import Data.Act.Act-import Data.Act.Torsor+ + +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Act +-- Description : Actions of sets, semigroups, monoids or groups. +-- Copyright : (c) Alice Rixte 2024 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : unstable +-- Portability : non-portable (GHC extensions) +-- +-- == Presentation +-- +-- An action lifts an element (the "/actor/") of some type @s@, the /acting/ +-- type, into a function of another type @x@ which we call the "/actee/". +-- +-- The class hierarchy for actions is fine-grained, which means it is flexible +-- but sometimes cumbersome to deal with. In particular, this allows to specify +-- specific properties on the action for a semidirect product to be a semigroup +-- or a monoid (see @'Data.Semidirect'@). Here is a tree summarizing the class +-- hierarchy and their laws: +-- +-- @ +-- 'LAct' /Set action/ +-- => 'LActSg' /Semigroup action/ +-- => 'LActMn' /Monoid action/ +-- => 'LTorsor' /Torsor/ +-- => 'LActDistrib' /Distributive action/ +-- => 'LActNeutral' /Neutral preserving action/ +-- => 'LActGen' /Action generated by a set/ +-- => 'LActCyclic' /Cyclic action (generated by a single element)/ +-- @ +-- +-- +-- == Instances driven by the acting type +-- +-- The action classes do not have functional dependencies, which can make it +-- awkward to work with them. To avoid overlapping issues, this library chooses +-- to drive instances by the second parameter, i.e. to _never_ write instances +-- of the form +-- +-- @ +-- instance LAct SomeType s +-- instance RAct SomeType s +-- @ +-- +-- +-- If you need such an instance, you should make a newtype. This library already +-- provides some, such as @'ActSelf'@, @'ActTrivial'@, @'ActSelf''@, @'ActFold''@ +-- and @'ActMap'@. +-- +-- == Design choices compared to existing libraries +-- +-- This library is inspired by the already existing action libraries. +-- +-- * The deriving mechanism is inspired by the one from the @acts@ library. The +-- main difference between this library and the @acts@ library is that @acts@ +-- drives its instances by the actee parameter. +-- +-- * The @monoid-extras@ library drives its instances by the acting type, but +-- does not provide a deriving mechanism. This library started as an extension +-- of @monoid-extras@, but the design choices made it diverge from it. +-- +-- * The idea of specifying action properties using empty classes comes from the +-- @semigroups-actions@ library, which inspired some design of this library. +-- This library offers everything @semigroups-actions@ offers, and more. +-- +-------------------------------------------------------------------------------- + +module Data.Act + ( module Data.Act.Act + , module Data.Act.Torsor + , module Data.Act.Cyclic + ) where + +import Data.Act.Act +import Data.Act.Torsor import Data.Act.Cyclic
src/Data/Act/Act.hs view
@@ -1,773 +1,773 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ConstraintKinds #-}------------------------------------------------------------------------------------- |------ Module : Data.Act.Act--- Description : Actions of sets, semigroups, monoids and groups.--- Copyright : (c) Alice Rixte 2024--- License : BSD 3--- Maintainer : alice.rixte@u-bordeaux.fr--- Stability : unstable--- Portability : non-portable (GHC extensions)------ = Usage------ For both @'LAct'@ and @'RAct'@, the acting type is the second parameter. This--- is a bit counter intuitive when using @'LAct'@, but it allows to use the--- @DerivingVia@ mechanism to derive instances of @'LAct'@ and @'RAct'@ for--- newtypes that wrap the acting type. For example, you can use @'ActSelf''@ as--- follow to derive instances for @'LAct'@ and @'RAct'@ :------ @--- {-# LANGUAGE DerivingVia #-}------ import Data.Act--- import Data.Semigroup------ newtype Seconds = Seconds Float--- newtype Duration = Duration Seconds--- deriving (Semigroup, Monoid) via (Sum Float)------ deriving ('LAct' Seconds, 'RAct' Seconds) via ('ActSelf'' (Sum Float))--- -- derives LAct Second Duration------ deriving ('LAct' [Seconds], RAct [Seconds]) via ('ActMap' ('ActSelf'' (Sum Float)))--- -- derives LAct [Second] Duration------ newtype Durations = Durations [Duration]--- deriving ('LAct' Seconds, 'RAct' Seconds) via ('ActFold' [Duration])--- -- derives LAct Second Durations--- @--- >>> Duration (Seconds 1) <>$ (Seconds 2)--- Seconds 3.0--- >>> Duration 2 <>$ Seconds 3--- Seconds 5.0--- >>> Duration 2 <>$ [Seconds 3, Seconds 4]--- [Seconds 5.0,Seconds 6.0]--- >>> [Duration 2, Duration 3] <>$ Seconds 4--- [Seconds 5.0,Seconds 6.0]--- >>> Durations [Duration 2, Duration 3] <>$ Seconds 4--- Seconds 9.0--------------------------------------------------------------------------------------module Data.Act.Act- ( -- * Left actions- LAct (..)- , LActSg- , LActMn- , LActGp- , LActDistrib- , LActSgMorph- , LActNeutral- , LActMnMorph- -- * Right actions- , RAct (..)- , RActSg- , RActMn- , RActGp- , RActDistrib- , RActSgMorph- , RActNeutral- , RActMnMorph- -- * Newtypes for instance derivation- , ActSelf (..)- , ActSelf' (..)- , ActMap (..)- , ActFold (..)- , ActFold' (..)- , ActTrivial (..)-) where--import Data.Semigroup as Sg-import Data.Monoid as Mn-import Data.Group-import Data.Functor.Identity-import Data.Foldable-import Data.Coerce----- | A left action of a set @s@ on another set @x@ is a function that maps--- elements of @s@ to functions on @x@.------ There are no additional laws for this class to satisfy.------ The order @'LAct'@'s arguments is counter intuitive : even though we write--- left actions as @s <>$ x@, we declare the constraint as @LAct x s@. The--- reason for this is to be able to derive instances of @LAct@ while driving the--- instances by the acting type.------ Instances of @LAct@ are driven by the second parameter (the acting type).--- Concretely, this means you should never write instances of the form------ @instance LAct SomeType s@------ where @s@ is a type variable.--------class LAct x s where- {-# MINIMAL lact | (<>$) #-}- -- | Lifts an element of the set @s@ into a function on the set @x@- lact :: s -> x -> x- lact = (<>$)- {-# INLINE lact #-}- infixr 5 `lact`-- -- | Infix synonym or @'lact'@- --- -- The acting part is on the right of the operator (symbolized by @<>@) and- -- the actee on the right (symbolized by @$@), hence the notation @<>$@- (<>$) :: s -> x -> x- (<>$) = lact- {-# INLINE (<>$) #-}- infixr 5 <>$---- | A left semigroup action------ Instances must satisfy the following law :------ @ (s <> t) <>$ x == s <>$ (t <>$ x) @----class (LAct x s, Semigroup s) => LActSg x s---- | A left monoid action, also called a left /unitary/ action.------ In addition to the laws of @'LActSg'@, instances must satisfy the following--- law :------ @ 'mempty' <>$ x == x @----class (LActSg x s, Monoid s) => LActMn x s---- | A left action of groups. No additional laws are needed.----type LActGp x s = (LActMn x s, Group s)----- | A left distributive action------ Instances must satisfy the following law :------ @ s <>$ (x <> y) == (s <>$ x) <> (s <>$ y) @----class (LAct x s, Semigroup x) => LActDistrib x s---- | A left action by morphism of semigroups------ Whenever the constaints @'LActSg' x s@ and @'LActDistrib' x s@ are satisfied,--- @(s <>$)@ is a morphism of semigroups for any @s@.----type LActSgMorph x s = (LActSg x s, LActDistrib x s)------ | A left action on a monoid that preserves its neutral element.------ Instances must satisfy the following law :------ @ s <>$ 'mempty' == 'mempty' @----class (LAct x s, Monoid x) => LActNeutral x s------ | A left action by morphism of monoids i.e. such that @(s <>$)@ is a morphism of monoids.------ This is equivalent to satisfy the three following properties :------ 1. left action by morphism of semigroups (i.e. @'LActSgMorph' x s@)--- 2. left monoid action (i.e. @'LActMn' x s@)--- 3. preseving neutral element (i.e. @'LActNeutral' x s@)----type LActMnMorph x s = (LActMn x s, LActSgMorph x s, LActNeutral x s)----- | A right action of a set @s@ on another set @x@.------ There are no additional laws for this class to satisfy.----class RAct x s where- {-# MINIMAL ract | ($<>) #-}- -- | Act on the right of some element of @x@- ract :: x -> s -> x- ract = ($<>)- {-# INLINE ract #-}- infixl 5 `ract`-- -- | Infix synonym or @'ract'@- --- -- The acting part is on the right of the operator (symbolized by @<>@) and- -- the actee on the left (symbolized by @$@), hence the notation @$<>@.- --- ($<>) :: x -> s -> x- ($<>) = ract- {-# INLINE ($<>) #-}- infixl 5 $<>----- | A right semigroup action------ Instances must satisfy the following law :------ @ x $<> (s <> t) == (x $<> s) $<> t @----class (RAct x s, Semigroup s) => RActSg x s---- | A right monoid action, also called a right /unitary/ action.------ In addition to the laws of @'RActSg'@, instances must satisfy the following--- law :------ @ x $<> 'mempty' == x @----class (RActSg x s, Monoid s) => RActMn x s---- | A left action of groups. No additional laws are needed.----type RActGp x s = (RActMn x s, Group s)---- | A right distributive action------ Instances must satisfy the following law :------ @ (x <> y) $<> s == (x $<> s) <> (y $<> s) @----class (RAct x s, Semigroup x) => RActDistrib x s----- | A right action by morphism of semigroups------ Whenever the constaints @'RActSg' x s@ and @'RActDistrib' x s@ are satisfied,--- @($<> s)@ is a morphism of semigroups for any @s@.----type RActSgMorph x s = (RActSg x s, RActDistrib x s)----- | A right action on a monoid that preserves its neutral element.------ Instances must satisfy the following law :------ @ x $<> mempty == x @----class (RAct x s, Monoid x) => RActNeutral x s---- | A right action by morphism of monoids i.e. such that------ @($<> s)@ is a morphism of monoids----type RActMnMorph x s = (RActMn x s, RActSgMorph x s, RActNeutral x s)------------------------------------ Newtype actions ------------------------------------ | A semigroup always acts on itself by translation.------ Notice that whenever there is an instance @LAct x s@ with @x@ different from--- @s@, this action is lifted to an @ActSelf@ action.------ >>> ActSelf "Hello" <>$ " World !"--- "Hello World !"----newtype ActSelf s = ActSelf {unactSelf :: s}- deriving stock (Show, Eq)- deriving newtype (Semigroup, Monoid, Group)---- | Semigroup action (monoid action when @Monoid s@)-instance Semigroup s => LAct s (ActSelf s) where- ActSelf s <>$ x = s <> x- {-# INLINE (<>$) #-}--instance Semigroup s => LActSg s (ActSelf s)-instance Monoid s => LActMn s (ActSelf s)---- | Semigroup action (monoid action when @Monoid s@)-instance Semigroup s => RAct s (ActSelf s) where- x $<> ActSelf s = x <> s- {-# INLINE ($<>) #-}--instance Semigroup s => RActSg s (ActSelf s)-instance Monoid s => RActMn s (ActSelf s)---- | Actions of @ActSelf'@ behave similarly to those of @'ActSelf'@, but first--- try to coerce @x@ to @s@ before using the @Semigroup@ instance. If @x@ can be--- coerced to @s@, then we use the @ActSelf@ action.------ This is meant to be used in conjunction with the @deriving via@ strategy when--- defining newtype wrappers. Here is a concrete example, where durations act on--- time. Here, @Seconds@ is not a semigroup and @Duration@ is a group that acts--- on time via the derived instance @LAct Seconds Duration@.------ @--- import Data.Semigroup------ newtype Seconds = Seconds Float------ newtype Duration = Duration Seconds--- deriving ('Semigroup', 'Monoid', 'Group') via ('Sum' Float)--- deriving ('LAct' Seconds) via ('ActSelf'' ('Sum' Float))--- @------ >>> Duration 2 <>$ Seconds 3--- Seconds 5.0----newtype ActSelf' x = ActSelf' {unactCoerce :: x}- deriving stock (Show, Eq)- deriving newtype (Semigroup, Monoid, Group)---- | Semigroup action (monoid action when @Monoid s@)-instance {-# OVERLAPPABLE #-} (Semigroup s, Coercible x s)- => LAct x (ActSelf' s) where- ActSelf' s <>$ x = coerce $ s <> (coerce x :: s)- {-# INLINE (<>$) #-}--instance (Coercible x s, Semigroup s) => LActSg x (ActSelf' s)-instance (Coercible x s, Monoid s) => LActMn x (ActSelf' s)---- | Semigroup action (monoid action when @Monoid s@)-instance {-# OVERLAPPABLE #-} (Semigroup s, Coercible x s)- => RAct x (ActSelf' s) where- x $<> ActSelf' s = coerce $ (coerce x :: s) <> s- {-# INLINE ($<>) #-}--instance (Coercible x s, Semigroup s) => RActSg x (ActSelf' s)-instance (Coercible x s, Monoid s) => RActMn x (ActSelf' s)---- | The trivial action where any element of @s@ acts as the identity function--- on @x@------ >>> ActTrivial "Hello !" <>$ "Hi !"--- " Hi !"--newtype ActTrivial x = ActTrivial {unactId :: x}- deriving stock (Show, Eq)- deriving newtype (Semigroup, Monoid, Group)---- | Action by morphism of monoids when @'Monoid' s@ and @'Monoid' x@-instance LAct x (ActTrivial s) where- (<>$) _ = id- {-# INLINE (<>$) #-}--instance Semigroup s => LActSg x (ActTrivial s)-instance Monoid s => LActMn x (ActTrivial s)-instance Semigroup x => LActDistrib x (ActTrivial s)-instance Monoid x => LActNeutral x (ActTrivial s)---- | Action by morphism of monoids when @'Monoid' s@ and @'Monoid' x@-instance RAct x (ActTrivial s) where- x $<> _ = x- {-# INLINE ($<>) #-}--instance Semigroup s => RActSg x (ActTrivial s)-instance Monoid s => RActMn x (ActTrivial s)-instance Semigroup x => RActDistrib x (ActTrivial s)-instance Monoid x => RActNeutral x (ActTrivial s)---- | An action on any functor that uses the @fmap@ function. For example :------ >>> ActMap (ActSelf "Hello") <>$ [" World !", " !"]--- ["Hello World !","Hello !"]----newtype ActMap s = ActMap {unactMap :: s}- deriving stock (Show, Eq)- deriving newtype (Semigroup, Monoid, Group)---- | Preserves the semigroup (resp. monoid) property of @'LAct' x s@, but--- __not__ the morphism properties, which depend on potential @'Semigroup'@--- (resp. @'Monoid'@) instances of @f x@-instance (LAct x s, Functor f) => LAct (f x) (ActMap s) where- ActMap s <>$ x = fmap (s <>$) x- {-# INLINE (<>$) #-}--instance (LActSg x s, Functor f) => LActSg (f x) (ActMap s)-instance (LActMn x s, Functor f) => LActMn (f x) (ActMap s)-instance LAct x s => LActDistrib [x] (ActMap s)-instance LAct x s => LActNeutral [x] (ActMap s)----- | Preserves the semigroup (resp. monoid) property of @'LAct' x s@, but--- __not__ the morphism properties, which depend on potential @'Semigroup'@--- (resp. @'Monoid'@) instances of @f x@. When $f = []@, this is an action by morphism of monoids.-instance (RAct x s, Functor f) => RAct (f x) (ActMap s) where- x $<> ActMap s = fmap ($<> s) x- {-# INLINE ($<>) #-}--instance (RActSg x s, Functor f) => RActSg (f x) (ActMap s)-instance (RActMn x s, Functor f) => RActMn (f x) (ActMap s)-instance RAct x s => RActDistrib [x] (ActMap s)-instance RAct x s => RActNeutral [x] (ActMap s)---- | Lifting an a container as an action using @'foldr'@ (for /left/ actions) or--- @'foldl'@ (for /right/ actions). For a strict version, use @'ActFold''@.------ A left action @(<>$)@ can be seen as an operator for the @'foldr'@ function,--- and a allowing to lift any action to some @'Foldable'@ container.------ >> ActFold [Sum (1 :: Int), Sum 2, Sum 3] <>$ (4 :: Int)--- > 10----newtype ActFold s = ActFold {unactFold :: s}- deriving stock (Show, Eq)- deriving newtype (Semigroup, Monoid, Group)---- | When used with lists @[]@, this is a monoid action-instance (Foldable f, LAct x s) => LAct x (ActFold (f s)) where- ActFold f <>$ x = foldr (<>$) x f- {-# INLINE (<>$) #-}--instance LAct x s => LActSg x (ActFold [s])---- | When used with lists @[]@, this is a monoid action-instance (Foldable f, RAct x s) => RAct x (ActFold (f s)) where- x $<> ActFold f = foldl ($<>) x f- {-# INLINE ($<>) #-}---- | Lifting an a container as an action using @'fold'r'@ (for /left/ actions)--- or @'foldl''@ (for /right/ actions). For a lazy version, use @'ActFold'@.------ A left action @(<>$)@ can be seen as an operator for the @'foldr'@ function,--- and a allowing to lift any action to some @'Foldable'@ container.------ >>> ActFold' [Sum (1 :: Int), Sum 2, Sum 3] <>$ (4 :: Int)--- 10----newtype ActFold' s = ActFold' {unactFold' :: s}- deriving stock (Show, Eq)- deriving newtype (Semigroup, Monoid, Group)---- | When used with lists @[]@, this is a monoid action-instance (Foldable f, LAct x s) => LAct x (ActFold' (f s)) where- ActFold' f <>$ x = foldr' (<>$) x f- {-# INLINE (<>$) #-}--instance LAct x s => LActSg x (ActFold' [s])---- | When used with lists @[]@, this is a monoid action-instance (Foldable f, RAct x s) => RAct x (ActFold' (f s)) where- x $<> ActFold' f = foldl' ($<>) x f- {-# INLINE ($<>) #-}------------------------------------- Instances --------------------------------------- | Action by morphism of monoids-instance LAct x () where- () <>$ x = x- {-# INLINE (<>$) #-}--instance LActSg x ()-instance LActMn x ()-instance Semigroup x => LActDistrib x ()-instance Monoid x => LActNeutral x ()---- | Monoid action-instance RAct x () where- x $<> () = x- {-# INLINE ($<>) #-}--instance RActSg x ()-instance RActMn x ()-instance Semigroup x => RActDistrib x ()-instance Monoid x => RActNeutral x ()---- | Action by morphism of semigroups (resp. monoids) when @'Semigroup' s@--- (resp. @'Monoid' s@)-instance {-# INCOHERENT #-} LAct () s where- _ <>$ () = ()- {-# INLINE (<>$) #-}--instance {-# INCOHERENT #-} Semigroup s =>LActSg () s-instance {-# INCOHERENT #-} Monoid s => LActMn () s-instance {-# INCOHERENT #-} LActDistrib () s-instance {-# INCOHERENT #-} LActNeutral () s---- | Action by morphism of semigroups (resp. monoids) when @'Semigroup' s@--- (resp. @'Monoid' s@)-instance {-# INCOHERENT #-} RAct () s where- () $<> _ = ()- {-# INLINE ($<>) #-}--instance {-# INCOHERENT #-} Semigroup s => RActSg () s-instance {-# INCOHERENT #-} Monoid s => RActMn () s-instance {-# INCOHERENT #-} RActDistrib () s-instance {-# INCOHERENT #-} RActNeutral () s---- | Monoid action when @'LAct' x s@ is a semigroup action.-instance LAct x s => LAct x (Maybe s) where- Nothing <>$ x = x- Just s <>$ x = s <>$ x--instance LActSg x s => LActSg x (Maybe s)-instance LActSg x s => LActMn x (Maybe s)---- | Monoid action when @'LAct' x s@ is a semigroup action.-instance RAct x s => RAct x (Maybe s) where- x $<> Nothing = x- x $<> Just s = x $<> s--instance RActSg x s => RActSg x (Maybe s)-instance RActSg x s => RActMn x (Maybe s)---- | Same action propety as the weaker properties of @('LAct' x1 s1, 'LAct' x2--- s2)@-instance (LAct x1 s1, LAct x2 s2) => LAct (x1, x2) (s1, s2) where- (s1, s2) <>$ (x1, x2) = (s1 <>$ x1, s2 <>$ x2)--instance (LActSg x1 s1, LActSg x2 s2) => LActSg (x1, x2) (s1, s2)-instance (LActMn x1 s1, LActMn x2 s2) => LActMn (x1, x2) (s1, s2)-instance (LActDistrib x1 s1, LActDistrib x2 s2) => LActDistrib (x1, x2) (s1, s2)-instance (LActNeutral x1 s1, LActNeutral x2 s2) => LActNeutral (x1, x2) (s1, s2)---- | Same action propety as the weaker properties of @('LAct' x1 s1, 'LAct' x2--- s2)@-instance (RAct x1 s1, RAct x2 s2) => RAct (x1, x2) (s1, s2) where- (x1, x2) $<> (s1, s2) = (x1 $<> s1, x2 $<> s2)--instance (RActSg x1 s1, RActSg x2 s2) => RActSg (x1, x2) (s1, s2)-instance (RActMn x1 s1, RActMn x2 s2) => RActMn (x1, x2) (s1, s2)-instance (RActDistrib x1 s1, RActDistrib x2 s2) => RActDistrib (x1, x2) (s1, s2)-instance (RActNeutral x1 s1, RActNeutral x2 s2) => RActNeutral (x1, x2) (s1, s2)---- | No additionnal properties. In particular this is _not_ a semigroup action.-instance (LAct x s, LAct x t) => LAct x (Either s t) where- (Left s) <>$ x = s <>$ x- (Right s) <>$ x = s <>$ x---- | No additionnal properties. In particular this is _not_ a semigroup action.-instance (RAct x s, RAct x t) => RAct x (Either s t) where- x $<> (Left s) = x $<> s- x $<> (Right s) = x $<> s----------------------- Instances for base library functors ------------------------- | Preserves action properties of @'LAct' x s@.-instance LAct x s => LAct x (Identity s) where- Identity s <>$ x = s <>$ x- {-# INLINE (<>$) #-}--instance LActSg x s => LActSg x (Identity s)-instance LActMn x s => LActMn x (Identity s)-instance LActDistrib x s => LActDistrib x (Identity s)-instance LActNeutral x s => LActNeutral x (Identity s)----- | Preserves action properties of @'LAct' x s@.-instance {-# OVERLAPPING #-} LAct x s => LAct (Identity x) (Identity s) where- Identity s <>$ Identity x = Identity (s <>$ x)--instance {-# OVERLAPPING #-} LActSg x s => LActSg (Identity x) (Identity s)-instance {-# OVERLAPPING #-} LActMn x s => LActMn (Identity x) (Identity s)-instance {-# OVERLAPPING #-} LActDistrib x s- => LActDistrib (Identity x) (Identity s)-instance {-# OVERLAPPING #-} LActNeutral x s- => LActNeutral (Identity x) (Identity s)---- | Preserves action properties of @'RAct' x s@.-instance RAct x s => RAct x (Identity s) where- x $<> Identity s = x $<> s- {-# INLINE ($<>) #-}--instance RActSg x s => RActSg x (Identity s)-instance RActMn x s => RActMn x (Identity s)-instance RActDistrib x s => RActDistrib x (Identity s)-instance RActNeutral x s => RActNeutral x (Identity s)---- | Preserves action properties of @'LAct' x s@.-instance {-# OVERLAPPING #-} RAct x s => RAct (Identity x) (Identity s) where- Identity x $<> Identity s = Identity (x $<> s)--instance {-# OVERLAPPING #-} RActSg x s => RActSg (Identity x) (Identity s)-instance {-# OVERLAPPING #-} RActMn x s => RActMn (Identity x) (Identity s)-instance {-# OVERLAPPING #-} RActDistrib x s- => RActDistrib (Identity x) (Identity s)-instance {-# OVERLAPPING #-} RActNeutral x s- => RActNeutral (Identity x) (Identity s)--------------------------- Instances for Data.Semigroup ----------------------------- | Preserves action properties of @'LAct' x s@.-instance LAct x s => RAct x (Dual s) where- x $<> Dual s = s <>$ x- {-# INLINE ($<>) #-}--instance LActSg x s => RActSg x (Dual s)-instance LActMn x s => RActMn x (Dual s)-instance LActDistrib x s => RActDistrib x (Dual s)-instance LActNeutral x s => RActNeutral x (Dual s)---- | Preserves action properties of @'LAct' x s@.-instance RAct x s => LAct x (Dual s) where- Dual s <>$ x = x $<> s- {-# INLINE (<>$) #-}--instance RActSg x s => LActSg x (Dual s)-instance RActMn x s => LActMn x (Dual s)-instance RActDistrib x s => LActDistrib x (Dual s)-instance RActNeutral x s => LActNeutral x (Dual s)---- | Monoid action-instance LAct x (Endo x) where- Endo f <>$ x = f x- {-# INLINE (<>$) #-}--instance LActSg x (Endo x)-instance LActMn x (Endo x)---- | Monoid action-instance Num x => LAct x (Sum x) where- (<>$) s = coerce (s <>)- {-# INLINE (<>$) #-}--instance Num x => LActSg x (Sum x)-instance Num x => LActMn x (Sum x)----- | Monoid action-instance Num x => RAct x (Sum x) where- x $<> s = coerce $ coerce x <> s- {-# INLINE ($<>) #-}--instance Num x => RActSg x (Sum x)-instance Num x => RActMn x (Sum x)---- | Monoid action-instance Num x => LAct x (Product x) where- (<>$) s = coerce (s <>)- {-# INLINE (<>$) #-}--instance Num x => LActSg x (Product x)-instance Num x => LActMn x (Product x)---- | Monoid action-instance Num x => RAct x (Product x) where- x $<> s = coerce $ coerce x <> s- {-# INLINE ($<>) #-}--instance Num x => RActSg x (Product x)-instance Num x => RActMn x (Product x)---- | Monoid action-instance {-# OVERLAPPING #-} Num x => LAct (Sum x) (Sum x) where- (<>$) = (<>)- {-# INLINE (<>$) #-}--instance {-# OVERLAPPING #-} Num x => LActSg (Sum x) (Sum x)-instance {-# OVERLAPPING #-} Num x => LActMn (Sum x) (Sum x)---- | Monoid action-instance {-# OVERLAPPING #-} Num x => RAct (Sum x) (Sum x) where- ($<>) = (<>)- {-# INLINE ($<>) #-}--instance {-# OVERLAPPING #-} Num x => RActSg (Sum x) (Sum x)-instance {-# OVERLAPPING #-} Num x => RActMn (Sum x) (Sum x)---- | Monoid action-instance {-# OVERLAPPING #-} Num x => LAct (Product x) (Product x) where- (<>$) s = coerce (s <>)- {-# INLINE (<>$) #-}--instance {-# OVERLAPPING #-} Num x => LActSg (Product x) (Product x)-instance {-# OVERLAPPING #-} Num x => LActMn (Product x) (Product x)---- | Monoid action-instance {-# OVERLAPPING #-} Num x => RAct (Product x) (Product x) where- ($<>) = (<>)- {-# INLINE ($<>) #-}--instance {-# OVERLAPPING #-} Num x => RActSg (Product x) (Product x)-instance {-# OVERLAPPING #-} Num x => RActMn (Product x) (Product x)---- | Action by morphism of monoids-instance Num x => LAct (Sum x) (Product x) where- (<>$) s = coerce (s <>)- {-# INLINE (<>$) #-}--instance Num x => LActSg (Sum x) (Product x)-instance Num x => LActMn (Sum x) (Product x)-instance Num x => LActDistrib (Sum x) (Product x)-instance Num x => LActNeutral (Sum x) (Product x)---- | Action by morphism of monoids-instance Num x => RAct (Sum x) (Product x) where- x $<> s = coerce $ coerce x <> s- {-# INLINE ($<>) #-}--instance Num x => RActSg (Sum x) (Product x)-instance Num x => RActMn (Sum x) (Product x)-instance Num x => RActDistrib (Sum x) (Product x)-instance Num x => RActNeutral (Sum x) (Product x)---- | Monoid action-instance LAct Bool Any where- (<>$) s = coerce (s <>)- {-# INLINE (<>$) #-}--instance LActSg Bool Any-instance LActMn Bool Any---- | Monoid action-instance RAct Bool Any where- x $<> s = coerce $ coerce x <> s- {-# INLINE ($<>) #-}--instance RActSg Bool Any-instance RActMn Bool Any---- | Monoid action-instance LAct Bool All where- (<>$) s = coerce (s <>)- {-# INLINE (<>$) #-}--instance LActSg Bool All-instance LActMn Bool All---- | Monoid action-instance RAct Bool All where- x $<> s = coerce $ coerce x <> s- {-# INLINE ($<>) #-}--instance RActSg Bool All-instance RActMn Bool All---- | Semigroup action-instance LAct x (Sg.First x) where- (<>$) s = coerce (s <>)- {-# INLINE (<>$) #-}--instance LActSg x (Sg.First x)---- | Semigroup action-instance RAct x (Sg.Last x) where- x $<> s = coerce $ coerce x <> s- {-# INLINE ($<>) #-}--instance RActSg x (Sg.Last x)---- | Monoid action-instance LAct x (Mn.First x) where- Mn.First Nothing <>$ x = x- Mn.First (Just s) <>$ _ = s- {-# INLINE (<>$) #-}--instance LActSg x (Mn.First x)-instance LActMn x (Mn.First x)---- | Monoid action-instance RAct x (Mn.Last x) where- x $<> Mn.Last Nothing = x- _ $<> Mn.Last (Just s) = s- {-# INLINE ($<>) #-}--instance RActSg x (Mn.Last x)-instance RActMn x (Mn.Last x)+{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds #-} + +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Act.Act +-- Description : Actions of sets, semigroups, monoids and groups. +-- Copyright : (c) Alice Rixte 2024 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : unstable +-- Portability : non-portable (GHC extensions) +-- +-- = Usage +-- +-- For both @'LAct'@ and @'RAct'@, the acting type is the second parameter. This +-- is a bit counter intuitive when using @'LAct'@, but it allows to use the +-- @DerivingVia@ mechanism to derive instances of @'LAct'@ and @'RAct'@ for +-- newtypes that wrap the acting type. For example, you can use @'ActSelf''@ as +-- follow to derive instances for @'LAct'@ and @'RAct'@ : +-- +-- @ +-- {-# LANGUAGE DerivingVia #-} +-- +-- import Data.Act +-- import Data.Semigroup +-- +-- newtype Seconds = Seconds Float +-- newtype Duration = Duration Seconds +-- deriving (Semigroup, Monoid) via (Sum Float) +-- +-- deriving ('LAct' Seconds, 'RAct' Seconds) via ('ActSelf'' (Sum Float)) +-- -- derives LAct Second Duration +-- +-- deriving ('LAct' [Seconds], RAct [Seconds]) via ('ActMap' ('ActSelf'' (Sum Float))) +-- -- derives LAct [Second] Duration +-- +-- newtype Durations = Durations [Duration] +-- deriving ('LAct' Seconds, 'RAct' Seconds) via ('ActFold' [Duration]) +-- -- derives LAct Second Durations +-- @ +-- >>> Duration (Seconds 1) <>$ (Seconds 2) +-- Seconds 3.0 +-- >>> Duration 2 <>$ Seconds 3 +-- Seconds 5.0 +-- >>> Duration 2 <>$ [Seconds 3, Seconds 4] +-- [Seconds 5.0,Seconds 6.0] +-- >>> [Duration 2, Duration 3] <>$ Seconds 4 +-- [Seconds 5.0,Seconds 6.0] +-- >>> Durations [Duration 2, Duration 3] <>$ Seconds 4 +-- Seconds 9.0 +-- +-------------------------------------------------------------------------------- + +module Data.Act.Act + ( -- * Left actions + LAct (..) + , LActSg + , LActMn + , LActGp + , LActDistrib + , LActSgMorph + , LActNeutral + , LActMnMorph + -- * Right actions + , RAct (..) + , RActSg + , RActMn + , RActGp + , RActDistrib + , RActSgMorph + , RActNeutral + , RActMnMorph + -- * Newtypes for instance derivation + , ActSelf (..) + , ActSelf' (..) + , ActMap (..) + , ActFold (..) + , ActFold' (..) + , ActTrivial (..) +) where + +import Data.Semigroup as Sg +import Data.Monoid as Mn +import Data.Group +import Data.Functor.Identity +import Data.Foldable +import Data.Coerce + + +-- | A left action of a set @s@ on another set @x@ is a function that maps +-- elements of @s@ to functions on @x@. +-- +-- There are no additional laws for this class to satisfy. +-- +-- The order @'LAct'@'s arguments is counter intuitive : even though we write +-- left actions as @s <>$ x@, we declare the constraint as @LAct x s@. The +-- reason for this is to be able to derive instances of @LAct@ while driving the +-- instances by the acting type. +-- +-- Instances of @LAct@ are driven by the second parameter (the acting type). +-- Concretely, this means you should never write instances of the form +-- +-- @instance LAct SomeType s@ +-- +-- where @s@ is a type variable. +-- + +-- +class LAct x s where + {-# MINIMAL lact | (<>$) #-} + -- | Lifts an element of the set @s@ into a function on the set @x@ + lact :: s -> x -> x + lact = (<>$) + {-# INLINE lact #-} + infixr 5 `lact` + + -- | Infix synonym or @'lact'@ + -- + -- The acting part is on the right of the operator (symbolized by @<>@) and + -- the actee on the right (symbolized by @$@), hence the notation @<>$@ + (<>$) :: s -> x -> x + (<>$) = lact + {-# INLINE (<>$) #-} + infixr 5 <>$ + +-- | A left semigroup action +-- +-- Instances must satisfy the following law : +-- +-- @ (s <> t) <>$ x == s <>$ (t <>$ x) @ +-- +class (LAct x s, Semigroup s) => LActSg x s + +-- | A left monoid action, also called a left /unitary/ action. +-- +-- In addition to the laws of @'LActSg'@, instances must satisfy the following +-- law : +-- +-- @ 'mempty' <>$ x == x @ +-- +class (LActSg x s, Monoid s) => LActMn x s + +-- | A left action of groups. No additional laws are needed. +-- +type LActGp x s = (LActMn x s, Group s) + + +-- | A left distributive action +-- +-- Instances must satisfy the following law : +-- +-- @ s <>$ (x <> y) == (s <>$ x) <> (s <>$ y) @ +-- +class (LAct x s, Semigroup x) => LActDistrib x s + +-- | A left action by morphism of semigroups +-- +-- Whenever the constaints @'LActSg' x s@ and @'LActDistrib' x s@ are satisfied, +-- @(s <>$)@ is a morphism of semigroups for any @s@. +-- +type LActSgMorph x s = (LActSg x s, LActDistrib x s) + + + +-- | A left action on a monoid that preserves its neutral element. +-- +-- Instances must satisfy the following law : +-- +-- @ s <>$ 'mempty' == 'mempty' @ +-- +class (LAct x s, Monoid x) => LActNeutral x s + + + +-- | A left action by morphism of monoids i.e. such that @(s <>$)@ is a morphism of monoids. +-- +-- This is equivalent to satisfy the three following properties : +-- +-- 1. left action by morphism of semigroups (i.e. @'LActSgMorph' x s@) +-- 2. left monoid action (i.e. @'LActMn' x s@) +-- 3. preseving neutral element (i.e. @'LActNeutral' x s@) +-- +type LActMnMorph x s = (LActMn x s, LActSgMorph x s, LActNeutral x s) + + +-- | A right action of a set @s@ on another set @x@. +-- +-- There are no additional laws for this class to satisfy. +-- +class RAct x s where + {-# MINIMAL ract | ($<>) #-} + -- | Act on the right of some element of @x@ + ract :: x -> s -> x + ract = ($<>) + {-# INLINE ract #-} + infixl 5 `ract` + + -- | Infix synonym or @'ract'@ + -- + -- The acting part is on the right of the operator (symbolized by @<>@) and + -- the actee on the left (symbolized by @$@), hence the notation @$<>@. + -- + ($<>) :: x -> s -> x + ($<>) = ract + {-# INLINE ($<>) #-} + infixl 5 $<> + + +-- | A right semigroup action +-- +-- Instances must satisfy the following law : +-- +-- @ x $<> (s <> t) == (x $<> s) $<> t @ +-- +class (RAct x s, Semigroup s) => RActSg x s + +-- | A right monoid action, also called a right /unitary/ action. +-- +-- In addition to the laws of @'RActSg'@, instances must satisfy the following +-- law : +-- +-- @ x $<> 'mempty' == x @ +-- +class (RActSg x s, Monoid s) => RActMn x s + +-- | A left action of groups. No additional laws are needed. +-- +type RActGp x s = (RActMn x s, Group s) + +-- | A right distributive action +-- +-- Instances must satisfy the following law : +-- +-- @ (x <> y) $<> s == (x $<> s) <> (y $<> s) @ +-- +class (RAct x s, Semigroup x) => RActDistrib x s + + +-- | A right action by morphism of semigroups +-- +-- Whenever the constaints @'RActSg' x s@ and @'RActDistrib' x s@ are satisfied, +-- @($<> s)@ is a morphism of semigroups for any @s@. +-- +type RActSgMorph x s = (RActSg x s, RActDistrib x s) + + +-- | A right action on a monoid that preserves its neutral element. +-- +-- Instances must satisfy the following law : +-- +-- @ x $<> mempty == x @ +-- +class (RAct x s, Monoid x) => RActNeutral x s + +-- | A right action by morphism of monoids i.e. such that +-- +-- @($<> s)@ is a morphism of monoids +-- +type RActMnMorph x s = (RActMn x s, RActSgMorph x s, RActNeutral x s) + + + + +------------------------------- Newtype actions -------------------------------- + +-- | A semigroup always acts on itself by translation. +-- +-- Notice that whenever there is an instance @LAct x s@ with @x@ different from +-- @s@, this action is lifted to an @ActSelf@ action. +-- +-- >>> ActSelf "Hello" <>$ " World !" +-- "Hello World !" +-- +newtype ActSelf s = ActSelf {unactSelf :: s} + deriving stock (Show, Eq) + deriving newtype (Semigroup, Monoid, Group) + +-- | Semigroup action (monoid action when @Monoid s@) +instance Semigroup s => LAct s (ActSelf s) where + ActSelf s <>$ x = s <> x + {-# INLINE (<>$) #-} + +instance Semigroup s => LActSg s (ActSelf s) +instance Monoid s => LActMn s (ActSelf s) + +-- | Semigroup action (monoid action when @Monoid s@) +instance Semigroup s => RAct s (ActSelf s) where + x $<> ActSelf s = x <> s + {-# INLINE ($<>) #-} + +instance Semigroup s => RActSg s (ActSelf s) +instance Monoid s => RActMn s (ActSelf s) + +-- | Actions of @ActSelf'@ behave similarly to those of @'ActSelf'@, but first +-- try to coerce @x@ to @s@ before using the @Semigroup@ instance. If @x@ can be +-- coerced to @s@, then we use the @ActSelf@ action. +-- +-- This is meant to be used in conjunction with the @deriving via@ strategy when +-- defining newtype wrappers. Here is a concrete example, where durations act on +-- time. Here, @Seconds@ is not a semigroup and @Duration@ is a group that acts +-- on time via the derived instance @LAct Seconds Duration@. +-- +-- @ +-- import Data.Semigroup +-- +-- newtype Seconds = Seconds Float +-- +-- newtype Duration = Duration Seconds +-- deriving ('Semigroup', 'Monoid', 'Group') via ('Sum' Float) +-- deriving ('LAct' Seconds) via ('ActSelf'' ('Sum' Float)) +-- @ +-- +-- >>> Duration 2 <>$ Seconds 3 +-- Seconds 5.0 +-- +newtype ActSelf' x = ActSelf' {unactCoerce :: x} + deriving stock (Show, Eq) + deriving newtype (Semigroup, Monoid, Group) + +-- | Semigroup action (monoid action when @Monoid s@) +instance {-# OVERLAPPABLE #-} (Semigroup s, Coercible x s) + => LAct x (ActSelf' s) where + ActSelf' s <>$ x = coerce $ s <> (coerce x :: s) + {-# INLINE (<>$) #-} + +instance (Coercible x s, Semigroup s) => LActSg x (ActSelf' s) +instance (Coercible x s, Monoid s) => LActMn x (ActSelf' s) + +-- | Semigroup action (monoid action when @Monoid s@) +instance {-# OVERLAPPABLE #-} (Semigroup s, Coercible x s) + => RAct x (ActSelf' s) where + x $<> ActSelf' s = coerce $ (coerce x :: s) <> s + {-# INLINE ($<>) #-} + +instance (Coercible x s, Semigroup s) => RActSg x (ActSelf' s) +instance (Coercible x s, Monoid s) => RActMn x (ActSelf' s) + +-- | The trivial action where any element of @s@ acts as the identity function +-- on @x@ +-- +-- >>> ActTrivial "Hello !" <>$ "Hi !" +-- " Hi !" + +newtype ActTrivial x = ActTrivial {unactId :: x} + deriving stock (Show, Eq) + deriving newtype (Semigroup, Monoid, Group) + +-- | Action by morphism of monoids when @'Monoid' s@ and @'Monoid' x@ +instance LAct x (ActTrivial s) where + (<>$) _ = id + {-# INLINE (<>$) #-} + +instance Semigroup s => LActSg x (ActTrivial s) +instance Monoid s => LActMn x (ActTrivial s) +instance Semigroup x => LActDistrib x (ActTrivial s) +instance Monoid x => LActNeutral x (ActTrivial s) + +-- | Action by morphism of monoids when @'Monoid' s@ and @'Monoid' x@ +instance RAct x (ActTrivial s) where + x $<> _ = x + {-# INLINE ($<>) #-} + +instance Semigroup s => RActSg x (ActTrivial s) +instance Monoid s => RActMn x (ActTrivial s) +instance Semigroup x => RActDistrib x (ActTrivial s) +instance Monoid x => RActNeutral x (ActTrivial s) + +-- | An action on any functor that uses the @fmap@ function. For example : +-- +-- >>> ActMap (ActSelf "Hello") <>$ [" World !", " !"] +-- ["Hello World !","Hello !"] +-- +newtype ActMap s = ActMap {unactMap :: s} + deriving stock (Show, Eq) + deriving newtype (Semigroup, Monoid, Group) + +-- | Preserves the semigroup (resp. monoid) property of @'LAct' x s@, but +-- __not__ the morphism properties, which depend on potential @'Semigroup'@ +-- (resp. @'Monoid'@) instances of @f x@ +instance (LAct x s, Functor f) => LAct (f x) (ActMap s) where + ActMap s <>$ x = fmap (s <>$) x + {-# INLINE (<>$) #-} + +instance (LActSg x s, Functor f) => LActSg (f x) (ActMap s) +instance (LActMn x s, Functor f) => LActMn (f x) (ActMap s) +instance LAct x s => LActDistrib [x] (ActMap s) +instance LAct x s => LActNeutral [x] (ActMap s) + + +-- | Preserves the semigroup (resp. monoid) property of @'LAct' x s@, but +-- __not__ the morphism properties, which depend on potential @'Semigroup'@ +-- (resp. @'Monoid'@) instances of @f x@. When $f = []@, this is an action by morphism of monoids. +instance (RAct x s, Functor f) => RAct (f x) (ActMap s) where + x $<> ActMap s = fmap ($<> s) x + {-# INLINE ($<>) #-} + +instance (RActSg x s, Functor f) => RActSg (f x) (ActMap s) +instance (RActMn x s, Functor f) => RActMn (f x) (ActMap s) +instance RAct x s => RActDistrib [x] (ActMap s) +instance RAct x s => RActNeutral [x] (ActMap s) + +-- | Lifting an a container as an action using @'foldr'@ (for /left/ actions) or +-- @'foldl'@ (for /right/ actions). For a strict version, use @'ActFold''@. +-- +-- A left action @(<>$)@ can be seen as an operator for the @'foldr'@ function, +-- and a allowing to lift any action to some @'Foldable'@ container. +-- +-- >> ActFold [Sum (1 :: Int), Sum 2, Sum 3] <>$ (4 :: Int) +-- > 10 +-- +newtype ActFold s = ActFold {unactFold :: s} + deriving stock (Show, Eq) + deriving newtype (Semigroup, Monoid, Group) + +-- | When used with lists @[]@, this is a monoid action +instance (Foldable f, LAct x s) => LAct x (ActFold (f s)) where + ActFold f <>$ x = foldr (<>$) x f + {-# INLINE (<>$) #-} + +instance LAct x s => LActSg x (ActFold [s]) + +-- | When used with lists @[]@, this is a monoid action +instance (Foldable f, RAct x s) => RAct x (ActFold (f s)) where + x $<> ActFold f = foldl ($<>) x f + {-# INLINE ($<>) #-} + +-- | Lifting an a container as an action using @'fold'r'@ (for /left/ actions) +-- or @'foldl''@ (for /right/ actions). For a lazy version, use @'ActFold'@. +-- +-- A left action @(<>$)@ can be seen as an operator for the @'foldr'@ function, +-- and a allowing to lift any action to some @'Foldable'@ container. +-- +-- >>> ActFold' [Sum (1 :: Int), Sum 2, Sum 3] <>$ (4 :: Int) +-- 10 +-- +newtype ActFold' s = ActFold' {unactFold' :: s} + deriving stock (Show, Eq) + deriving newtype (Semigroup, Monoid, Group) + +-- | When used with lists @[]@, this is a monoid action +instance (Foldable f, LAct x s) => LAct x (ActFold' (f s)) where + ActFold' f <>$ x = foldr' (<>$) x f + {-# INLINE (<>$) #-} + +instance LAct x s => LActSg x (ActFold' [s]) + +-- | When used with lists @[]@, this is a monoid action +instance (Foldable f, RAct x s) => RAct x (ActFold' (f s)) where + x $<> ActFold' f = foldl' ($<>) x f + {-# INLINE ($<>) #-} + + +---------------------------------- Instances ----------------------------------- + +-- | Action by morphism of monoids +instance LAct x () where + () <>$ x = x + {-# INLINE (<>$) #-} + +instance LActSg x () +instance LActMn x () +instance Semigroup x => LActDistrib x () +instance Monoid x => LActNeutral x () + +-- | Monoid action +instance RAct x () where + x $<> () = x + {-# INLINE ($<>) #-} + +instance RActSg x () +instance RActMn x () +instance Semigroup x => RActDistrib x () +instance Monoid x => RActNeutral x () + +-- | Action by morphism of semigroups (resp. monoids) when @'Semigroup' s@ +-- (resp. @'Monoid' s@) +instance {-# INCOHERENT #-} LAct () s where + _ <>$ () = () + {-# INLINE (<>$) #-} + +instance {-# INCOHERENT #-} Semigroup s =>LActSg () s +instance {-# INCOHERENT #-} Monoid s => LActMn () s +instance {-# INCOHERENT #-} LActDistrib () s +instance {-# INCOHERENT #-} LActNeutral () s + +-- | Action by morphism of semigroups (resp. monoids) when @'Semigroup' s@ +-- (resp. @'Monoid' s@) +instance {-# INCOHERENT #-} RAct () s where + () $<> _ = () + {-# INLINE ($<>) #-} + +instance {-# INCOHERENT #-} Semigroup s => RActSg () s +instance {-# INCOHERENT #-} Monoid s => RActMn () s +instance {-# INCOHERENT #-} RActDistrib () s +instance {-# INCOHERENT #-} RActNeutral () s + +-- | Monoid action when @'LAct' x s@ is a semigroup action. +instance LAct x s => LAct x (Maybe s) where + Nothing <>$ x = x + Just s <>$ x = s <>$ x + +instance LActSg x s => LActSg x (Maybe s) +instance LActSg x s => LActMn x (Maybe s) + +-- | Monoid action when @'LAct' x s@ is a semigroup action. +instance RAct x s => RAct x (Maybe s) where + x $<> Nothing = x + x $<> Just s = x $<> s + +instance RActSg x s => RActSg x (Maybe s) +instance RActSg x s => RActMn x (Maybe s) + +-- | Same action propety as the weaker properties of @('LAct' x1 s1, 'LAct' x2 +-- s2)@ +instance (LAct x1 s1, LAct x2 s2) => LAct (x1, x2) (s1, s2) where + (s1, s2) <>$ (x1, x2) = (s1 <>$ x1, s2 <>$ x2) + +instance (LActSg x1 s1, LActSg x2 s2) => LActSg (x1, x2) (s1, s2) +instance (LActMn x1 s1, LActMn x2 s2) => LActMn (x1, x2) (s1, s2) +instance (LActDistrib x1 s1, LActDistrib x2 s2) => LActDistrib (x1, x2) (s1, s2) +instance (LActNeutral x1 s1, LActNeutral x2 s2) => LActNeutral (x1, x2) (s1, s2) + +-- | Same action propety as the weaker properties of @('LAct' x1 s1, 'LAct' x2 +-- s2)@ +instance (RAct x1 s1, RAct x2 s2) => RAct (x1, x2) (s1, s2) where + (x1, x2) $<> (s1, s2) = (x1 $<> s1, x2 $<> s2) + +instance (RActSg x1 s1, RActSg x2 s2) => RActSg (x1, x2) (s1, s2) +instance (RActMn x1 s1, RActMn x2 s2) => RActMn (x1, x2) (s1, s2) +instance (RActDistrib x1 s1, RActDistrib x2 s2) => RActDistrib (x1, x2) (s1, s2) +instance (RActNeutral x1 s1, RActNeutral x2 s2) => RActNeutral (x1, x2) (s1, s2) + +-- | No additionnal properties. In particular this is _not_ a semigroup action. +instance (LAct x s, LAct x t) => LAct x (Either s t) where + (Left s) <>$ x = s <>$ x + (Right s) <>$ x = s <>$ x + +-- | No additionnal properties. In particular this is _not_ a semigroup action. +instance (RAct x s, RAct x t) => RAct x (Either s t) where + x $<> (Left s) = x $<> s + x $<> (Right s) = x $<> s + + +-------------------- Instances for base library functors --------------------- + +-- | Preserves action properties of @'LAct' x s@. +instance LAct x s => LAct x (Identity s) where + Identity s <>$ x = s <>$ x + {-# INLINE (<>$) #-} + +instance LActSg x s => LActSg x (Identity s) +instance LActMn x s => LActMn x (Identity s) +instance LActDistrib x s => LActDistrib x (Identity s) +instance LActNeutral x s => LActNeutral x (Identity s) + + +-- | Preserves action properties of @'LAct' x s@. +instance {-# OVERLAPPING #-} LAct x s => LAct (Identity x) (Identity s) where + Identity s <>$ Identity x = Identity (s <>$ x) + +instance {-# OVERLAPPING #-} LActSg x s => LActSg (Identity x) (Identity s) +instance {-# OVERLAPPING #-} LActMn x s => LActMn (Identity x) (Identity s) +instance {-# OVERLAPPING #-} LActDistrib x s + => LActDistrib (Identity x) (Identity s) +instance {-# OVERLAPPING #-} LActNeutral x s + => LActNeutral (Identity x) (Identity s) + +-- | Preserves action properties of @'RAct' x s@. +instance RAct x s => RAct x (Identity s) where + x $<> Identity s = x $<> s + {-# INLINE ($<>) #-} + +instance RActSg x s => RActSg x (Identity s) +instance RActMn x s => RActMn x (Identity s) +instance RActDistrib x s => RActDistrib x (Identity s) +instance RActNeutral x s => RActNeutral x (Identity s) + +-- | Preserves action properties of @'LAct' x s@. +instance {-# OVERLAPPING #-} RAct x s => RAct (Identity x) (Identity s) where + Identity x $<> Identity s = Identity (x $<> s) + +instance {-# OVERLAPPING #-} RActSg x s => RActSg (Identity x) (Identity s) +instance {-# OVERLAPPING #-} RActMn x s => RActMn (Identity x) (Identity s) +instance {-# OVERLAPPING #-} RActDistrib x s + => RActDistrib (Identity x) (Identity s) +instance {-# OVERLAPPING #-} RActNeutral x s + => RActNeutral (Identity x) (Identity s) + +------------------------- Instances for Data.Semigroup ------------------------- + +-- | Preserves action properties of @'LAct' x s@. +instance LAct x s => RAct x (Dual s) where + x $<> Dual s = s <>$ x + {-# INLINE ($<>) #-} + +instance LActSg x s => RActSg x (Dual s) +instance LActMn x s => RActMn x (Dual s) +instance LActDistrib x s => RActDistrib x (Dual s) +instance LActNeutral x s => RActNeutral x (Dual s) + +-- | Preserves action properties of @'LAct' x s@. +instance RAct x s => LAct x (Dual s) where + Dual s <>$ x = x $<> s + {-# INLINE (<>$) #-} + +instance RActSg x s => LActSg x (Dual s) +instance RActMn x s => LActMn x (Dual s) +instance RActDistrib x s => LActDistrib x (Dual s) +instance RActNeutral x s => LActNeutral x (Dual s) + +-- | Monoid action +instance LAct x (Endo x) where + Endo f <>$ x = f x + {-# INLINE (<>$) #-} + +instance LActSg x (Endo x) +instance LActMn x (Endo x) + +-- | Monoid action +instance Num x => LAct x (Sum x) where + (<>$) s = coerce (s <>) + {-# INLINE (<>$) #-} + +instance Num x => LActSg x (Sum x) +instance Num x => LActMn x (Sum x) + + +-- | Monoid action +instance Num x => RAct x (Sum x) where + x $<> s = coerce $ coerce x <> s + {-# INLINE ($<>) #-} + +instance Num x => RActSg x (Sum x) +instance Num x => RActMn x (Sum x) + +-- | Monoid action +instance Num x => LAct x (Product x) where + (<>$) s = coerce (s <>) + {-# INLINE (<>$) #-} + +instance Num x => LActSg x (Product x) +instance Num x => LActMn x (Product x) + +-- | Monoid action +instance Num x => RAct x (Product x) where + x $<> s = coerce $ coerce x <> s + {-# INLINE ($<>) #-} + +instance Num x => RActSg x (Product x) +instance Num x => RActMn x (Product x) + +-- | Monoid action +instance {-# OVERLAPPING #-} Num x => LAct (Sum x) (Sum x) where + (<>$) = (<>) + {-# INLINE (<>$) #-} + +instance {-# OVERLAPPING #-} Num x => LActSg (Sum x) (Sum x) +instance {-# OVERLAPPING #-} Num x => LActMn (Sum x) (Sum x) + +-- | Monoid action +instance {-# OVERLAPPING #-} Num x => RAct (Sum x) (Sum x) where + ($<>) = (<>) + {-# INLINE ($<>) #-} + +instance {-# OVERLAPPING #-} Num x => RActSg (Sum x) (Sum x) +instance {-# OVERLAPPING #-} Num x => RActMn (Sum x) (Sum x) + +-- | Monoid action +instance {-# OVERLAPPING #-} Num x => LAct (Product x) (Product x) where + (<>$) s = coerce (s <>) + {-# INLINE (<>$) #-} + +instance {-# OVERLAPPING #-} Num x => LActSg (Product x) (Product x) +instance {-# OVERLAPPING #-} Num x => LActMn (Product x) (Product x) + +-- | Monoid action +instance {-# OVERLAPPING #-} Num x => RAct (Product x) (Product x) where + ($<>) = (<>) + {-# INLINE ($<>) #-} + +instance {-# OVERLAPPING #-} Num x => RActSg (Product x) (Product x) +instance {-# OVERLAPPING #-} Num x => RActMn (Product x) (Product x) + +-- | Action by morphism of monoids +instance Num x => LAct (Sum x) (Product x) where + (<>$) s = coerce (s <>) + {-# INLINE (<>$) #-} + +instance Num x => LActSg (Sum x) (Product x) +instance Num x => LActMn (Sum x) (Product x) +instance Num x => LActDistrib (Sum x) (Product x) +instance Num x => LActNeutral (Sum x) (Product x) + +-- | Action by morphism of monoids +instance Num x => RAct (Sum x) (Product x) where + x $<> s = coerce $ coerce x <> s + {-# INLINE ($<>) #-} + +instance Num x => RActSg (Sum x) (Product x) +instance Num x => RActMn (Sum x) (Product x) +instance Num x => RActDistrib (Sum x) (Product x) +instance Num x => RActNeutral (Sum x) (Product x) + +-- | Monoid action +instance LAct Bool Any where + (<>$) s = coerce (s <>) + {-# INLINE (<>$) #-} + +instance LActSg Bool Any +instance LActMn Bool Any + +-- | Monoid action +instance RAct Bool Any where + x $<> s = coerce $ coerce x <> s + {-# INLINE ($<>) #-} + +instance RActSg Bool Any +instance RActMn Bool Any + +-- | Monoid action +instance LAct Bool All where + (<>$) s = coerce (s <>) + {-# INLINE (<>$) #-} + +instance LActSg Bool All +instance LActMn Bool All + +-- | Monoid action +instance RAct Bool All where + x $<> s = coerce $ coerce x <> s + {-# INLINE ($<>) #-} + +instance RActSg Bool All +instance RActMn Bool All + +-- | Semigroup action +instance LAct x (Sg.First x) where + (<>$) s = coerce (s <>) + {-# INLINE (<>$) #-} + +instance LActSg x (Sg.First x) + +-- | Semigroup action +instance RAct x (Sg.Last x) where + x $<> s = coerce $ coerce x <> s + {-# INLINE ($<>) #-} + +instance RActSg x (Sg.Last x) + +-- | Monoid action +instance LAct x (Mn.First x) where + Mn.First Nothing <>$ x = x + Mn.First (Just s) <>$ _ = s + {-# INLINE (<>$) #-} + +instance LActSg x (Mn.First x) +instance LActMn x (Mn.First x) + +-- | Monoid action +instance RAct x (Mn.Last x) where + x $<> Mn.Last Nothing = x + _ $<> Mn.Last (Just s) = s + {-# INLINE ($<>) #-} + +instance RActSg x (Mn.Last x) +instance RActMn x (Mn.Last x)
src/Data/Act/Cyclic.hs view
@@ -1,494 +1,494 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DerivingStrategies #-}------------------------------------------------------------------------------------- |------ Module : Data.Act.Cyclic--- Description : Cyclic actions and actions generated by a subset of generators.--- Copyright : (c) Alice Rixte 2024--- License : BSD 3--- Maintainer : alice.rixte@u-bordeaux.fr--- Stability : unstable--- Portability : non-portable (GHC extensions)------ = Presentation------ === Cyclic actions------ A cyclic action (see @'LActCyclic'@ or @'RActCyclic'@) is an action such that--- every element of the actee set can be obtained by acting on some generator,--- which we call here the /origin/ of the actee set.------ For example, @'Sum' Integer@ acts cyclically on @'Integer'@ because for every--- @n :: Integer@, we have @Sum n <>$ O == n@. In this example, @0@ is a--- generator of the action @'LAct' Int (Sum Int)@ and in this library, we will--- call it @'lorigin'@.------ This gives us a way to lift any actee element into an action element. In this--- library, we call that lifting @'lshift'@ (resp. @'rshift'@). In the--- previous example we get @'lshift' = Sum@.------ === Actions generated by a subset of generators------ In a more general setting, this library also provides @'LActGen'@ and--- @'RActGen'@. In theory, they should be superclasses of @'LActCyclic'@ and--- @'RActCyclic'@. In practice it is annoying to need @'Eq'@ instances for--- defining @'lgenerators'@ and @'rgenerators'@. Please open an issue if you--- actually need this.--------- = Usage------ >>> {-# LANGUAGE TypeApplications #-}--- >>> import Data.Act.Cyclic--- >>> import Data.Semigroup--- >>> lorigin @(Sum Int) :: Int--- 0--- >>> lshift (4 :: Int) :: Sum Int--- Sum {getSum = 4}------ = Formal algebraic definitions------ In algebraic terms, a subset @u@ of the set @x@ is a /generating set/ of the--- action @LAct x s@ if for every @x :: x@, there exists a pair @(u,s) :: (u,s)@--- such that @s <>$ u = x@. When the set @u@ is finite, the action @LAct x s@ is--- said to be finitely generated. When the set @u@ is a singleton, the action is--- said to be /cyclic/.------ When the previous decomposition is unique, the action is said to be /free/.--- If it is both free and cyclic, it is /1-free/.------ (See /Monoids, Acts and Categories/ by Mati--- Kilp, Ulrich Knauer, Alexander V. Mikhalev, definition 1.5.1, p.63.)------ Remark : Freeness could be represented with classes @LActFree@ and--- @LActOneFree@ that have no methods. Feel free to open an issue if you need--- them.------------------------------------------------------------------------------------module Data.Act.Cyclic- ( -- * Cyclic actions- LActCyclic (..)- , lorigin- , RActCyclic (..)- , rorigin- -- * Action generated by a subset of generators- , LActGen (..)- , lgenerators- , lgeneratorsList- , lorigins- , RActGen (..)- , rgenerators- , rgeneratorsList- , rorigins- )- where--import Data.Bifunctor-import Data.Functor.Identity-import Data.Coerce-import Data.Semigroup as Sg-import Data.Monoid as Mn--import Data.Default----import Data.Act.Act----- | A left action generated by a single generator.------ Instances must satisfy the following law :------ * 'lshift' x @ <>$ 'lorigin' == x@------ In other words, 'lorigin' is a generator of the action @LAct x s@.----class LAct x s => LActCyclic x s where- -- | The only generator of the action @LAct x s@.- --- -- >>> lorigin' @Int @(Sum Int)- -- 0- --- -- To avoid having to use the redundant first type aplication, use- -- @'lorigin'@.- --- lorigin' :: x-- --- | Shifts an element of @x@ into an action @lshift x@ such that- -- @lshift x <>$ lorigin == x@.- --- lshift :: x -> s---- | A version of @'lorigin''@ such that the first type application is @s@.------ >>> lorigin @(Sum Int) :: Int--- 0----lorigin :: forall s x. LActCyclic x s => x-lorigin = lorigin' @x @s-{-# INLINE lorigin #-}----- | A right action generated by a single generator.------ Instances must satisfy the following law :------ * 'rorigin' @ $<> 'rshift' x == x@------ In other words, 'rorigin' is a generator of the action @RAct x s@.----class RAct x s => RActCyclic x s where- -- | The only generator of the action @RAct x s@.- --- -- >>> rorigin' @Int @(Sum Int) :: Int- -- 0- --- -- To avoid having to use the redundant first type aplication, use- -- @'rorigin'@.- rorigin' :: x-- -- | Shifts an element of @x@ into an action @rshift x@ such that- -- @rshift x $<> rorigin == x@.- rshift :: x -> s---- | A version of @'rorigin''@ such that the first type application is @s@.------ >>> rorigin @(Sum Int) :: Int--- 0----rorigin :: forall s x. RActCyclic x s => x-rorigin = rorigin' @x @s-{-# INLINE rorigin #-}------- | A left action generated by a subset of generators @'lgenerators'@.------ Intuitively, by acting repeteadly on generators with actions--- of @s@, we can reach any element of @x@.------ Since the generating subset of @x@ maybe infinite, we give two alternative--- ways to define it : one using a characteristic function @'lgenerators'@ and--- the other using a list @'lgeneratorsList'@.------ All the above is summarized by the following law that all instances must--- satisfy :------ 1. 'snd' @('lshiftFromGen' x) <>$ 'fst' ('lshiftFromGen' x) == x@--- 2. 'lgenerators'@ ('fst' $ 'lshiftFromGen' x) == True@--- 3. 'lgenerators' @ x == x `'elem'` 'lgeneratorsList' proxy@----class LAct x s => LActGen x s where- -- | The set of origins of the action @'LAct' x s@.- --- -- This is a subset of @x@, represented as its characteristic function,- -- meaning the function that returns @True@ for all elements of @x@ that are- -- origins of the action and @False@ otherwise.- --- -- To use @'lgenerators'@, you need TypeApplications:- --- -- >>> lgenerators' @Int @(Sum Int) 4- -- False- --- -- >>> lgenerators' @Int @(Sum Int) 0- -- True- --- -- To avoid having to use the redundant first type aplication, use- -- @'lgenerators'@.- lgenerators' :: x -> Bool- default lgenerators' :: Eq x => x -> Bool- lgenerators' x = x `elem` lgeneratorsList' @x @s-- -- | The set of origins of the action @LAct x s@ seen as a list.- --- -- You can let this function undefined if the set of origins cannot be- -- represented as a list.- --- -- >>> lgeneratorsList' @Int @(Sum Int)- -- [0]- --- -- To avoid having to use the redundant first type aplication, use- -- @'lgeneratorsList'@.- --- lgeneratorsList' :: [x]- default lgeneratorsList' :: LActCyclic x s => [x]- lgeneratorsList' = [lorigin @s]-- -- | Returns a point's associated genrator @u@ along with an action @s@ such- -- that @s <>$ u == x@.- lshiftFromGen:: x -> (x,s)- default lshiftFromGen :: LActCyclic x s => x -> (x,s)- lshiftFromGen x = (lorigin @s, lshift x)---- | A version of @'lgenerators''@ such that the first type application is @s@.------ >>> lgenerators @(Sum Int) (4 :: Int)--- False------ >>> lgenerators @(Sum Int) (0 :: Int)--- True----lgenerators :: forall s x. LActGen x s => x -> Bool-lgenerators = lgenerators' @x @s-{-# INLINE lgenerators #-}---- | A version of @'lgeneratorsList''@ such that the first type application is--- @s@.------ >>> lgeneratorsList @(Sum Int) :: [Int]--- [0]----lgeneratorsList :: forall s x. LActGen x s => [x]-lgeneratorsList = lgeneratorsList' @x @s-{-# INLINE lgeneratorsList #-}---- | An alias for @'lgeneratorsList'@.-lorigins :: forall s x. LActGen x s => [x]-lorigins = lgeneratorsList @s-{-# INLINE lorigins #-}-------------------------------------------------------------------------------------- | A right action generated by a subset of generators @'lgenerators'@.------ Intuitively, by acting repeteadly on generators with actions--- of @s@, we can reach any element of @x@.--------- Since the generating subset of @x@ maybe infinite, we give two alternative--- ways to define it : one using a characteristic function @'rgenerators'@ and--- the other using a list @'rgeneratorsList'@.------ All the above is summarized by the following law that all instances must--- satisfy :------ 1. 'rgenerators'@ ('fst' $ 'rshiftFromGen' x) == True@--- 2. 'fst' ('rshiftFromGen' x) $<> 'snd' @('rshiftFromGen' x) == x@--- 3. 'rgenerators' @x == x `'elem'` 'rgeneratorsList' x@----class RAct x s => RActGen x s where- -- | The set of origins of the action @'RAct' x s@.- --- -- This is a subset of @x@, represented as its characteristic function,- -- meaning the function that returns @True@ for all elements of @x@ that are- -- origins of the action and @False@ otherwise.- --- -- To use @'rgenerators'@, you need TypeApplications:- --- -- >>> rgenerators' @(Sum Int) (4 :: Int)- -- False- --- -- >>> rgenerators' @(Sum Int) (0 :: Int)- -- True- --- -- To avoid having to use the redundant first type aplication, use- -- @'rgenerators'@.- rgenerators' :: x -> Bool- default rgenerators' :: Eq x => x -> Bool- rgenerators' x = x `elem` rgeneratorsList' @x @s- {-# INLINE rgenerators' #-}-- -- | The set of origins of the action @RAct x s@ seen as a list.- --- -- You can let this function undefined if the set of origins cannot be- -- represented as a list.- --- -- >>> rgeneratorsList' @(Sum Int) :: [Int]- -- [0]- --- rgeneratorsList' :: [x]- default rgeneratorsList' :: RActCyclic x s => [x]- rgeneratorsList' = [rorigin @s]- {-# INLINE rgeneratorsList' #-}-- -- | Returns a point's associated generator @u@ along with an action @s@ such- -- that @u $<> s == x@.- rshiftFromGen :: x -> (x,s)- default rshiftFromGen :: RActCyclic x s => x -> (x,s)- rshiftFromGen x = (rorigin @s, rshift x)- {-# INLINE rshiftFromGen #-}---- | A version of @'rgenerators''@ such that the first type application is @s@.------ >>> rgenerators @(Sum Int) (4 :: Int)--- False------ >>> rgenerators @(Sum Int) (0 :: Int)--- True----rgenerators :: forall s x. RActGen x s => x -> Bool-rgenerators = rgenerators' @x @s-{-# INLINE rgenerators #-}---- | A version of @'rgeneratorsList''@ such that the first type application is--- @s@.------ >>> rgeneratorsList @(Sum Int) :: [Int]--- [0]----rgeneratorsList :: forall s x. RActGen x s => [x]-rgeneratorsList = rgeneratorsList' @x @s-{-# INLINE rgeneratorsList #-}---- | An alias for @'rgeneratorsList'@.----rorigins :: forall s x. RActGen x s => [x]-rorigins = rgeneratorsList @s-{-# INLINE rorigins #-}-------------------------------------- Instances --------------------------------------- Identity ----instance LActGen x s => LActGen (Identity x) (Identity s) where- lgenerators' (Identity x) = lgenerators @s x- {-# INLINE lgenerators' #-}- lgeneratorsList' = Identity <$> lgeneratorsList @s- {-# INLINE lgeneratorsList' #-}- lshiftFromGen (Identity x) = bimap Identity Identity $ lshiftFromGen x- {-# INLINE lshiftFromGen #-}--instance LActCyclic x s => LActCyclic (Identity x) (Identity s) where- lorigin' = Identity (lorigin @s)- {-# INLINE lorigin' #-}- lshift (Identity x) = Identity (lshift x)- {-# INLINE lshift #-}--instance RActGen x s => RActGen (Identity x) (Identity s) where- rgenerators' (Identity x) = rgenerators @s x- {-# INLINE rgenerators' #-}- rgeneratorsList' = Identity <$> rgeneratorsList @s- {-# INLINE rgeneratorsList' #-}- rshiftFromGen (Identity x) = bimap Identity Identity $ rshiftFromGen x- {-# INLINE rshiftFromGen #-}--instance RActCyclic x s => RActCyclic (Identity x) (Identity s) where- rorigin' = Identity (rorigin @s)- {-# INLINE rorigin' #-}- rshift (Identity x) = Identity (rshift x)- {-# INLINE rshift #-}---- ActSelf ----instance (Eq s, Monoid s) => LActGen s (ActSelf s)--instance Monoid s => LActCyclic s (ActSelf s) where- lorigin' = mempty- {-# INLINE lorigin' #-}- lshift = ActSelf- {-# INLINE lshift #-}--instance (Eq s, Monoid s) => RActGen s (ActSelf s)--instance Monoid s => RActCyclic s (ActSelf s) where- rorigin' = mempty- {-# INLINE rorigin' #-}- rshift = ActSelf- {-# INLINE rshift #-}----- ActSelf' ----instance (Eq x, Coercible x s, Monoid s) => LActGen x (ActSelf' s)--instance (Coercible x s, Monoid s) => LActCyclic x (ActSelf' s) where- lorigin' = coerce (mempty :: s)- {-# INLINE lorigin' #-}- lshift = coerce- {-# INLINE lshift #-}--instance (Eq x, Coercible x s, Monoid s) => RActGen x (ActSelf' s)--instance (Coercible x s, Monoid s) => RActCyclic x (ActSelf' s) where- rorigin' = coerce (mempty :: s)- {-# INLINE rorigin' #-}- rshift = coerce- {-# INLINE rshift #-}---- Sum ----instance (Eq x, Num x) => LActGen x (Sum x)--instance Num x => LActCyclic x (Sum x) where- lorigin' = 0- {-# INLINE lorigin' #-}- lshift = Sum- {-# INLINE lshift #-}--instance (Eq x, Num x) => RActGen x (Sum x)--instance Num x => RActCyclic x (Sum x) where- rorigin' = 0- {-# INLINE rorigin' #-}- rshift = Sum- {-# INLINE rshift #-}---- Product ----instance (Eq x, Num x) => LActGen x (Product x)--instance Num x => LActCyclic x (Product x) where- lorigin' = 1- {-# INLINE lorigin' #-}- lshift = Product- {-# INLINE lshift #-}--instance (Eq x, Num x) => RActGen x (Product x)--instance Num x => RActCyclic x (Product x) where- rorigin' = 1- {-# INLINE rorigin' #-}- rshift = Product- {-# INLINE rshift #-}---- Product on Sum ----instance (Eq x, Num x) => LActGen (Sum x) (Product x)--instance Num x => LActCyclic (Sum x) (Product x) where- lorigin' = 1- {-# INLINE lorigin' #-}- lshift = coerce- {-# INLINE lshift #-}--instance (Eq x, Num x) => RActGen (Sum x) (Product x)--instance Num x => RActCyclic (Sum x) (Product x) where- rorigin' = 1- {-# INLINE rorigin' #-}- rshift = coerce- {-# INLINE rshift #-}---- First ----instance Default x => LActCyclic x (Sg.First x) where- lorigin' = def- lshift = Sg.First--instance Default x => LActCyclic x (Mn.First x) where- lorigin' = def- lshift = Mn.First . Just--instance Default x => RActCyclic x (Sg.Last x) where- rorigin' = def- rshift = Sg.Last--instance Default x => RActCyclic x (Mn.Last x) where- rorigin' = def- rshift = Mn.Last . Just-+{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DerivingStrategies #-} + +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Act.Cyclic +-- Description : Cyclic actions and actions generated by a subset of generators. +-- Copyright : (c) Alice Rixte 2024 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : unstable +-- Portability : non-portable (GHC extensions) +-- +-- = Presentation +-- +-- === Cyclic actions +-- +-- A cyclic action (see @'LActCyclic'@ or @'RActCyclic'@) is an action such that +-- every element of the actee set can be obtained by acting on some generator, +-- which we call here the /origin/ of the actee set. +-- +-- For example, @'Sum' Integer@ acts cyclically on @'Integer'@ because for every +-- @n :: Integer@, we have @Sum n <>$ O == n@. In this example, @0@ is a +-- generator of the action @'LAct' Int (Sum Int)@ and in this library, we will +-- call it @'lorigin'@. +-- +-- This gives us a way to lift any actee element into an action element. In this +-- library, we call that lifting @'lshift'@ (resp. @'rshift'@). In the +-- previous example we get @'lshift' = Sum@. +-- +-- === Actions generated by a subset of generators +-- +-- In a more general setting, this library also provides @'LActGen'@ and +-- @'RActGen'@. In theory, they should be superclasses of @'LActCyclic'@ and +-- @'RActCyclic'@. In practice it is annoying to need @'Eq'@ instances for +-- defining @'lgenerators'@ and @'rgenerators'@. Please open an issue if you +-- actually need this. +-- +-- +-- = Usage +-- +-- >>> {-# LANGUAGE TypeApplications #-} +-- >>> import Data.Act.Cyclic +-- >>> import Data.Semigroup +-- >>> lorigin @(Sum Int) :: Int +-- 0 +-- >>> lshift (4 :: Int) :: Sum Int +-- Sum {getSum = 4} +-- +-- = Formal algebraic definitions +-- +-- In algebraic terms, a subset @u@ of the set @x@ is a /generating set/ of the +-- action @LAct x s@ if for every @x :: x@, there exists a pair @(u,s) :: (u,s)@ +-- such that @s <>$ u = x@. When the set @u@ is finite, the action @LAct x s@ is +-- said to be finitely generated. When the set @u@ is a singleton, the action is +-- said to be /cyclic/. +-- +-- When the previous decomposition is unique, the action is said to be /free/. +-- If it is both free and cyclic, it is /1-free/. +-- +-- (See /Monoids, Acts and Categories/ by Mati +-- Kilp, Ulrich Knauer, Alexander V. Mikhalev, definition 1.5.1, p.63.) +-- +-- Remark : Freeness could be represented with classes @LActFree@ and +-- @LActOneFree@ that have no methods. Feel free to open an issue if you need +-- them. +-------------------------------------------------------------------------------- + + +module Data.Act.Cyclic + ( -- * Cyclic actions + LActCyclic (..) + , lorigin + , RActCyclic (..) + , rorigin + -- * Action generated by a subset of generators + , LActGen (..) + , lgenerators + , lgeneratorsList + , lorigins + , RActGen (..) + , rgenerators + , rgeneratorsList + , rorigins + ) + where + +import Data.Bifunctor +import Data.Functor.Identity +import Data.Coerce +import Data.Semigroup as Sg +import Data.Monoid as Mn + +import Data.Default + + + +import Data.Act.Act + + +-- | A left action generated by a single generator. +-- +-- Instances must satisfy the following law : +-- +-- * 'lshift' x @ <>$ 'lorigin' == x@ +-- +-- In other words, 'lorigin' is a generator of the action @LAct x s@. +-- +class LAct x s => LActCyclic x s where + -- | The only generator of the action @LAct x s@. + -- + -- >>> lorigin' @Int @(Sum Int) + -- 0 + -- + -- To avoid having to use the redundant first type aplication, use + -- @'lorigin'@. + -- + lorigin' :: x + + --- | Shifts an element of @x@ into an action @lshift x@ such that + -- @lshift x <>$ lorigin == x@. + -- + lshift :: x -> s + +-- | A version of @'lorigin''@ such that the first type application is @s@. +-- +-- >>> lorigin @(Sum Int) :: Int +-- 0 +-- +lorigin :: forall s x. LActCyclic x s => x +lorigin = lorigin' @x @s +{-# INLINE lorigin #-} + + +-- | A right action generated by a single generator. +-- +-- Instances must satisfy the following law : +-- +-- * 'rorigin' @ $<> 'rshift' x == x@ +-- +-- In other words, 'rorigin' is a generator of the action @RAct x s@. +-- +class RAct x s => RActCyclic x s where + -- | The only generator of the action @RAct x s@. + -- + -- >>> rorigin' @Int @(Sum Int) :: Int + -- 0 + -- + -- To avoid having to use the redundant first type aplication, use + -- @'rorigin'@. + rorigin' :: x + + -- | Shifts an element of @x@ into an action @rshift x@ such that + -- @rshift x $<> rorigin == x@. + rshift :: x -> s + +-- | A version of @'rorigin''@ such that the first type application is @s@. +-- +-- >>> rorigin @(Sum Int) :: Int +-- 0 +-- +rorigin :: forall s x. RActCyclic x s => x +rorigin = rorigin' @x @s +{-# INLINE rorigin #-} + + + + +-- | A left action generated by a subset of generators @'lgenerators'@. +-- +-- Intuitively, by acting repeteadly on generators with actions +-- of @s@, we can reach any element of @x@. +-- +-- Since the generating subset of @x@ maybe infinite, we give two alternative +-- ways to define it : one using a characteristic function @'lgenerators'@ and +-- the other using a list @'lgeneratorsList'@. +-- +-- All the above is summarized by the following law that all instances must +-- satisfy : +-- +-- 1. 'snd' @('lshiftFromGen' x) <>$ 'fst' ('lshiftFromGen' x) == x@ +-- 2. 'lgenerators'@ ('fst' $ 'lshiftFromGen' x) == True@ +-- 3. 'lgenerators' @ x == x `'elem'` 'lgeneratorsList' proxy@ +-- +class LAct x s => LActGen x s where + -- | The set of origins of the action @'LAct' x s@. + -- + -- This is a subset of @x@, represented as its characteristic function, + -- meaning the function that returns @True@ for all elements of @x@ that are + -- origins of the action and @False@ otherwise. + -- + -- To use @'lgenerators'@, you need TypeApplications: + -- + -- >>> lgenerators' @Int @(Sum Int) 4 + -- False + -- + -- >>> lgenerators' @Int @(Sum Int) 0 + -- True + -- + -- To avoid having to use the redundant first type aplication, use + -- @'lgenerators'@. + lgenerators' :: x -> Bool + default lgenerators' :: Eq x => x -> Bool + lgenerators' x = x `elem` lgeneratorsList' @x @s + + -- | The set of origins of the action @LAct x s@ seen as a list. + -- + -- You can let this function undefined if the set of origins cannot be + -- represented as a list. + -- + -- >>> lgeneratorsList' @Int @(Sum Int) + -- [0] + -- + -- To avoid having to use the redundant first type aplication, use + -- @'lgeneratorsList'@. + -- + lgeneratorsList' :: [x] + default lgeneratorsList' :: LActCyclic x s => [x] + lgeneratorsList' = [lorigin @s] + + -- | Returns a point's associated genrator @u@ along with an action @s@ such + -- that @s <>$ u == x@. + lshiftFromGen:: x -> (x,s) + default lshiftFromGen :: LActCyclic x s => x -> (x,s) + lshiftFromGen x = (lorigin @s, lshift x) + +-- | A version of @'lgenerators''@ such that the first type application is @s@. +-- +-- >>> lgenerators @(Sum Int) (4 :: Int) +-- False +-- +-- >>> lgenerators @(Sum Int) (0 :: Int) +-- True +-- +lgenerators :: forall s x. LActGen x s => x -> Bool +lgenerators = lgenerators' @x @s +{-# INLINE lgenerators #-} + +-- | A version of @'lgeneratorsList''@ such that the first type application is +-- @s@. +-- +-- >>> lgeneratorsList @(Sum Int) :: [Int] +-- [0] +-- +lgeneratorsList :: forall s x. LActGen x s => [x] +lgeneratorsList = lgeneratorsList' @x @s +{-# INLINE lgeneratorsList #-} + +-- | An alias for @'lgeneratorsList'@. +lorigins :: forall s x. LActGen x s => [x] +lorigins = lgeneratorsList @s +{-# INLINE lorigins #-} + + + +------------------------------------------------------------------------------ + +-- | A right action generated by a subset of generators @'lgenerators'@. +-- +-- Intuitively, by acting repeteadly on generators with actions +-- of @s@, we can reach any element of @x@. +-- +-- +-- Since the generating subset of @x@ maybe infinite, we give two alternative +-- ways to define it : one using a characteristic function @'rgenerators'@ and +-- the other using a list @'rgeneratorsList'@. +-- +-- All the above is summarized by the following law that all instances must +-- satisfy : +-- +-- 1. 'rgenerators'@ ('fst' $ 'rshiftFromGen' x) == True@ +-- 2. 'fst' ('rshiftFromGen' x) $<> 'snd' @('rshiftFromGen' x) == x@ +-- 3. 'rgenerators' @x == x `'elem'` 'rgeneratorsList' x@ +-- +class RAct x s => RActGen x s where + -- | The set of origins of the action @'RAct' x s@. + -- + -- This is a subset of @x@, represented as its characteristic function, + -- meaning the function that returns @True@ for all elements of @x@ that are + -- origins of the action and @False@ otherwise. + -- + -- To use @'rgenerators'@, you need TypeApplications: + -- + -- >>> rgenerators' @(Sum Int) (4 :: Int) + -- False + -- + -- >>> rgenerators' @(Sum Int) (0 :: Int) + -- True + -- + -- To avoid having to use the redundant first type aplication, use + -- @'rgenerators'@. + rgenerators' :: x -> Bool + default rgenerators' :: Eq x => x -> Bool + rgenerators' x = x `elem` rgeneratorsList' @x @s + {-# INLINE rgenerators' #-} + + -- | The set of origins of the action @RAct x s@ seen as a list. + -- + -- You can let this function undefined if the set of origins cannot be + -- represented as a list. + -- + -- >>> rgeneratorsList' @(Sum Int) :: [Int] + -- [0] + -- + rgeneratorsList' :: [x] + default rgeneratorsList' :: RActCyclic x s => [x] + rgeneratorsList' = [rorigin @s] + {-# INLINE rgeneratorsList' #-} + + -- | Returns a point's associated generator @u@ along with an action @s@ such + -- that @u $<> s == x@. + rshiftFromGen :: x -> (x,s) + default rshiftFromGen :: RActCyclic x s => x -> (x,s) + rshiftFromGen x = (rorigin @s, rshift x) + {-# INLINE rshiftFromGen #-} + +-- | A version of @'rgenerators''@ such that the first type application is @s@. +-- +-- >>> rgenerators @(Sum Int) (4 :: Int) +-- False +-- +-- >>> rgenerators @(Sum Int) (0 :: Int) +-- True +-- +rgenerators :: forall s x. RActGen x s => x -> Bool +rgenerators = rgenerators' @x @s +{-# INLINE rgenerators #-} + +-- | A version of @'rgeneratorsList''@ such that the first type application is +-- @s@. +-- +-- >>> rgeneratorsList @(Sum Int) :: [Int] +-- [0] +-- +rgeneratorsList :: forall s x. RActGen x s => [x] +rgeneratorsList = rgeneratorsList' @x @s +{-# INLINE rgeneratorsList #-} + +-- | An alias for @'rgeneratorsList'@. +-- +rorigins :: forall s x. RActGen x s => [x] +rorigins = rgeneratorsList @s +{-# INLINE rorigins #-} + + + +---------------------------------- Instances ----------------------------------- + +-- Identity -- + +instance LActGen x s => LActGen (Identity x) (Identity s) where + lgenerators' (Identity x) = lgenerators @s x + {-# INLINE lgenerators' #-} + lgeneratorsList' = Identity <$> lgeneratorsList @s + {-# INLINE lgeneratorsList' #-} + lshiftFromGen (Identity x) = bimap Identity Identity $ lshiftFromGen x + {-# INLINE lshiftFromGen #-} + +instance LActCyclic x s => LActCyclic (Identity x) (Identity s) where + lorigin' = Identity (lorigin @s) + {-# INLINE lorigin' #-} + lshift (Identity x) = Identity (lshift x) + {-# INLINE lshift #-} + +instance RActGen x s => RActGen (Identity x) (Identity s) where + rgenerators' (Identity x) = rgenerators @s x + {-# INLINE rgenerators' #-} + rgeneratorsList' = Identity <$> rgeneratorsList @s + {-# INLINE rgeneratorsList' #-} + rshiftFromGen (Identity x) = bimap Identity Identity $ rshiftFromGen x + {-# INLINE rshiftFromGen #-} + +instance RActCyclic x s => RActCyclic (Identity x) (Identity s) where + rorigin' = Identity (rorigin @s) + {-# INLINE rorigin' #-} + rshift (Identity x) = Identity (rshift x) + {-# INLINE rshift #-} + +-- ActSelf -- + +instance (Eq s, Monoid s) => LActGen s (ActSelf s) + +instance Monoid s => LActCyclic s (ActSelf s) where + lorigin' = mempty + {-# INLINE lorigin' #-} + lshift = ActSelf + {-# INLINE lshift #-} + +instance (Eq s, Monoid s) => RActGen s (ActSelf s) + +instance Monoid s => RActCyclic s (ActSelf s) where + rorigin' = mempty + {-# INLINE rorigin' #-} + rshift = ActSelf + {-# INLINE rshift #-} + + +-- ActSelf' -- + +instance (Eq x, Coercible x s, Monoid s) => LActGen x (ActSelf' s) + +instance (Coercible x s, Monoid s) => LActCyclic x (ActSelf' s) where + lorigin' = coerce (mempty :: s) + {-# INLINE lorigin' #-} + lshift = coerce + {-# INLINE lshift #-} + +instance (Eq x, Coercible x s, Monoid s) => RActGen x (ActSelf' s) + +instance (Coercible x s, Monoid s) => RActCyclic x (ActSelf' s) where + rorigin' = coerce (mempty :: s) + {-# INLINE rorigin' #-} + rshift = coerce + {-# INLINE rshift #-} + +-- Sum -- + +instance (Eq x, Num x) => LActGen x (Sum x) + +instance Num x => LActCyclic x (Sum x) where + lorigin' = 0 + {-# INLINE lorigin' #-} + lshift = Sum + {-# INLINE lshift #-} + +instance (Eq x, Num x) => RActGen x (Sum x) + +instance Num x => RActCyclic x (Sum x) where + rorigin' = 0 + {-# INLINE rorigin' #-} + rshift = Sum + {-# INLINE rshift #-} + +-- Product -- + +instance (Eq x, Num x) => LActGen x (Product x) + +instance Num x => LActCyclic x (Product x) where + lorigin' = 1 + {-# INLINE lorigin' #-} + lshift = Product + {-# INLINE lshift #-} + +instance (Eq x, Num x) => RActGen x (Product x) + +instance Num x => RActCyclic x (Product x) where + rorigin' = 1 + {-# INLINE rorigin' #-} + rshift = Product + {-# INLINE rshift #-} + +-- Product on Sum -- + +instance (Eq x, Num x) => LActGen (Sum x) (Product x) + +instance Num x => LActCyclic (Sum x) (Product x) where + lorigin' = 1 + {-# INLINE lorigin' #-} + lshift = coerce + {-# INLINE lshift #-} + +instance (Eq x, Num x) => RActGen (Sum x) (Product x) + +instance Num x => RActCyclic (Sum x) (Product x) where + rorigin' = 1 + {-# INLINE rorigin' #-} + rshift = coerce + {-# INLINE rshift #-} + +-- First -- + +instance Default x => LActCyclic x (Sg.First x) where + lorigin' = def + lshift = Sg.First + +instance Default x => LActCyclic x (Mn.First x) where + lorigin' = def + lshift = Mn.First . Just + +instance Default x => RActCyclic x (Sg.Last x) where + rorigin' = def + rshift = Sg.Last + +instance Default x => RActCyclic x (Mn.Last x) where + rorigin' = def + rshift = Mn.Last . Just +
src/Data/Act/Torsor.hs view
@@ -1,184 +1,210 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}------------------------------------------------------------------------------------- |------ Module : Data.Act--- Description : Group torsors for left and right actions.--- Copyright : (c) Alice Rixte 2025--- License : BSD 3--- Maintainer : alice.rixte@u-bordeaux.fr--- Stability : unstable--- Portability : non-portable (GHC extensions)------ == Presentation-----------------------------------------------------------------------------------------module Data.Act.Torsor- ( LTorsor (..)- , RTorsor (..)- )-where--import Data.Coerce-import Data.Functor.Identity-import Data.Monoid--import Data.Group--import Data.Act.Act---- | A left group torsor.------ The most well known example of a torsor is the particular case of an affine--- space where the group is the additive group of the vector space and the set--- is a set of points. Torsors are more general than affine spaces since they--- don't enforce linearity. Notice that 'LActDistrib' may correspond to a--- linearity condition if you need one.------ See this nLab article for more information :--- https://ncatlab.org/nlab/show/torsor------ [In algebraic terms : ]------ A left group action is a torsor if and only if for every pair @(x,y) :: (x,--- x)@, there exists a unique group element @g :: g@ such that @g <>$ x = y@.------ [In Haskell terms : ]------ Instances must satisfy the following law :------ * @ y .-. x <>$ x == @ @y@--- * if @g <>$ x == y@ then @g == y .-. x@----class LActGp x g => LTorsor x g where- {-# MINIMAL ldiff | (.-.) #-}- -- | @ldiff y x@ is the only group element such that @'ldiff' y x <>$ x = y@.- ldiff :: x -> x -> g- ldiff y x = y .-. x- infix 6 `ldiff`- {-# INLINE ldiff #-}-- -- | Infix synonym for 'ldiff'.- --- -- This represents a point minus a point.- --- (.-.) :: LTorsor x g => x -> x -> g- (.-.) = ldiff- infix 6 .-.- {-# INLINE (.-.) #-}---instance LTorsor x () where- ldiff _ _ = ()- {-# INLINE ldiff #-}--instance LTorsor x g => LTorsor x (Identity g) where- ldiff y x = Identity (ldiff y x)- {-# INLINE ldiff #-}--instance (LTorsor x g, LTorsor y h) => LTorsor (x, y) (g,h) where- ldiff (y1, y2) (x1, x2) = (ldiff y1 x1, ldiff y2 x2)- {-# INLINE ldiff #-}--instance {-# OVERLAPPING #-} LTorsor x g- => LTorsor (Identity x) (Identity g) where- ldiff (Identity y) (Identity x) = Identity (ldiff y x)- {-# INLINE ldiff #-}---instance Group g => LTorsor g (ActSelf g) where- ldiff y x = ActSelf (y ~~ x)- {-# INLINE ldiff #-}--instance (Group g, Coercible x g) => LTorsor x (ActSelf' g) where- ldiff y x = ActSelf' ((coerce y :: g) ~~ (coerce x :: g))- {-# INLINE ldiff #-}---instance RTorsor x g => LTorsor x (Dual g) where- ldiff y x = Dual (rdiff y x)- {-# INLINE ldiff #-}--instance Num x => LTorsor x (Sum x) where- ldiff y x = Sum (y - x)- {-# INLINE ldiff #-}--instance Fractional x => LTorsor x (Product x) where- ldiff y x = Product (y / x)- {-# INLINE ldiff #-}------ | A right group torsor.------ [In algebraic terms : ]------ A left group action is a torsor if and only if for every pair @(x,y) :: (x,--- x)@, there exists a unique group element @g :: g@ such that @g <>$ x = y@.------ [In Haskell terms : ]------ Instances must satisfy the following law :------ * @ x $<> y .~. x == @ @y@--- * if @x $<> g == y@ then @g == y .~. x@----class RActGp x g => RTorsor x g where- {-# MINIMAL rdiff | (.~.) #-}- -- | @rdiff y x@ is the only group element such that @'rdiff' y x $<> x = y@.- rdiff :: x -> x -> g- rdiff y x = y .~. x- infix 6 `rdiff`- {-# INLINE rdiff #-}-- -- | Infix synonym for 'rdiff'.- --- -- This represents a point minus a point.- --- (.~.) :: RTorsor x g => x -> x -> g- (.~.) = rdiff- infix 6 .~.- {-# INLINE (.~.) #-}--instance RTorsor x () where- rdiff _ _ = ()- {-# INLINE rdiff #-}--instance RTorsor x g => RTorsor x (Identity g) where- rdiff y x = Identity (rdiff y x)- {-# INLINE rdiff #-}--instance {-# OVERLAPPING #-} RTorsor x g- => RTorsor (Identity x) (Identity g) where- rdiff (Identity y) (Identity x) = Identity (rdiff y x)- {-# INLINE rdiff #-}--instance (RTorsor x g, RTorsor y h) => RTorsor (x, y) (g,h) where- rdiff (y1, y2) (x1, x2) = (rdiff y1 x1, rdiff y2 x2)- {-# INLINE rdiff #-}--instance Group g => RTorsor g (ActSelf g) where- rdiff y x = ActSelf (y ~~ x)- {-# INLINE rdiff #-}--instance (Group g, Coercible x g) => RTorsor x (ActSelf' g) where- rdiff y x = ActSelf' ((coerce y :: g) ~~ (coerce x :: g))- {-# INLINE rdiff #-}--instance LTorsor x g => RTorsor x (Dual g) where- rdiff y x = Dual (ldiff y x)- {-# INLINE rdiff #-}--instance Num x => RTorsor x (Sum x) where- rdiff y x = Sum (y - x)- {-# INLINE rdiff #-}--instance Fractional x => RTorsor x (Product x) where- rdiff y x = Product (y / x)- {-# INLINE rdiff #-}-+{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Act.Torsor +-- Description : Group torsors for left and right actions. +-- Copyright : (c) Alice Rixte 2025 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : unstable +-- Portability : non-portable (GHC extensions) +-- +-- == Presentation +-- +-- Torsors are sets for which the /differences/ between elements form a group. +-- One good example is time : it does not make sense to add or substract two +-- dates together so we should model these dates as a set (we keep this simple by using only days): +-- +-- >>> newtype Days = Days Int +-- deriving Show +-- +-- But subtracting two dates together does makes sense. This is where LTorsor +-- can become useful : +-- +-- @ +-- newtype Duration = Duration Days +-- deriving Show +-- deriving (Semigroup, Monoid, Group) via Sum Int +-- deriving (LAct Days, LActSg Days, LActMn Days, LTorsor Days) +-- via (ActSelf' (Sum Int)) +-- @ +-- +-- Now only @Duration@ can be added or subtracted together and not dates. +-- +-- >>> (Days 5 .-. Days 3 :: Duration) + (Days 7 .-. Days 5) +-- Duration (Days 4) +-- +-- +-- For a more details and examples see this +-- [article](https://math.ucr.edu/home/baez/torsors.html) +-- +-------------------------------------------------------------------------------- + +module Data.Act.Torsor + ( LTorsor (..) + , RTorsor (..) + ) +where + +import Data.Coerce +import Data.Functor.Identity +import Data.Monoid + +import Data.Group + +import Data.Act.Act + +-- | A left group torsor. +-- +-- The most well known example of a torsor is the particular case of an affine +-- space where the group is the additive group of the vector space and the set +-- is a set of points. Torsors are more general than affine spaces since they +-- don't enforce linearity. Notice that 'LActDistrib' may correspond to a +-- linearity condition if you need one. +-- +-- See this nLab article for more information : +-- https://ncatlab.org/nlab/show/torsor +-- +-- [In algebraic terms : ] +-- +-- A left group action is a torsor if and only if for every pair @(x,y) :: (x, +-- x)@, there exists a unique group element @g :: g@ such that @g <>$ x = y@. +-- +-- [In Haskell terms : ] +-- +-- Instances must satisfy the following law : +-- +-- * @ y .-. x <>$ x == @ @y@ +-- * if @g <>$ x == y@ then @g == y .-. x@ +-- +class LActGp x g => LTorsor x g where + {-# MINIMAL ldiff | (.-.) #-} + -- | @ldiff y x@ is the only group element such that @'ldiff' y x <>$ x = y@. + ldiff :: x -> x -> g + ldiff y x = y .-. x + infix 6 `ldiff` + {-# INLINE ldiff #-} + + -- | Infix synonym for 'ldiff'. + -- + -- This represents a point minus a point. + -- + (.-.) :: x -> x -> g + (.-.) = ldiff + infix 6 .-. + {-# INLINE (.-.) #-} + + +instance LTorsor x () where + ldiff _ _ = () + {-# INLINE ldiff #-} + +instance LTorsor x g => LTorsor x (Identity g) where + ldiff y x = Identity (ldiff y x) + {-# INLINE ldiff #-} + +instance (LTorsor x g, LTorsor y h) => LTorsor (x, y) (g,h) where + ldiff (y1, y2) (x1, x2) = (ldiff y1 x1, ldiff y2 x2) + {-# INLINE ldiff #-} + +instance {-# OVERLAPPING #-} LTorsor x g + => LTorsor (Identity x) (Identity g) where + ldiff (Identity y) (Identity x) = Identity (ldiff y x) + {-# INLINE ldiff #-} + + +instance Group g => LTorsor g (ActSelf g) where + ldiff y x = ActSelf (y ~~ x) + {-# INLINE ldiff #-} + +instance (Group g, Coercible x g) => LTorsor x (ActSelf' g) where + ldiff y x = ActSelf' ((coerce y :: g) ~~ (coerce x :: g)) + {-# INLINE ldiff #-} + + +instance RTorsor x g => LTorsor x (Dual g) where + ldiff y x = Dual (rdiff y x) + {-# INLINE ldiff #-} + +instance Num x => LTorsor x (Sum x) where + ldiff y x = Sum (y - x) + {-# INLINE ldiff #-} + +instance Fractional x => LTorsor x (Product x) where + ldiff y x = Product (y / x) + {-# INLINE ldiff #-} + + + +-- | A right group torsor. +-- +-- [In algebraic terms : ] +-- +-- A left group action is a torsor if and only if for every pair @(x,y) :: (x, +-- x)@, there exists a unique group element @g :: g@ such that @g <>$ x = y@. +-- +-- [In Haskell terms : ] +-- +-- Instances must satisfy the following law : +-- +-- * @ x $<> y .~. x == @ @y@ +-- * if @x $<> g == y@ then @g == y .~. x@ +-- +class RActGp x g => RTorsor x g where + {-# MINIMAL rdiff | (.~.) #-} + -- | @rdiff y x@ is the only group element such that @'rdiff' y x $<> x = y@. + rdiff :: x -> x -> g + rdiff y x = y .~. x + infix 6 `rdiff` + {-# INLINE rdiff #-} + + -- | Infix synonym for 'rdiff'. + -- + -- This represents a point minus a point. + -- + (.~.) :: x -> x -> g + (.~.) = rdiff + infix 6 .~. + {-# INLINE (.~.) #-} + +instance RTorsor x () where + rdiff _ _ = () + {-# INLINE rdiff #-} + +instance RTorsor x g => RTorsor x (Identity g) where + rdiff y x = Identity (rdiff y x) + {-# INLINE rdiff #-} + +instance {-# OVERLAPPING #-} RTorsor x g + => RTorsor (Identity x) (Identity g) where + rdiff (Identity y) (Identity x) = Identity (rdiff y x) + {-# INLINE rdiff #-} + +instance (RTorsor x g, RTorsor y h) => RTorsor (x, y) (g,h) where + rdiff (y1, y2) (x1, x2) = (rdiff y1 x1, rdiff y2 x2) + {-# INLINE rdiff #-} + +instance Group g => RTorsor g (ActSelf g) where + rdiff y x = ActSelf (y ~~ x) + {-# INLINE rdiff #-} + +instance (Group g, Coercible x g) => RTorsor x (ActSelf' g) where + rdiff y x = ActSelf' ((coerce y :: g) ~~ (coerce x :: g)) + {-# INLINE rdiff #-} + +instance LTorsor x g => RTorsor x (Dual g) where + rdiff y x = Dual (ldiff y x) + {-# INLINE rdiff #-} + +instance Num x => RTorsor x (Sum x) where + rdiff y x = Sum (y - x) + {-# INLINE rdiff #-} + +instance Fractional x => RTorsor x (Product x) where + rdiff y x = Product (y / x) + {-# INLINE rdiff #-} +
src/Data/Semidirect.hs view
@@ -1,16 +1,16 @@--------------------------------------------------------------------------------- |--- Module : Data.Semigroup.Semidirect--- Copyright : (c) Alice Rixte (2024)--- License : BSD 3 (see LICENSE)--- Maintainer : alice.rixte@u-bordeaux.fr------ This is a re-export of "Data.Semigroup.Semidirect.Lazy". If you need a strict--- version, please import "Data.Semigroup.Semidirect.Strict".----------------------------------------------------------------------------------module Data.Semidirect- ( module Data.Semidirect.Lazy- ) where-+----------------------------------------------------------------------------- +-- | +-- Module : Data.Semigroup.Semidirect +-- Copyright : (c) Alice Rixte (2024) +-- License : BSD 3 (see LICENSE) +-- Maintainer : alice.rixte@u-bordeaux.fr +-- +-- This is a re-export of "Data.Semigroup.Semidirect.Lazy". If you need a strict +-- version, please import "Data.Semigroup.Semidirect.Strict". +-- +----------------------------------------------------------------------------- +module Data.Semidirect + ( module Data.Semidirect.Lazy + ) where + import Data.Semidirect.Lazy
src/Data/Semidirect/Lazy.hs view
@@ -1,144 +1,144 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE ScopedTypeVariables #-}---------------------------------------------------------------------------------- |--- Module : Data.Semidirect.Lazy--- Description : Lazy semidirect products--- Copyright : (c) Alice Rixte 2025--- License : BSD 3--- Maintainer : alice.rixte@u-bordeaux.fr--- Stability : unstable--- Portability : non-portable (GHC extensions)------ Semidirect products for left and right actions.------ For a strict version, see @'Data.Semidirect.Strict'@.------ [Usage :]------ >>> import Data.Semigroup--- >>> LSemidirect (Sum 1) (Product 2) <> LSemidirect (Sum (3 :: Int)) (Product (4 :: Int))--- LSemidirect {lactee = Sum {getSum = 7}, lactor = Product {getProduct = 8}}------ [Property checking :]------ There is a @'Semigroup'@ instance for @'LSemidirect'@ (resp. @'RSemidirect'@)--- only if there is a @'LActSgMorph'@ (resp. @'RActSgMorph'@) instance. For--- example, @'Sum' Int@ acting on itself is not a semigroup action by morphism--- and therefore the semidirect product is not associative :------ >>> LSemidirect (Sum 1) (Sum 2) <> LSemidirect (Sum (3 :: Int)) (Sum (4 :: Int))--- No instance for `LActDistrib (Sum Int) (Sum Int)'--- arising from a use of `<>'-----------------------------------------------------------------------------------module Data.Semidirect.Lazy- ( LSemidirect (..)- , lerase- , lforget- , lembedActee- , lembedActor- , lfromPair- , RSemidirect (..)- , rerase- , rforget- , rembedActee- , rembedActor- , rfromPair- ) where--import Data.Bifunctor-import Data.Act---- | A semi-direct product for a left action, where @s@ acts on @x@----data LSemidirect x s = LSemidirect- { lactee :: x -- ^ The value being acted on- , lactor :: s -- ^ The acting element- }- deriving (Show, Read, Eq)--instance LActSgMorph x s- => Semigroup (LSemidirect x s) where- ~(LSemidirect x s) <> ~(LSemidirect x' s') =- LSemidirect (x <> (s <>$ x')) (s <> s')--instance LActMnMorph x s => Monoid (LSemidirect x s) where- mempty = LSemidirect mempty mempty--instance Functor (LSemidirect x) where- fmap f a = a {lactor = f (lactor a)}--instance Bifunctor LSemidirect where- first f a = a {lactee = f (lactee a)}- second = fmap---- | Erases the actee (i.e. replace it with @mempty@).-lerase :: Monoid x => LSemidirect x s -> LSemidirect x s-lerase a = a {lactee = mempty}---- | Forget the actor (i.e. replace it with @mempty@).-lforget :: Monoid s => LSemidirect x s -> LSemidirect x s-lforget a =a {lactor = mempty}---- | Make a semidirect pair whose actee is @mempty@.-lembedActor :: Monoid x => s -> LSemidirect x s-lembedActor s = LSemidirect mempty s---- | Make a semidirect pair whose actor is @mempty@.-lembedActee :: Monoid s => x -> LSemidirect x s-lembedActee x = LSemidirect x mempty---- | Converts a pair into a semidirect product element.-lfromPair :: (x,s) -> LSemidirect x s-lfromPair (x,s) = LSemidirect x s------------------------------------------------------------------------------------- | A semidirect product for a right action, where @s@ acts on @x@----data RSemidirect x s = RSemidirect- { ractee :: x -- ^ The value being acted on- , ractor :: s -- ^ The acting element- }- deriving (Show, Read, Eq)--instance RActSgMorph x s- => Semigroup (RSemidirect x s) where- ~(RSemidirect x s) <> ~(RSemidirect x' s') =- RSemidirect (x <> (x' $<> s)) (s <> s')--instance RActMnMorph x s => Monoid (RSemidirect x s) where- mempty = RSemidirect mempty mempty--instance Functor (RSemidirect x) where- fmap f a = a {ractor = f (ractor a)}--instance Bifunctor RSemidirect where- first f a = a {ractee = f (ractee a)}- second = fmap---- | Erase the actee (i.e. replace it with @mempty@).-rerase :: Monoid x => RSemidirect x s -> RSemidirect x s-rerase a = a {ractee = mempty}---- | Forget the actor (i.e. replace it with @mempty@).-rforget :: Monoid s => RSemidirect x s -> RSemidirect x s-rforget a = a {ractor = mempty}---- | Make a semidirect pair whose actee is @mempty@.-rembedActor :: Monoid x => s -> RSemidirect x s-rembedActor s = RSemidirect mempty s---- | Make a semidirect pair whose actor element is @mempty@ .-rembedActee :: Monoid s => x -> RSemidirect x s-rembedActee x = RSemidirect x mempty---- | Convert a pair into a semidirect product element-rfromPair :: (x,s) -> RSemidirect x s-rfromPair (x,s) = RSemidirect x s+{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Semidirect.Lazy +-- Description : Lazy semidirect products +-- Copyright : (c) Alice Rixte 2025 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : unstable +-- Portability : non-portable (GHC extensions) +-- +-- Semidirect products for left and right actions. +-- +-- For a strict version, see @'Data.Semidirect.Strict'@. +-- +-- [Usage :] +-- +-- >>> import Data.Semigroup +-- >>> LSemidirect (Sum 1) (Product 2) <> LSemidirect (Sum (3 :: Int)) (Product (4 :: Int)) +-- LSemidirect {lactee = Sum {getSum = 7}, lactor = Product {getProduct = 8}} +-- +-- [Property checking :] +-- +-- There is a @'Semigroup'@ instance for @'LSemidirect'@ (resp. @'RSemidirect'@) +-- only if there is a @'LActSgMorph'@ (resp. @'RActSgMorph'@) instance. For +-- example, @'Sum' Int@ acting on itself is not a semigroup action by morphism +-- and therefore the semidirect product is not associative : +-- +-- >>> LSemidirect (Sum 1) (Sum 2) <> LSemidirect (Sum (3 :: Int)) (Sum (4 :: Int)) +-- No instance for `LActDistrib (Sum Int) (Sum Int)' +-- arising from a use of `<>' +-- +----------------------------------------------------------------------------- + +module Data.Semidirect.Lazy + ( LSemidirect (..) + , lerase + , lforget + , lembedActee + , lembedActor + , lfromPair + , RSemidirect (..) + , rerase + , rforget + , rembedActee + , rembedActor + , rfromPair + ) where + +import Data.Bifunctor +import Data.Act + +-- | A semi-direct product for a left action, where @s@ acts on @x@ +-- +data LSemidirect x s = LSemidirect + { lactee :: x -- ^ The value being acted on + , lactor :: s -- ^ The acting element + } + deriving (Show, Read, Eq) + +instance LActSgMorph x s + => Semigroup (LSemidirect x s) where + ~(LSemidirect x s) <> ~(LSemidirect x' s') = + LSemidirect (x <> (s <>$ x')) (s <> s') + +instance LActMnMorph x s => Monoid (LSemidirect x s) where + mempty = LSemidirect mempty mempty + +instance Functor (LSemidirect x) where + fmap f a = a {lactor = f (lactor a)} + +instance Bifunctor LSemidirect where + first f a = a {lactee = f (lactee a)} + second = fmap + +-- | Erases the actee (i.e. replace it with @mempty@). +lerase :: Monoid x => LSemidirect x s -> LSemidirect x s +lerase a = a {lactee = mempty} + +-- | Forget the actor (i.e. replace it with @mempty@). +lforget :: Monoid s => LSemidirect x s -> LSemidirect x s +lforget a =a {lactor = mempty} + +-- | Make a semidirect pair whose actee is @mempty@. +lembedActor :: Monoid x => s -> LSemidirect x s +lembedActor s = LSemidirect mempty s + +-- | Make a semidirect pair whose actor is @mempty@. +lembedActee :: Monoid s => x -> LSemidirect x s +lembedActee x = LSemidirect x mempty + +-- | Converts a pair into a semidirect product element. +lfromPair :: (x,s) -> LSemidirect x s +lfromPair (x,s) = LSemidirect x s + + +------------------------------------------------------------------------------ + +-- | A semidirect product for a right action, where @s@ acts on @x@ +-- +data RSemidirect x s = RSemidirect + { ractee :: x -- ^ The value being acted on + , ractor :: s -- ^ The acting element + } + deriving (Show, Read, Eq) + +instance RActSgMorph x s + => Semigroup (RSemidirect x s) where + ~(RSemidirect x s) <> ~(RSemidirect x' s') = + RSemidirect (x <> (x' $<> s)) (s <> s') + +instance RActMnMorph x s => Monoid (RSemidirect x s) where + mempty = RSemidirect mempty mempty + +instance Functor (RSemidirect x) where + fmap f a = a {ractor = f (ractor a)} + +instance Bifunctor RSemidirect where + first f a = a {ractee = f (ractee a)} + second = fmap + +-- | Erase the actee (i.e. replace it with @mempty@). +rerase :: Monoid x => RSemidirect x s -> RSemidirect x s +rerase a = a {ractee = mempty} + +-- | Forget the actor (i.e. replace it with @mempty@). +rforget :: Monoid s => RSemidirect x s -> RSemidirect x s +rforget a = a {ractor = mempty} + +-- | Make a semidirect pair whose actee is @mempty@. +rembedActor :: Monoid x => s -> RSemidirect x s +rembedActor s = RSemidirect mempty s + +-- | Make a semidirect pair whose actor element is @mempty@ . +rembedActee :: Monoid s => x -> RSemidirect x s +rembedActee x = RSemidirect x mempty + +-- | Convert a pair into a semidirect product element +rfromPair :: (x,s) -> RSemidirect x s +rfromPair (x,s) = RSemidirect x s
src/Data/Semidirect/Strict.hs view
@@ -1,144 +1,144 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE ScopedTypeVariables #-}---------------------------------------------------------------------------------- |--- Module : Data.Semidirect.Strict--- Description : Strict semidirect products--- Copyright : (c) Alice Rixte 2025--- License : BSD 3--- Maintainer : alice.rixte@u-bordeaux.fr--- Stability : unstable--- Portability : non-portable (GHC extensions)------ Semidirect products for left and right actions.------ For a lazy version, see @'Data.Semidirect.Lazy'@.------ [Usage :]------ >>> import Data.Semigroup--- >>> LSemidirect (Sum 1) (Product 2) <> LSemidirect (Sum (3 :: Int)) (Product (4 :: Int))--- LSemidirect {lactee = Sum {getSum = 7}, lactor = Product {getProduct = 8}}------ [Property checking :]------ There is a @'Semigroup'@ instance for @'LSemidirect'@ (resp. @'RSemidirect'@)--- only if there is a @'LActSgMorph'@ (resp. @'RActSgMorph'@) instance. For--- example, @'Sum' Int@ acting on itself is not a semigroup action by morphism--- and therefore the semidirect product is not associative :------ >>> LSemidirect (Sum 1) (Sum 2) <> LSemidirect (Sum (3 :: Int)) (Sum (4 :: Int))--- No instance for `LActDistrib (Sum Int) (Sum Int)'--- arising from a use of `<>'-----------------------------------------------------------------------------------module Data.Semidirect.Strict- ( LSemidirect (..)- , lerase- , lforget- , lembedActee- , lembedActor- , lfromPair- , RSemidirect (..)- , rerase- , rforget- , rembedActee- , rembedActor- , rfromPair- ) where--import Data.Bifunctor-import Data.Act---- | A semi-direct product for a left action, where @s@ acts on @x@----data LSemidirect x s = LSemidirect- { lactee :: !x -- ^ The value being acted on- , lactor :: !s -- ^ The acting element- }- deriving (Show, Read, Eq)--instance LActSgMorph x s- => Semigroup (LSemidirect x s) where- LSemidirect x s <> LSemidirect x' s' =- LSemidirect (x <> (s <>$ x')) (s <> s')--instance LActMnMorph x s => Monoid (LSemidirect x s) where- mempty = LSemidirect mempty mempty--instance Functor (LSemidirect x) where- fmap f a = a {lactor = f (lactor a)}--instance Bifunctor LSemidirect where- first f a = a {lactee = f (lactee a)}- second = fmap---- | Erase the actee (i.e. replace it with @mempty@).-lerase :: Monoid x => LSemidirect x s -> LSemidirect x s-lerase a = a {lactee = mempty}---- | Forget the actor (i.e. replace it with @mempty@).-lforget :: Monoid s => LSemidirect x s -> LSemidirect x s-lforget a =a {lactor = mempty}---- | Make a semidirect pair whose actee is @mempty@.-lembedActor :: Monoid x => s -> LSemidirect x s-lembedActor s = LSemidirect mempty s---- | Make a semidirect pair whose actor is @mempty@.-lembedActee :: Monoid s => x -> LSemidirect x s-lembedActee x = LSemidirect x mempty---- | Convert a pair into a semidirect product element.-lfromPair :: (x,s) -> LSemidirect x s-lfromPair (x,s) = LSemidirect x s------------------------------------------------------------------------------------- | A semidirect product for a right action, where @s@ acts on @x@----data RSemidirect x s = RSemidirect- { ractee :: !x -- ^ The value being acted on- , ractor :: !s -- ^ The acting element- }- deriving (Show, Read, Eq)--instance RActSgMorph x s- => Semigroup (RSemidirect x s) where- RSemidirect x s <> RSemidirect x' s' =- RSemidirect (x <> (x' $<> s)) (s <> s')--instance RActMnMorph x s => Monoid (RSemidirect x s) where- mempty = RSemidirect mempty mempty--instance Functor (RSemidirect x) where- fmap f a = a {ractor = f (ractor a)}--instance Bifunctor RSemidirect where- first f a = a {ractee = f (ractee a)}- second = fmap---- | Erase the actee (i.e. replace it with @mempty@).-rerase :: Monoid x => RSemidirect x s -> RSemidirect x s-rerase a = a {ractee = mempty}---- | Forget the actor (i.e. replace it with @mempty@).-rforget :: Monoid s => RSemidirect x s -> RSemidirect x s-rforget a = a {ractor = mempty}---- | Make a semidirect pair whose actee is @mempty@.-rembedActor :: Monoid x => s -> RSemidirect x s-rembedActor s = RSemidirect mempty s---- | Make a semidirect pair whose actor element is @mempty@ .-rembedActee :: Monoid s => x -> RSemidirect x s-rembedActee x = RSemidirect x mempty---- | Convert a pair into a semidirect product element-rfromPair :: (x,s) -> RSemidirect x s-rfromPair (x,s) = RSemidirect x s+{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Semidirect.Strict +-- Description : Strict semidirect products +-- Copyright : (c) Alice Rixte 2025 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : unstable +-- Portability : non-portable (GHC extensions) +-- +-- Semidirect products for left and right actions. +-- +-- For a lazy version, see @'Data.Semidirect.Lazy'@. +-- +-- [Usage :] +-- +-- >>> import Data.Semigroup +-- >>> LSemidirect (Sum 1) (Product 2) <> LSemidirect (Sum (3 :: Int)) (Product (4 :: Int)) +-- LSemidirect {lactee = Sum {getSum = 7}, lactor = Product {getProduct = 8}} +-- +-- [Property checking :] +-- +-- There is a @'Semigroup'@ instance for @'LSemidirect'@ (resp. @'RSemidirect'@) +-- only if there is a @'LActSgMorph'@ (resp. @'RActSgMorph'@) instance. For +-- example, @'Sum' Int@ acting on itself is not a semigroup action by morphism +-- and therefore the semidirect product is not associative : +-- +-- >>> LSemidirect (Sum 1) (Sum 2) <> LSemidirect (Sum (3 :: Int)) (Sum (4 :: Int)) +-- No instance for `LActDistrib (Sum Int) (Sum Int)' +-- arising from a use of `<>' +-- +----------------------------------------------------------------------------- + +module Data.Semidirect.Strict + ( LSemidirect (..) + , lerase + , lforget + , lembedActee + , lembedActor + , lfromPair + , RSemidirect (..) + , rerase + , rforget + , rembedActee + , rembedActor + , rfromPair + ) where + +import Data.Bifunctor +import Data.Act + +-- | A semi-direct product for a left action, where @s@ acts on @x@ +-- +data LSemidirect x s = LSemidirect + { lactee :: !x -- ^ The value being acted on + , lactor :: !s -- ^ The acting element + } + deriving (Show, Read, Eq) + +instance LActSgMorph x s + => Semigroup (LSemidirect x s) where + LSemidirect x s <> LSemidirect x' s' = + LSemidirect (x <> (s <>$ x')) (s <> s') + +instance LActMnMorph x s => Monoid (LSemidirect x s) where + mempty = LSemidirect mempty mempty + +instance Functor (LSemidirect x) where + fmap f a = a {lactor = f (lactor a)} + +instance Bifunctor LSemidirect where + first f a = a {lactee = f (lactee a)} + second = fmap + +-- | Erase the actee (i.e. replace it with @mempty@). +lerase :: Monoid x => LSemidirect x s -> LSemidirect x s +lerase a = a {lactee = mempty} + +-- | Forget the actor (i.e. replace it with @mempty@). +lforget :: Monoid s => LSemidirect x s -> LSemidirect x s +lforget a =a {lactor = mempty} + +-- | Make a semidirect pair whose actee is @mempty@. +lembedActor :: Monoid x => s -> LSemidirect x s +lembedActor s = LSemidirect mempty s + +-- | Make a semidirect pair whose actor is @mempty@. +lembedActee :: Monoid s => x -> LSemidirect x s +lembedActee x = LSemidirect x mempty + +-- | Convert a pair into a semidirect product element. +lfromPair :: (x,s) -> LSemidirect x s +lfromPair (x,s) = LSemidirect x s + + +------------------------------------------------------------------------------ + +-- | A semidirect product for a right action, where @s@ acts on @x@ +-- +data RSemidirect x s = RSemidirect + { ractee :: !x -- ^ The value being acted on + , ractor :: !s -- ^ The acting element + } + deriving (Show, Read, Eq) + +instance RActSgMorph x s + => Semigroup (RSemidirect x s) where + RSemidirect x s <> RSemidirect x' s' = + RSemidirect (x <> (x' $<> s)) (s <> s') + +instance RActMnMorph x s => Monoid (RSemidirect x s) where + mempty = RSemidirect mempty mempty + +instance Functor (RSemidirect x) where + fmap f a = a {ractor = f (ractor a)} + +instance Bifunctor RSemidirect where + first f a = a {ractee = f (ractee a)} + second = fmap + +-- | Erase the actee (i.e. replace it with @mempty@). +rerase :: Monoid x => RSemidirect x s -> RSemidirect x s +rerase a = a {ractee = mempty} + +-- | Forget the actor (i.e. replace it with @mempty@). +rforget :: Monoid s => RSemidirect x s -> RSemidirect x s +rforget a = a {ractor = mempty} + +-- | Make a semidirect pair whose actee is @mempty@. +rembedActor :: Monoid x => s -> RSemidirect x s +rembedActor s = RSemidirect mempty s + +-- | Make a semidirect pair whose actor element is @mempty@ . +rembedActee :: Monoid s => x -> RSemidirect x s +rembedActee x = RSemidirect x mempty + +-- | Convert a pair into a semidirect product element +rfromPair :: (x,s) -> RSemidirect x s +rfromPair (x,s) = RSemidirect x s
test/Spec.hs view
@@ -1,66 +1,76 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedLabels #-}--import Test.Hspec-import Test.QuickCheck--import Data.Monoid-import Data.Act--import qualified Data.Semidirect.Lazy as Lazy-import qualified Data.Semidirect.Strict as Strict--main :: IO ()-main = hspec $ do- describe "Semidirect" $ do- describe "LSemidirect" $ do- describe "Lazy" $ do- it "Product on Sum Semigroup" $ property $- \x s y t ->- Lazy.LSemidirect (Sum (x :: Int)) (Product (s :: Int))- <> Lazy.LSemidirect (Sum y) (Product t)- `shouldBe`- Lazy.LSemidirect (Sum (x + s*y)) (Product (s*t))- it "Product on Sum Monoid" $- mempty `shouldBe`- Lazy.LSemidirect (mempty :: Sum Int) (mempty :: Product Int)- describe "Strict" $ do- it "Product on Sum Semigroup" $ property $- \x s y t ->- Strict.LSemidirect (Sum (x :: Int)) (Product (s :: Int))- <> Strict.LSemidirect (Sum y) (Product t)- `shouldBe`- Strict.LSemidirect (Sum (x + s*y)) (Product (s*t))- it "Product on Sum Monoid" $- mempty `shouldBe`- Strict.LSemidirect (mempty :: Sum Int) (mempty :: Product Int)- describe "RSemidirect" $ do- describe "Lazy" $ do- it "Product on Sum Semigroup" $ property $- \x s y t ->- Lazy.RSemidirect (Sum (x :: Int)) (Product (s :: Int))- <> Lazy.RSemidirect (Sum y) (Product t)- `shouldBe`- Lazy.RSemidirect (Sum (x + s*y)) (Product (s*t))- it "Product on Sum Monoid" $- mempty `shouldBe`- Lazy.RSemidirect (mempty :: Sum Int) (mempty :: Product Int)- describe "Strict" $ do- it "Product on Sum Semigroup" $ property $- \x s y t ->- Strict.RSemidirect (Sum (x :: Int)) (Product (s :: Int))- <> Strict.RSemidirect (Sum y) (Product t)- `shouldBe`- Strict.RSemidirect (Sum (x + s*y)) (Product (s*t))- it "Product on Sum Monoid" $- mempty `shouldBe`- Strict.RSemidirect (mempty :: Sum Int) (mempty :: Product Int)-- describe "Action" $ do- describe "ActSelf" $ do- it "Int acts on unit" $ property $- \x -> (x :: Int) <>$ () `shouldBe` ()- it "Unit acts on char" $ property $- \x -> () <>$ (x :: Char) `shouldBe` x+{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +import Test.Hspec +import Test.QuickCheck + +import Data.Monoid +import Data.Group +import Data.Act + +import qualified Data.Semidirect.Lazy as Lazy +import qualified Data.Semidirect.Strict as Strict + +newtype Days = Days Int + deriving Show + +newtype Duration = Duration Days + deriving Show + deriving (Semigroup, Monoid, Group) via Sum Int + deriving (LAct Days, LActSg Days, LActMn Days, LTorsor Days) + via (ActSelf' (Sum Int)) + deriving (RAct Days, RActSg Days, RActMn Days, RTorsor Days) + via (ActSelf' (Sum Int)) + +main :: IO () +main = hspec $ do + describe "Semidirect" $ do + describe "LSemidirect" $ do + describe "Lazy" $ do + it "Product on Sum Semigroup" $ property $ + \x s y t -> + Lazy.LSemidirect (Sum (x :: Int)) (Product (s :: Int)) + <> Lazy.LSemidirect (Sum y) (Product t) + `shouldBe` + Lazy.LSemidirect (Sum (x + s*y)) (Product (s*t)) + it "Product on Sum Monoid" $ + mempty `shouldBe` + Lazy.LSemidirect (mempty :: Sum Int) (mempty :: Product Int) + describe "Strict" $ do + it "Product on Sum Semigroup" $ property $ + \x s y t -> + Strict.LSemidirect (Sum (x :: Int)) (Product (s :: Int)) + <> Strict.LSemidirect (Sum y) (Product t) + `shouldBe` + Strict.LSemidirect (Sum (x + s*y)) (Product (s*t)) + it "Product on Sum Monoid" $ + mempty `shouldBe` + Strict.LSemidirect (mempty :: Sum Int) (mempty :: Product Int) + describe "RSemidirect" $ do + describe "Lazy" $ do + it "Product on Sum Semigroup" $ property $ + \x s y t -> + Lazy.RSemidirect (Sum (x :: Int)) (Product (s :: Int)) + <> Lazy.RSemidirect (Sum y) (Product t) + `shouldBe` + Lazy.RSemidirect (Sum (x + s*y)) (Product (s*t)) + it "Product on Sum Monoid" $ + mempty `shouldBe` + Lazy.RSemidirect (mempty :: Sum Int) (mempty :: Product Int) + describe "Strict" $ do + it "Product on Sum Semigroup" $ property $ + \x s y t -> + Strict.RSemidirect (Sum (x :: Int)) (Product (s :: Int)) + <> Strict.RSemidirect (Sum y) (Product t) + `shouldBe` + Strict.RSemidirect (Sum (x + s*y)) (Product (s*t)) + it "Product on Sum Monoid" $ + mempty `shouldBe` + Strict.RSemidirect (mempty :: Sum Int) (mempty :: Product Int) + + describe "Action" $ do + describe "ActSelf" $ do + it "Int acts on unit" $ property $ + \x -> (x :: Int) <>$ () `shouldBe` () + it "Unit acts on char" $ property $ + \x -> () <>$ (x :: Char) `shouldBe` x