├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── .travis.yml ├── CHANGES ├── LICENSE ├── README.markdown ├── Setup.hs ├── benchmarks └── SemiDirectProduct.hs ├── monoid-extras.cabal └── src ├── Data ├── Monoid │ ├── Action.hs │ ├── Coproduct.hs │ ├── Cut.hs │ ├── Deletable.hs │ ├── Endomorphism.hs │ ├── Inf.hs │ ├── MList.hs │ ├── Recommend.hs │ ├── SemiDirectProduct.hs │ ├── SemiDirectProduct │ │ └── Strict.hs │ ├── Split.hs │ └── WithSemigroup.hs └── Semigroup │ └── Coproduct.hs └── Test.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'monoid-extras.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250330 12 | # 13 | # REGENDATA ("0.19.20250330",["github","monoid-extras.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-24.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.12.1 32 | compilerKind: ghc 33 | compilerVersion: 9.12.1 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.10.1 37 | compilerKind: ghc 38 | compilerVersion: 9.10.1 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.8.2 42 | compilerKind: ghc 43 | compilerVersion: 9.8.2 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.6.6 47 | compilerKind: ghc 48 | compilerVersion: 9.6.6 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-9.4.8 52 | compilerKind: ghc 53 | compilerVersion: 9.4.8 54 | setup-method: ghcup 55 | allow-failure: false 56 | - compiler: ghc-9.2.8 57 | compilerKind: ghc 58 | compilerVersion: 9.2.8 59 | setup-method: ghcup 60 | allow-failure: false 61 | - compiler: ghc-9.0.2 62 | compilerKind: ghc 63 | compilerVersion: 9.0.2 64 | setup-method: ghcup 65 | allow-failure: false 66 | - compiler: ghc-8.10.7 67 | compilerKind: ghc 68 | compilerVersion: 8.10.7 69 | setup-method: ghcup 70 | allow-failure: false 71 | - compiler: ghc-8.8.4 72 | compilerKind: ghc 73 | compilerVersion: 8.8.4 74 | setup-method: ghcup 75 | allow-failure: false 76 | - compiler: ghc-8.6.5 77 | compilerKind: ghc 78 | compilerVersion: 8.6.5 79 | setup-method: ghcup 80 | allow-failure: false 81 | - compiler: ghc-8.4.4 82 | compilerKind: ghc 83 | compilerVersion: 8.4.4 84 | setup-method: ghcup 85 | allow-failure: false 86 | fail-fast: false 87 | steps: 88 | - name: apt-get install 89 | run: | 90 | apt-get update 91 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev 92 | - name: Install GHCup 93 | run: | 94 | mkdir -p "$HOME/.ghcup/bin" 95 | curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup" 96 | chmod a+x "$HOME/.ghcup/bin/ghcup" 97 | - name: Install cabal-install 98 | run: | 99 | "$HOME/.ghcup/bin/ghcup" install cabal 3.14.1.1-p1 || (cat "$HOME"/.ghcup/logs/*.* && false) 100 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.1.1-p1 -vnormal+nowrap" >> "$GITHUB_ENV" 101 | - name: Install GHC (GHCup) 102 | if: matrix.setup-method == 'ghcup' 103 | run: | 104 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 105 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 106 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 107 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 108 | echo "HC=$HC" >> "$GITHUB_ENV" 109 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 110 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 111 | env: 112 | HCKIND: ${{ matrix.compilerKind }} 113 | HCNAME: ${{ matrix.compiler }} 114 | HCVER: ${{ matrix.compilerVersion }} 115 | - name: Set PATH and environment variables 116 | run: | 117 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 118 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 119 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 120 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 121 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 122 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 123 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 124 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 125 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 126 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 127 | env: 128 | HCKIND: ${{ matrix.compilerKind }} 129 | HCNAME: ${{ matrix.compiler }} 130 | HCVER: ${{ matrix.compilerVersion }} 131 | - name: env 132 | run: | 133 | env 134 | - name: write cabal config 135 | run: | 136 | mkdir -p $CABAL_DIR 137 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 170 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 171 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 172 | rm -f cabal-plan.xz 173 | chmod a+x $HOME/.cabal/bin/cabal-plan 174 | cabal-plan --version 175 | - name: checkout 176 | uses: actions/checkout@v4 177 | with: 178 | path: source 179 | - name: initial cabal.project for sdist 180 | run: | 181 | touch cabal.project 182 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 183 | cat cabal.project 184 | - name: sdist 185 | run: | 186 | mkdir -p sdist 187 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 188 | - name: unpack 189 | run: | 190 | mkdir -p unpacked 191 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 192 | - name: generate cabal.project 193 | run: | 194 | PKGDIR_monoid_extras="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/monoid-extras-[0-9.]*')" 195 | echo "PKGDIR_monoid_extras=${PKGDIR_monoid_extras}" >> "$GITHUB_ENV" 196 | rm -f cabal.project cabal.project.local 197 | touch cabal.project 198 | touch cabal.project.local 199 | echo "packages: ${PKGDIR_monoid_extras}" >> cabal.project 200 | echo "package monoid-extras" >> cabal.project 201 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 202 | cat >> cabal.project <> cabal.project.local 205 | cat cabal.project 206 | cat cabal.project.local 207 | - name: dump install plan 208 | run: | 209 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 210 | cabal-plan 211 | - name: restore cache 212 | uses: actions/cache/restore@v4 213 | with: 214 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 215 | path: ~/.cabal/store 216 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 217 | - name: install dependencies 218 | run: | 219 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 220 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 221 | - name: build w/o tests 222 | run: | 223 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 224 | - name: build 225 | run: | 226 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 227 | - name: cabal check 228 | run: | 229 | cd ${PKGDIR_monoid_extras} || false 230 | ${CABAL} -vnormal check 231 | - name: haddock 232 | run: | 233 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 234 | - name: unconstrained build 235 | run: | 236 | rm -f cabal.project.local 237 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 238 | - name: save cache 239 | if: always() 240 | uses: actions/cache/save@v4 241 | with: 242 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 243 | path: ~/.cabal/store 244 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | .virthualenv 9 | *~ 10 | .hsenv_* 11 | dist_* 12 | history 13 | TAGS 14 | cabal.project.local 15 | .cabal-sandbox/ 16 | cabal.sandbox.config 17 | .stack-work/ 18 | stack.yaml.lock 19 | codex.tags 20 | .ghc.environment.* 21 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | 3 | env: 4 | matrix: 5 | - GHCVER=7.10.3 CABALVER=1.22 6 | - GHCVER=8.0.2 CABALVER=1.24 SKIP_HADDOCK=true 7 | - GHCVER=8.2.2 CABALVER=2.0 8 | - GHCVER=8.4.2 CABALVER=2.2 9 | - GHCVER=8.6.1 CABALVER=2.4 10 | - GHCVER=8.8.1 CABALVER=3.0 11 | - GHCVER=head CABALVER=head 12 | 13 | matrix: 14 | allow_failures: 15 | - env: GHCVER=head CABALVER=head 16 | 17 | before_install: 18 | - git clone http://github.com/diagrams/diagrams-travis travis 19 | - source travis/scripts/set_env.sh 20 | - ./travis/scripts/before_install.sh 21 | 22 | install: ./travis/scripts/install.sh 23 | 24 | script: ./travis/scripts/script.sh 25 | 26 | notifications: 27 | email: false 28 | irc: 29 | channels: 30 | - irc.freenode.org#diagrams 31 | skip_join: true 32 | template: 33 | - "\x0313monoid-extras\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" 34 | 35 | -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | * 0.7: 12 May 2025 2 | 3 | - Updates to `Data.Monoid.Coproduct`: 4 | - Fix `Eq` instance for monoid coproducts to take `mempty` into account 5 | - `cop` implements coproduct universal map 6 | - `untangleSemi`, like `untangle` but as a monoid homomorphism to semidirect product 7 | - `toReducedAltList`, like `toAltList` but also gets rid of `mempty` 8 | - New module `Data.Semigroup.Coproduct` with semigroup coproducts 9 | - Remove `Data.Monoid.Coproduct.Strict` 10 | 11 | Thanks to Sonat Süer (@sonatsuer) for the updates! 12 | 13 | * 0.6.5: 22 February 2025 14 | 15 | - New instance `Eq (m :+: n)` ([#59](https://github.com/diagrams/monoid-extras/issues/59)) 16 | - New function `toAltList :: (m :+: n) -> [Either m n]` 17 | 18 | * 0.6.4: 10 February 2025 19 | 20 | - New instance `Action m a => Action [m] a` (thanks to Manuel Bärenz for the suggestion) 21 | 22 | * 0.6.3: 8 August 2024 23 | 24 | - New instances (thanks to Clinton Mead): 25 | - `Action (First a) a` 26 | - `Action Void a` 27 | - `Action m a => Action (Identity m) a` 28 | 29 | - r1 (27 Jan 2025): 30 | - Allow `base-4.21` and test on GHC 9.12. 31 | 32 | * 0.6.2: 20 Dec 2022 33 | 34 | - New class and newtypes in `Data.Monoid.Action` (thanks to Manuel Bärenz): 35 | - `Torsor` class for transitive group actions 36 | - `Regular` and `Conjugate` newtypes for groups acting on themselves 37 | 38 | - r1 (27 March 2023): 39 | - allow `semigroupoids-6.0` 40 | - allow `base-4.18` and test on GHC 9.6. 41 | 42 | - r2 (17 Oct 2023): 43 | - allow `base-4.19` and test on GHC 9.8. 44 | 45 | - r3 (15 May 2024): 46 | - allow `base-4.20` and test on GHC 9.10. 47 | 48 | * 0.6.1: 16 Nov 2021 49 | 50 | - Add more efficient `stimes` implementations for several `Semigroup` 51 | instances. Thanks to BlackCapCoder for the patch! 52 | - Allow `base-4.16` and test on GHC 9.2.1. 53 | 54 | - r1: allow `base-4.16` in benchmarks 55 | - r2 (15 August 2022): allow `base-4.17` and test with GHC 9.4. 56 | 57 | * 0.6: 8 May 2021 58 | 59 | - Updates for GHC 8.10 and 9.0. 60 | - Drop support for GHC 8.2 or older. 61 | - Replace deprecated `Option` type with `Maybe`. 62 | 63 | * 0.5.1: 19 Oct 2019 64 | 65 | - New module Data.Monoid.Coproduct.Strict for a more efficient coproduct in 66 | some use cases. 67 | - Update for GHC 8.8. 68 | - Drop support for GHC 7.8. 69 | 70 | * 0.5: 14 May 2018 71 | 72 | - Modernize Data.Monoid.WithSemigroup 73 | 74 | It used to export a type class Monoid' with no methods and a single 75 | instance, for use as a "poor man's constraint synonym" for the 76 | combination of Monoid and Semigroup. Now Monoid': 77 | 78 | - Is a real constraint synonym, using ConstraintKinds. 79 | - Is simply a synonym for Monoid under base-4.11 and later, in 80 | which case Semigroup is already a superclass of Monoid. 81 | 82 | This technically necessitates a major version bump but should not 83 | cause any issues for packages that depend on monoid-extras, other 84 | than potentially requiring the addition of a ConstraintKinds pragma 85 | under GHC 7.8. 86 | 87 | * 0.4.4: 8 April 2018 88 | 89 | - Fix build on older (< 7.10) GHCs (thanks to George Wilson for the fix) 90 | 91 | * 0.4.3: 3 April 2018 92 | 93 | - Allow base-4.11 94 | - Fix compilation on GHC 8.4 95 | - Add more instances for Inf 96 | 97 | * 0.4.2: 16 July 2016 98 | 99 | - Additions to Data.Monoid.SemiDirectProduct (unSemi, tag, untag) 100 | 101 | - Hackage revision 1: allow semigroupoids-5.2 102 | - Hackage revision 2: allow base-4.10 103 | 104 | * 0.4.1.2: 16 June 2016 105 | 106 | - allow semigroupoids-5.1 107 | 108 | * 0.4.1: 8 June 2016 109 | 110 | - new modules Data.Monoid.SemiDirectProduct[.Strict]. 111 | 112 | * 0.4.0.4: 14 February 2016 113 | 114 | - allow base-4.9 for GHC-8 115 | 116 | * 0.4.0.3: 10 November 2015 117 | 118 | - allow semigroups-0.18 119 | 120 | * 0.4.0.2: 16 September 2015 121 | 122 | - allow semigroups-0.17 123 | 124 | * v0.4.0.1 125 | 126 | - allow semigroupoids-5.0 127 | 128 | * 0.4: 19 April 2015 129 | 130 | - add derived instances where possible: 131 | Typeable, Data, Read, Eq, Ord, Functor, Foldable, Traversable 132 | - allow base-4.8 133 | 134 | * 0.3.3.5: 03 Dec 2014 135 | 136 | - allow semigroups-0.15 137 | 138 | * 0.3.3.4: 28 May 2014 139 | 140 | - allow semigroups-0.15 141 | 142 | * 0.3.3.3: 15 May 2014 143 | 144 | - allow semigroups-0.14 145 | 146 | * 0.3.3.2: 10 April 2014 147 | 148 | - allow semigroups-0.13 149 | 150 | * 0.3.3.1: 9 March 2014 151 | 152 | - drop dependency on deprecated `groupoids` package 153 | 154 | * 0.3.3: 4 March 2014 155 | 156 | - export Pos and Neg types, to improve Haddock documentation 157 | 158 | * 0.3.2.4: 27 November 2013 159 | 160 | - allow semigroups-0.12 161 | 162 | * 0.3.2.3: 19 October 2013 163 | 164 | - Allow groupoids-4 and semigroupoids-4 165 | 166 | * 0.3.2.2: 26 September 2013 167 | 168 | - allow semigroups-0.11 169 | 170 | * 0.3.2.1: 25 September 2013 171 | 172 | - allow groups-0.4 173 | 174 | * 0.3.2: 30 August 2013 175 | 176 | - new Group instance for Endomorphism 177 | 178 | * 0.3.1: 20 August 2013 179 | 180 | - new module Data.Monoid.Endomorphism 181 | - add derived Functor, Foldable, and Traversable instances for Data.Monoid.Inf.Inf 182 | 183 | * 0.3: 2 May 2013 184 | 185 | - generalize PosInf to Inf, which supports making monoids out of 186 | semigroups under both min and max 187 | 188 | * 0.2.2.3: 28 March 2013 189 | 190 | - bump upper bound to allow base-4.7 191 | 192 | * 0.2.2.2: 7 January 2013 193 | 194 | - bump upper bound to allow semigroups-0.9 195 | 196 | * 0.2.2.1: 11 December 2012 197 | 198 | - Small fix to allow building under older GHCs 199 | 200 | * 0.2.2.0: 10 December 2012 201 | 202 | - Add new module Data.Monoid.Recommend 203 | 204 | * 0.2.1.0: 28 September 2012 205 | 206 | - Add new module Data.Monoid.Cut 207 | - Documentation improvements 208 | - Add Show instance for Split 209 | 210 | * 0.2.0.0: 3 September 2012 211 | 212 | - Remove instances for actions on pairs and triples, and add some 213 | commentary explaining why adding them was a bad idea in the first 214 | place. 215 | 216 | * 0.1.1.0 217 | 218 | - Add instances for actions on pairs and triples 219 | 220 | * 0.1.0.0 221 | 222 | - initial release 223 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012-2015, monoid-extras team: 2 | 3 | Daniel Bergey 4 | Christopher Chalmers 5 | Nathan van Doorn 6 | Daniil Frumin 7 | Hans Höglund 8 | Moritz Kiefer 9 | Piyush P Kurur 10 | Daniel Wagner 11 | Ryan Yates 12 | Brent Yorgey 13 | 14 | All rights reserved. 15 | 16 | Redistribution and use in source and binary forms, with or without 17 | modification, are permitted provided that the following conditions are met: 18 | 19 | * Redistributions of source code must retain the above copyright 20 | notice, this list of conditions and the following disclaimer. 21 | 22 | * Redistributions in binary form must reproduce the above 23 | copyright notice, this list of conditions and the following 24 | disclaimer in the documentation and/or other materials provided 25 | with the distribution. 26 | 27 | * Neither the name of Brent Yorgey nor the names of other 28 | contributors may be used to endorse or promote products derived 29 | from this software without specific prior written permission. 30 | 31 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 32 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 33 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 34 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 35 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 36 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 37 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 38 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 39 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 40 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 41 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 42 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | [![Build Status](https://secure.travis-ci.org/diagrams/monoid-extras.png)](http://travis-ci.org/diagrams/monoid-extras) 2 | 3 | Various extra monoid-related definitions and utilities, such as monoid 4 | actions, monoid coproducts, "deletable" monoids, "split" monoids, and 5 | "cut" monoids. 6 | 7 | To install, 8 | 9 | cabal install monoid-extras 10 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /benchmarks/SemiDirectProduct.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | 6 | module Main where 7 | 8 | import Criterion.Main 9 | 10 | #if !MIN_VERSION_base(4,8,0) 11 | import Data.Monoid 12 | import Data.Word 13 | #else 14 | import Data.Monoid (Sum(..)) 15 | #endif 16 | #if !MIN_VERSION_base(4,11,0) 17 | import Data.Semigroup (Semigroup) 18 | #endif 19 | 20 | import Data.Monoid.Action 21 | import qualified Data.Monoid.SemiDirectProduct as L 22 | import qualified Data.Monoid.SemiDirectProduct.Strict as S 23 | 24 | newtype MyMonoid = MyMonoid (Sum Word) deriving (Semigroup, Monoid) 25 | 26 | instance Action MyMonoid () where 27 | act _ = id 28 | {-# NOINLINE act #-} 29 | 30 | main :: IO () 31 | main = defaultMain 32 | [ bench "mconcat/strict" $ whnf mconcat strict 33 | , bench "mconcat/lazy" $ whnf mconcat lazy 34 | , bench "strict/quotient" $ whnf (S.quotient . mconcat) strict 35 | , bench "lazy/quotient" $ whnf (L.quotient . mconcat) lazy 36 | ] 37 | where strict :: [S.Semi () MyMonoid] 38 | strict = map (S.embed . MyMonoid . Sum) $ take 1000 [1..] 39 | lazy :: [L.Semi () (MyMonoid)] 40 | lazy = map (L.embed . MyMonoid . Sum) $ take 1000 [1..] 41 | -------------------------------------------------------------------------------- /monoid-extras.cabal: -------------------------------------------------------------------------------- 1 | name: monoid-extras 2 | version: 0.7 3 | synopsis: Various extra monoid-related definitions and utilities 4 | description: Various extra monoid-related definitions and utilities, 5 | such as monoid actions, monoid coproducts, semi-direct 6 | products, \"deletable\" monoids, \"split\" monoids, 7 | and \"cut\" monoids. 8 | license: BSD3 9 | license-file: LICENSE 10 | extra-source-files: CHANGES 11 | author: Brent Yorgey 12 | maintainer: diagrams-discuss@googlegroups.com 13 | bug-reports: https://github.com/diagrams/monoid-extras/issues 14 | category: Data 15 | build-type: Simple 16 | cabal-version: >=1.10 17 | tested-with: GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.2 || ==9.10.1 || ==9.12.1 18 | 19 | source-repository head 20 | type: git 21 | location: https://github.com/diagrams/monoid-extras.git 22 | 23 | library 24 | default-language: Haskell2010 25 | exposed-modules: Data.Monoid.Action, 26 | Data.Monoid.SemiDirectProduct, 27 | Data.Monoid.SemiDirectProduct.Strict 28 | Data.Monoid.Coproduct, 29 | Data.Monoid.Cut, 30 | Data.Monoid.Deletable, 31 | Data.Monoid.Endomorphism, 32 | Data.Monoid.Inf, 33 | Data.Monoid.MList, 34 | Data.Monoid.Recommend, 35 | Data.Monoid.Split, 36 | Data.Monoid.WithSemigroup, 37 | Data.Semigroup.Coproduct 38 | 39 | build-depends: base >= 4.11 && < 4.22, 40 | groups < 0.6, 41 | semigroupoids >= 4.0 && < 6.1 42 | 43 | hs-source-dirs: src 44 | 45 | ghc-options: -Wall 46 | 47 | other-extensions: DeriveFunctor 48 | FlexibleInstances 49 | MultiParamTypeClasses 50 | TypeOperators 51 | ConstraintKinds 52 | 53 | benchmark semi-direct-product 54 | default-language: Haskell2010 55 | hs-source-dirs: benchmarks 56 | main-is: SemiDirectProduct.hs 57 | type: exitcode-stdio-1.0 58 | build-depends: base >= 4.3 && < 4.22 59 | , semigroups 60 | , criterion 61 | , monoid-extras 62 | -------------------------------------------------------------------------------- /src/Data/Monoid/Action.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Data.Monoid.Action 7 | -- Copyright : (c) 2011 diagrams-core team (see LICENSE) 8 | -- License : BSD-style (see LICENSE) 9 | -- Maintainer : diagrams-discuss@googlegroups.com 10 | -- 11 | -- Monoid and semigroup actions. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Data.Monoid.Action 16 | ( Action(..) 17 | , Regular(..) 18 | , Conjugate(..) 19 | , Torsor(..) 20 | ) where 21 | 22 | import Data.Functor.Identity (Identity(Identity)) 23 | import Data.Semigroup 24 | import qualified Data.Semigroup as Semigroup 25 | import Data.Group 26 | import qualified Data.Monoid as Monoid 27 | import Data.Void (Void, absurd) 28 | 29 | ------------------------------------------------------------ 30 | -- Monoid and semigroup actions 31 | ------------------------------------------------------------ 32 | 33 | -- | Type class for monoid (and semigroup) actions, where monoidal 34 | -- values of type @m@ \"act\" on values of another type @s@. 35 | -- Instances are required to satisfy the laws 36 | -- 37 | -- * @act mempty = id@ 38 | -- 39 | -- * @act (m1 \`mappend\` m2) = act m1 . act m2@ 40 | -- 41 | -- Semigroup instances are required to satisfy the second law but with 42 | -- ('<>') instead of 'mappend'. Additionally, if the type @s@ has 43 | -- any algebraic structure, @act m@ should be a homomorphism. For 44 | -- example, if @s@ is also a monoid we should have @act m mempty = 45 | -- mempty@ and @act m (s1 \`mappend\` s2) = (act m s1) \`mappend\` 46 | -- (act m s2)@. 47 | -- 48 | -- By default, @act = const id@, so for a type @M@ which should have 49 | -- no action on anything, it suffices to write 50 | -- 51 | -- > instance Action M s 52 | -- 53 | -- with no method implementations. 54 | -- 55 | -- It is a bit awkward dealing with instances of @Action@, since it 56 | -- is a multi-parameter type class but we can't add any functional 57 | -- dependencies---the relationship between monoids and the types on 58 | -- which they act is truly many-to-many. In practice, this library 59 | -- has chosen to have instance selection for @Action@ driven by the 60 | -- /first/ type parameter. That is, you should never write an 61 | -- instance of the form @Action m SomeType@ since it will overlap 62 | -- with instances of the form @Action SomeMonoid t@. Newtype 63 | -- wrappers can be used to (awkwardly) get around this. 64 | class Action m s where 65 | 66 | -- | Convert a value of type @m@ to an action on @s@ values. 67 | act :: m -> s -> s 68 | act = const id 69 | 70 | -- | @()@ acts as the identity. 71 | instance Action () l where 72 | act () = id 73 | 74 | -- | @Nothing@ acts as the identity; @Just m@ acts as @m@. 75 | instance Action m s => Action (Maybe m) s where 76 | act Nothing s = s 77 | act (Just m) s = act m s 78 | 79 | -- | @act [a,b,c,...] = act a . act b . act c . ...@ 80 | instance Action m s => Action [m] s where 81 | act = flip (foldr act) 82 | 83 | -- | @Endo@ acts by application. 84 | -- 85 | -- Note that in order for this instance to satisfy the @Action@ 86 | -- laws, whenever the type @a@ has some sort of algebraic structure, 87 | -- the type @Endo a@ must be considered to represent /homomorphisms/ 88 | -- (structure-preserving maps) on @a@, even though there is no way 89 | -- to enforce this in the type system. For example, if @a@ is an 90 | -- instance of @Monoid@, then one should only use @Endo a@ values 91 | -- @f@ with the property that @f mempty = mempty@ and @f (a <> b) = 92 | -- f a <> f b@. 93 | instance Action (Endo a) a where 94 | act = appEndo 95 | 96 | instance Num a => Action Integer (Sum a) where 97 | n `act` a = fromInteger n <> a 98 | 99 | instance Num a => Action Integer (Product a) where 100 | n `act` a = fromInteger n <> a 101 | 102 | instance Fractional a => Action Rational (Sum a) where 103 | n `act` a = Sum (fromRational n) <> a 104 | 105 | instance Fractional a => Action Rational (Product a) where 106 | n `act` a = Product (fromRational n) <> a 107 | 108 | -- | An action of a group is "free transitive", "regular", or a "torsor" 109 | -- iff it is invertible. 110 | -- 111 | -- Given an original value `sOrig`, and a value `sActed` that is the result 112 | -- of acting on `sOrig` by some `m`, 113 | -- it is possible to recover this `m`. 114 | -- This is encoded in the laws: 115 | -- 116 | -- * @(m `'act'` s) `'difference'` s = m@ 117 | -- * @(sActed `'difference'` sOrig) `'act'` sOrig = sActed@ 118 | class Group m => Torsor m s where 119 | 120 | -- | @'difference' sActed sOrig@ is the element @m@ such that @sActed = m `'act'` sOrig@. 121 | difference :: s -> s -> m 122 | 123 | -- | Any monoid acts on itself by left multiplication. 124 | -- This newtype witnesses this action: 125 | -- @'getRegular' $ 'Regular' m1 `'act'` 'Regular' m2 = m1 '<>' m2@ 126 | newtype Regular m = Regular { getRegular :: m } 127 | 128 | instance Semigroup m => Action m (Regular m) where 129 | m1 `act` Regular m2 = Regular $ m1 <> m2 130 | 131 | instance Group m => Torsor m (Regular m) where 132 | Regular m1 `difference` Regular m2 = m1 ~~ m2 133 | 134 | -- | Any group acts on itself by conjugation. 135 | newtype Conjugate m = Conjugate { getConjugate :: m } 136 | 137 | instance Group m => Action m (Conjugate m) where 138 | m1 `act` Conjugate m2 = Conjugate $ m1 <> m2 ~~ m1 139 | 140 | instance Action (Semigroup.First a) a where 141 | act (Semigroup.First m) _ = m 142 | 143 | instance Action (Monoid.First a) a where 144 | act (Monoid.First m) s = case m of 145 | Nothing -> s 146 | Just m' -> m' 147 | 148 | instance Action Void a where 149 | act = absurd 150 | 151 | instance Action m s => Action (Identity m) s where 152 | act (Identity m) = act m 153 | -------------------------------------------------------------------------------- /src/Data/Monoid/Coproduct.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | 7 | ----------------------------------------------------------------------------- 8 | -- | 9 | -- Module : Data.Monoid.Coproduct 10 | -- Copyright : (c) 2011-2015 diagrams-core team (see LICENSE) 11 | -- License : BSD-style (see LICENSE) 12 | -- Maintainer : diagrams-discuss@googlegroups.com 13 | -- 14 | -- The coproduct of two monoids. 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module Data.Monoid.Coproduct 19 | ( (:+:) 20 | , inL, inR 21 | , mappendL, mappendR 22 | , cop 23 | , killL, killR 24 | , toAltList 25 | , toReducedAltList 26 | , untangle 27 | , untangleSemi 28 | ) where 29 | 30 | import Data.Function (on) 31 | import Data.Semigroup 32 | import Data.Typeable 33 | 34 | import Data.Monoid.Action 35 | import Data.Monoid.SemiDirectProduct ( embed, inject, Semi, unSemi ) 36 | import Data.Tuple (swap) 37 | 38 | -- | @m :+: n@ is the coproduct of monoids @m@ and @n@. Values of 39 | -- type @m :+: n@ consist of alternating lists of @m@ and @n@ 40 | -- values. The empty list is the identity, and composition is list 41 | -- concatenation, with appropriate combining of adjacent elements 42 | -- and removing identities when possible. 43 | newtype m :+: n = MCo { unMCo :: [Either m n] } 44 | deriving (Typeable, Show) 45 | 46 | instance (Eq m, Eq n, Monoid m, Monoid n) => Eq (m :+: n) where 47 | (==) = (==) `on` (normalizeEq . unMCo) 48 | 49 | -- | Extract a monoid coproduct to a list of @Either@ values. The 50 | -- resulting list is guaranteed to be normalized, in the sense that 51 | -- it will strictly alternate between @Left@ and @Right@. 52 | toAltList :: (Semigroup m, Semigroup n) => (m :+: n) -> [Either m n] 53 | toAltList (MCo ms) = normalize ms 54 | 55 | -- | Extract a monoid coproduct to a list of @Either@ values. The 56 | -- resulting list is guaranteed to be normalized, in the sense that 57 | -- it will strictly alternate between @Left@ and @Right@ and no identity 58 | -- element from @m@ or @n@ will occur in the list. 59 | toReducedAltList :: (Eq m, Eq n, Monoid m, Monoid n) => (m :+: n) -> [Either m n] 60 | toReducedAltList (MCo ms) = normalizeEq ms 61 | 62 | -- Normalize a list of @Either@ values by combining any consecutive 63 | -- values of the same type. 64 | normalize :: (Semigroup m, Semigroup n) => [Either m n] -> [Either m n] 65 | normalize = \case 66 | (Left e1:Left e2 : es) -> normalize (Left (e1 <> e2) : es) 67 | (Right e1:Right e2:es) -> normalize (Right (e1 <> e2) : es) 68 | [] -> [] 69 | (e:es) -> e : normalize es 70 | 71 | 72 | -- Similar to @normalize@. In addition to combining consecutive values of the same 73 | -- type it also removes the identities. 74 | normalizeEq :: (Eq m, Eq n, Monoid m, Monoid n) => [Either m n] -> [Either m n] 75 | normalizeEq es = until (all nonIdentity) reduce (normalize es) 76 | where 77 | reduce = normalize . filter nonIdentity 78 | nonIdentity e = e /= Left mempty && e /= Right mempty 79 | 80 | -- For efficiency and simplicity, we implement it just as [Either m 81 | -- n]: of course, this does not preserve the invariant of strictly 82 | -- alternating types, but it doesn't really matter as long as we don't 83 | -- let anyone inspect the internal representation. 84 | 85 | -- | Universal map of the coproduct. The name @cop@ is an abbreviation 86 | -- for copairing. Both functions in the signature should be monoid 87 | -- homomorphisms. If they are general functions then the copairing may 88 | -- not be well defined in the sense that it may send equal elements to 89 | -- unequal elements. This is also the reason why @cop@ is not the 90 | -- @Data.Bifoldable.bifoldMap@ function even though they have the same 91 | -- signature. 92 | cop :: Monoid k => (m -> k) -> (n -> k) -> (m :+: n) -> k 93 | f `cop` g = foldMap (either f g) . unMCo 94 | 95 | -- | Injection from the left monoid into a coproduct. 96 | inL :: m -> m :+: n 97 | inL m = MCo [Left m] 98 | 99 | -- | Injection from the right monoid into a coproduct. 100 | inR :: n -> m :+: n 101 | inR n = MCo [Right n] 102 | 103 | -- | Prepend a value from the left monoid. 104 | mappendL :: m -> m :+: n -> m :+: n 105 | mappendL = mappend . inL 106 | 107 | -- | Prepend a value from the right monoid. 108 | mappendR :: n -> m :+: n -> m :+: n 109 | mappendR = mappend . inR 110 | 111 | instance Semigroup (m :+: n) where 112 | (MCo es1) <> (MCo es2) = MCo (es1 ++ es2) 113 | 114 | -- | The coproduct of two monoids is itself a monoid. 115 | instance Monoid (m :+: n) where 116 | mempty = MCo [] 117 | mappend = (<>) 118 | 119 | -- | @killR@ takes a value in a coproduct monoid and sends all the 120 | -- values from the right monoid to the identity. 121 | killR :: Monoid m => m :+: n -> m 122 | killR = id `cop` const mempty 123 | 124 | -- | @killL@ takes a value in a coproduct monoid and sends all the 125 | -- values from the left monoid to the identity. 126 | killL :: Monoid n => m :+: n -> n 127 | killL = const mempty `cop` id 128 | 129 | -- | The copairing of @embed@ and @inject@ homomorphisms into the 130 | -- semidirect product. Note that @embed@ and @inject@ are monoid 131 | -- homomorphisms. Therefore @untangleSemi@ is also a monoid homomorphism. 132 | untangleSemi :: (Action m n, Monoid m, Monoid n) => m :+: n -> Semi n m 133 | untangleSemi = embed `cop` inject 134 | 135 | -- | Same as @untangleSemi@ but the result is uwrapped. Concretely, given 136 | -- a value from a coproduct monoid where the left monoid has an 137 | -- action on the right, and \"untangle\" it into a pair of values. In 138 | -- particular, 139 | -- 140 | -- > m1 <> n1 <> m2 <> n2 <> m3 <> n3 <> ... 141 | -- 142 | -- is sent to 143 | -- 144 | -- > (m1 <> m2 <> m3 <> ..., (act m1 n1) <> (act (m1 <> m2) n2) <> (act (m1 <> m2 <> m3) n3) <> ...) 145 | -- 146 | -- That is, before combining @n@ values, every @n@ value is acted on 147 | -- by all the @m@ values to its left. 148 | untangle :: (Action m n, Monoid m, Monoid n) => m :+: n -> (m,n) 149 | untangle = swap . unSemi . untangleSemi 150 | 151 | -- | Coproducts act on other things by having each of the components 152 | -- act individually. 153 | instance (Action m r, Action n r) => Action (m :+: n) r where 154 | act = appEndo . ((Endo . act) `cop` (Endo . act)) 155 | -------------------------------------------------------------------------------- /src/Data/Monoid/Cut.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveTraversable #-} 5 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Data.Monoid.Cut 9 | -- Copyright : (c) 2012-2015 diagrams-core team (see LICENSE) 10 | -- License : BSD-style (see LICENSE) 11 | -- Maintainer : diagrams-discuss@googlegroups.com 12 | -- 13 | -- The @Cut@ monoid transformer introduces \"cut points\" such that 14 | -- all values between any two cut points are thrown away. That is, 15 | -- 16 | -- > a b c | d e | f g h i | j k == a b c | j k 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module Data.Monoid.Cut 21 | ( Cut(..), cut 22 | 23 | ) where 24 | 25 | import Data.Data 26 | import Data.Semigroup 27 | import Data.Foldable 28 | import Data.Traversable 29 | 30 | infix 5 :||: 31 | 32 | -- | A value of type @Cut m@ is either a single @m@, or a pair of 33 | -- @m@'s separated by a divider. The divider represents a \"cut 34 | -- point\". 35 | -- 36 | -- @Cut@ is similar to "Data.Monoid.Split", but split keeps only the 37 | -- rightmost divider and accumulates all values, whereas cut always 38 | -- keeps the leftmost and rightmost divider, coalescing them into 39 | -- one and throwing away all the information in between. 40 | -- 41 | -- @Split@ uses the asymmetric constructor @:|@, and @Cut@ the 42 | -- symmetric constructor @:||:@, to emphasize the inherent asymmetry 43 | -- of @Split@ and symmetry of @Cut@. @Split@ keeps only the 44 | -- rightmost split and combines everything on the left; @Cut@ keeps 45 | -- the outermost splits and throws away everything in between. 46 | data Cut m = Uncut m 47 | | m :||: m 48 | deriving (Data, Typeable, Show, Read, Functor, Foldable, Traversable) 49 | 50 | -- | If @m@ is a @Semigroup@, then @Cut m@ is a semigroup which 51 | -- contains @m@ as a sub-semigroup, but also contains elements of 52 | -- the form @m1 :||: m2@. When elements of @m@ combine with such 53 | -- \"cut\" elements they are combined with the value on the 54 | -- corresponding side of the cut (/e.g./ @(Uncut m1) \<\> (m1' :||: 55 | -- m2) = (m1 \<\> m1') :||: m2@). When two \"cut\" elements meet, the 56 | -- two inside values are thrown away and only the outside values are 57 | -- kept. 58 | instance Semigroup m => Semigroup (Cut m) where 59 | (Uncut m1) <> (Uncut m2) = Uncut (m1 <> m2) 60 | (Uncut m1) <> (m1' :||: m2) = m1 <> m1' :||: m2 61 | (m1 :||: m2) <> (Uncut m2') = m1 :||: m2 <> m2' 62 | (m11 :||: _) <> (_ :||: m22) = m11 :||: m22 63 | 64 | stimes n (Uncut m) = Uncut (stimes n m) 65 | stimes _ (m ) = m 66 | 67 | instance (Semigroup m, Monoid m) => Monoid (Cut m) where 68 | mempty = Uncut mempty 69 | mappend = (<>) 70 | 71 | -- | A convenient name for @mempty :||: mempty@, so composing with 72 | -- @cut@ introduces a cut point. For example, @Uncut a \<\> cut \<\> 73 | -- Uncut b == a :||: b@. 74 | cut :: Monoid m => Cut m 75 | cut = mempty :||: mempty 76 | 77 | -- Note that it is impossible for a cut monoid to have an action in 78 | -- general -- the composition operation can throw away information so 79 | -- it is impossible to satisfy the law (act (m1 <> m2) x = act m1 (act 80 | -- m2 x)) in general (although it may be possible for specific types 81 | -- x). 82 | -------------------------------------------------------------------------------- /src/Data/Monoid/Deletable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveTraversable #-} 5 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Data.Monoid.Deletable 9 | -- Copyright : (c) 2011-2015 diagrams-core team (see LICENSE) 10 | -- License : BSD-style (see LICENSE) 11 | -- Maintainer : diagrams-discuss@googlegroups.com 12 | -- 13 | -- A monoid transformer that allows deleting information from a 14 | -- concatenation of monoidal values. 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module Data.Monoid.Deletable 19 | ( Deletable(..) 20 | 21 | , unDelete, toDeletable 22 | 23 | , deleteL, deleteR 24 | 25 | ) where 26 | 27 | import Data.Data 28 | import Data.Foldable 29 | import Data.Traversable 30 | import Data.Semigroup 31 | 32 | -- | If @m@ is a 'Monoid', then @Deletable m@ (intuitively speaking) 33 | -- adds two distinguished new elements @[@ and @]@, such that an 34 | -- occurrence of [ \"deletes\" everything from it to the next ]. For 35 | -- example, 36 | -- 37 | -- > abc[def]gh == abcgh 38 | -- 39 | -- This is all you really need to know to /use/ @Deletable m@ 40 | -- values; to understand the actual implementation, read on. 41 | -- 42 | -- To properly deal with nesting and associativity we need to be 43 | -- able to assign meanings to things like @[[@, @][@, and so on. (We 44 | -- cannot just define, say, @[[ == [@, since then @([[)] == [] == 45 | -- id@ but @[([]) == [id == [@.) Formally, elements of @Deletable 46 | -- m@ are triples of the form (r, m, l) representing words @]^r m 47 | -- [^l@. When combining two triples (r1, m1, l1) and (r2, m2, l2) 48 | -- there are three cases: 49 | -- 50 | -- * If l1 == r2 then the [s from the left and ]s from the right 51 | -- exactly cancel, and we are left with (r1, m1 \<\> m2, l2). 52 | -- 53 | -- * If l1 < r2 then all of the [s cancel with some of the ]s, but 54 | -- m1 is still inside the remaining ]s and is deleted, yielding (r1 55 | -- + r2 - l1, m2, l2) 56 | -- 57 | -- * The remaining case is symmetric with the second. 58 | 59 | data Deletable m = Deletable Int m Int 60 | deriving (Data, Typeable, Show, Read, Functor, Foldable, Traversable) 61 | 62 | -- | Project the wrapped value out of a `Deletable` value. 63 | unDelete :: Deletable m -> m 64 | unDelete (Deletable _ m _) = m 65 | 66 | -- | Inject a value into a `Deletable` wrapper. Satisfies the 67 | -- property 68 | -- 69 | -- > unDelete . toDeletable === id 70 | -- 71 | toDeletable :: m -> Deletable m 72 | toDeletable m = Deletable 0 m 0 73 | 74 | instance Semigroup m => Semigroup (Deletable m) where 75 | (Deletable r1 m1 l1) <> (Deletable r2 m2 l2) 76 | | l1 == r2 = Deletable r1 (m1 <> m2) l2 77 | | l1 < r2 = Deletable (r1 + r2 - l1) m2 l2 78 | | otherwise = Deletable r1 m1 (l2 + l1 - r2) 79 | 80 | stimes n (Deletable r m l) 81 | | r == l = Deletable r (stimes n m) l 82 | | l < r = Deletable (i*(r-l) + l) m l 83 | | otherwise = Deletable r m (i*(l-r) + r) 84 | where 85 | i = fromIntegral n :: Int 86 | 87 | instance (Semigroup m, Monoid m) => Monoid (Deletable m) where 88 | mempty = Deletable 0 mempty 0 89 | mappend = (<>) 90 | 91 | -- | A \"left bracket\", which causes everything between it and the 92 | -- next right bracket to be deleted. 93 | deleteL :: Monoid m => Deletable m 94 | deleteL = Deletable 0 mempty 1 95 | 96 | -- | A \"right bracket\", denoting the end of the section that should 97 | -- be deleted. 98 | deleteR :: Monoid m => Deletable m 99 | deleteR = Deletable 1 mempty 0 100 | -------------------------------------------------------------------------------- /src/Data/Monoid/Endomorphism.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Data.Monoid.Endomorphism 8 | -- Copyright : (c) 2013-2015 diagrams-core team (see LICENSE) 9 | -- License : BSD-style (see LICENSE) 10 | -- Maintainer : diagrams-discuss@googlegroups.com 11 | -- 12 | -- The monoid of endomorphisms over any 'Category'. 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module Data.Monoid.Endomorphism 17 | ( Endomorphism(..) 18 | ) 19 | where 20 | 21 | import Control.Category 22 | import Data.Group 23 | import Data.Groupoid 24 | import Data.Monoid (Monoid(..)) 25 | import Data.Semigroup (Semigroup(..)) 26 | import Data.Semigroupoid 27 | import Prelude (Show) 28 | 29 | -- | An 'Endomorphism' in a given 'Category' is a morphism from some 30 | -- object to itself. The set of endomorphisms for a particular 31 | -- object form a monoid, with composition as the combining operation 32 | -- and the identity morphism as the identity element. 33 | newtype Endomorphism k a = Endomorphism {getEndomorphism :: k a a} 34 | 35 | deriving instance Show (k a a) => Show (Endomorphism k a) 36 | 37 | instance Semigroupoid k => Semigroup (Endomorphism k a) where 38 | Endomorphism a <> Endomorphism b = Endomorphism (a `o` b) 39 | 40 | instance (Semigroupoid k, Category k) => Monoid (Endomorphism k a) where 41 | mempty = Endomorphism id 42 | #if !MIN_VERSION_base(4,11,0) 43 | Endomorphism a `mappend` Endomorphism b = Endomorphism (a . b) 44 | #endif 45 | 46 | instance (Category k, Groupoid k) => Group (Endomorphism k a) where 47 | invert (Endomorphism a) = Endomorphism (inv a) 48 | -------------------------------------------------------------------------------- /src/Data/Monoid/Inf.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveTraversable #-} 5 | {-# LANGUAGE EmptyDataDecls #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE TypeSynonymInstances #-} 8 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 9 | 10 | ----------------------------------------------------------------------------- 11 | -- | 12 | -- Module : Data.Monoid.Inf 13 | -- Copyright : (c) 2012-2015 diagrams-core team (see LICENSE) 14 | -- License : BSD-style (see LICENSE) 15 | -- Maintainer : diagrams-discuss@googlegroups.com 16 | -- 17 | -- Make semigroups under 'min' or 'max' into monoids by adjoining an 18 | -- element corresponding to infinity (positive or negative, 19 | -- respectively). These types are similar to @Maybe (Min a)@ and 20 | -- @Maybe (Max a)@ respectively, except that the 'Ord' instance 21 | -- matches the 'Monoid' instance. 22 | -- 23 | ----------------------------------------------------------------------------- 24 | 25 | module Data.Monoid.Inf 26 | ( Inf(..) 27 | , Pos, Neg 28 | , PosInf, NegInf 29 | , minimum, maximum 30 | -- * Type-restricted constructors 31 | , posInfty, negInfty 32 | , posFinite, negFinite 33 | ) where 34 | 35 | import Control.Applicative (Applicative(..), liftA2) 36 | import Data.Data 37 | import Data.Semigroup 38 | import Prelude hiding (maximum, minimum) 39 | import qualified Prelude as P 40 | 41 | import Data.Foldable (Foldable) 42 | import Data.Traversable (Traversable) 43 | 44 | -- | Type index indicating positive infinity. 45 | data Pos 46 | -- | Type index indicating negative infinity. 47 | data Neg 48 | 49 | -- | @Inf p a@ represents the type 'a' extended with a new "infinite" 50 | -- value, which is treated as either positive or negative infinity 51 | -- depending on the type index 'p'. This type exists mostly for its 52 | -- 'Ord', 'Semigroup', and 'Monoid' instances. 53 | data Inf p a = Infinity | Finite a 54 | deriving (Data, Typeable, Show, Read, Eq, Functor, Foldable, 55 | Traversable) 56 | 57 | -- | The type 'a' extended with positive infinity. 58 | type PosInf a = Inf Pos a 59 | 60 | -- | The type 'a' extended with negative infinity. 61 | type NegInf a = Inf Neg a 62 | 63 | -- | Positive infinity is greater than any finite value. 64 | instance Ord a => Ord (Inf Pos a) where 65 | compare Infinity Infinity = EQ 66 | compare Infinity Finite{} = GT 67 | compare Finite{} Infinity = LT 68 | compare (Finite a) (Finite b) = compare a b 69 | 70 | -- | Negative infinity is less than any finite value. 71 | instance Ord a => Ord (Inf Neg a) where 72 | compare Infinity Infinity = EQ 73 | compare Infinity Finite{} = LT 74 | compare Finite{} Infinity = GT 75 | compare (Finite a) (Finite b) = compare a b 76 | 77 | -- | An ordered type extended with positive infinity is a semigroup 78 | -- under 'min'. 79 | instance Ord a => Semigroup (Inf Pos a) where 80 | (<>) = min 81 | 82 | -- | An ordered type extended with negative infinity is a semigroup 83 | -- under 'max'. 84 | instance Ord a => Semigroup (Inf Neg a) where 85 | (<>) = max 86 | 87 | -- | An ordered type extended with positive infinity is a monoid under 88 | -- 'min', with positive infinity as the identity element. 89 | instance Ord a => Monoid (Inf Pos a) where 90 | mempty = Infinity 91 | mappend = (<>) 92 | 93 | -- | An ordered type extended with negative infinity is a monoid under 94 | -- 'max', with negative infinity as the identity element. 95 | instance Ord a => Monoid (Inf Neg a) where 96 | mempty = Infinity 97 | mappend = (<>) 98 | 99 | instance Applicative (Inf p) where 100 | pure = Finite 101 | Infinity <*> _ = Infinity 102 | _ <*> Infinity = Infinity 103 | Finite f <*> Finite x = Finite $ f x 104 | 105 | instance Monad (Inf p) where 106 | Infinity >>= _ = Infinity 107 | Finite x >>= f = f x 108 | return = pure 109 | 110 | instance Bounded a => Bounded (NegInf a) where 111 | minBound = Infinity 112 | maxBound = Finite maxBound 113 | 114 | instance Bounded a => Bounded (PosInf a) where 115 | minBound = Finite minBound 116 | maxBound = Infinity 117 | 118 | -- | Find the minimum of a list of values. Returns positive infinity 119 | -- iff the list is empty. 120 | minimum :: Ord a => [a] -> PosInf a 121 | minimum xs = P.minimum (Infinity : map Finite xs) 122 | 123 | -- | Find the maximum of a list of values. Returns negative infinity 124 | -- iff the list is empty. 125 | maximum :: Ord a => [a] -> NegInf a 126 | maximum xs = P.maximum (Infinity : map Finite xs) 127 | 128 | -- | Positive infinity. 129 | posInfty :: PosInf a 130 | 131 | -- | Negative infinity. 132 | negInfty :: NegInf a 133 | 134 | -- | Embed a finite value into the space of such values extended with 135 | -- positive infinity. 136 | posFinite :: a -> PosInf a 137 | 138 | -- | Embed a finite value into the space of such values extended with 139 | -- negative infinity. 140 | negFinite :: a -> NegInf a 141 | 142 | posInfty = Infinity 143 | negInfty = Infinity 144 | posFinite = Finite 145 | negFinite = Finite 146 | -------------------------------------------------------------------------------- /src/Data/Monoid/MList.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE TypeSynonymInstances #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | #if __GLASGOW_HASKELL__ < 710 11 | {-# LANGUAGE OverlappingInstances #-} 12 | #endif 13 | 14 | {-# OPTIONS_GHC -fno-warn-orphans #-} 15 | 16 | ----------------------------------------------------------------------------- 17 | -- | 18 | -- Module : Data.Monoid.MList 19 | -- Copyright : (c) 2011 diagrams-core team (see LICENSE) 20 | -- License : BSD-style (see LICENSE) 21 | -- Maintainer : diagrams-discuss@googlegroups.com 22 | -- 23 | -- Heterogeneous lists of monoids. 24 | -- 25 | ----------------------------------------------------------------------------- 26 | module Data.Monoid.MList 27 | ( -- * Heterogeneous monoidal lists 28 | 29 | -- $mlist 30 | 31 | (:::), (*:) 32 | 33 | , MList(..) 34 | 35 | -- * Accessing embedded values 36 | , (:>:)(..) 37 | 38 | -- * Monoid actions of heterogeneous lists 39 | 40 | -- $mlist-actions 41 | 42 | , SM(..) 43 | ) where 44 | 45 | import Control.Arrow 46 | import Data.Monoid.Action 47 | 48 | -- $mlist 49 | -- 50 | -- The idea of /heterogeneous lists/ has been around for a long time. 51 | -- Here, we adopt heterogeneous lists where the element types are all 52 | -- monoids: this allows us to leave out identity values, so that a 53 | -- heterogeneous list containing only a single non-identity value can 54 | -- be created without incurring constraints due to all the other 55 | -- types, by leaving all the other values out. 56 | 57 | infixr 5 ::: 58 | infixr 5 *: 59 | 60 | type a ::: l = (Maybe a, l) 61 | 62 | (*:) :: a -> l -> a ::: l 63 | a *: l = (Just a, l) 64 | 65 | -- MList ----------------------------------- 66 | 67 | -- | Type class for heterogeneous monoidal lists, with a single method 68 | -- allowing construction of an empty list. 69 | class MList l where 70 | -- | The /empty/ heterogeneous list of type @l@. Of course, @empty 71 | -- == 'mempty'@, but unlike 'mempty', @empty@ does not require 72 | -- 'Monoid' constraints on all the elements of @l@. 73 | empty :: l 74 | 75 | instance MList () where 76 | empty = () 77 | 78 | instance MList l => MList (a ::: l) where 79 | empty = (Nothing, empty) 80 | 81 | -- Embedding ------------------------------------------- 82 | 83 | -- | The relation @l :>: a@ holds when @a@ is the type of an element 84 | -- in @l@. For example, @(Char ::: Int ::: Bool ::: Nil) :>: Int@. 85 | class l :>: a where 86 | -- | Inject a value into an otherwise empty heterogeneous list. 87 | inj :: a -> l 88 | 89 | -- | Get the value of type @a@ from a heterogeneous list, if there 90 | -- is one. 91 | get :: l -> Maybe a 92 | 93 | -- | Alter the value of type @a@ by applying the given function to it. 94 | alt :: (Maybe a -> Maybe a) -> l -> l 95 | 96 | #if __GLASGOW_HASKELL__ >= 710 97 | instance {-# OVERLAPPING #-} MList t => (:>:) (a ::: t) a where 98 | #else 99 | instance MList t => (:>:) (a ::: t) a where 100 | #endif 101 | inj a = (Just a, empty) 102 | get = fst 103 | alt = first 104 | 105 | instance (t :>: a) => (:>:) (b ::: t) a where 106 | inj a = (Nothing, inj a) 107 | get = get . snd 108 | alt = second . alt 109 | 110 | -- Monoid actions ----------------------------------------- 111 | 112 | -- $mlist-actions 113 | -- Monoidal heterogeneous lists may act on one another as you would 114 | -- expect, with each element in the first list acting on each in the 115 | -- second. Unfortunately, coding this up in type class instances is a 116 | -- bit fiddly. 117 | 118 | -- | @SM@, an abbreviation for \"single monoid\" (as opposed to a 119 | -- heterogeneous list of monoids), is only used internally to help 120 | -- guide instance selection when defining the action of 121 | -- heterogeneous monoidal lists on each other. 122 | newtype SM m = SM m 123 | deriving Show 124 | 125 | instance (Action (SM a) l2, Action l1 l2) => Action (a, l1) l2 where 126 | act (a,l) = act (SM a) . act l 127 | 128 | instance Action (SM a) () where 129 | act _ _ = () 130 | 131 | instance (Action a a', Action (SM a) l) => Action (SM a) (Maybe a', l) where 132 | act (SM a) (Nothing, l) = (Nothing, act (SM a) l) 133 | act (SM a) (Just a', l) = (Just (act a a'), act (SM a) l) 134 | -------------------------------------------------------------------------------- /src/Data/Monoid/Recommend.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveFoldable #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE DeriveTraversable #-} 6 | 7 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Data.Monoid.Recommend 11 | -- Copyright : (c) 2012-2015 diagrams-core team (see LICENSE) 12 | -- License : BSD-style (see LICENSE) 13 | -- Maintainer : diagrams-discuss@googlegroups.com 14 | -- 15 | -- A type for representing values with an additional bit saying 16 | -- whether the value is \"just a recommendation\" (to be used only if 17 | -- nothing better comes along) or a \"commitment\" (to certainly be 18 | -- used, overriding merely recommended values), along with 19 | -- corresponding @Semigroup@ and @Monoid@ instances. 20 | -- 21 | ----------------------------------------------------------------------------- 22 | 23 | module Data.Monoid.Recommend 24 | ( Recommend(..) 25 | , getRecommend 26 | ) where 27 | 28 | #if __GLASGOW_HASKELL__ < 710 29 | import Data.Foldable 30 | import Data.Traversable 31 | #endif 32 | 33 | import Data.Data 34 | import Data.Semigroup 35 | 36 | -- | A value of type @Recommend a@ consists of a value of type @a@ 37 | -- wrapped up in one of two constructors. The @Recommend@ 38 | -- constructor indicates a \"non-committal recommendation\"---that 39 | -- is, the given value should be used if no other/better values are 40 | -- available. The @Commit@ constructor indicates a 41 | -- \"commitment\"---a value which should definitely be used, 42 | -- overriding any @Recommend@ed values. 43 | data Recommend a = Recommend a 44 | | Commit a 45 | deriving (Show, Read, Functor, Eq, Ord, Typeable, Data, Foldable, Traversable) 46 | 47 | -- | Extract the value of type @a@ wrapped in @Recommend a@. 48 | getRecommend :: Recommend a -> a 49 | getRecommend (Recommend a) = a 50 | getRecommend (Commit a) = a 51 | 52 | -- | 'Commit' overrides 'Recommend'. Two values wrapped in the same 53 | -- constructor (both 'Recommend' or both 'Commit') are combined 54 | -- according to the underlying @Semigroup@ instance. 55 | instance Semigroup a => Semigroup (Recommend a) where 56 | Recommend a <> Recommend b = Recommend (a <> b) 57 | Recommend _ <> Commit b = Commit b 58 | Commit a <> Recommend _ = Commit a 59 | Commit a <> Commit b = Commit (a <> b) 60 | 61 | stimes n (Recommend m) = Recommend (stimes n m) 62 | stimes n (Commit m) = Commit (stimes n m) 63 | 64 | instance (Semigroup a, Monoid a) => Monoid (Recommend a) where 65 | mappend = (<>) 66 | mempty = Recommend mempty 67 | -------------------------------------------------------------------------------- /src/Data/Monoid/SemiDirectProduct.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TupleSections #-} 5 | 6 | module Data.Monoid.SemiDirectProduct 7 | ( Semi, unSemi, tag, inject, untag, embed, quotient 8 | ) where 9 | 10 | #if !MIN_VERSION_base(4,8,0) 11 | import Data.Monoid (Monoid(..)) 12 | #endif 13 | import Data.Semigroup (Semigroup(..)) 14 | 15 | import Data.Monoid.Action 16 | 17 | -- | The semi-direct product of monoids @s@ and @m@, which is a monoid 18 | -- when @m@ acts on @s@. Structurally, the semi-direct product is 19 | -- just a pair @(s,m)@. However, the monoid instance is different. 20 | -- In particular, we have 21 | -- 22 | -- > (s1,m1) <> (s2,m2) = (s1 <> (m1 `act` s2), m1 <> m2) 23 | -- 24 | -- We think of the @m@ values as a "tag" decorating the @s@ values, 25 | -- which also affect the way the @s@ values combine. 26 | -- 27 | -- We call the monoid @m@ the quotient monoid and the monoid @s@ the 28 | -- sub-monoid of the semi-direct product. The semi-direct product 29 | -- @Semi s m@ is an extension of the monoid @s@ with @m@ being the 30 | -- quotient. 31 | newtype Semi s m = Semi { unSemi :: (s,m) } 32 | 33 | instance (Semigroup m, Semigroup s, Action m s) => Semigroup (Semi s m) where 34 | x <> y = Semi (xs <> (xm `act` ys), xm <> ym) 35 | where (xs, xm) = unSemi x 36 | (ys, ym) = unSemi y 37 | {-# INLINE (<>) #-} 38 | 39 | #if MIN_VERSION_base(4,8,0) 40 | sconcat = foldr1 (<>) 41 | {-# INLINE sconcat #-} 42 | #endif 43 | 44 | instance (Monoid m, Monoid s, Action m s) => Monoid (Semi s m) where 45 | mempty = Semi (mempty, mempty) 46 | {-# INLINE mempty #-} 47 | 48 | #if !MIN_VERSION_base(4,11,0) 49 | mappend x y = Semi (xs `mappend` (xm `act` ys), xm `mappend` ym) 50 | where (xs, xm) = unSemi x 51 | (ys, ym) = unSemi y 52 | 53 | {-# INLINE mappend #-} 54 | #endif 55 | 56 | mconcat = foldr mappend mempty 57 | {-# INLINE mconcat #-} 58 | 59 | -- | Tag an @s@ value with an @m@ value to create an element of the 60 | -- semi-direct product. 61 | tag :: s -> m -> Semi s m 62 | tag s m = Semi (s,m) 63 | 64 | -- | The injection map, /i.e./ give an @s@ value a trivial tag. 65 | inject :: Monoid m => s -> Semi s m 66 | inject = Semi . (,mempty) 67 | 68 | -- | Forget the monoidal tag. Of course, @untag . inject = id@, and 69 | -- @untag (tag s m) = s@. 70 | untag :: Semi s m -> s 71 | untag = fst . unSemi 72 | 73 | -- | Embed a "tag" value as a value of type @Semi s m@. Note that 74 | -- 75 | -- @inject s <> embed m = tag s m@ 76 | -- 77 | -- and 78 | -- 79 | -- @embed m <> inject s@ = tag (act m s) m@ 80 | -- 81 | -- The semi-direct product gives a split extension of @s@ by 82 | -- @m@. This allows us to embed @m@ into the semi-direct 83 | -- product. This is the embedding map. The quotient and embed maps 84 | -- should satisfy the equation @quotient . embed = id@. 85 | embed :: Monoid s => m -> Semi s m 86 | embed = Semi . (mempty,) 87 | 88 | -- | The quotient map, /i.e./ retrieve the monoidal tag value. 89 | quotient :: Semi s m -> m 90 | quotient = snd . unSemi 91 | 92 | 93 | -------------------------------------------------------------------------------- /src/Data/Monoid/SemiDirectProduct/Strict.hs: -------------------------------------------------------------------------------- 1 | -- | A strict version of the semi-direct product. If a monoid m acts 2 | -- on s then this version of the semi-direct product is strict in 3 | -- the m-portion of the semi-direct product. 4 | 5 | {-# LANGUAGE CPP #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE TupleSections #-} 9 | 10 | module Data.Monoid.SemiDirectProduct.Strict 11 | ( Semi, unSemi, tag, inject, untag, embed, quotient 12 | ) where 13 | 14 | #if !MIN_VERSION_base(4,8,0) 15 | import Data.Monoid (Monoid(..)) 16 | #endif 17 | import Data.Semigroup (Semigroup(..)) 18 | 19 | import Data.Monoid.Action 20 | 21 | -- | The semi-direct product of monoids @s@ and @m@, which is a monoid 22 | -- when @m@ acts on @s@. Structurally, the semi-direct product is 23 | -- just a pair @(s,m)@. However, the monoid instance is different. 24 | -- In particular, we have 25 | -- 26 | -- > (s1,m1) <> (s2,m2) = (s1 <> (m1 `act` s2), m1 <> m2) 27 | -- 28 | -- We call the monoid @m@ the quotient monoid and the monoid @s@ the 29 | -- sub-monoid of the semi-direct product. The semi-direct product 30 | -- @Semi s m@ is an extension of the monoid @s@ with @m@ being the 31 | -- quotient. 32 | data Semi s m = Semi s !m 33 | 34 | unSemi :: Semi s m -> (s,m) 35 | unSemi (Semi s m) = (s,m) 36 | 37 | instance (Semigroup m, Semigroup s, Action m s) => Semigroup (Semi s m) where 38 | Semi xs xm <> Semi ys ym = Semi (xs <> (xm `act` ys)) (xm <> ym) 39 | {-# INLINE (<>) #-} 40 | 41 | #if MIN_VERSION_base(4,8,0) 42 | sconcat = foldr1 (<>) 43 | {-# INLINE sconcat #-} 44 | #endif 45 | 46 | instance (Monoid m, Monoid s, Action m s) => Monoid (Semi s m) where 47 | mempty = Semi mempty mempty 48 | {-# INLINE mempty #-} 49 | #if !MIN_VERSION_base(4,11,0) 50 | mappend (Semi xs xm) (Semi ys ym) = Semi (xs `mappend` (xm `act` ys)) (xm `mappend` ym) 51 | {-# INLINE mappend #-} 52 | #endif 53 | mconcat = foldr mappend mempty 54 | {-# INLINE mconcat #-} 55 | 56 | -- | Tag an @s@ value with an @m@ value to create an element of the 57 | -- semi-direct product. 58 | tag :: s -> m -> Semi s m 59 | tag = Semi 60 | 61 | -- | The injection map, /i.e./ give an @s@ value a trivial tag. 62 | inject :: Monoid m => s -> Semi s m 63 | inject = flip Semi mempty 64 | 65 | -- | Forget the monoidal tag. Of course, @untag . inject = id@, and 66 | -- @untag (tag s m) = s@. 67 | untag :: Semi s m -> s 68 | untag (Semi s _) = s 69 | 70 | -- | Embed a "tag" value as a value of type @Semi s m@. Note that 71 | -- 72 | -- @inject s <> embed m = tag s m@ 73 | -- 74 | -- and 75 | -- 76 | -- @embed m <> inject s@ = tag (act m s) m@ 77 | -- 78 | -- The semi-direct product gives a split extension of @s@ by 79 | -- @m@. This allows us to embed @m@ into the semi-direct 80 | -- product. This is the embedding map. The quotient and embed maps 81 | -- should satisfy the equation @quotient . embed = id@. 82 | embed :: Monoid s => m -> Semi s m 83 | embed = Semi mempty 84 | 85 | -- | The quotient map, /i.e./ retrieve the monoidal tag value. 86 | quotient :: Semi s m -> m 87 | quotient (Semi _ m) = m 88 | -------------------------------------------------------------------------------- /src/Data/Monoid/Split.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveTraversable #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Data.Monoid.Split 11 | -- Copyright : (c) 2011-2015 diagrams-core team (see LICENSE) 12 | -- License : BSD-style (see LICENSE) 13 | -- Maintainer : diagrams-discuss@googlegroups.com 14 | -- 15 | -- Sometimes we want to accumulate values from some monoid, but have 16 | -- the ability to introduce a \"split\" which separates values on 17 | -- either side. Only the rightmost split is kept. For example, 18 | -- 19 | -- > a b c | d e | f g h == a b c d e | f g h 20 | -- 21 | -- In the diagrams graphics framework this is used when accumulating 22 | -- transformations to be applied to primitive diagrams: the 'freeze' 23 | -- operation introduces a split, since only transformations occurring 24 | -- outside the freeze should be applied to attributes. 25 | -- 26 | ----------------------------------------------------------------------------- 27 | 28 | module Data.Monoid.Split 29 | ( Split(..) 30 | , split 31 | , unsplit 32 | 33 | ) where 34 | 35 | import Data.Data 36 | import Data.Foldable 37 | import Data.Semigroup 38 | import Data.Traversable 39 | 40 | import Data.Monoid.Action 41 | 42 | infix 5 :| 43 | 44 | -- | A value of type @Split m@ is either a single @m@, or a pair of 45 | -- @m@'s separated by a divider. Single @m@'s combine as usual; 46 | -- single @m@'s combine with split values by combining with the 47 | -- value on the appropriate side; when two split values meet only 48 | -- the rightmost split is kept, with both the values from the left 49 | -- split combining with the left-hand value of the right split. 50 | -- 51 | -- "Data.Monoid.Cut" is similar, but uses a different scheme for 52 | -- composition. @Split@ uses the asymmetric constructor @:|@, and 53 | -- @Cut@ the symmetric constructor @:||:@, to emphasize the inherent 54 | -- asymmetry of @Split@ and symmetry of @Cut@. @Split@ keeps only 55 | -- the rightmost split and combines everything on the left; @Cut@ 56 | -- keeps the outermost splits and throws away everything in between. 57 | data Split m = M m 58 | | m :| m 59 | deriving (Data, Typeable, Show, Read, Eq, Functor, Foldable, Traversable) 60 | 61 | -- | If @m@ is a @Semigroup@, then @Split m@ is a semigroup which 62 | -- combines values on either side of a split, keeping only the 63 | -- rightmost split. 64 | instance Semigroup m => Semigroup (Split m) where 65 | (M m1) <> (M m2) = M (m1 <> m2) 66 | (M m1) <> (m1' :| m2) = m1 <> m1' :| m2 67 | (m1 :| m2) <> (M m2') = m1 :| m2 <> m2' 68 | (m11 :| m12) <> (m21 :| m22) = m11 <> m12 <> m21 :| m22 69 | 70 | stimes n (M m ) = M (stimes n m) 71 | stimes 1 (m ) = m 72 | stimes n (m1 :| m2) = m1 <> stimes (pred n) (m2 <> m1) :| m2 73 | 74 | instance (Semigroup m, Monoid m) => Monoid (Split m) where 75 | mempty = M mempty 76 | mappend = (<>) 77 | 78 | -- | A convenient name for @mempty :| mempty@, so @M a \<\> split \<\> 79 | -- M b == a :| b@. 80 | split :: Monoid m => Split m 81 | split = mempty :| mempty 82 | 83 | -- | \"Unsplit\" a split monoid value, combining the two values into 84 | -- one (or returning the single value if there is no split). 85 | unsplit :: Semigroup m => Split m -> m 86 | unsplit (M m) = m 87 | unsplit (m1 :| m2) = m1 <> m2 88 | 89 | -- | By default, the action of a split monoid is the same as for 90 | -- the underlying monoid, as if the split were removed. 91 | instance Action m n => Action (Split m) n where 92 | act (M m) n = act m n 93 | act (m1 :| m2) n = act m1 (act m2 n) 94 | -------------------------------------------------------------------------------- /src/Data/Monoid/WithSemigroup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 7 | ----------------------------------------------------------------------------- 8 | -- | 9 | -- Module : Data.Monoid.WithSemigroup 10 | -- Copyright : (c) 2011 diagrams-core team (see LICENSE) 11 | -- License : BSD-style (see LICENSE) 12 | -- Maintainer : diagrams-discuss@googlegroups.com 13 | -- 14 | -- Convenience alias for the combination of @Monoid@ and @Semigroup@ constraints. 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module Data.Monoid.WithSemigroup 19 | ( Monoid' 20 | ) where 21 | 22 | import Data.Semigroup 23 | 24 | -- | For base < 4.11, the @Monoid'@ constraint is a synonym for things 25 | -- which are instances of both 'Semigroup' and 'Monoid'. For base 26 | -- version 4.11 and onwards, @Monoid@ has @Semigroup@ as a 27 | -- superclass already, so for backwards compatibility @Monoid'@ is 28 | -- provided as a synonym for @Monoid@. 29 | #if MIN_VERSION_base(4,11,0) 30 | type Monoid' = Monoid 31 | #else 32 | type Monoid' m = (Semigroup m, Monoid m) 33 | #endif 34 | -------------------------------------------------------------------------------- /src/Data/Semigroup/Coproduct.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | 7 | module Data.Semigroup.Coproduct 8 | ( (:+.) 9 | , inL, inR 10 | , cop 11 | , toAltList 12 | , toMonoid 13 | ) where 14 | 15 | import Data.Function (on) 16 | import Data.List.NonEmpty (NonEmpty(..)) 17 | import Data.Typeable (Typeable) 18 | import Data.Semigroup (Endo(Endo, appEndo)) 19 | import Data.Semigroup.Foldable (foldMap1) 20 | 21 | import Data.Monoid.Action (Action(..)) 22 | import Data.Monoid.Coproduct ((:+:)) 23 | import qualified Data.Monoid.Coproduct as M 24 | 25 | -- | @m :+. n@ is the coproduct of semigroups @m@ and @n@. Values of 26 | -- type @m :+. n@ consist of alternating non-empty lists of @m@ and @n@ 27 | -- values. Composition is list concatenation, with appropriate 28 | -- combining of adjacent elements 29 | newtype m :+. n = SCo { unSCo :: NonEmpty (Either m n) } 30 | deriving (Typeable, Show) 31 | 32 | instance (Eq m, Eq n, Semigroup m, Semigroup n) => Eq (m :+. n) where 33 | (==) = (==) `on` (normalize . unSCo) 34 | 35 | -- | Extract a semigroup coproduct to a non-empty list of @Either@ values. 36 | -- The resulting list is guaranteed to be normalized, in the sense that 37 | -- it will strictly alternate between @Left@ and @Right@. 38 | toAltList :: (Semigroup m, Semigroup n) => (m :+. n) -> NonEmpty (Either m n) 39 | toAltList (SCo ms) = normalize ms 40 | 41 | -- Normalize a list of @Either@ values by combining any consecutive 42 | -- values of the same type. 43 | normalize :: (Semigroup m, Semigroup n) => NonEmpty (Either m n) -> NonEmpty (Either m n) 44 | normalize = \case 45 | Left e1 :| Left e2 : es -> normalize (Left (e1 <> e2) :| es) 46 | Right e1 :| Right e2 : es -> normalize (Right (e1 <> e2) :| es) 47 | e1 :| es1 -> case es1 of 48 | e2 : es2 -> (e1 :| []) <> normalize (e2 :| es2) 49 | [] -> e1 :| [] 50 | 51 | -- | Universal map of the coproduct. The name @cop@ is an abbreviation 52 | -- for copairing. Both functions in the signature should be semigroup 53 | -- homomorphisms. If they are general functions then the copairing may 54 | -- not be well defined in the sense that it may send equal elements to 55 | -- unequal elements. This is also the reason why @cop@ is not the 56 | -- @Data.Bifoldable1.bifoldMap1@ function even though they have the same 57 | -- signature. 58 | cop :: Semigroup k => (m -> k) -> (n -> k) -> (m :+. n) -> k 59 | f `cop` g = foldMap1 (either f g) . unSCo 60 | 61 | -- | Injection from the left semigroup into a coproduct. 62 | inL :: m -> m :+. n 63 | inL m = SCo (Left m :| []) 64 | 65 | -- | Injection from the right semigroup into a coproduct. 66 | inR :: n -> m :+. n 67 | inR n = SCo (Right n :| []) 68 | 69 | -- | Given monoids @m@ and @n@, we can form their semigroup coproduct 70 | -- @m :+. n@. Every monoid homomorphism is a semigroup homomorphism. 71 | -- In particular the canonical inections of the monoid coproduct from 72 | -- @m@ and @n@ into @m :+: n@ are semigroup homomorphisms. By pairing 73 | -- them using the universal property of the semigroup coproduct we 74 | -- obtain a canonical semigroup homomorphism `toMonoid` from @m :+. n@ 75 | -- to @m :+: n@. 76 | toMonoid :: (Monoid m, Monoid n) => m :+. n -> m :+: n 77 | toMonoid = M.inL `cop` M.inR 78 | 79 | instance Semigroup (m :+. n) where 80 | (SCo es1) <> (SCo es2) = SCo (es1 <> es2) 81 | 82 | -- | Coproducts act on other things by having each of the components 83 | -- act individually. 84 | instance (Action m r, Action n r) => Action (m :+. n) r where 85 | act = appEndo . ((Endo . act) `cop` (Endo . act)) 86 | -------------------------------------------------------------------------------- /src/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | import Test.QuickCheck 4 | import Control.Applicative 5 | 6 | import Data.Monoid.Cut 7 | import Data.Semigroup 8 | 9 | instance Arbitrary a => Arbitrary (Sum a) where 10 | arbitrary = Sum <$> arbitrary 11 | 12 | instance Arbitrary a => Arbitrary (Cut a) where 13 | arbitrary = oneof [ Uncut <$> arbitrary 14 | , liftA2 (:||:) arbitrary arbitrary 15 | ] 16 | 17 | deriving instance Eq a => Eq (Cut a) 18 | 19 | type S = Sum Int 20 | 21 | prop_idL :: Cut S -> Bool 22 | prop_idL c = mempty <> c == c 23 | 24 | prop_idR :: Cut S -> Bool 25 | prop_idR c = c <> mempty == c 26 | 27 | prop_mappend_assoc :: Cut S -> Cut S -> Cut S -> Bool 28 | prop_mappend_assoc a b c = (a <> b) <> c == a <> (b <> c) --------------------------------------------------------------------------------