diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,21 +1,27 @@ -# 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 +# 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 + +## 0.1 - unreleased + +- Rename LSemidirect and RSemidirect constructors to LPair and RPair +- Instances for ActCyclic x () +- Add LDefault and RDefault newtypes for ActCyclic diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,107 +1,106 @@ -# lr-acts - -[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/lr-acts.svg)](https://hackage.haskell.org/package/lr-acts) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](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 + +[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/AliceRixte/lr-acts/LICENSE) [![Hackage](https://img.shields.io/hackage/v/lr-acts.svg)](https://hackage.haskell.org/package/lr-acts) [![Nightly](https://www.stackage.org/package/lr-acts/badge/nightly)](https://www.stackage.org/nightly/package/lr-acts) [![LTS](https://www.stackage.org/package/lr-acts/badge/lts)](https://www.stackage.org/lts/package/lr-acts) + +## 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. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/benchmark/Main.hs b/benchmark/Main.hs --- a/benchmark/Main.hs +++ b/benchmark/Main.hs @@ -1,38 +1,69 @@ -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) - ] +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -ddump-to-file #-} + +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 +import Data.Act + +import GHC.Real + +--------------------------------- Semidirect --------------------------------- + +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) + +--------------------------------- LDefault ---------------------------------- + +mulDef :: Int -> Double +mulDef 0 = 0 +mulDef n = lorigin @(LDefault (2 :% 3) Double) + mulDef (n-1) + +mulDouble :: Int -> Double +mulDouble 0 = 0 +mulDouble n = 2/3 + mulDouble (n-1) + + + +------------------------------------------------------------------------------ + +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 "ActCyclic" [ + bgroup "Double " (fmap (mkBench mulDouble) nlist) + , bgroup "LDefault Ratio" (fmap (mkBench mulDef) nlist) + ] + + , bgroup "Semidirect" [ + bgroup "Lazy pair (,)" (fmap (mkBench sumProduct) nlist) + , bgroup "Lazy LSemidirect" (fmap (mkBench stimesLSemiLazy) nlist) + , bgroup "Strict LSemidirect" (fmap (mkBench stimesLSemiStrict) nlist) + ] + ] diff --git a/lr-acts.cabal b/lr-acts.cabal --- a/lr-acts.cabal +++ b/lr-acts.cabal @@ -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.1 +version: 0.1 synopsis: Left and right actions, semidirect products and torsors description: Please see the README on GitHub at category: Algebra, Math, Data @@ -13,11 +13,12 @@ bug-reports: https://github.com/AliceRixte/lr-acts/issues author: Alice Rixte maintainer: alice.rixte@u-bordeaux.fr +copyright: (c) Alice Rixte 2025 license: BSD-3-Clause license-file: LICENSE build-type: Simple tested-with: - GHC == 9.8.2 + GHC == 9.8.2 || == 9.10.2 || == 9.10.3 extra-source-files: README.md extra-doc-files: @@ -47,7 +48,7 @@ base >=4.18 && <5 , data-default >=0.7 && <0.9 , groups ==0.5.* - default-language: Haskell2010 + default-language: GHC2024 test-suite lr-acts-test type: exitcode-stdio-1.0 @@ -58,7 +59,7 @@ Paths_lr_acts hs-source-dirs: test - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -threaded build-depends: QuickCheck >=2.14.3 , base >=4.18 && <5 @@ -66,7 +67,7 @@ , groups ==0.5.* , hspec >=2.11 , lr-acts - default-language: Haskell2010 + default-language: GHC2024 benchmark lr-acts-bench type: exitcode-stdio-1.0 @@ -84,4 +85,4 @@ , data-default >=0.7 && <0.9 , groups ==0.5.* , lr-acts - default-language: Haskell2010 + default-language: GHC2024 diff --git a/src/Data/Act.hs b/src/Data/Act.hs --- a/src/Data/Act.hs +++ b/src/Data/Act.hs @@ -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 diff --git a/src/Data/Act/Act.hs b/src/Data/Act/Act.hs --- a/src/Data/Act/Act.hs +++ b/src/Data/Act/Act.hs @@ -1,773 +1,784 @@ -{-# 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) +-------------------------------------------------------------------------------- +-- | +-- +-- 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. +-- +-- One example of useful set action that is not a semigroup action is declared +-- in this file : +-- +-- @ +-- instance (LAct x s, LAct x t) => LAct x (Either s t) where +-- Left s <>$ x = s <>$ x +-- Right s <>$ x = s <>$ x +-- @ +-- +-- This is often useful when dealing with free monoids : +-- +-- >>> ActFold [Right (Product (2 :: Int)) , Left (Sum (1 :: Int))] <>$ (2 :: Int) +-- 6 +-- >>> (2 :: Int) $<> ActFold [Right (Product (2 :: Int)) , Left (Sum (1 :: Int))] +-- 5 +-- +-- 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 + {-# INLINE (<>$) #-} + +-- | 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 + {-# INLINE ($<>) #-} + +-------------------- 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) diff --git a/src/Data/Act/Cyclic.hs b/src/Data/Act/Cyclic.hs --- a/src/Data/Act/Cyclic.hs +++ b/src/Data/Act/Cyclic.hs @@ -1,494 +1,599 @@ -{-# 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 DefaultSignatures #-} +{-# LANGUAGE DerivingVia #-} + +-------------------------------------------------------------------------------- +-- | +-- +-- 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 + -- * Default newtypes + , LDefault (..) + , RDefault (..) + -- * 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.Proxy +import GHC.TypeLits +import GHC.Real + +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 #-} + +------------------------------------------------------------------------------ + +-- | A semigroup that allows to define a default value for @'lorigin'@ thanks +-- to type level programming. +-- +-- The semigroup returns the first value, just like @'Data.Semigroup.First'@, +-- i.e. verifies +-- +-- @ LDefault x <> LDefault y == LDefault x @ +-- +-- [Usage:] +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> lorigin @(LDefault 'True Bool) :: Bool +-- True +-- +-- >>> lorigin @(LDefault 'False Bool) :: Bool +-- False +-- +-- >>> lorigin @(LDefault 42 Int) :: Int +-- 42 +-- +-- >>> :set -XTypeOperators +-- >>> import GHC.Real +-- >>> lorigin @(LDefault (31415 :% 10000) Float) :: Float +-- 3.14159 +-- +-- @since lr-acts-0.0.2 +-- +newtype LDefault k x = LDefault x + deriving (Semigroup, LAct x, LActSg x) via (Sg.First x) + +instance Default a => LActCyclic a (LDefault () a) where + lorigin' = def + lshift = LDefault + +instance LActCyclic Bool (LDefault 'True Bool) where + lorigin' = True + lshift = LDefault + +instance LActCyclic Bool (LDefault 'False Bool) where + lorigin' = False + lshift = LDefault + +instance (Num a, KnownNat n) => LActCyclic a (LDefault n a) where + lorigin' = fromInteger (natVal (Proxy :: Proxy n)) + lshift = LDefault + +instance (Fractional a, KnownNat n, KnownNat m) + => LActCyclic a (LDefault (n :% m) a) where + lorigin' = fromInteger (natVal (Proxy :: Proxy n)) + / fromInteger (natVal (Proxy :: Proxy m)) + lshift = LDefault + +-- | Same as @'LDefault'@, but for right actions. +-- +-- The semigroup returns the first value, just like @'Data.Semigroup.Last'@, +-- i.e. verifies +-- +-- @ RDefault x <> RDefault y == RDefault y @ +-- +-- @since lr-acts-0.0.2 +-- +newtype RDefault (a :: k) x = RDefault x + deriving (Semigroup, RAct x, RActSg x) via (Sg.Last x) + +instance Default a => RActCyclic a (RDefault () a) where + rorigin' = def + rshift = RDefault + +instance RActCyclic Bool (RDefault 'True Bool) where + rorigin' = True + rshift = RDefault + +instance RActCyclic Bool (RDefault 'False Bool) where + rorigin' = True + rshift = RDefault + +instance (Num a, KnownNat n) => RActCyclic a (RDefault n a) where + rorigin' = fromInteger (natVal (Proxy :: Proxy n)) + rshift = RDefault + +instance (Fractional a, KnownNat n, KnownNat m) + => RActCyclic a (RDefault (n :% m) a) where + rorigin' = fromInteger (natVal (Proxy :: Proxy n)) + / fromInteger (natVal (Proxy :: Proxy n)) + rshift = RDefault + + +---------------------------------- Instances ----------------------------------- + +-- Unit -- + +instance Default x => LActCyclic x () where + lorigin' = def + {-# INLINE lorigin' #-} + lshift _ = () + {-# INLINE lshift #-} + +instance Default x => RActCyclic x () where + rorigin' = def + {-# INLINE rorigin' #-} + rshift _ = () + {-# INLINE rshift #-} + + +-- 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 + diff --git a/src/Data/Act/Torsor.hs b/src/Data/Act/Torsor.hs --- a/src/Data/Act/Torsor.hs +++ b/src/Data/Act/Torsor.hs @@ -1,210 +1,207 @@ -{-# 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 #-} - +-------------------------------------------------------------------------------- +-- | +-- +-- 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 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 #-} + diff --git a/src/Data/Semidirect.hs b/src/Data/Semidirect.hs --- a/src/Data/Semidirect.hs +++ b/src/Data/Semidirect.hs @@ -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 diff --git a/src/Data/Semidirect/Lazy.hs b/src/Data/Semidirect/Lazy.hs --- a/src/Data/Semidirect/Lazy.hs +++ b/src/Data/Semidirect/Lazy.hs @@ -1,144 +1,139 @@ -{-# 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 +----------------------------------------------------------------------------- +-- | +-- 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 +-- >>> LPair (Sum 1) (Product 2) <> LPair (Sum (3 :: Int)) (Product (4 :: Int)) +-- LPair {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 : +-- +-- >>> LPair (Sum 1) (Sum 2) <> LPair (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 = LPair + { 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 + ~(LPair x s) <> ~(LPair x' s') = + LPair (x <> (s <>$ x')) (s <> s') + +instance LActMnMorph x s => Monoid (LSemidirect x s) where + mempty = LPair 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 = LPair mempty s + +-- | Make a semidirect pair whose actor is @mempty@. +lembedActee :: Monoid s => x -> LSemidirect x s +lembedActee x = LPair x mempty + +-- | Converts a pair into a semidirect product element. +lfromPair :: (x,s) -> LSemidirect x s +lfromPair (x,s) = LPair x s + + +------------------------------------------------------------------------------ + +-- | A semidirect product for a right action, where @s@ acts on @x@ +-- +data RSemidirect x s = RPair + { 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 + ~(RPair x s) <> ~(RPair x' s') = + RPair (x <> (x' $<> s)) (s <> s') + +instance RActMnMorph x s => Monoid (RSemidirect x s) where + mempty = RPair 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 = RPair mempty s + +-- | Make a semidirect pair whose actor element is @mempty@ . +rembedActee :: Monoid s => x -> RSemidirect x s +rembedActee x = RPair x mempty + +-- | Convert a pair into a semidirect product element +rfromPair :: (x,s) -> RSemidirect x s +rfromPair (x,s) = RPair x s diff --git a/src/Data/Semidirect/Strict.hs b/src/Data/Semidirect/Strict.hs --- a/src/Data/Semidirect/Strict.hs +++ b/src/Data/Semidirect/Strict.hs @@ -1,144 +1,139 @@ -{-# 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 +----------------------------------------------------------------------------- +-- | +-- 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 +-- >>> LPair (Sum 1) (Product 2) <> LPair (Sum (3 :: Int)) (Product (4 :: Int)) +-- LPair {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 : +-- +-- >>> LPair (Sum 1) (Sum 2) <> LPair (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 = LPair + { 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 + LPair x s <> LPair x' s' = + LPair (x <> (s <>$ x')) (s <> s') + +instance LActMnMorph x s => Monoid (LSemidirect x s) where + mempty = LPair 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 = LPair mempty s + +-- | Make a semidirect pair whose actor is @mempty@. +lembedActee :: Monoid s => x -> LSemidirect x s +lembedActee x = LPair x mempty + +-- | Convert a pair into a semidirect product element. +lfromPair :: (x,s) -> LSemidirect x s +lfromPair (x,s) = LPair x s + + +------------------------------------------------------------------------------ + +-- | A semidirect product for a right action, where @s@ acts on @x@ +-- +data RSemidirect x s = RPair + { 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 + RPair x s <> RPair x' s' = + RPair (x <> (x' $<> s)) (s <> s') + +instance RActMnMorph x s => Monoid (RSemidirect x s) where + mempty = RPair 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 = RPair mempty s + +-- | Make a semidirect pair whose actor element is @mempty@ . +rembedActee :: Monoid s => x -> RSemidirect x s +rembedActee x = RPair x mempty + +-- | Convert a pair into a semidirect product element +rfromPair :: (x,s) -> RSemidirect x s +rfromPair (x,s) = RPair x s diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,76 +1,75 @@ -{-# 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 +{-# LANGUAGE DerivingVia #-} + +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.LPair (Sum (x :: Int)) (Product (s :: Int)) + <> Lazy.LPair (Sum y) (Product t) + `shouldBe` + Lazy.LPair (Sum (x + s*y)) (Product (s*t)) + it "Product on Sum Monoid" $ + mempty `shouldBe` + Lazy.LPair (mempty :: Sum Int) (mempty :: Product Int) + describe "Strict" $ do + it "Product on Sum Semigroup" $ property $ + \x s y t -> + Strict.LPair (Sum (x :: Int)) (Product (s :: Int)) + <> Strict.LPair (Sum y) (Product t) + `shouldBe` + Strict.LPair (Sum (x + s*y)) (Product (s*t)) + it "Product on Sum Monoid" $ + mempty `shouldBe` + Strict.LPair (mempty :: Sum Int) (mempty :: Product Int) + describe "RSemidirect" $ do + describe "Lazy" $ do + it "Product on Sum Semigroup" $ property $ + \x s y t -> + Lazy.RPair (Sum (x :: Int)) (Product (s :: Int)) + <> Lazy.RPair (Sum y) (Product t) + `shouldBe` + Lazy.RPair (Sum (x + s*y)) (Product (s*t)) + it "Product on Sum Monoid" $ + mempty `shouldBe` + Lazy.RPair (mempty :: Sum Int) (mempty :: Product Int) + describe "Strict" $ do + it "Product on Sum Semigroup" $ property $ + \x s y t -> + Strict.RPair (Sum (x :: Int)) (Product (s :: Int)) + <> Strict.RPair (Sum y) (Product t) + `shouldBe` + Strict.RPair (Sum (x + s*y)) (Product (s*t)) + it "Product on Sum Monoid" $ + mempty `shouldBe` + Strict.RPair (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