semigroupoids 6 → 6.0.0.1
raw patch · 36 files changed
+4718/−4723 lines, 36 filesdep ~basedep ~containersdep ~transformerssetup-changed
Dependency ranges changed: base, containers, transformers
Files
- .gitignore +30/−30
- .vim.custom +31/−31
- CHANGELOG.markdown +283/−276
- LICENSE +26/−26
- README.markdown +63/−63
- Setup.lhs +7/−7
- img/classes.dot +52/−52
- img/classes.svg +306/−306
- semigroupoids.cabal +203/−196
- src/Data/Bifunctor/Apply.hs +39/−39
- src/Data/Functor/Alt.hs +335/−335
- src/Data/Functor/Apply.hs +64/−64
- src/Data/Functor/Bind.hs +59/−59
- src/Data/Functor/Bind/Class.hs +837/−837
- src/Data/Functor/Bind/Trans.hs +85/−85
- src/Data/Functor/Contravariant/Conclude.hs +222/−222
- src/Data/Functor/Contravariant/Decide.hs +245/−245
- src/Data/Functor/Contravariant/Divise.hs +289/−289
- src/Data/Functor/Extend.hs +242/−242
- src/Data/Functor/Plus.hs +235/−235
- src/Data/Groupoid.hs +42/−42
- src/Data/Isomorphism.hs +33/−33
- src/Data/Semigroup/Bifoldable.hs +64/−64
- src/Data/Semigroup/Bitraversable.hs +26/−26
- src/Data/Semigroup/Foldable.hs +126/−126
- src/Data/Semigroup/Foldable/Class.hs +28/−28
- src/Data/Semigroup/Traversable.hs +68/−68
- src/Data/Semigroup/Traversable/Class.hs +243/−262
- src/Data/Semigroupoid.hs +106/−106
- src/Data/Semigroupoid/Categorical.hs +48/−48
- src/Data/Semigroupoid/Dual.hs +28/−28
- src/Data/Semigroupoid/Ob.hs +41/−41
- src/Data/Semigroupoid/Static.hs +87/−87
- src/Data/Traversable/Instances.hs +16/−16
- src/Semigroupoids/Do.hs +81/−81
- src/Semigroupoids/Internal.hs +28/−28
.gitignore view
@@ -1,30 +1,30 @@-.ghc.environment.*-dist-docs-wiki-TAGS-tags-wip-.DS_Store-.*.swp-.*.swo-*.o-*.hi-*~-*#-dist-*-cabal-dev-*.chi-*.chs.h-*.dyn_o-*.dyn_hi-.hpc-.hsenv-.cabal-sandbox/-cabal.sandbox.config-*.prof-*.aux-*.hp-*.eventlog-.stack-work/-cabal.project.local+.ghc.environment.* +dist +docs +wiki +TAGS +tags +wip +.DS_Store +.*.swp +.*.swo +*.o +*.hi +*~ +*# +dist-* +cabal-dev +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.hpc +.hsenv +.cabal-sandbox/ +cabal.sandbox.config +*.prof +*.aux +*.hp +*.eventlog +.stack-work/ +cabal.project.local
.vim.custom view
@@ -1,31 +1,31 @@-" Add the following to your .vimrc to automatically load this on startup--" if filereadable(".vim.custom")-" so .vim.custom-" endif--function StripTrailingWhitespace()- let myline=line(".")- let mycolumn = col(".")- silent %s/ *$//- call cursor(myline, mycolumn)-endfunction--" enable syntax highlighting-syntax on--" search for the tags file anywhere between here and /-set tags=TAGS;/--" highlight tabs and trailing spaces-set listchars=tab:‗‗,trail:‗-set list--" f2 runs hasktags-map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR>--" strip trailing whitespace before saving-" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace()--" rebuild hasktags after saving-au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"+" Add the following to your .vimrc to automatically load this on startup + +" if filereadable(".vim.custom") +" so .vim.custom +" endif + +function StripTrailingWhitespace() + let myline=line(".") + let mycolumn = col(".") + silent %s/ *$// + call cursor(myline, mycolumn) +endfunction + +" enable syntax highlighting +syntax on + +" search for the tags file anywhere between here and / +set tags=TAGS;/ + +" highlight tabs and trailing spaces +set listchars=tab:‗‗,trail:‗ +set list + +" f2 runs hasktags +map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR> + +" strip trailing whitespace before saving +" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() + +" rebuild hasktags after saving +au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"
CHANGELOG.markdown view
@@ -1,276 +1,283 @@-6 [2023.03.12]----------------* Drop support for GHC 7.10 and earlier.-* The `Foldable1` and `Bifoldable1` classes have been migrated:- * When building with `base-4.18` or later, `semigroupoids` re-exports- `Foldable1` and `Bifoldable1` from `base`. (These classes were added to- `base-4.18` as a result of- [this Core Libraries proposal](haskell/core-libraries-committee#9).)- * When building with older versions of `base`, `semigroupoids` re-exports- `Foldable1` and `Bifoldable1` from the- [`foldable1-classes-compat`](https://github.com/haskell-compat/foldable1-classes-compat)- compatibility package.-- Note that the version of `Foldable1` that `semigroupoids` defined in previous- releases only had three class methods: `fold1`, `foldMap1`, and `toNonEmpty`.- Moreover, `foldMap1` had a default implementation in terms of a `Foldable`- constraint. `base`'s version of `Foldable1`, however, has some notable- differences:-- 1. It has many more methods than the three listed above, such as the- `foldrMap1` method.- 2. `foldMap1` now has a default implementation in terms of `foldrMap1` instead- of in terms of a `Foldable` constraint.-- To avoid (1) causing issues when upgrading to `semigroupoids-6`,- `Data.Semigroup.Foldable` only re-exports the `fold1`, `foldMap1`, and- `toNonEmpty` methods, which reflects the API in previous `semigroupoids`- releases. If you want to use the other, new class methods of `Foldable1`,- consider importing it from `Data.Foldable1` (its home in `base`) instead.-- Difference (2) is trickier, because it is possible that existing code that- defines valid `Foldable1` instances will need to be migrated. If you have an- instance like this:-- ```hs- import Data.Semigroup.Foldable-- data T a = MkT a-- instance Foldable T where- foldMap f (MkT x) = f x-- instance Foldable1 T -- Relying on Foldable-based defaults- ```-- Then calling `foldMap1` on `T` will throw an error with `semigroupoids-6`, as- `foldMap1`'s default implementation no longer uses `Foldable`. To migrate this- code, change the instance to explicitly define `foldMap1`:-- ```hs- instance Foldable1 T where- foldMap1 f (MkT x) = f x- ```-- This approach should be backwards-compatible with previous `semigroupoids`- releases.-- Some other side effects of this migration include:-- * The `Data.Semigroup.Foldable.Class` module has been deprecated. It no- longer serves a useful role, as it simply re-exports a limited subset of- the `Data.Foldable1` and `Data.Bifoldable1` API.- * All of the `Foldable1` and `Bifoldable1` instances that were previously- defined in `semigroupoids` have now been migrated to downstream libraries- (`base`, `bifunctors`, `containers`, `tagged`, and `transformers`), so it- is no longer strictly necessary to depend on `semigroupoids` to make use of- these instances.-* Add `Generic1`-based functions for many classes, useful for writing instances:- - `Data.Functor.Alt.(<!>)` -> `Data.Functor.Alt.galt`- - `Data.Functor.Apply.{liftF2,liftF3}` -> `Data.Functor.Apply.{gliftF2,gliftF3}`- - `Data.Functor.Bind.(>>-)` -> `Data.Functor.Bind.gbind`- - `Data.Functor.Contravariant.Conclude.{conclude,concluded}` -> `Data.Functor.Contravariant.Conclude.{gconclude,gconcluded}`- - `Data.Functor.Contravariant.Decide.{decide,decided}` -> `Data.Functor.Contravariant.Decide.{gdecide,gdecided}`- - `Data.Functor.Contravariant.Divise.{divise,divised}` -> `Data.Functor.Contravariant.Divise.{gdivise,gdivised}`- - `Data.Functor.Extend.{duplicated,extended}` -> `Data.Functor.Extend.{gduplicated,gextended}`- - `Data.Functor.Plus.zero` -> `Data.Functor.Plus.gzero`- - `Data.Semigroup.Foldable.{fold1,foldMap1,toNonEmpty}` -> `Data.Semigroup.Foldable.{gfold1,gfoldMap1,gtoNonEmpty}`- - `Data.Semigroup.Traversable.{traverse1,sequence1}` -> `Data.Semigroup.Traversable.{gtraverse1,gsequence1}`--5.3.7 [2022.01.09]--------------------* Relax the `Bind` constraints in the following instances to `Functor`:-- ```diff- -instance (Bind f, Monad f) => Alt (MaybeT f)- -instance (Bind f, Monad f) => Plus (MaybeT f)- +instance (Functor f, Monad f) => Alt (MaybeT f)- +instance (Functor f, Monad f) => Plus (MaybeT f)-- -instance (Bind f, Monad f, Semigroup e) => Alt (ExceptT e f)- -instance (Bind f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f)- +instance (Functor f, Monad f, Semigroup e) => Alt (ExceptT e f)- +instance (Functor f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f)-- -- If building with transformers-0.5.* or older- -instance (Bind f, Monad f) => Alt (ErrorT e f)- -instance (Bind f, Monad f, Error e) => Plus (ErrorT e f- +instance (Functor f, Monad f) => Alt (ErrorT e f)- +instance (Functor f, Monad f, Error e) => Plus (ErrorT e f)- ```--5.3.6 [2021.10.07]--------------------* Allow building with GHC 9.2.-* Allow building with `transformers-0.6.*`.-* Add `Alt` instance for `Identity`.-* Add `Conclude`, `Decide` and `Divise` type classes and instances.-* Add `(<.*>)`, `(<*.>)`, and `traverseMaybe` functions, which make it easier- to defined `Traversable1` instances for data types that have fields with a- combination of `Traversable` and `Traversable1` instances.-* Add `Semigroupoids.Do` module with overloads for use with `QualifiedDo`.-* Add `Apply`, `Alt`, `Plus`, `Bind` and `BindTrans` instances for the CPS- versions of `WriterT` and `RWST`.-* Add `psum` function to `Data.Functor.Plus`.-* Add `Categorical` data type.--5.3.5 [2020.12.31]--------------------* The build-type has been changed from `Custom` to `Simple`.- To achieve this, the `doctests` test suite has been removed in favor of using- [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec)- to run the doctests.-* Explicitly mark modules as `Safe`.--5.3.4 [2019.11.26]--------------------* Achieve forward compatibility with- [GHC proposal 229](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst).--5.3.3 [2019.08.27]--------------------* Add `Alt` and `Plus` instances for `HashMap` from the `unordered-containers`- package.--5.3.2 [2019.01.04]--------------------* Bump the lower bound on `semigroups` to 0.16.2, and avoid incurring- the dependency entirely on recent GHCs.-* Fix the build on GHC 7.0 and 7.2.--5.3.1 [2018.07.02]--------------------* Fix a regression introduced in `semigroupoids-5.3` in which some modules- regressed from `Trustworthy` to `Unsafe`.--5.3 [2018.07.02]------------------* Allow building with `containers-0.6`.-* Add `Alt` instances for `First` and `Last` from `Data.Semigroup`, and- `Alt` and `Plus` instances for `First` and `Last` from `Data.Monoid`.-* Add missing `Apply`, `Bind`, `Extend`, `Foldable1` and `Traversable1`- instances for `Data.Semigroups`, `Data.Monoid` and `GHC.Generics`.--5.2.2 [2018.01.18]--------------------* Add `optional` to `Data.Functor.Alt` (analogous to the `optional` function- in `Control.Applicative`)-* `liftF2` is now a class method of `Apply` (mirroring the fact that `liftA2`- is now a class method of `Applicative`). `liftF2` and `(<.>)` have default- definitions in terms of the other.-* Allow building with GHC 8.4-* `Apply` and `Bind` instances for `Q`, from the `template-haskell` package.- (As a consequence, `Data.Semigroup.Foldable` is no longer a `Trustworthy`- module.)-* Add instances for `(:~:)` and `(:~~:)` from `Data.Type.Equality`, and- `Coercion` from `Data.Type.Coercion`--5.2.1-------* Add the `toNonEmpty` method to `Foldable1`. Add `foldrM1` and `foldlM1`- functions to `Data.Semigroup.Foldable` that are defined in terms of `toNonEmpty`.-* Add `Apply`, `Bind`, `Foldable1`, and `Traversable1` instances for `Complex`-* Add `Apply` and `Bind` instances for `HashMap` from the `unordered-containers` package- (on which `semigroupoids` now depends)-* Add `Semigroupoid` instances for `Tagged` and `Const`--5.2-----* Revamp `Setup.hs` to use `cabal-doctest`. This makes it build- with `Cabal-1.25`, and makes the `doctest`s work with `cabal new-build` and- sandboxes.-* Added instances to `Alt`, `Plus`, `Apply`, `Bind` and `Extend` for `GHC.Generics`, `Tagged` and `Proxy` where appropriate.--5.1-----* The remaining orphan instances in `Data.Traversable.Instances` have been replaced in favor of the orphan instances from `transformers-compat-0.5`.-* The documentation now states laws that instances of `Apply` are expected to uphold.-* `doctest-0.11` support-* Fixed compilation of tests with `stack`--5.0.1---------* `transformers-compat` 0.5 support-* Removed some redundant constraints.-* GHC 8 support--5.0.0.4---------* `doctest` 0.10 support--5.0.0.2---------* Bugfix for GHC 7.4. PolyKinds on 7.4 cause all sorts of haskell interface file errors. One of the #if guards that turned it off on 7.4 was missing and has been fixed.--5.0.0.1---------* Added the CHANGELOG to the distribution so that `hackage` can link to it in the haddocks.--5---* Absorbed `Data.Bifunctor.Apply`, `Data.Semigroup.Bifoldable` and `Data.Semigroup.Traversable` from `bifunctors`.-* This caused us to pick up a dependency on `tagged`.-* Exiled `Data.Semifunctor.*`, `Data.Semigroupoid.Product` and `Data.Semigroupoid.Coproduct` to `semigroupoid-extras`.-* This let us open up to older versions of GHC again.-* Set an explicit fixity for `-<-` and `->-`.--4.5-----* Major changes to the API to support PolyKinds and DataKinds. This necessarily shuts off GHC <= 7.4.-* Orphan instances have moved upstream into a common `base-orphans` package.--4.3.1-------* Added `asum1` to `Data.Semigroup.Foldable`.--4.3.0.1---------* Support for 'ConstrainedClassMethods' is currently required for GHC HEAD.--4.3-------* Added missing instances for `ExceptT`. Obtain it via `transformers-compat` if need be for old `transformers` versions.-* Several `Bind` and `Apply` instances now require somewhat more minimal contexts.--4.2-----* Backported `Foldable`/`Traversable` instances from `lens`--4.1-----* `Foldable1`/`Traversable1` for tuples--4.0.4-------* `contravariant` 1.0 support.--4.0.3-----* Added flags to provide unsupported cabal sandbox build modes.--4.0.1-------* Fixed bitrot in the `Data.Functor.Extend` documentation.-* Fixed warnings on GHC 7.8.1rc2 caused by importing `Control.Monad.Instances`.--4.0-----* Merged in the contents of the `groupoids` and `semigroupoid-extras` packages.--3.1-----* Added the [rectangular band](http://en.wikipedia.org/wiki/Band_(mathematics)#Rectangular_bands) `Semigroupoid` for `(,)`. Would that make it a Bandoid?--3.0.3-------* Claim to be `Trustworthy` where necessary--3.0.2-------* Tightened the upper bounds slightly to enable PVP compliance while retaining a flexible development cycle.-* Raised the upper bound on `contravariant`.--3.0.1-------* Removed upper bounds relative to my other packages-* Refactored directory layout+6.0.0.1 [2023.03.16] +-------------------- +* When building with GHC 9.6, require `transformers >= 0.6.1` and + `containers >= 0.6.7`. This ensures that `semigroupoids` always provides + `Traversable1` instances for data types from `transformers` and `containers` + unconditionally. + +6 [2023.03.12] +-------------- +* Drop support for GHC 7.10 and earlier. +* The `Foldable1` and `Bifoldable1` classes have been migrated: + * When building with `base-4.18` or later, `semigroupoids` re-exports + `Foldable1` and `Bifoldable1` from `base`. (These classes were added to + `base-4.18` as a result of + [this Core Libraries proposal](haskell/core-libraries-committee#9).) + * When building with older versions of `base`, `semigroupoids` re-exports + `Foldable1` and `Bifoldable1` from the + [`foldable1-classes-compat`](https://github.com/haskell-compat/foldable1-classes-compat) + compatibility package. + + Note that the version of `Foldable1` that `semigroupoids` defined in previous + releases only had three class methods: `fold1`, `foldMap1`, and `toNonEmpty`. + Moreover, `foldMap1` had a default implementation in terms of a `Foldable` + constraint. `base`'s version of `Foldable1`, however, has some notable + differences: + + 1. It has many more methods than the three listed above, such as the + `foldrMap1` method. + 2. `foldMap1` now has a default implementation in terms of `foldrMap1` instead + of in terms of a `Foldable` constraint. + + To avoid (1) causing issues when upgrading to `semigroupoids-6`, + `Data.Semigroup.Foldable` only re-exports the `fold1`, `foldMap1`, and + `toNonEmpty` methods, which reflects the API in previous `semigroupoids` + releases. If you want to use the other, new class methods of `Foldable1`, + consider importing it from `Data.Foldable1` (its home in `base`) instead. + + Difference (2) is trickier, because it is possible that existing code that + defines valid `Foldable1` instances will need to be migrated. If you have an + instance like this: + + ```hs + import Data.Semigroup.Foldable + + data T a = MkT a + + instance Foldable T where + foldMap f (MkT x) = f x + + instance Foldable1 T -- Relying on Foldable-based defaults + ``` + + Then calling `foldMap1` on `T` will throw an error with `semigroupoids-6`, as + `foldMap1`'s default implementation no longer uses `Foldable`. To migrate this + code, change the instance to explicitly define `foldMap1`: + + ```hs + instance Foldable1 T where + foldMap1 f (MkT x) = f x + ``` + + This approach should be backwards-compatible with previous `semigroupoids` + releases. + + Some other side effects of this migration include: + + * The `Data.Semigroup.Foldable.Class` module has been deprecated. It no + longer serves a useful role, as it simply re-exports a limited subset of + the `Data.Foldable1` and `Data.Bifoldable1` API. + * All of the `Foldable1` and `Bifoldable1` instances that were previously + defined in `semigroupoids` have now been migrated to downstream libraries + (`base`, `bifunctors`, `containers`, `tagged`, and `transformers`), so it + is no longer strictly necessary to depend on `semigroupoids` to make use of + these instances. +* Add `Generic1`-based functions for many classes, useful for writing instances: + - `Data.Functor.Alt.(<!>)` -> `Data.Functor.Alt.galt` + - `Data.Functor.Apply.{liftF2,liftF3}` -> `Data.Functor.Apply.{gliftF2,gliftF3}` + - `Data.Functor.Bind.(>>-)` -> `Data.Functor.Bind.gbind` + - `Data.Functor.Contravariant.Conclude.{conclude,concluded}` -> `Data.Functor.Contravariant.Conclude.{gconclude,gconcluded}` + - `Data.Functor.Contravariant.Decide.{decide,decided}` -> `Data.Functor.Contravariant.Decide.{gdecide,gdecided}` + - `Data.Functor.Contravariant.Divise.{divise,divised}` -> `Data.Functor.Contravariant.Divise.{gdivise,gdivised}` + - `Data.Functor.Extend.{duplicated,extended}` -> `Data.Functor.Extend.{gduplicated,gextended}` + - `Data.Functor.Plus.zero` -> `Data.Functor.Plus.gzero` + - `Data.Semigroup.Foldable.{fold1,foldMap1,toNonEmpty}` -> `Data.Semigroup.Foldable.{gfold1,gfoldMap1,gtoNonEmpty}` + - `Data.Semigroup.Traversable.{traverse1,sequence1}` -> `Data.Semigroup.Traversable.{gtraverse1,gsequence1}` + +5.3.7 [2022.01.09] +------------------ +* Relax the `Bind` constraints in the following instances to `Functor`: + + ```diff + -instance (Bind f, Monad f) => Alt (MaybeT f) + -instance (Bind f, Monad f) => Plus (MaybeT f) + +instance (Functor f, Monad f) => Alt (MaybeT f) + +instance (Functor f, Monad f) => Plus (MaybeT f) + + -instance (Bind f, Monad f, Semigroup e) => Alt (ExceptT e f) + -instance (Bind f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f) + +instance (Functor f, Monad f, Semigroup e) => Alt (ExceptT e f) + +instance (Functor f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f) + + -- If building with transformers-0.5.* or older + -instance (Bind f, Monad f) => Alt (ErrorT e f) + -instance (Bind f, Monad f, Error e) => Plus (ErrorT e f + +instance (Functor f, Monad f) => Alt (ErrorT e f) + +instance (Functor f, Monad f, Error e) => Plus (ErrorT e f) + ``` + +5.3.6 [2021.10.07] +------------------ +* Allow building with GHC 9.2. +* Allow building with `transformers-0.6.*`. +* Add `Alt` instance for `Identity`. +* Add `Conclude`, `Decide` and `Divise` type classes and instances. +* Add `(<.*>)`, `(<*.>)`, and `traverseMaybe` functions, which make it easier + to defined `Traversable1` instances for data types that have fields with a + combination of `Traversable` and `Traversable1` instances. +* Add `Semigroupoids.Do` module with overloads for use with `QualifiedDo`. +* Add `Apply`, `Alt`, `Plus`, `Bind` and `BindTrans` instances for the CPS + versions of `WriterT` and `RWST`. +* Add `psum` function to `Data.Functor.Plus`. +* Add `Categorical` data type. + +5.3.5 [2020.12.31] +------------------ +* The build-type has been changed from `Custom` to `Simple`. + To achieve this, the `doctests` test suite has been removed in favor of using + [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) + to run the doctests. +* Explicitly mark modules as `Safe`. + +5.3.4 [2019.11.26] +------------------ +* Achieve forward compatibility with + [GHC proposal 229](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst). + +5.3.3 [2019.08.27] +------------------ +* Add `Alt` and `Plus` instances for `HashMap` from the `unordered-containers` + package. + +5.3.2 [2019.01.04] +------------------ +* Bump the lower bound on `semigroups` to 0.16.2, and avoid incurring + the dependency entirely on recent GHCs. +* Fix the build on GHC 7.0 and 7.2. + +5.3.1 [2018.07.02] +------------------ +* Fix a regression introduced in `semigroupoids-5.3` in which some modules + regressed from `Trustworthy` to `Unsafe`. + +5.3 [2018.07.02] +---------------- +* Allow building with `containers-0.6`. +* Add `Alt` instances for `First` and `Last` from `Data.Semigroup`, and + `Alt` and `Plus` instances for `First` and `Last` from `Data.Monoid`. +* Add missing `Apply`, `Bind`, `Extend`, `Foldable1` and `Traversable1` + instances for `Data.Semigroups`, `Data.Monoid` and `GHC.Generics`. + +5.2.2 [2018.01.18] +------------------ +* Add `optional` to `Data.Functor.Alt` (analogous to the `optional` function + in `Control.Applicative`) +* `liftF2` is now a class method of `Apply` (mirroring the fact that `liftA2` + is now a class method of `Applicative`). `liftF2` and `(<.>)` have default + definitions in terms of the other. +* Allow building with GHC 8.4 +* `Apply` and `Bind` instances for `Q`, from the `template-haskell` package. + (As a consequence, `Data.Semigroup.Foldable` is no longer a `Trustworthy` + module.) +* Add instances for `(:~:)` and `(:~~:)` from `Data.Type.Equality`, and + `Coercion` from `Data.Type.Coercion` + +5.2.1 +----- +* Add the `toNonEmpty` method to `Foldable1`. Add `foldrM1` and `foldlM1` + functions to `Data.Semigroup.Foldable` that are defined in terms of `toNonEmpty`. +* Add `Apply`, `Bind`, `Foldable1`, and `Traversable1` instances for `Complex` +* Add `Apply` and `Bind` instances for `HashMap` from the `unordered-containers` package + (on which `semigroupoids` now depends) +* Add `Semigroupoid` instances for `Tagged` and `Const` + +5.2 +--- +* Revamp `Setup.hs` to use `cabal-doctest`. This makes it build + with `Cabal-1.25`, and makes the `doctest`s work with `cabal new-build` and + sandboxes. +* Added instances to `Alt`, `Plus`, `Apply`, `Bind` and `Extend` for `GHC.Generics`, `Tagged` and `Proxy` where appropriate. + +5.1 +--- +* The remaining orphan instances in `Data.Traversable.Instances` have been replaced in favor of the orphan instances from `transformers-compat-0.5`. +* The documentation now states laws that instances of `Apply` are expected to uphold. +* `doctest-0.11` support +* Fixed compilation of tests with `stack` + +5.0.1 +------- +* `transformers-compat` 0.5 support +* Removed some redundant constraints. +* GHC 8 support + +5.0.0.4 +------- +* `doctest` 0.10 support + +5.0.0.2 +------- +* Bugfix for GHC 7.4. PolyKinds on 7.4 cause all sorts of haskell interface file errors. One of the #if guards that turned it off on 7.4 was missing and has been fixed. + +5.0.0.1 +------- +* Added the CHANGELOG to the distribution so that `hackage` can link to it in the haddocks. + +5 +- +* Absorbed `Data.Bifunctor.Apply`, `Data.Semigroup.Bifoldable` and `Data.Semigroup.Traversable` from `bifunctors`. +* This caused us to pick up a dependency on `tagged`. +* Exiled `Data.Semifunctor.*`, `Data.Semigroupoid.Product` and `Data.Semigroupoid.Coproduct` to `semigroupoid-extras`. +* This let us open up to older versions of GHC again. +* Set an explicit fixity for `-<-` and `->-`. + +4.5 +--- +* Major changes to the API to support PolyKinds and DataKinds. This necessarily shuts off GHC <= 7.4. +* Orphan instances have moved upstream into a common `base-orphans` package. + +4.3.1 +----- +* Added `asum1` to `Data.Semigroup.Foldable`. + +4.3.0.1 +------- +* Support for 'ConstrainedClassMethods' is currently required for GHC HEAD. + +4.3 +----- +* Added missing instances for `ExceptT`. Obtain it via `transformers-compat` if need be for old `transformers` versions. +* Several `Bind` and `Apply` instances now require somewhat more minimal contexts. + +4.2 +--- +* Backported `Foldable`/`Traversable` instances from `lens` + +4.1 +--- +* `Foldable1`/`Traversable1` for tuples + +4.0.4 +----- +* `contravariant` 1.0 support. + +4.0.3 +--- +* Added flags to provide unsupported cabal sandbox build modes. + +4.0.1 +----- +* Fixed bitrot in the `Data.Functor.Extend` documentation. +* Fixed warnings on GHC 7.8.1rc2 caused by importing `Control.Monad.Instances`. + +4.0 +--- +* Merged in the contents of the `groupoids` and `semigroupoid-extras` packages. + +3.1 +--- +* Added the [rectangular band](http://en.wikipedia.org/wiki/Band_(mathematics)#Rectangular_bands) `Semigroupoid` for `(,)`. Would that make it a Bandoid? + +3.0.3 +----- +* Claim to be `Trustworthy` where necessary + +3.0.2 +----- +* Tightened the upper bounds slightly to enable PVP compliance while retaining a flexible development cycle. +* Raised the upper bound on `contravariant`. + +3.0.1 +----- +* Removed upper bounds relative to my other packages +* Refactored directory layout
LICENSE view
@@ -1,26 +1,26 @@-Copyright 2011-2015 Edward Kmett--All rights reserved.--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.--THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.+Copyright 2011-2015 Edward Kmett + +All rights reserved. + +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. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE.
README.markdown view
@@ -1,63 +1,63 @@-semigroupoids-=============--[](https://hackage.haskell.org/package/semigroupoids) [](https://github.com/ekmett/semigroupoids/actions?query=workflow%3AHaskell-CI)--A semigroupoid is a `Category` without `id`. This package provides a range of -`id`-free versions of type classes, as well as some supporting functions and-data types.--Field Guide--------------The diagram below describes the relationships between the type classes defined-in this package, and those from `base` (with some from `contravariant` as well). Thick-bordered-nodes correspond to type classes defined in this package; thin-bordered ones are-from elsewhere. Solid edges represent subclass relationships that actually-exist; dashed edges are those which _should_ exist in theory.----We also provide the following table. This is structured in superclass order --thus, for any type class `T`, all superclasses of `T` will be listed before `T`-in the table.--|**Name**|**Location**|**Superclass of**|**Ideally superclass of**|-|--------|------------|-----------------|-------------------------|-|`Functor`|`base`|`Alt`, `Apply`, `Traversable`||-|`Foldable`|`base`|`Traversable`, `Foldable1`||-|`Bifunctor`|`base`|`Biapply`||-|`Contravariant`|`base`|`Divise`, `Decide`||-|`Semigroupoid`|`semigroupoids`||`Category`|-|`Alt`|`semigroupoids`|`Plus`||-|`Apply`|`semigroupoids`|`Bind`|`Applicative`|-|`Traversable`|`base`|`Traversable1`||-|`Foldable1`|`semigroupoids`|`Traversable1`||-|`Biapply`|`semigroupoids`|||-|`Divise`|`semigroupoids`||`Divisible`|-|`Decide`|`semigroupoids`|`Conclude`|`Decidable`|-|`Category`|`base`|`Arrow`||-|`Plus`|`semigroupoids`||`Alternative`|-|`Applicative`|`base`|`Alternative`, `Monad`||-|`Bind`|`semigroupoids`||`Monad`|-|`Traversable1`|`semigroupoids`|||-|`Divisible`|`contravariant`|||-|`Conclude`|`semigroupoids`||`Decidable`|-|`Arrow`|`base`|||-|`Alternative`|`base`|`MonadPlus`||-|`Monad`|`base`|`MonadPlus`||-|`Decidable`|`contravariant`|||-|`MonadPlus`|`base`|||--We omit some type class relationships from this diagram, as they are not-relevant for the purposes of this package.--Contact Information----------------------Contributions and bug reports are welcome!--Please feel free to contact me through Github or on the #haskell IRC channel on-LiberaChat.---Edward Kmett+semigroupoids +============= + +[](https://hackage.haskell.org/package/semigroupoids) [](https://github.com/ekmett/semigroupoids/actions?query=workflow%3AHaskell-CI) + +A semigroupoid is a `Category` without `id`. This package provides a range of +`id`-free versions of type classes, as well as some supporting functions and +data types. + +Field Guide +----------- + +The diagram below describes the relationships between the type classes defined +in this package, and those from `base` (with some from `contravariant` as well). Thick-bordered +nodes correspond to type classes defined in this package; thin-bordered ones are +from elsewhere. Solid edges represent subclass relationships that actually +exist; dashed edges are those which _should_ exist in theory. + + + +We also provide the following table. This is structured in superclass order - +thus, for any type class `T`, all superclasses of `T` will be listed before `T` +in the table. + +|**Name**|**Location**|**Superclass of**|**Ideally superclass of**| +|--------|------------|-----------------|-------------------------| +|`Functor`|`base`|`Alt`, `Apply`, `Traversable`|| +|`Foldable`|`base`|`Traversable`, `Foldable1`|| +|`Bifunctor`|`base`|`Biapply`|| +|`Contravariant`|`base`|`Divise`, `Decide`|| +|`Semigroupoid`|`semigroupoids`||`Category`| +|`Alt`|`semigroupoids`|`Plus`|| +|`Apply`|`semigroupoids`|`Bind`|`Applicative`| +|`Traversable`|`base`|`Traversable1`|| +|`Foldable1`|`semigroupoids`|`Traversable1`|| +|`Biapply`|`semigroupoids`||| +|`Divise`|`semigroupoids`||`Divisible`| +|`Decide`|`semigroupoids`|`Conclude`|`Decidable`| +|`Category`|`base`|`Arrow`|| +|`Plus`|`semigroupoids`||`Alternative`| +|`Applicative`|`base`|`Alternative`, `Monad`|| +|`Bind`|`semigroupoids`||`Monad`| +|`Traversable1`|`semigroupoids`||| +|`Divisible`|`contravariant`||| +|`Conclude`|`semigroupoids`||`Decidable`| +|`Arrow`|`base`||| +|`Alternative`|`base`|`MonadPlus`|| +|`Monad`|`base`|`MonadPlus`|| +|`Decidable`|`contravariant`||| +|`MonadPlus`|`base`||| + +We omit some type class relationships from this diagram, as they are not +relevant for the purposes of this package. + +Contact Information +------------------- + +Contributions and bug reports are welcome! + +Please feel free to contact me through Github or on the #haskell IRC channel on +LiberaChat. + +-Edward Kmett
Setup.lhs view
@@ -1,7 +1,7 @@-#!/usr/bin/runhaskell-> module Main (main) where--> import Distribution.Simple--> main :: IO ()-> main = defaultMain+#!/usr/bin/runhaskell +> module Main (main) where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain
img/classes.dot view
@@ -1,52 +1,52 @@-digraph {- node[shape=box];- functor [label="Functor"];- foldable [label="Foldable"];- traversable [label="Traversable"];- apply [label="Apply", penwidth=2.0];- bind [label="Bind", penwidth=2.0];- applicative [label="Applicative"];- alt [label="Alt", penwidth=2.0];- plus [label="Plus", penwidth=2.0];- alternative [label="Alternative"];- monad [label="Monad"];- monad_plus [label="MonadPlus"];- foldable1 [label="Foldable1", penwidth=2.0];- traversable1 [label="Traversable1", penwidth=2.0];- bifunctor [label="Bifunctor"];- biapply [label="Biapply", penwidth=2.0];- contravariant [label="Contravariant"];- divise [label="Divise", penwidth=2.0];- decide [label="Decide", penwidth=2.0];- divisible [label="Divisible"];- decidable [label="Decidable"];- conclude [label="Conclude", penwidth=2.0];- semigroupoid [label="Semigroupoid", penwidth=2.0];- category [label="Category"];- arrow [label="Arrow"];- functor -> apply;- functor -> alt;- apply -> bind;- apply -> applicative [style=dashed];- alt -> plus;- plus -> alternative [style=dashed];- applicative -> alternative;- applicative -> monad;- bind -> monad [style=dashed];- monad -> monad_plus;- alternative -> monad_plus;- functor -> traversable;- foldable -> traversable;- foldable -> foldable1;- foldable1 -> traversable1;- traversable -> traversable1;- bifunctor -> biapply;- contravariant -> divise;- contravariant -> decide;- divise -> divisible [style=dashed];- decide -> decidable [style=dashed];- decide -> conclude;- conclude -> decidable [style=dashed];- semigroupoid -> category [style=dashed];- category -> arrow;-}+digraph { + node[shape=box]; + functor [label="Functor"]; + foldable [label="Foldable"]; + traversable [label="Traversable"]; + apply [label="Apply", penwidth=2.0]; + bind [label="Bind", penwidth=2.0]; + applicative [label="Applicative"]; + alt [label="Alt", penwidth=2.0]; + plus [label="Plus", penwidth=2.0]; + alternative [label="Alternative"]; + monad [label="Monad"]; + monad_plus [label="MonadPlus"]; + foldable1 [label="Foldable1", penwidth=2.0]; + traversable1 [label="Traversable1", penwidth=2.0]; + bifunctor [label="Bifunctor"]; + biapply [label="Biapply", penwidth=2.0]; + contravariant [label="Contravariant"]; + divise [label="Divise", penwidth=2.0]; + decide [label="Decide", penwidth=2.0]; + divisible [label="Divisible"]; + decidable [label="Decidable"]; + conclude [label="Conclude", penwidth=2.0]; + semigroupoid [label="Semigroupoid", penwidth=2.0]; + category [label="Category"]; + arrow [label="Arrow"]; + functor -> apply; + functor -> alt; + apply -> bind; + apply -> applicative [style=dashed]; + alt -> plus; + plus -> alternative [style=dashed]; + applicative -> alternative; + applicative -> monad; + bind -> monad [style=dashed]; + monad -> monad_plus; + alternative -> monad_plus; + functor -> traversable; + foldable -> traversable; + foldable -> foldable1; + foldable1 -> traversable1; + traversable -> traversable1; + bifunctor -> biapply; + contravariant -> divise; + contravariant -> decide; + divise -> divisible [style=dashed]; + decide -> decidable [style=dashed]; + decide -> conclude; + conclude -> decidable [style=dashed]; + semigroupoid -> category [style=dashed]; + category -> arrow; +}
img/classes.svg view
@@ -1,306 +1,306 @@-<?xml version="1.0" encoding="UTF-8" standalone="no"?>-<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"- "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">-<!-- Generated by graphviz version 2.49.1 (0)- -->-<!-- Pages: 1 -->-<svg width="712pt" height="332pt"- viewBox="0.00 0.00 712.00 332.00" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">-<g id="graph0" class="graph" transform="scale(1 1) rotate(0) translate(4 328)">-<polygon fill="white" stroke="transparent" points="-4,4 -4,-328 708,-328 708,4 -4,4"/>-<!-- functor -->-<g id="node1" class="node">-<title>functor</title>-<polygon fill="none" stroke="black" points="141.5,-324 82.5,-324 82.5,-288 141.5,-288 141.5,-324"/>-<text text-anchor="middle" x="112" y="-302.3" font-family="Times,serif" font-size="14.00">Functor</text>-</g>-<!-- traversable -->-<g id="node3" class="node">-<title>traversable</title>-<polygon fill="none" stroke="black" points="237,-252 157,-252 157,-216 237,-216 237,-252"/>-<text text-anchor="middle" x="197" y="-230.3" font-family="Times,serif" font-size="14.00">Traversable</text>-</g>-<!-- functor->traversable -->-<g id="edge12" class="edge">-<title>functor->traversable</title>-<path fill="none" stroke="black" d="M133.01,-287.7C143.72,-278.88 156.89,-268.03 168.5,-258.47"/>-<polygon fill="black" stroke="black" points="170.74,-261.16 176.23,-252.1 166.29,-255.76 170.74,-261.16"/>-</g>-<!-- apply -->-<g id="node4" class="node">-<title>apply</title>-<polygon fill="none" stroke="black" stroke-width="2" points="139,-252 85,-252 85,-216 139,-216 139,-252"/>-<text text-anchor="middle" x="112" y="-230.3" font-family="Times,serif" font-size="14.00">Apply</text>-</g>-<!-- functor->apply -->-<g id="edge1" class="edge">-<title>functor->apply</title>-<path fill="none" stroke="black" d="M112,-287.7C112,-279.98 112,-270.71 112,-262.11"/>-<polygon fill="black" stroke="black" points="115.5,-262.1 112,-252.1 108.5,-262.1 115.5,-262.1"/>-</g>-<!-- alt -->-<g id="node7" class="node">-<title>alt</title>-<polygon fill="none" stroke="black" stroke-width="2" points="61,-252 7,-252 7,-216 61,-216 61,-252"/>-<text text-anchor="middle" x="34" y="-230.3" font-family="Times,serif" font-size="14.00">Alt</text>-</g>-<!-- functor->alt -->-<g id="edge2" class="edge">-<title>functor->alt</title>-<path fill="none" stroke="black" d="M92.72,-287.7C83.08,-279.05 71.27,-268.45 60.77,-259.03"/>-<polygon fill="black" stroke="black" points="62.84,-256.18 53.06,-252.1 58.16,-261.39 62.84,-256.18"/>-</g>-<!-- foldable -->-<g id="node2" class="node">-<title>foldable</title>-<polygon fill="none" stroke="black" points="275,-324 211,-324 211,-288 275,-288 275,-324"/>-<text text-anchor="middle" x="243" y="-302.3" font-family="Times,serif" font-size="14.00">Foldable</text>-</g>-<!-- foldable->traversable -->-<g id="edge13" class="edge">-<title>foldable->traversable</title>-<path fill="none" stroke="black" d="M231.63,-287.7C226.28,-279.56 219.8,-269.69 213.89,-260.7"/>-<polygon fill="black" stroke="black" points="216.66,-258.54 208.24,-252.1 210.81,-262.38 216.66,-258.54"/>-</g>-<!-- foldable1 -->-<g id="node12" class="node">-<title>foldable1</title>-<polygon fill="none" stroke="black" stroke-width="2" points="326.5,-252 255.5,-252 255.5,-216 326.5,-216 326.5,-252"/>-<text text-anchor="middle" x="291" y="-230.3" font-family="Times,serif" font-size="14.00">Foldable1</text>-</g>-<!-- foldable->foldable1 -->-<g id="edge14" class="edge">-<title>foldable->foldable1</title>-<path fill="none" stroke="black" d="M254.87,-287.7C260.5,-279.47 267.35,-269.48 273.57,-260.42"/>-<polygon fill="black" stroke="black" points="276.5,-262.33 279.27,-252.1 270.73,-258.37 276.5,-262.33"/>-</g>-<!-- traversable1 -->-<g id="node13" class="node">-<title>traversable1</title>-<polygon fill="none" stroke="black" stroke-width="2" points="332.5,-180 245.5,-180 245.5,-144 332.5,-144 332.5,-180"/>-<text text-anchor="middle" x="289" y="-158.3" font-family="Times,serif" font-size="14.00">Traversable1</text>-</g>-<!-- traversable->traversable1 -->-<g id="edge16" class="edge">-<title>traversable->traversable1</title>-<path fill="none" stroke="black" d="M219.74,-215.7C231.44,-206.8 245.86,-195.82 258.51,-186.2"/>-<polygon fill="black" stroke="black" points="260.68,-188.94 266.52,-180.1 256.44,-183.37 260.68,-188.94"/>-</g>-<!-- bind -->-<g id="node5" class="node">-<title>bind</title>-<polygon fill="none" stroke="black" stroke-width="2" points="224,-180 170,-180 170,-144 224,-144 224,-180"/>-<text text-anchor="middle" x="197" y="-158.3" font-family="Times,serif" font-size="14.00">Bind</text>-</g>-<!-- apply->bind -->-<g id="edge3" class="edge">-<title>apply->bind</title>-<path fill="none" stroke="black" d="M133.01,-215.7C143.72,-206.88 156.89,-196.03 168.5,-186.47"/>-<polygon fill="black" stroke="black" points="170.74,-189.16 176.23,-180.1 166.29,-183.76 170.74,-189.16"/>-</g>-<!-- applicative -->-<g id="node6" class="node">-<title>applicative</title>-<polygon fill="none" stroke="black" points="152,-180 72,-180 72,-144 152,-144 152,-180"/>-<text text-anchor="middle" x="112" y="-158.3" font-family="Times,serif" font-size="14.00">Applicative</text>-</g>-<!-- apply->applicative -->-<g id="edge4" class="edge">-<title>apply->applicative</title>-<path fill="none" stroke="black" stroke-dasharray="5,2" d="M112,-215.7C112,-207.98 112,-198.71 112,-190.11"/>-<polygon fill="black" stroke="black" points="115.5,-190.1 112,-180.1 108.5,-190.1 115.5,-190.1"/>-</g>-<!-- monad -->-<g id="node10" class="node">-<title>monad</title>-<polygon fill="none" stroke="black" points="183,-108 127,-108 127,-72 183,-72 183,-108"/>-<text text-anchor="middle" x="155" y="-86.3" font-family="Times,serif" font-size="14.00">Monad</text>-</g>-<!-- bind->monad -->-<g id="edge9" class="edge">-<title>bind->monad</title>-<path fill="none" stroke="black" stroke-dasharray="5,2" d="M186.62,-143.7C181.74,-135.56 175.81,-125.69 170.42,-116.7"/>-<polygon fill="black" stroke="black" points="173.41,-114.88 165.26,-108.1 167.41,-118.48 173.41,-114.88"/>-</g>-<!-- alternative -->-<g id="node9" class="node">-<title>alternative</title>-<polygon fill="none" stroke="black" points="108.5,-108 31.5,-108 31.5,-72 108.5,-72 108.5,-108"/>-<text text-anchor="middle" x="70" y="-86.3" font-family="Times,serif" font-size="14.00">Alternative</text>-</g>-<!-- applicative->alternative -->-<g id="edge7" class="edge">-<title>applicative->alternative</title>-<path fill="none" stroke="black" d="M101.62,-143.7C96.74,-135.56 90.81,-125.69 85.42,-116.7"/>-<polygon fill="black" stroke="black" points="88.41,-114.88 80.26,-108.1 82.41,-118.48 88.41,-114.88"/>-</g>-<!-- applicative->monad -->-<g id="edge8" class="edge">-<title>applicative->monad</title>-<path fill="none" stroke="black" d="M122.63,-143.7C127.63,-135.56 133.69,-125.69 139.21,-116.7"/>-<polygon fill="black" stroke="black" points="142.24,-118.46 144.49,-108.1 136.28,-114.79 142.24,-118.46"/>-</g>-<!-- plus -->-<g id="node8" class="node">-<title>plus</title>-<polygon fill="none" stroke="black" stroke-width="2" points="54,-180 0,-180 0,-144 54,-144 54,-180"/>-<text text-anchor="middle" x="27" y="-158.3" font-family="Times,serif" font-size="14.00">Plus</text>-</g>-<!-- alt->plus -->-<g id="edge5" class="edge">-<title>alt->plus</title>-<path fill="none" stroke="black" d="M32.27,-215.7C31.5,-207.98 30.57,-198.71 29.71,-190.11"/>-<polygon fill="black" stroke="black" points="33.19,-189.71 28.71,-180.1 26.22,-190.4 33.19,-189.71"/>-</g>-<!-- plus->alternative -->-<g id="edge6" class="edge">-<title>plus->alternative</title>-<path fill="none" stroke="black" stroke-dasharray="5,2" d="M37.63,-143.7C42.63,-135.56 48.69,-125.69 54.21,-116.7"/>-<polygon fill="black" stroke="black" points="57.24,-118.46 59.49,-108.1 51.28,-114.79 57.24,-118.46"/>-</g>-<!-- monad_plus -->-<g id="node11" class="node">-<title>monad_plus</title>-<polygon fill="none" stroke="black" points="151.5,-36 72.5,-36 72.5,0 151.5,0 151.5,-36"/>-<text text-anchor="middle" x="112" y="-14.3" font-family="Times,serif" font-size="14.00">MonadPlus</text>-</g>-<!-- alternative->monad_plus -->-<g id="edge11" class="edge">-<title>alternative->monad_plus</title>-<path fill="none" stroke="black" d="M80.38,-71.7C85.26,-63.56 91.19,-53.69 96.58,-44.7"/>-<polygon fill="black" stroke="black" points="99.59,-46.48 101.74,-36.1 93.59,-42.88 99.59,-46.48"/>-</g>-<!-- monad->monad_plus -->-<g id="edge10" class="edge">-<title>monad->monad_plus</title>-<path fill="none" stroke="black" d="M144.37,-71.7C139.37,-63.56 133.31,-53.69 127.79,-44.7"/>-<polygon fill="black" stroke="black" points="130.72,-42.79 122.51,-36.1 124.76,-46.46 130.72,-42.79"/>-</g>-<!-- foldable1->traversable1 -->-<g id="edge15" class="edge">-<title>foldable1->traversable1</title>-<path fill="none" stroke="black" d="M290.51,-215.7C290.29,-207.98 290.02,-198.71 289.77,-190.11"/>-<polygon fill="black" stroke="black" points="293.27,-190 289.49,-180.1 286.28,-190.2 293.27,-190"/>-</g>-<!-- bifunctor -->-<g id="node14" class="node">-<title>bifunctor</title>-<polygon fill="none" stroke="black" points="408,-324 340,-324 340,-288 408,-288 408,-324"/>-<text text-anchor="middle" x="374" y="-302.3" font-family="Times,serif" font-size="14.00">Bifunctor</text>-</g>-<!-- biapply -->-<g id="node15" class="node">-<title>biapply</title>-<polygon fill="none" stroke="black" stroke-width="2" points="403.5,-252 344.5,-252 344.5,-216 403.5,-216 403.5,-252"/>-<text text-anchor="middle" x="374" y="-230.3" font-family="Times,serif" font-size="14.00">Biapply</text>-</g>-<!-- bifunctor->biapply -->-<g id="edge17" class="edge">-<title>bifunctor->biapply</title>-<path fill="none" stroke="black" d="M374,-287.7C374,-279.98 374,-270.71 374,-262.11"/>-<polygon fill="black" stroke="black" points="377.5,-262.1 374,-252.1 370.5,-262.1 377.5,-262.1"/>-</g>-<!-- contravariant -->-<g id="node16" class="node">-<title>contravariant</title>-<polygon fill="none" stroke="black" points="542.5,-324 451.5,-324 451.5,-288 542.5,-288 542.5,-324"/>-<text text-anchor="middle" x="497" y="-302.3" font-family="Times,serif" font-size="14.00">Contravariant</text>-</g>-<!-- divise -->-<g id="node17" class="node">-<title>divise</title>-<polygon fill="none" stroke="black" stroke-width="2" points="476,-252 422,-252 422,-216 476,-216 476,-252"/>-<text text-anchor="middle" x="449" y="-230.3" font-family="Times,serif" font-size="14.00">Divise</text>-</g>-<!-- contravariant->divise -->-<g id="edge18" class="edge">-<title>contravariant->divise</title>-<path fill="none" stroke="black" d="M485.13,-287.7C479.5,-279.47 472.65,-269.48 466.43,-260.42"/>-<polygon fill="black" stroke="black" points="469.27,-258.37 460.73,-252.1 463.5,-262.33 469.27,-258.37"/>-</g>-<!-- decide -->-<g id="node18" class="node">-<title>decide</title>-<polygon fill="none" stroke="black" stroke-width="2" points="549.5,-252 494.5,-252 494.5,-216 549.5,-216 549.5,-252"/>-<text text-anchor="middle" x="522" y="-230.3" font-family="Times,serif" font-size="14.00">Decide</text>-</g>-<!-- contravariant->decide -->-<g id="edge19" class="edge">-<title>contravariant->decide</title>-<path fill="none" stroke="black" d="M503.18,-287.7C506,-279.81 509.39,-270.3 512.52,-261.55"/>-<polygon fill="black" stroke="black" points="515.82,-262.7 515.89,-252.1 509.23,-260.34 515.82,-262.7"/>-</g>-<!-- divisible -->-<g id="node19" class="node">-<title>divisible</title>-<polygon fill="none" stroke="black" points="482,-180 416,-180 416,-144 482,-144 482,-180"/>-<text text-anchor="middle" x="449" y="-158.3" font-family="Times,serif" font-size="14.00">Divisible</text>-</g>-<!-- divise->divisible -->-<g id="edge20" class="edge">-<title>divise->divisible</title>-<path fill="none" stroke="black" stroke-dasharray="5,2" d="M449,-215.7C449,-207.98 449,-198.71 449,-190.11"/>-<polygon fill="black" stroke="black" points="452.5,-190.1 449,-180.1 445.5,-190.1 452.5,-190.1"/>-</g>-<!-- decidable -->-<g id="node20" class="node">-<title>decidable</title>-<polygon fill="none" stroke="black" points="582.5,-108 511.5,-108 511.5,-72 582.5,-72 582.5,-108"/>-<text text-anchor="middle" x="547" y="-86.3" font-family="Times,serif" font-size="14.00">Decidable</text>-</g>-<!-- decide->decidable -->-<g id="edge21" class="edge">-<title>decide->decidable</title>-<path fill="none" stroke="black" stroke-dasharray="5,2" d="M524.1,-215.87C526.4,-197.9 530.38,-168.87 535,-144 536.58,-135.52 538.56,-126.34 540.45,-118.04"/>-<polygon fill="black" stroke="black" points="543.9,-118.65 542.77,-108.12 537.09,-117.06 543.9,-118.65"/>-</g>-<!-- conclude -->-<g id="node21" class="node">-<title>conclude</title>-<polygon fill="none" stroke="black" stroke-width="2" points="612,-180 544,-180 544,-144 612,-144 612,-180"/>-<text text-anchor="middle" x="578" y="-158.3" font-family="Times,serif" font-size="14.00">Conclude</text>-</g>-<!-- decide->conclude -->-<g id="edge22" class="edge">-<title>decide->conclude</title>-<path fill="none" stroke="black" d="M535.84,-215.7C542.49,-207.39 550.58,-197.28 557.89,-188.14"/>-<polygon fill="black" stroke="black" points="560.8,-190.1 564.32,-180.1 555.34,-185.73 560.8,-190.1"/>-</g>-<!-- conclude->decidable -->-<g id="edge23" class="edge">-<title>conclude->decidable</title>-<path fill="none" stroke="black" stroke-dasharray="5,2" d="M570.34,-143.7C566.81,-135.73 562.54,-126.1 558.63,-117.26"/>-<polygon fill="black" stroke="black" points="561.82,-115.83 554.57,-108.1 555.42,-118.67 561.82,-115.83"/>-</g>-<!-- semigroupoid -->-<g id="node22" class="node">-<title>semigroupoid</title>-<polygon fill="none" stroke="black" stroke-width="2" points="704,-324 610,-324 610,-288 704,-288 704,-324"/>-<text text-anchor="middle" x="657" y="-302.3" font-family="Times,serif" font-size="14.00">Semigroupoid</text>-</g>-<!-- category -->-<g id="node23" class="node">-<title>category</title>-<polygon fill="none" stroke="black" points="690,-252 624,-252 624,-216 690,-216 690,-252"/>-<text text-anchor="middle" x="657" y="-230.3" font-family="Times,serif" font-size="14.00">Category</text>-</g>-<!-- semigroupoid->category -->-<g id="edge24" class="edge">-<title>semigroupoid->category</title>-<path fill="none" stroke="black" stroke-dasharray="5,2" d="M657,-287.7C657,-279.98 657,-270.71 657,-262.11"/>-<polygon fill="black" stroke="black" points="660.5,-262.1 657,-252.1 653.5,-262.1 660.5,-262.1"/>-</g>-<!-- arrow -->-<g id="node24" class="node">-<title>arrow</title>-<polygon fill="none" stroke="black" points="684,-180 630,-180 630,-144 684,-144 684,-180"/>-<text text-anchor="middle" x="657" y="-158.3" font-family="Times,serif" font-size="14.00">Arrow</text>-</g>-<!-- category->arrow -->-<g id="edge25" class="edge">-<title>category->arrow</title>-<path fill="none" stroke="black" d="M657,-215.7C657,-207.98 657,-198.71 657,-190.11"/>-<polygon fill="black" stroke="black" points="660.5,-190.1 657,-180.1 653.5,-190.1 660.5,-190.1"/>-</g>-</g>-</svg>+<?xml version="1.0" encoding="UTF-8" standalone="no"?> +<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN" + "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"> +<!-- Generated by graphviz version 2.49.1 (0) + --> +<!-- Pages: 1 --> +<svg width="712pt" height="332pt" + viewBox="0.00 0.00 712.00 332.00" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink"> +<g id="graph0" class="graph" transform="scale(1 1) rotate(0) translate(4 328)"> +<polygon fill="white" stroke="transparent" points="-4,4 -4,-328 708,-328 708,4 -4,4"/> +<!-- functor --> +<g id="node1" class="node"> +<title>functor</title> +<polygon fill="none" stroke="black" points="141.5,-324 82.5,-324 82.5,-288 141.5,-288 141.5,-324"/> +<text text-anchor="middle" x="112" y="-302.3" font-family="Times,serif" font-size="14.00">Functor</text> +</g> +<!-- traversable --> +<g id="node3" class="node"> +<title>traversable</title> +<polygon fill="none" stroke="black" points="237,-252 157,-252 157,-216 237,-216 237,-252"/> +<text text-anchor="middle" x="197" y="-230.3" font-family="Times,serif" font-size="14.00">Traversable</text> +</g> +<!-- functor->traversable --> +<g id="edge12" class="edge"> +<title>functor->traversable</title> +<path fill="none" stroke="black" d="M133.01,-287.7C143.72,-278.88 156.89,-268.03 168.5,-258.47"/> +<polygon fill="black" stroke="black" points="170.74,-261.16 176.23,-252.1 166.29,-255.76 170.74,-261.16"/> +</g> +<!-- apply --> +<g id="node4" class="node"> +<title>apply</title> +<polygon fill="none" stroke="black" stroke-width="2" points="139,-252 85,-252 85,-216 139,-216 139,-252"/> +<text text-anchor="middle" x="112" y="-230.3" font-family="Times,serif" font-size="14.00">Apply</text> +</g> +<!-- functor->apply --> +<g id="edge1" class="edge"> +<title>functor->apply</title> +<path fill="none" stroke="black" d="M112,-287.7C112,-279.98 112,-270.71 112,-262.11"/> +<polygon fill="black" stroke="black" points="115.5,-262.1 112,-252.1 108.5,-262.1 115.5,-262.1"/> +</g> +<!-- alt --> +<g id="node7" class="node"> +<title>alt</title> +<polygon fill="none" stroke="black" stroke-width="2" points="61,-252 7,-252 7,-216 61,-216 61,-252"/> +<text text-anchor="middle" x="34" y="-230.3" font-family="Times,serif" font-size="14.00">Alt</text> +</g> +<!-- functor->alt --> +<g id="edge2" class="edge"> +<title>functor->alt</title> +<path fill="none" stroke="black" d="M92.72,-287.7C83.08,-279.05 71.27,-268.45 60.77,-259.03"/> +<polygon fill="black" stroke="black" points="62.84,-256.18 53.06,-252.1 58.16,-261.39 62.84,-256.18"/> +</g> +<!-- foldable --> +<g id="node2" class="node"> +<title>foldable</title> +<polygon fill="none" stroke="black" points="275,-324 211,-324 211,-288 275,-288 275,-324"/> +<text text-anchor="middle" x="243" y="-302.3" font-family="Times,serif" font-size="14.00">Foldable</text> +</g> +<!-- foldable->traversable --> +<g id="edge13" class="edge"> +<title>foldable->traversable</title> +<path fill="none" stroke="black" d="M231.63,-287.7C226.28,-279.56 219.8,-269.69 213.89,-260.7"/> +<polygon fill="black" stroke="black" points="216.66,-258.54 208.24,-252.1 210.81,-262.38 216.66,-258.54"/> +</g> +<!-- foldable1 --> +<g id="node12" class="node"> +<title>foldable1</title> +<polygon fill="none" stroke="black" stroke-width="2" points="326.5,-252 255.5,-252 255.5,-216 326.5,-216 326.5,-252"/> +<text text-anchor="middle" x="291" y="-230.3" font-family="Times,serif" font-size="14.00">Foldable1</text> +</g> +<!-- foldable->foldable1 --> +<g id="edge14" class="edge"> +<title>foldable->foldable1</title> +<path fill="none" stroke="black" d="M254.87,-287.7C260.5,-279.47 267.35,-269.48 273.57,-260.42"/> +<polygon fill="black" stroke="black" points="276.5,-262.33 279.27,-252.1 270.73,-258.37 276.5,-262.33"/> +</g> +<!-- traversable1 --> +<g id="node13" class="node"> +<title>traversable1</title> +<polygon fill="none" stroke="black" stroke-width="2" points="332.5,-180 245.5,-180 245.5,-144 332.5,-144 332.5,-180"/> +<text text-anchor="middle" x="289" y="-158.3" font-family="Times,serif" font-size="14.00">Traversable1</text> +</g> +<!-- traversable->traversable1 --> +<g id="edge16" class="edge"> +<title>traversable->traversable1</title> +<path fill="none" stroke="black" d="M219.74,-215.7C231.44,-206.8 245.86,-195.82 258.51,-186.2"/> +<polygon fill="black" stroke="black" points="260.68,-188.94 266.52,-180.1 256.44,-183.37 260.68,-188.94"/> +</g> +<!-- bind --> +<g id="node5" class="node"> +<title>bind</title> +<polygon fill="none" stroke="black" stroke-width="2" points="224,-180 170,-180 170,-144 224,-144 224,-180"/> +<text text-anchor="middle" x="197" y="-158.3" font-family="Times,serif" font-size="14.00">Bind</text> +</g> +<!-- apply->bind --> +<g id="edge3" class="edge"> +<title>apply->bind</title> +<path fill="none" stroke="black" d="M133.01,-215.7C143.72,-206.88 156.89,-196.03 168.5,-186.47"/> +<polygon fill="black" stroke="black" points="170.74,-189.16 176.23,-180.1 166.29,-183.76 170.74,-189.16"/> +</g> +<!-- applicative --> +<g id="node6" class="node"> +<title>applicative</title> +<polygon fill="none" stroke="black" points="152,-180 72,-180 72,-144 152,-144 152,-180"/> +<text text-anchor="middle" x="112" y="-158.3" font-family="Times,serif" font-size="14.00">Applicative</text> +</g> +<!-- apply->applicative --> +<g id="edge4" class="edge"> +<title>apply->applicative</title> +<path fill="none" stroke="black" stroke-dasharray="5,2" d="M112,-215.7C112,-207.98 112,-198.71 112,-190.11"/> +<polygon fill="black" stroke="black" points="115.5,-190.1 112,-180.1 108.5,-190.1 115.5,-190.1"/> +</g> +<!-- monad --> +<g id="node10" class="node"> +<title>monad</title> +<polygon fill="none" stroke="black" points="183,-108 127,-108 127,-72 183,-72 183,-108"/> +<text text-anchor="middle" x="155" y="-86.3" font-family="Times,serif" font-size="14.00">Monad</text> +</g> +<!-- bind->monad --> +<g id="edge9" class="edge"> +<title>bind->monad</title> +<path fill="none" stroke="black" stroke-dasharray="5,2" d="M186.62,-143.7C181.74,-135.56 175.81,-125.69 170.42,-116.7"/> +<polygon fill="black" stroke="black" points="173.41,-114.88 165.26,-108.1 167.41,-118.48 173.41,-114.88"/> +</g> +<!-- alternative --> +<g id="node9" class="node"> +<title>alternative</title> +<polygon fill="none" stroke="black" points="108.5,-108 31.5,-108 31.5,-72 108.5,-72 108.5,-108"/> +<text text-anchor="middle" x="70" y="-86.3" font-family="Times,serif" font-size="14.00">Alternative</text> +</g> +<!-- applicative->alternative --> +<g id="edge7" class="edge"> +<title>applicative->alternative</title> +<path fill="none" stroke="black" d="M101.62,-143.7C96.74,-135.56 90.81,-125.69 85.42,-116.7"/> +<polygon fill="black" stroke="black" points="88.41,-114.88 80.26,-108.1 82.41,-118.48 88.41,-114.88"/> +</g> +<!-- applicative->monad --> +<g id="edge8" class="edge"> +<title>applicative->monad</title> +<path fill="none" stroke="black" d="M122.63,-143.7C127.63,-135.56 133.69,-125.69 139.21,-116.7"/> +<polygon fill="black" stroke="black" points="142.24,-118.46 144.49,-108.1 136.28,-114.79 142.24,-118.46"/> +</g> +<!-- plus --> +<g id="node8" class="node"> +<title>plus</title> +<polygon fill="none" stroke="black" stroke-width="2" points="54,-180 0,-180 0,-144 54,-144 54,-180"/> +<text text-anchor="middle" x="27" y="-158.3" font-family="Times,serif" font-size="14.00">Plus</text> +</g> +<!-- alt->plus --> +<g id="edge5" class="edge"> +<title>alt->plus</title> +<path fill="none" stroke="black" d="M32.27,-215.7C31.5,-207.98 30.57,-198.71 29.71,-190.11"/> +<polygon fill="black" stroke="black" points="33.19,-189.71 28.71,-180.1 26.22,-190.4 33.19,-189.71"/> +</g> +<!-- plus->alternative --> +<g id="edge6" class="edge"> +<title>plus->alternative</title> +<path fill="none" stroke="black" stroke-dasharray="5,2" d="M37.63,-143.7C42.63,-135.56 48.69,-125.69 54.21,-116.7"/> +<polygon fill="black" stroke="black" points="57.24,-118.46 59.49,-108.1 51.28,-114.79 57.24,-118.46"/> +</g> +<!-- monad_plus --> +<g id="node11" class="node"> +<title>monad_plus</title> +<polygon fill="none" stroke="black" points="151.5,-36 72.5,-36 72.5,0 151.5,0 151.5,-36"/> +<text text-anchor="middle" x="112" y="-14.3" font-family="Times,serif" font-size="14.00">MonadPlus</text> +</g> +<!-- alternative->monad_plus --> +<g id="edge11" class="edge"> +<title>alternative->monad_plus</title> +<path fill="none" stroke="black" d="M80.38,-71.7C85.26,-63.56 91.19,-53.69 96.58,-44.7"/> +<polygon fill="black" stroke="black" points="99.59,-46.48 101.74,-36.1 93.59,-42.88 99.59,-46.48"/> +</g> +<!-- monad->monad_plus --> +<g id="edge10" class="edge"> +<title>monad->monad_plus</title> +<path fill="none" stroke="black" d="M144.37,-71.7C139.37,-63.56 133.31,-53.69 127.79,-44.7"/> +<polygon fill="black" stroke="black" points="130.72,-42.79 122.51,-36.1 124.76,-46.46 130.72,-42.79"/> +</g> +<!-- foldable1->traversable1 --> +<g id="edge15" class="edge"> +<title>foldable1->traversable1</title> +<path fill="none" stroke="black" d="M290.51,-215.7C290.29,-207.98 290.02,-198.71 289.77,-190.11"/> +<polygon fill="black" stroke="black" points="293.27,-190 289.49,-180.1 286.28,-190.2 293.27,-190"/> +</g> +<!-- bifunctor --> +<g id="node14" class="node"> +<title>bifunctor</title> +<polygon fill="none" stroke="black" points="408,-324 340,-324 340,-288 408,-288 408,-324"/> +<text text-anchor="middle" x="374" y="-302.3" font-family="Times,serif" font-size="14.00">Bifunctor</text> +</g> +<!-- biapply --> +<g id="node15" class="node"> +<title>biapply</title> +<polygon fill="none" stroke="black" stroke-width="2" points="403.5,-252 344.5,-252 344.5,-216 403.5,-216 403.5,-252"/> +<text text-anchor="middle" x="374" y="-230.3" font-family="Times,serif" font-size="14.00">Biapply</text> +</g> +<!-- bifunctor->biapply --> +<g id="edge17" class="edge"> +<title>bifunctor->biapply</title> +<path fill="none" stroke="black" d="M374,-287.7C374,-279.98 374,-270.71 374,-262.11"/> +<polygon fill="black" stroke="black" points="377.5,-262.1 374,-252.1 370.5,-262.1 377.5,-262.1"/> +</g> +<!-- contravariant --> +<g id="node16" class="node"> +<title>contravariant</title> +<polygon fill="none" stroke="black" points="542.5,-324 451.5,-324 451.5,-288 542.5,-288 542.5,-324"/> +<text text-anchor="middle" x="497" y="-302.3" font-family="Times,serif" font-size="14.00">Contravariant</text> +</g> +<!-- divise --> +<g id="node17" class="node"> +<title>divise</title> +<polygon fill="none" stroke="black" stroke-width="2" points="476,-252 422,-252 422,-216 476,-216 476,-252"/> +<text text-anchor="middle" x="449" y="-230.3" font-family="Times,serif" font-size="14.00">Divise</text> +</g> +<!-- contravariant->divise --> +<g id="edge18" class="edge"> +<title>contravariant->divise</title> +<path fill="none" stroke="black" d="M485.13,-287.7C479.5,-279.47 472.65,-269.48 466.43,-260.42"/> +<polygon fill="black" stroke="black" points="469.27,-258.37 460.73,-252.1 463.5,-262.33 469.27,-258.37"/> +</g> +<!-- decide --> +<g id="node18" class="node"> +<title>decide</title> +<polygon fill="none" stroke="black" stroke-width="2" points="549.5,-252 494.5,-252 494.5,-216 549.5,-216 549.5,-252"/> +<text text-anchor="middle" x="522" y="-230.3" font-family="Times,serif" font-size="14.00">Decide</text> +</g> +<!-- contravariant->decide --> +<g id="edge19" class="edge"> +<title>contravariant->decide</title> +<path fill="none" stroke="black" d="M503.18,-287.7C506,-279.81 509.39,-270.3 512.52,-261.55"/> +<polygon fill="black" stroke="black" points="515.82,-262.7 515.89,-252.1 509.23,-260.34 515.82,-262.7"/> +</g> +<!-- divisible --> +<g id="node19" class="node"> +<title>divisible</title> +<polygon fill="none" stroke="black" points="482,-180 416,-180 416,-144 482,-144 482,-180"/> +<text text-anchor="middle" x="449" y="-158.3" font-family="Times,serif" font-size="14.00">Divisible</text> +</g> +<!-- divise->divisible --> +<g id="edge20" class="edge"> +<title>divise->divisible</title> +<path fill="none" stroke="black" stroke-dasharray="5,2" d="M449,-215.7C449,-207.98 449,-198.71 449,-190.11"/> +<polygon fill="black" stroke="black" points="452.5,-190.1 449,-180.1 445.5,-190.1 452.5,-190.1"/> +</g> +<!-- decidable --> +<g id="node20" class="node"> +<title>decidable</title> +<polygon fill="none" stroke="black" points="582.5,-108 511.5,-108 511.5,-72 582.5,-72 582.5,-108"/> +<text text-anchor="middle" x="547" y="-86.3" font-family="Times,serif" font-size="14.00">Decidable</text> +</g> +<!-- decide->decidable --> +<g id="edge21" class="edge"> +<title>decide->decidable</title> +<path fill="none" stroke="black" stroke-dasharray="5,2" d="M524.1,-215.87C526.4,-197.9 530.38,-168.87 535,-144 536.58,-135.52 538.56,-126.34 540.45,-118.04"/> +<polygon fill="black" stroke="black" points="543.9,-118.65 542.77,-108.12 537.09,-117.06 543.9,-118.65"/> +</g> +<!-- conclude --> +<g id="node21" class="node"> +<title>conclude</title> +<polygon fill="none" stroke="black" stroke-width="2" points="612,-180 544,-180 544,-144 612,-144 612,-180"/> +<text text-anchor="middle" x="578" y="-158.3" font-family="Times,serif" font-size="14.00">Conclude</text> +</g> +<!-- decide->conclude --> +<g id="edge22" class="edge"> +<title>decide->conclude</title> +<path fill="none" stroke="black" d="M535.84,-215.7C542.49,-207.39 550.58,-197.28 557.89,-188.14"/> +<polygon fill="black" stroke="black" points="560.8,-190.1 564.32,-180.1 555.34,-185.73 560.8,-190.1"/> +</g> +<!-- conclude->decidable --> +<g id="edge23" class="edge"> +<title>conclude->decidable</title> +<path fill="none" stroke="black" stroke-dasharray="5,2" d="M570.34,-143.7C566.81,-135.73 562.54,-126.1 558.63,-117.26"/> +<polygon fill="black" stroke="black" points="561.82,-115.83 554.57,-108.1 555.42,-118.67 561.82,-115.83"/> +</g> +<!-- semigroupoid --> +<g id="node22" class="node"> +<title>semigroupoid</title> +<polygon fill="none" stroke="black" stroke-width="2" points="704,-324 610,-324 610,-288 704,-288 704,-324"/> +<text text-anchor="middle" x="657" y="-302.3" font-family="Times,serif" font-size="14.00">Semigroupoid</text> +</g> +<!-- category --> +<g id="node23" class="node"> +<title>category</title> +<polygon fill="none" stroke="black" points="690,-252 624,-252 624,-216 690,-216 690,-252"/> +<text text-anchor="middle" x="657" y="-230.3" font-family="Times,serif" font-size="14.00">Category</text> +</g> +<!-- semigroupoid->category --> +<g id="edge24" class="edge"> +<title>semigroupoid->category</title> +<path fill="none" stroke="black" stroke-dasharray="5,2" d="M657,-287.7C657,-279.98 657,-270.71 657,-262.11"/> +<polygon fill="black" stroke="black" points="660.5,-262.1 657,-252.1 653.5,-262.1 660.5,-262.1"/> +</g> +<!-- arrow --> +<g id="node24" class="node"> +<title>arrow</title> +<polygon fill="none" stroke="black" points="684,-180 630,-180 630,-144 684,-144 684,-180"/> +<text text-anchor="middle" x="657" y="-158.3" font-family="Times,serif" font-size="14.00">Arrow</text> +</g> +<!-- category->arrow --> +<g id="edge25" class="edge"> +<title>category->arrow</title> +<path fill="none" stroke="black" d="M657,-215.7C657,-207.98 657,-198.71 657,-190.11"/> +<polygon fill="black" stroke="black" points="660.5,-190.1 657,-180.1 653.5,-190.1 660.5,-190.1"/> +</g> +</g> +</svg>
semigroupoids.cabal view
@@ -1,196 +1,203 @@-cabal-version: 1.24-name: semigroupoids-category: Control, Comonads-version: 6-license: BSD2-license-file: LICENSE-author: Edward A. Kmett-maintainer: Edward A. Kmett <ekmett@gmail.com>-stability: provisional-homepage: http://github.com/ekmett/semigroupoids-bug-reports: http://github.com/ekmett/semigroupoids/issues-copyright: Copyright (C) 2011-2015 Edward A. Kmett-tested-with: GHC == 8.0.2- , GHC == 8.2.2- , GHC == 8.4.4- , GHC == 8.6.5- , GHC == 8.8.4- , GHC == 8.10.7- , GHC == 9.0.2- , GHC == 9.2.7- , GHC == 9.4.4- , GHC == 9.6.1-build-type: Simple-synopsis: Semigroupoids: Category sans id-extra-source-files:- .gitignore- .vim.custom- README.markdown- CHANGELOG.markdown- img/classes.dot-extra-doc-files:- img/classes.svg--description:- Provides a wide array of (semi)groupoids and operations for working with them.- .- A 'Semigroupoid' is a 'Category' without the requirement of identity arrows for every object in the category.- .- A 'Category' is any 'Semigroupoid' for which the Yoneda lemma holds.- .- When working with comonads you often have the @\<*\>@ portion of an @Applicative@, but- not the @pure@. This was captured in Uustalu and Vene's \"Essence of Dataflow Programming\"- in the form of the @ComonadZip@ class in the days before @Applicative@. Apply provides a weaker invariant, but for the comonads used for data flow programming (found in the streams package), this invariant is preserved. Applicative function composition forms a semigroupoid.- .- Similarly many structures are nearly a comonad, but not quite, for instance lists provide a reasonable 'extend' operation in the form of 'tails', but do not always contain a value.- .- We describe the relationships between the type classes defined in this package- and those from `base` (and some from `contravariant`) in the diagram below.- Thick-bordered nodes correspond to type classes defined in this package;- thin-bordered ones correspond to type classes from elsewhere. Solid edges- indicate a subclass relationship that actually exists; dashed edges indicate a- subclass relationship that /should/ exist, but currently doesn't.- .- <<https://raw.githubusercontent.com/ekmett/semigroupoids/master/img/classes.svg Relationships among type classes from this package and others>>- .- Apply, Bind, and Extend (not shown) give rise the Static, Kleisli and Cokleisli semigroupoids respectively.- .- This lets us remove many of the restrictions from various monad transformers- as in many cases the binding operation or @\<*\>@ operation does not require them.- .- Finally, to work with these weaker structures it is beneficial to have containers- that can provide stronger guarantees about their contents, so versions of 'Traversable'- and 'Foldable' that can be folded with just a 'Semigroup' are added.--source-repository head- type: git- location: git://github.com/ekmett/semigroupoids.git--flag containers- description:- You can disable the use of the `containers` package using `-f-containers`.- .- Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.- default: True- manual: True--flag contravariant- description:- You can disable the use of the `contravariant` package using `-f-contravariant`.- .- Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.- .- If disabled we will not supply instances of `Contravariant`- .- default: True- manual: True--flag distributive- description:- You can disable the use of the `distributive` package using `-f-distributive`.- .- Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.- .- If disabled we will not supply instances of `Distributive`- .- default: True- manual: True--flag comonad- description:- You can disable the use of the `comonad` package using `-f-comonad`.- .- Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.- .- If disabled we will not supply instances of `Comonad`- .- default: True- manual: True--flag tagged- description:- You can disable the use of the `tagged` package using `-f-tagged`.- .- Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.- default: True- manual: True--flag unordered-containers- description:- You can disable the use of the `unordered-containers` package (and also its dependency `hashable`) using `-f-unordered-containers`.- .- Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.- default: True- manual: True--library- build-depends:- base >= 4.9 && < 5,- base-orphans >= 0.8.4 && < 1,- bifunctors >= 5.6 && < 6,- template-haskell >= 0.2.11,- transformers >= 0.5 && < 0.7,- transformers-compat >= 0.6 && < 0.8-- if !impl(ghc >= 9.6)- build-depends: foldable1-classes-compat >= 0.1 && < 0.2-- if flag(containers)- build-depends: containers >= 0.5.7.1 && < 0.7-- if flag(contravariant)- build-depends: contravariant >= 1.5.3 && < 2-- if flag(distributive)- build-depends: distributive >= 0.5.2 && < 1-- if flag(comonad)- build-depends: comonad >= 5.0.8 && < 6-- if flag(tagged)- build-depends: tagged >= 0.8.7 && < 1-- if flag(unordered-containers)- build-depends: hashable >= 1.2.7.0 && < 1.5,- unordered-containers >= 0.2.8.0 && < 0.3-- hs-source-dirs: src-- exposed-modules:- Data.Bifunctor.Apply- Data.Functor.Alt- Data.Functor.Apply- Data.Functor.Bind- Data.Functor.Bind.Class- Data.Functor.Bind.Trans- Data.Functor.Contravariant.Conclude- Data.Functor.Contravariant.Decide- Data.Functor.Contravariant.Divise- Data.Functor.Extend- Data.Functor.Plus- Data.Groupoid- Data.Isomorphism- Data.Semigroup.Bifoldable- Data.Semigroup.Bitraversable- Data.Semigroup.Foldable- Data.Semigroup.Foldable.Class- Data.Semigroup.Traversable- Data.Semigroup.Traversable.Class- Data.Semigroupoid- Data.Semigroupoid.Categorical- Data.Semigroupoid.Dual- Data.Semigroupoid.Ob- Data.Semigroupoid.Static- Data.Traversable.Instances- Semigroupoids.Do- other-modules:- Semigroupoids.Internal-- ghc-options: -Wall -Wno-warnings-deprecations -Wno-trustworthy-safe-- if impl(ghc >= 9.0)- -- these flags may abort compilation with GHC-8.10- -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295- ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode-- default-language: Haskell2010+cabal-version: 1.24 +name: semigroupoids +category: Control, Comonads +version: 6.0.0.1 +license: BSD2 +license-file: LICENSE +author: Edward A. Kmett +maintainer: Edward A. Kmett <ekmett@gmail.com> +stability: provisional +homepage: http://github.com/ekmett/semigroupoids +bug-reports: http://github.com/ekmett/semigroupoids/issues +copyright: Copyright (C) 2011-2015 Edward A. Kmett +tested-with: GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.7 + , GHC == 9.4.4 + , GHC == 9.6.1 +build-type: Simple +synopsis: Semigroupoids: Category sans id +extra-source-files: + .gitignore + .vim.custom + README.markdown + CHANGELOG.markdown + img/classes.dot +extra-doc-files: + img/classes.svg + +description: + Provides a wide array of (semi)groupoids and operations for working with them. + . + A 'Semigroupoid' is a 'Category' without the requirement of identity arrows for every object in the category. + . + A 'Category' is any 'Semigroupoid' for which the Yoneda lemma holds. + . + When working with comonads you often have the @\<*\>@ portion of an @Applicative@, but + not the @pure@. This was captured in Uustalu and Vene's \"Essence of Dataflow Programming\" + in the form of the @ComonadZip@ class in the days before @Applicative@. Apply provides a weaker invariant, but for the comonads used for data flow programming (found in the streams package), this invariant is preserved. Applicative function composition forms a semigroupoid. + . + Similarly many structures are nearly a comonad, but not quite, for instance lists provide a reasonable 'extend' operation in the form of 'tails', but do not always contain a value. + . + We describe the relationships between the type classes defined in this package + and those from `base` (and some from `contravariant`) in the diagram below. + Thick-bordered nodes correspond to type classes defined in this package; + thin-bordered ones correspond to type classes from elsewhere. Solid edges + indicate a subclass relationship that actually exists; dashed edges indicate a + subclass relationship that /should/ exist, but currently doesn't. + . + <<https://raw.githubusercontent.com/ekmett/semigroupoids/master/img/classes.svg Relationships among type classes from this package and others>> + . + Apply, Bind, and Extend (not shown) give rise the Static, Kleisli and Cokleisli semigroupoids respectively. + . + This lets us remove many of the restrictions from various monad transformers + as in many cases the binding operation or @\<*\>@ operation does not require them. + . + Finally, to work with these weaker structures it is beneficial to have containers + that can provide stronger guarantees about their contents, so versions of 'Traversable' + and 'Foldable' that can be folded with just a 'Semigroup' are added. + +source-repository head + type: git + location: git://github.com/ekmett/semigroupoids.git + +flag containers + description: + You can disable the use of the `containers` package using `-f-containers`. + . + Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. + default: True + manual: True + +flag contravariant + description: + You can disable the use of the `contravariant` package using `-f-contravariant`. + . + Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. + . + If disabled we will not supply instances of `Contravariant` + . + default: True + manual: True + +flag distributive + description: + You can disable the use of the `distributive` package using `-f-distributive`. + . + Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. + . + If disabled we will not supply instances of `Distributive` + . + default: True + manual: True + +flag comonad + description: + You can disable the use of the `comonad` package using `-f-comonad`. + . + Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. + . + If disabled we will not supply instances of `Comonad` + . + default: True + manual: True + +flag tagged + description: + You can disable the use of the `tagged` package using `-f-tagged`. + . + Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. + default: True + manual: True + +flag unordered-containers + description: + You can disable the use of the `unordered-containers` package (and also its dependency `hashable`) using `-f-unordered-containers`. + . + Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. + default: True + manual: True + +library + build-depends: + base >= 4.9 && < 5, + base-orphans >= 0.8.4 && < 1, + bifunctors >= 5.6 && < 6, + template-haskell >= 0.2.11, + transformers >= 0.5 && < 0.7, + transformers-compat >= 0.6 && < 0.8 + + if !impl(ghc >= 9.6) + build-depends: foldable1-classes-compat >= 0.1 && < 0.2 + + -- On GHC-9.6&base-4.18 we require recent enough transformers and containers + -- with Foldable1 instances. + if impl(ghc >= 9.6) + build-depends: transformers >= 0.6.1.0 + if flag(containers) + build-depends: containers >= 0.6.7 + + if flag(containers) + build-depends: containers >= 0.5.7.1 && < 0.7 + + if flag(contravariant) + build-depends: contravariant >= 1.5.3 && < 2 + + if flag(distributive) + build-depends: distributive >= 0.5.2 && < 1 + + if flag(comonad) + build-depends: comonad >= 5.0.8 && < 6 + + if flag(tagged) + build-depends: tagged >= 0.8.7 && < 1 + + if flag(unordered-containers) + build-depends: hashable >= 1.2.7.0 && < 1.5, + unordered-containers >= 0.2.8.0 && < 0.3 + + hs-source-dirs: src + + exposed-modules: + Data.Bifunctor.Apply + Data.Functor.Alt + Data.Functor.Apply + Data.Functor.Bind + Data.Functor.Bind.Class + Data.Functor.Bind.Trans + Data.Functor.Contravariant.Conclude + Data.Functor.Contravariant.Decide + Data.Functor.Contravariant.Divise + Data.Functor.Extend + Data.Functor.Plus + Data.Groupoid + Data.Isomorphism + Data.Semigroup.Bifoldable + Data.Semigroup.Bitraversable + Data.Semigroup.Foldable + Data.Semigroup.Foldable.Class + Data.Semigroup.Traversable + Data.Semigroup.Traversable.Class + Data.Semigroupoid + Data.Semigroupoid.Categorical + Data.Semigroupoid.Dual + Data.Semigroupoid.Ob + Data.Semigroupoid.Static + Data.Traversable.Instances + Semigroupoids.Do + other-modules: + Semigroupoids.Internal + + ghc-options: -Wall -Wno-warnings-deprecations -Wno-trustworthy-safe + + if impl(ghc >= 9.0) + -- these flags may abort compilation with GHC-8.10 + -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295 + ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode + + default-language: Haskell2010
src/Data/Bifunctor/Apply.hs view
@@ -1,39 +1,39 @@-{-# LANGUAGE Safe #-}--------------------------------------------------------------------------------- |--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Bifunctor.Apply (- -- * Biappliable bifunctors- Bifunctor(..)- , Biapply(..)- , (<<$>>)- , (<<..>>)- , bilift2- , bilift3- ) where--import Data.Functor.Bind.Class-import Data.Biapplicative--infixl 4 <<..>>--(<<..>>) :: Biapply p => p a c -> p (a -> b) (c -> d) -> p b d-(<<..>>) = bilift2 (flip id) (flip id)-{-# INLINE (<<..>>) #-}---- | Lift binary functions-bilift2 :: Biapply w => (a -> b -> c) -> (d -> e -> f) -> w a d -> w b e -> w c f-bilift2 f g a b = bimap f g <<$>> a <<.>> b-{-# INLINE bilift2 #-}---- | Lift ternary functions-bilift3 :: Biapply w => (a -> b -> c -> d) -> (e -> f -> g -> h) -> w a e -> w b f -> w c g -> w d h-bilift3 f g a b c = bimap f g <<$>> a <<.>> b <<.>> c-{-# INLINE bilift3 #-}+{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Bifunctor.Apply ( + -- * Biappliable bifunctors + Bifunctor(..) + , Biapply(..) + , (<<$>>) + , (<<..>>) + , bilift2 + , bilift3 + ) where + +import Data.Functor.Bind.Class +import Data.Biapplicative + +infixl 4 <<..>> + +(<<..>>) :: Biapply p => p a c -> p (a -> b) (c -> d) -> p b d +(<<..>>) = bilift2 (flip id) (flip id) +{-# INLINE (<<..>>) #-} + +-- | Lift binary functions +bilift2 :: Biapply w => (a -> b -> c) -> (d -> e -> f) -> w a d -> w b e -> w c f +bilift2 f g a b = bimap f g <<$>> a <<.>> b +{-# INLINE bilift2 #-} + +-- | Lift ternary functions +bilift3 :: Biapply w => (a -> b -> c -> d) -> (e -> f -> g -> h) -> w a e -> w b f -> w c g -> w d h +bilift3 f g a b c = bimap f g <<$>> a <<.>> b <<.>> c +{-# INLINE bilift3 #-}
src/Data/Functor/Alt.hs view
@@ -1,335 +1,335 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstrainedClassMethods #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Trustworthy #-}-{-# options_ghc -Wno-deprecations #-}--------------------------------------------------------------------------------- |--- Module : Data.Functor.Alt--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Functor.Alt- ( Alt(..)- , optional- , galt- , module Data.Functor.Apply- ) where--import Control.Applicative hiding (some, many, optional)-import Control.Applicative.Backwards-import Control.Applicative.Lift-import Control.Arrow-import Control.Exception (catch, SomeException)-import Control.Monad-import Control.Monad.Trans.Identity-import Control.Monad.Trans.Except-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Reader-#if MIN_VERSION_transformers(0,5,6)-import qualified Control.Monad.Trans.RWS.CPS as CPS-import qualified Control.Monad.Trans.Writer.CPS as CPS-import Semigroupoids.Internal-#endif-import qualified Control.Monad.Trans.RWS.Strict as Strict-import qualified Control.Monad.Trans.State.Strict as Strict-import qualified Control.Monad.Trans.Writer.Strict as Strict-import qualified Control.Monad.Trans.RWS.Lazy as Lazy-import qualified Control.Monad.Trans.State.Lazy as Lazy-import qualified Control.Monad.Trans.Writer.Lazy as Lazy-import Data.Functor.Apply-import Data.Functor.Compose-import Data.Functor.Identity (Identity (Identity))-import Data.Functor.Product-import Data.Functor.Reverse-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.Monoid as Monoid-import Data.Proxy-import Data.Semigroup (Semigroup(..))-import qualified Data.Semigroup as Semigroup-import GHC.Generics-import Prelude (($),Either(..),Maybe(..),const,IO,(++),(.),either,seq,undefined,repeat,mappend)-import Unsafe.Coerce--#if !(MIN_VERSION_transformers(0,6,0))-import Control.Monad.Trans.Error-import Control.Monad.Trans.List-#endif--#if !(MIN_VERSION_base(4,16,0))-import Data.Semigroup (Option(..))-#endif--#ifdef MIN_VERSION_containers-import qualified Data.IntMap as IntMap-import Data.IntMap (IntMap)-import Data.Sequence (Seq)-import qualified Data.Map as Map-import Data.Map (Map)-import Prelude (Ord)-#endif--#ifdef MIN_VERSION_unordered_containers-import Data.Hashable-import Data.HashMap.Lazy (HashMap)-import qualified Data.HashMap.Lazy as HashMap-import Prelude (Eq)-#endif--infixl 3 <!>---- | Laws:------ > <!> is associative: (a <!> b) <!> c = a <!> (b <!> c)--- > <$> left-distributes over <!>: f <$> (a <!> b) = (f <$> a) <!> (f <$> b)------ If extended to an 'Alternative' then '<!>' should equal '<|>'.------ Ideally, an instance of 'Alt' also satisfies the \"left distribution\" law of--- MonadPlus with respect to '<.>':------ > <.> right-distributes over <!>: (a <!> b) <.> c = (a <.> c) <!> (b <.> c)------ 'IO', @'Either' a@, @'ExceptT' e m@ and 'GHC.Conc.STM' instead satisfy the--- \"left catch\" law:------ > pure a <!> b = pure a------ 'Maybe' and 'Identity' satisfy both \"left distribution\" and \"left catch\".------ These variations cannot be stated purely in terms of the dependencies of 'Alt'.------ When and if MonadPlus is successfully refactored, this class should also--- be refactored to remove these instances.------ The right distributive law should extend in the cases where the a 'Bind' or 'Monad' is--- provided to yield variations of the right distributive law:------ > (m <!> n) >>- f = (m >>- f) <!> (m >>- f)--- > (m <!> n) >>= f = (m >>= f) <!> (m >>= f)--class Functor f => Alt f where- -- | '<|>' without a required @empty@- (<!>) :: f a -> f a -> f a-- some :: Applicative f => f a -> f [a]- some v = some_v- where many_v = some_v <!> pure []- some_v = (:) <$> v <*> many_v-- many :: Applicative f => f a -> f [a]- many v = many_v- where many_v = some_v <!> pure []- some_v = (:) <$> v <*> many_v---- | One or none.-optional :: (Alt f, Applicative f) => f a -> f (Maybe a)-optional v = Just <$> v <!> pure Nothing---- | Generic ('<!>'). Caveats:------ 1. Will not compile if @f@ is a sum type.--- 2. Any types where the @a@ does not appear must have a 'Semigroup' instance.------ @since 5.3.8-galt :: (Generic1 f, Alt (Rep1 f)) => f a -> f a -> f a-galt as bs = to1 $ from1 as <!> from1 bs--instance (Alt f, Alt g) => Alt (f :*: g) where- (as :*: bs) <!> (cs :*: ds) = (as <!> cs) :*: (bs <!> ds)---- | @since 5.3.8-instance (Alt f, Functor g) => Alt (f :.: g) where- Comp1 as <!> Comp1 bs = Comp1 (as <!> bs)--newtype Magic f = Magic { runMagic :: forall a. Applicative f => f a -> f [a] }--instance Alt f => Alt (M1 i c f) where- M1 f <!> M1 g = M1 (f <!> g)- some = runMagic (unsafeCoerce (Magic some :: Magic f))- many = runMagic (unsafeCoerce (Magic many :: Magic f))--instance Alt f => Alt (Rec1 f) where- Rec1 f <!> Rec1 g = Rec1 (f <!> g)- some = runMagic (unsafeCoerce (Magic some :: Magic f))- many = runMagic (unsafeCoerce (Magic many :: Magic f))---- | @since 5.3.8@-instance Semigroup c => Alt (K1 i c) where- K1 c1 <!> K1 c2 = K1 $ c1 <> c2--instance Alt U1 where- _ <!> _ = U1- some _ = U1- many _ = U1--instance Alt V1 where- v <!> u = v `seq` u `seq` undefined- some v = v `seq` undefined- many v = v `seq` undefined--instance Alt Proxy where- _ <!> _ = Proxy- some _ = Proxy- many _ = Proxy--instance Alt (Either a) where- Left _ <!> b = b- a <!> _ = a---- | This instance does not actually satisfy the ('<.>') right distributive law--- It instead satisfies the \"left catch\" law-instance Alt IO where- m <!> n = catch m (go n) where- go :: x -> SomeException -> x- go = const---- | Choose the first option every time. While \'choose the last option\' every--- time is also valid, this instance satisfies more laws.------ @since 5.3.6-instance Alt Identity where- {-# INLINEABLE (<!>) #-}- m <!> _ = m- some (Identity x) = Identity . repeat $ x- many (Identity x) = Identity . repeat $ x--instance Alt [] where- (<!>) = (++)--instance Alt Maybe where- Nothing <!> b = b- a <!> _ = a--#if !(MIN_VERSION_base(4,16,0))-instance Alt Option where- (<!>) = (<|>)-#endif--instance MonadPlus m => Alt (WrappedMonad m) where- (<!>) = (<|>)--instance ArrowPlus a => Alt (WrappedArrow a b) where- (<!>) = (<|>)--#ifdef MIN_VERSION_containers-instance Ord k => Alt (Map k) where- (<!>) = Map.union--instance Alt IntMap where- (<!>) = IntMap.union--instance Alt Seq where- (<!>) = mappend-#endif--#ifdef MIN_VERSION_unordered_containers-instance (Hashable k, Eq k) => Alt (HashMap k) where- (<!>) = HashMap.union-#endif--instance Alt NonEmpty where- (a :| as) <!> ~(b :| bs) = a :| (as ++ b : bs)--instance Alternative f => Alt (WrappedApplicative f) where- WrapApplicative a <!> WrapApplicative b = WrapApplicative (a <|> b)--instance Alt f => Alt (IdentityT f) where- IdentityT a <!> IdentityT b = IdentityT (a <!> b)--instance Alt f => Alt (ReaderT e f) where- ReaderT a <!> ReaderT b = ReaderT $ \e -> a e <!> b e--instance (Functor f, Monad f) => Alt (MaybeT f) where- MaybeT a <!> MaybeT b = MaybeT $ do- v <- a- case v of- Nothing -> b- Just _ -> return v--#if !(MIN_VERSION_transformers(0,6,0))-instance (Functor f, Monad f) => Alt (ErrorT e f) where- ErrorT m <!> ErrorT n = ErrorT $ do- a <- m- case a of- Left _ -> n- Right r -> return (Right r)--instance Apply f => Alt (ListT f) where- ListT a <!> ListT b = ListT $ (<!>) <$> a <.> b-#endif--instance (Functor f, Monad f, Semigroup e) => Alt (ExceptT e f) where- ExceptT m <!> ExceptT n = ExceptT $ do- a <- m- case a of- Left e -> liftM (either (Left . (<>) e) Right) n- Right x -> return (Right x)---instance Alt f => Alt (Strict.StateT e f) where- Strict.StateT m <!> Strict.StateT n = Strict.StateT $ \s -> m s <!> n s--instance Alt f => Alt (Lazy.StateT e f) where- Lazy.StateT m <!> Lazy.StateT n = Lazy.StateT $ \s -> m s <!> n s--instance Alt f => Alt (Strict.WriterT w f) where- Strict.WriterT m <!> Strict.WriterT n = Strict.WriterT $ m <!> n--instance Alt f => Alt (Lazy.WriterT w f) where- Lazy.WriterT m <!> Lazy.WriterT n = Lazy.WriterT $ m <!> n--#if MIN_VERSION_transformers(0,5,6)--- | @since 5.3.6-instance (Alt f) => Alt (CPS.WriterT w f) where- m <!> n = mkWriterT $ \w -> unWriterT m w <!> unWriterT n w-#endif--instance Alt f => Alt (Strict.RWST r w s f) where- Strict.RWST m <!> Strict.RWST n = Strict.RWST $ \r s -> m r s <!> n r s--instance Alt f => Alt (Lazy.RWST r w s f) where- Lazy.RWST m <!> Lazy.RWST n = Lazy.RWST $ \r s -> m r s <!> n r s--#if MIN_VERSION_transformers(0,5,6)--- | @since 5.3.6-instance (Alt f) => Alt (CPS.RWST r w s f) where- m <!> n = mkRWST $ \r s w -> unRWST m r s w <!> unRWST n r s w-#endif--instance Alt f => Alt (Backwards f) where- Backwards a <!> Backwards b = Backwards (a <!> b)--instance (Alt f, Functor g) => Alt (Compose f g) where- Compose a <!> Compose b = Compose (a <!> b)--instance Alt f => Alt (Lift f) where- Pure a <!> _ = Pure a- Other _ <!> Pure b = Pure b- Other a <!> Other b = Other (a <!> b)--instance (Alt f, Alt g) => Alt (Product f g) where- Pair a1 b1 <!> Pair a2 b2 = Pair (a1 <!> a2) (b1 <!> b2)--instance Alt f => Alt (Reverse f) where- Reverse a <!> Reverse b = Reverse (a <!> b)--instance Alt Semigroup.First where- (<!>) = (<>)--instance Alt Semigroup.Last where- (<!>) = (<>)--instance Alt Monoid.First where- (<!>) = mappend--instance Alt Monoid.Last where- (<!>) = mappend+{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# options_ghc -Wno-deprecations #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Alt +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Functor.Alt + ( Alt(..) + , optional + , galt + , module Data.Functor.Apply + ) where + +import Control.Applicative hiding (some, many, optional) +import Control.Applicative.Backwards +import Control.Applicative.Lift +import Control.Arrow +import Control.Exception (catch, SomeException) +import Control.Monad +import Control.Monad.Trans.Identity +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +#if MIN_VERSION_transformers(0,5,6) +import qualified Control.Monad.Trans.RWS.CPS as CPS +import qualified Control.Monad.Trans.Writer.CPS as CPS +import Semigroupoids.Internal +#endif +import qualified Control.Monad.Trans.RWS.Strict as Strict +import qualified Control.Monad.Trans.State.Strict as Strict +import qualified Control.Monad.Trans.Writer.Strict as Strict +import qualified Control.Monad.Trans.RWS.Lazy as Lazy +import qualified Control.Monad.Trans.State.Lazy as Lazy +import qualified Control.Monad.Trans.Writer.Lazy as Lazy +import Data.Functor.Apply +import Data.Functor.Compose +import Data.Functor.Identity (Identity (Identity)) +import Data.Functor.Product +import Data.Functor.Reverse +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.Monoid as Monoid +import Data.Proxy +import Data.Semigroup (Semigroup(..)) +import qualified Data.Semigroup as Semigroup +import GHC.Generics +import Prelude (($),Either(..),Maybe(..),const,IO,(++),(.),either,seq,undefined,repeat,mappend) +import Unsafe.Coerce + +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.Error +import Control.Monad.Trans.List +#endif + +#if !(MIN_VERSION_base(4,16,0)) +import Data.Semigroup (Option(..)) +#endif + +#ifdef MIN_VERSION_containers +import qualified Data.IntMap as IntMap +import Data.IntMap (IntMap) +import Data.Sequence (Seq) +import qualified Data.Map as Map +import Data.Map (Map) +import Prelude (Ord) +#endif + +#ifdef MIN_VERSION_unordered_containers +import Data.Hashable +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as HashMap +import Prelude (Eq) +#endif + +infixl 3 <!> + +-- | Laws: +-- +-- > <!> is associative: (a <!> b) <!> c = a <!> (b <!> c) +-- > <$> left-distributes over <!>: f <$> (a <!> b) = (f <$> a) <!> (f <$> b) +-- +-- If extended to an 'Alternative' then '<!>' should equal '<|>'. +-- +-- Ideally, an instance of 'Alt' also satisfies the \"left distribution\" law of +-- MonadPlus with respect to '<.>': +-- +-- > <.> right-distributes over <!>: (a <!> b) <.> c = (a <.> c) <!> (b <.> c) +-- +-- 'IO', @'Either' a@, @'ExceptT' e m@ and 'GHC.Conc.STM' instead satisfy the +-- \"left catch\" law: +-- +-- > pure a <!> b = pure a +-- +-- 'Maybe' and 'Identity' satisfy both \"left distribution\" and \"left catch\". +-- +-- These variations cannot be stated purely in terms of the dependencies of 'Alt'. +-- +-- When and if MonadPlus is successfully refactored, this class should also +-- be refactored to remove these instances. +-- +-- The right distributive law should extend in the cases where the a 'Bind' or 'Monad' is +-- provided to yield variations of the right distributive law: +-- +-- > (m <!> n) >>- f = (m >>- f) <!> (m >>- f) +-- > (m <!> n) >>= f = (m >>= f) <!> (m >>= f) + +class Functor f => Alt f where + -- | '<|>' without a required @empty@ + (<!>) :: f a -> f a -> f a + + some :: Applicative f => f a -> f [a] + some v = some_v + where many_v = some_v <!> pure [] + some_v = (:) <$> v <*> many_v + + many :: Applicative f => f a -> f [a] + many v = many_v + where many_v = some_v <!> pure [] + some_v = (:) <$> v <*> many_v + +-- | One or none. +optional :: (Alt f, Applicative f) => f a -> f (Maybe a) +optional v = Just <$> v <!> pure Nothing + +-- | Generic ('<!>'). Caveats: +-- +-- 1. Will not compile if @f@ is a sum type. +-- 2. Any types where the @a@ does not appear must have a 'Semigroup' instance. +-- +-- @since 5.3.8 +galt :: (Generic1 f, Alt (Rep1 f)) => f a -> f a -> f a +galt as bs = to1 $ from1 as <!> from1 bs + +instance (Alt f, Alt g) => Alt (f :*: g) where + (as :*: bs) <!> (cs :*: ds) = (as <!> cs) :*: (bs <!> ds) + +-- | @since 5.3.8 +instance (Alt f, Functor g) => Alt (f :.: g) where + Comp1 as <!> Comp1 bs = Comp1 (as <!> bs) + +newtype Magic f = Magic { runMagic :: forall a. Applicative f => f a -> f [a] } + +instance Alt f => Alt (M1 i c f) where + M1 f <!> M1 g = M1 (f <!> g) + some = runMagic (unsafeCoerce (Magic some :: Magic f)) + many = runMagic (unsafeCoerce (Magic many :: Magic f)) + +instance Alt f => Alt (Rec1 f) where + Rec1 f <!> Rec1 g = Rec1 (f <!> g) + some = runMagic (unsafeCoerce (Magic some :: Magic f)) + many = runMagic (unsafeCoerce (Magic many :: Magic f)) + +-- | @since 5.3.8@ +instance Semigroup c => Alt (K1 i c) where + K1 c1 <!> K1 c2 = K1 $ c1 <> c2 + +instance Alt U1 where + _ <!> _ = U1 + some _ = U1 + many _ = U1 + +instance Alt V1 where + v <!> u = v `seq` u `seq` undefined + some v = v `seq` undefined + many v = v `seq` undefined + +instance Alt Proxy where + _ <!> _ = Proxy + some _ = Proxy + many _ = Proxy + +instance Alt (Either a) where + Left _ <!> b = b + a <!> _ = a + +-- | This instance does not actually satisfy the ('<.>') right distributive law +-- It instead satisfies the \"left catch\" law +instance Alt IO where + m <!> n = catch m (go n) where + go :: x -> SomeException -> x + go = const + +-- | Choose the first option every time. While \'choose the last option\' every +-- time is also valid, this instance satisfies more laws. +-- +-- @since 5.3.6 +instance Alt Identity where + {-# INLINEABLE (<!>) #-} + m <!> _ = m + some (Identity x) = Identity . repeat $ x + many (Identity x) = Identity . repeat $ x + +instance Alt [] where + (<!>) = (++) + +instance Alt Maybe where + Nothing <!> b = b + a <!> _ = a + +#if !(MIN_VERSION_base(4,16,0)) +instance Alt Option where + (<!>) = (<|>) +#endif + +instance MonadPlus m => Alt (WrappedMonad m) where + (<!>) = (<|>) + +instance ArrowPlus a => Alt (WrappedArrow a b) where + (<!>) = (<|>) + +#ifdef MIN_VERSION_containers +instance Ord k => Alt (Map k) where + (<!>) = Map.union + +instance Alt IntMap where + (<!>) = IntMap.union + +instance Alt Seq where + (<!>) = mappend +#endif + +#ifdef MIN_VERSION_unordered_containers +instance (Hashable k, Eq k) => Alt (HashMap k) where + (<!>) = HashMap.union +#endif + +instance Alt NonEmpty where + (a :| as) <!> ~(b :| bs) = a :| (as ++ b : bs) + +instance Alternative f => Alt (WrappedApplicative f) where + WrapApplicative a <!> WrapApplicative b = WrapApplicative (a <|> b) + +instance Alt f => Alt (IdentityT f) where + IdentityT a <!> IdentityT b = IdentityT (a <!> b) + +instance Alt f => Alt (ReaderT e f) where + ReaderT a <!> ReaderT b = ReaderT $ \e -> a e <!> b e + +instance (Functor f, Monad f) => Alt (MaybeT f) where + MaybeT a <!> MaybeT b = MaybeT $ do + v <- a + case v of + Nothing -> b + Just _ -> return v + +#if !(MIN_VERSION_transformers(0,6,0)) +instance (Functor f, Monad f) => Alt (ErrorT e f) where + ErrorT m <!> ErrorT n = ErrorT $ do + a <- m + case a of + Left _ -> n + Right r -> return (Right r) + +instance Apply f => Alt (ListT f) where + ListT a <!> ListT b = ListT $ (<!>) <$> a <.> b +#endif + +instance (Functor f, Monad f, Semigroup e) => Alt (ExceptT e f) where + ExceptT m <!> ExceptT n = ExceptT $ do + a <- m + case a of + Left e -> liftM (either (Left . (<>) e) Right) n + Right x -> return (Right x) + + +instance Alt f => Alt (Strict.StateT e f) where + Strict.StateT m <!> Strict.StateT n = Strict.StateT $ \s -> m s <!> n s + +instance Alt f => Alt (Lazy.StateT e f) where + Lazy.StateT m <!> Lazy.StateT n = Lazy.StateT $ \s -> m s <!> n s + +instance Alt f => Alt (Strict.WriterT w f) where + Strict.WriterT m <!> Strict.WriterT n = Strict.WriterT $ m <!> n + +instance Alt f => Alt (Lazy.WriterT w f) where + Lazy.WriterT m <!> Lazy.WriterT n = Lazy.WriterT $ m <!> n + +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance (Alt f) => Alt (CPS.WriterT w f) where + m <!> n = mkWriterT $ \w -> unWriterT m w <!> unWriterT n w +#endif + +instance Alt f => Alt (Strict.RWST r w s f) where + Strict.RWST m <!> Strict.RWST n = Strict.RWST $ \r s -> m r s <!> n r s + +instance Alt f => Alt (Lazy.RWST r w s f) where + Lazy.RWST m <!> Lazy.RWST n = Lazy.RWST $ \r s -> m r s <!> n r s + +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance (Alt f) => Alt (CPS.RWST r w s f) where + m <!> n = mkRWST $ \r s w -> unRWST m r s w <!> unRWST n r s w +#endif + +instance Alt f => Alt (Backwards f) where + Backwards a <!> Backwards b = Backwards (a <!> b) + +instance (Alt f, Functor g) => Alt (Compose f g) where + Compose a <!> Compose b = Compose (a <!> b) + +instance Alt f => Alt (Lift f) where + Pure a <!> _ = Pure a + Other _ <!> Pure b = Pure b + Other a <!> Other b = Other (a <!> b) + +instance (Alt f, Alt g) => Alt (Product f g) where + Pair a1 b1 <!> Pair a2 b2 = Pair (a1 <!> a2) (b1 <!> b2) + +instance Alt f => Alt (Reverse f) where + Reverse a <!> Reverse b = Reverse (a <!> b) + +instance Alt Semigroup.First where + (<!>) = (<>) + +instance Alt Semigroup.Last where + (<!>) = (<>) + +instance Alt Monoid.First where + (<!>) = mappend + +instance Alt Monoid.Last where + (<!>) = mappend
src/Data/Functor/Apply.hs view
@@ -1,64 +1,64 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Trustworthy #-}--------------------------------------------------------------------------------- |--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Functor.Apply (- -- * Functors- Functor(..)- , (<$>) -- :: Functor f => (a -> b) -> f a -> f b- , ( $>) -- :: Functor f => f a -> b -> f b-- -- * Apply - a strong lax semimonoidal endofunctor-- , Apply(..)- , (<..>) -- :: Apply w => w a -> w (a -> b) -> w b- , liftF3 -- :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d- , gliftF2- , gliftF3-- -- * Wrappers- , WrappedApplicative(..)- , MaybeApply(..)- , (<.*>)- , (<*.>)- ) where--import Data.Functor-import Data.Functor.Bind.Class-import GHC.Generics--infixl 4 <..>---- | A variant of '<.>' with the arguments reversed.-(<..>) :: Apply w => w a -> w (a -> b) -> w b-(<..>) = liftF2 (flip id)-{-# INLINE (<..>) #-}----- | Lift a ternary function into a comonad with zipping-liftF3 :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d-liftF3 f a b c = f <$> a <.> b <.> c-{-# INLINE liftF3 #-}---- | Generic 'liftF2'. Caveats:------ 1. Will not compile if @w@ is a sum type.--- 2. Types in @w@ that do not mention the type variable must be instances of 'Semigroup'.------ @since 5.3.8-gliftF2 :: (Generic1 w, Apply (Rep1 w)) => (a -> b -> c) -> w a -> w b -> w c-gliftF2 f wa wb = to1 $ liftF2 f (from1 wa) (from1 wb)---- | Generic 'liftF3'. Caveats are the same as for 'gliftF2'.------ @since 5.3.8-gliftF3 :: (Generic1 w, Apply (Rep1 w)) => (a -> b -> c -> d) -> w a -> w b -> w c -> w d-gliftF3 f wa wb wc = to1 $ liftF3 f (from1 wa) (from1 wb) (from1 wc)+{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Trustworthy #-} +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Functor.Apply ( + -- * Functors + Functor(..) + , (<$>) -- :: Functor f => (a -> b) -> f a -> f b + , ( $>) -- :: Functor f => f a -> b -> f b + + -- * Apply - a strong lax semimonoidal endofunctor + + , Apply(..) + , (<..>) -- :: Apply w => w a -> w (a -> b) -> w b + , liftF3 -- :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d + , gliftF2 + , gliftF3 + + -- * Wrappers + , WrappedApplicative(..) + , MaybeApply(..) + , (<.*>) + , (<*.>) + ) where + +import Data.Functor +import Data.Functor.Bind.Class +import GHC.Generics + +infixl 4 <..> + +-- | A variant of '<.>' with the arguments reversed. +(<..>) :: Apply w => w a -> w (a -> b) -> w b +(<..>) = liftF2 (flip id) +{-# INLINE (<..>) #-} + + +-- | Lift a ternary function into a comonad with zipping +liftF3 :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d +liftF3 f a b c = f <$> a <.> b <.> c +{-# INLINE liftF3 #-} + +-- | Generic 'liftF2'. Caveats: +-- +-- 1. Will not compile if @w@ is a sum type. +-- 2. Types in @w@ that do not mention the type variable must be instances of 'Semigroup'. +-- +-- @since 5.3.8 +gliftF2 :: (Generic1 w, Apply (Rep1 w)) => (a -> b -> c) -> w a -> w b -> w c +gliftF2 f wa wb = to1 $ liftF2 f (from1 wa) (from1 wb) + +-- | Generic 'liftF3'. Caveats are the same as for 'gliftF2'. +-- +-- @since 5.3.8 +gliftF3 :: (Generic1 w, Apply (Rep1 w)) => (a -> b -> c -> d) -> w a -> w b -> w c -> w d +gliftF3 f wa wb wc = to1 $ liftF3 f (from1 wa) (from1 wb) (from1 wc)
src/Data/Functor/Bind.hs view
@@ -1,59 +1,59 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Trustworthy #-}--------------------------------------------------------------------------------- |--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Functor.Bind (- -- * Functors- Functor(..)- , (<$>) -- :: Functor f => (a -> b) -> f a -> f b- , ( $>) -- :: Functor f => f a -> b -> f b- -- * Applyable functors- , Apply(..)- , (<..>) -- :: Apply w => w a -> w (a -> b) -> w b- , liftF3 -- :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d- -- * Wrappers- , WrappedApplicative(..)- , MaybeApply(..)- -- * Bindable functors- , Bind(..)- , gbind- , (-<<)- , (-<-)- , (->-)- , apDefault- , returning- ) where--import Data.Functor.Apply-import Data.Functor.Bind.Class-import GHC.Generics---- | Generic '(>>-)'. Caveats:------ 1. Will not compile if @m@ is a sum type.--- 2. Will not compile if @m@ contains fields that do not mention its type variable.--- 3. Will not compile if @m@ contains fields where the type variable appears underneath the composition of type constructors (e.g., @f (g a)@).--- 4. May do redundant work, due to the nature of the 'Bind' instance for (':*:')------ @since 5.3.8-gbind :: (Generic1 m, Bind (Rep1 m)) => m a -> (a -> m b) -> m b-gbind m f = to1 $ from1 m >>- (\a -> from1 $ f a)--infixr 1 -<<, -<-, ->---(-<<) :: Bind m => (a -> m b) -> m a -> m b-(-<<) = flip (>>-)--(->-) :: Bind m => (a -> m b) -> (b -> m c) -> a -> m c-f ->- g = \a -> f a >>- g--(-<-) :: Bind m => (b -> m c) -> (a -> m b) -> a -> m c-g -<- f = \a -> f a >>- g+{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Trustworthy #-} +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Functor.Bind ( + -- * Functors + Functor(..) + , (<$>) -- :: Functor f => (a -> b) -> f a -> f b + , ( $>) -- :: Functor f => f a -> b -> f b + -- * Applyable functors + , Apply(..) + , (<..>) -- :: Apply w => w a -> w (a -> b) -> w b + , liftF3 -- :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d + -- * Wrappers + , WrappedApplicative(..) + , MaybeApply(..) + -- * Bindable functors + , Bind(..) + , gbind + , (-<<) + , (-<-) + , (->-) + , apDefault + , returning + ) where + +import Data.Functor.Apply +import Data.Functor.Bind.Class +import GHC.Generics + +-- | Generic '(>>-)'. Caveats: +-- +-- 1. Will not compile if @m@ is a sum type. +-- 2. Will not compile if @m@ contains fields that do not mention its type variable. +-- 3. Will not compile if @m@ contains fields where the type variable appears underneath the composition of type constructors (e.g., @f (g a)@). +-- 4. May do redundant work, due to the nature of the 'Bind' instance for (':*:') +-- +-- @since 5.3.8 +gbind :: (Generic1 m, Bind (Rep1 m)) => m a -> (a -> m b) -> m b +gbind m f = to1 $ from1 m >>- (\a -> from1 $ f a) + +infixr 1 -<<, -<-, ->- + +(-<<) :: Bind m => (a -> m b) -> m a -> m b +(-<<) = flip (>>-) + +(->-) :: Bind m => (a -> m b) -> (b -> m c) -> a -> m c +f ->- g = \a -> f a >>- g + +(-<-) :: Bind m => (b -> m c) -> (a -> m b) -> a -> m c +g -<- f = \a -> f a >>- g
src/Data/Functor/Bind/Class.hs view
@@ -1,837 +1,837 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeOperators #-}-{-# OPTIONS_GHC -Wno-deprecations #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Copyright : (C) 2011-2018 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ This module is used to resolve the cyclic we get from defining these--- classes here rather than in a package upstream. Otherwise we'd get--- orphaned heads for many instances on the types in @transformers@ and @bifunctors@.------------------------------------------------------------------------------module Data.Functor.Bind.Class (- -- * Applyable functors- Apply(..)- -- * Wrappers- , WrappedApplicative(..)- , MaybeApply(..)- , (<.*>)- , (<*.>)- , traverse1Maybe- -- * Bindable functors- , Bind(..)- , apDefault- , returning- -- * Biappliable bifunctors- , Biapply(..)- ) where--import Data.Semigroup-import Control.Applicative-import Control.Applicative.Backwards-import Control.Applicative.Lift-import Control.Arrow-import Control.Category-import Control.Monad (ap)-import Control.Monad.Trans.Cont-import Control.Monad.Trans.Except-import Control.Monad.Trans.Identity-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Reader-#if MIN_VERSION_transformers(0,5,6)-import qualified Control.Monad.Trans.RWS.CPS as CPS-import qualified Control.Monad.Trans.Writer.CPS as CPS-import Semigroupoids.Internal-#endif-import qualified Control.Monad.Trans.RWS.Lazy as Lazy-import qualified Control.Monad.Trans.State.Lazy as Lazy-import qualified Control.Monad.Trans.Writer.Lazy as Lazy-import qualified Control.Monad.Trans.RWS.Strict as Strict-import qualified Control.Monad.Trans.State.Strict as Strict-import qualified Control.Monad.Trans.Writer.Strict as Strict-import Data.Biapplicative-import Data.Bifunctor.Biff-import Data.Bifunctor.Clown-import Data.Bifunctor.Flip-import Data.Bifunctor.Joker-import Data.Bifunctor.Join-import Data.Bifunctor.Product as Bifunctor-import Data.Bifunctor.Tannen-import Data.Bifunctor.Wrapped-import Data.Complex-import Data.Functor.Compose-import Data.Functor.Constant-import Data.Functor.Identity-import Data.Functor.Product as Functor-import Data.Functor.Reverse-import Data.Functor.Extend-import Data.List.NonEmpty (NonEmpty)-import Data.Ord (Down (..))-import Data.Proxy-import Data.Semigroup as Semigroup-import qualified Data.Monoid as Monoid-import Data.Orphans ()-import GHC.Generics as Generics-import Language.Haskell.TH (Q)-import Prelude hiding (id, (.))--#if !(MIN_VERSION_transformers(0,6,0))-import Control.Monad.Trans.Error-import Control.Monad.Trans.List-#endif--#ifdef MIN_VERSION_containers-import qualified Data.IntMap as IntMap-import Data.IntMap (IntMap)-import qualified Data.Map as Map-import Data.Map (Map)-import Data.Sequence (Seq)-import Data.Tree (Tree)-#endif--#ifdef MIN_VERSION_tagged-import Data.Tagged-#endif--#ifdef MIN_VERSION_unordered_containers-import Data.Hashable-import Data.HashMap.Lazy (HashMap)-import qualified Data.HashMap.Lazy as HashMap-#endif--#ifdef MIN_VERSION_comonad-import Control.Comonad-import Control.Comonad.Trans.Env-import Control.Comonad.Trans.Store-import Control.Comonad.Trans.Traced-#else-($>) :: Functor f => f a -> b -> f b-($>) = flip (<$)-#endif--infixl 1 >>--infixl 4 <.>, <., .>---- | A strong lax semi-monoidal endofunctor.--- This is equivalent to an 'Applicative' without 'pure'.------ Laws:------ @--- ('.') '<$>' u '<.>' v '<.>' w = u '<.>' (v '<.>' w)--- x '<.>' (f '<$>' y) = ('.' f) '<$>' x '<.>' y--- f '<$>' (x '<.>' y) = (f '.') '<$>' x '<.>' y--- @------ The laws imply that `.>` and `<.` really ignore their--- left and right results, respectively, and really--- return their right and left results, respectively.--- Specifically,------ @--- (mf '<$>' m) '.>' (nf '<$>' n) = nf '<$>' (m '.>' n)--- (mf '<$>' m) '<.' (nf '<$>' n) = mf '<$>' (m '<.' n)--- @-class Functor f => Apply f where- (<.>) :: f (a -> b) -> f a -> f b- (<.>) = liftF2 id-- -- | @ a '.>' b = 'const' 'id' '<$>' a '<.>' b @- (.>) :: f a -> f b -> f b- a .> b = const id <$> a <.> b-- -- | @ a '<.' b = 'const' '<$>' a '<.>' b @- (<.) :: f a -> f b -> f a- a <. b = const <$> a <.> b-- -- | Lift a binary function into a comonad with zipping- liftF2 :: (a -> b -> c) -> f a -> f b -> f c- liftF2 f a b = f <$> a <.> b- {-# INLINE liftF2 #-}-- {-# MINIMAL (<.>) | liftF2 #-}--#ifdef MIN_VERSION_tagged-instance Apply (Tagged a) where- (<.>) = (<*>)- (<.) = (<*)- (.>) = (*>)-#endif--instance Apply Proxy where- (<.>) = (<*>)- (<.) = (<*)- (.>) = (*>)--instance Apply f => Apply (Backwards f) where- Backwards f <.> Backwards a = Backwards (flip id <$> a <.> f)--instance (Apply f, Apply g) => Apply (Compose f g) where- Compose f <.> Compose x = Compose ((<.>) <$> f <.> x)---- | A @'Constant' f@ is not 'Applicative' unless its @f@ is a 'Monoid', but it is an instance of 'Apply'-instance Semigroup f => Apply (Constant f) where- Constant a <.> Constant b = Constant (a <> b)- Constant a <. Constant b = Constant (a <> b)- Constant a .> Constant b = Constant (a <> b)--instance Apply f => Apply (Lift f) where- Pure f <.> Pure x = Pure (f x)- Pure f <.> Other y = Other (f <$> y)- Other f <.> Pure x = Other (($ x) <$> f)- Other f <.> Other y = Other (f <.> y)--instance (Apply f, Apply g) => Apply (Functor.Product f g) where- Functor.Pair f g <.> Functor.Pair x y = Functor.Pair (f <.> x) (g <.> y)--instance Apply f => Apply (Reverse f) where- Reverse a <.> Reverse b = Reverse (a <.> b)---- | A @'(,)' m@ is not 'Applicative' unless its @m@ is a 'Monoid', but it is an instance of 'Apply'-instance Semigroup m => Apply ((,)m) where- (m, f) <.> (n, a) = (m <> n, f a)- (m, a) <. (n, _) = (m <> n, a)- (m, _) .> (n, b) = (m <> n, b)--instance Apply NonEmpty where- (<.>) = ap--instance Apply (Either a) where- Left a <.> _ = Left a- Right _ <.> Left a = Left a- Right f <.> Right b = Right (f b)-- Left a <. _ = Left a- Right _ <. Left a = Left a- Right a <. Right _ = Right a-- Left a .> _ = Left a- Right _ .> Left a = Left a- Right _ .> Right b = Right b---- | A @'Const' m@ is not 'Applicative' unless its @m@ is a 'Monoid', but it is an instance of 'Apply'-instance Semigroup m => Apply (Const m) where- Const m <.> Const n = Const (m <> n)- Const m <. Const n = Const (m <> n)- Const m .> Const n = Const (m <> n)--instance Apply ((->)m) where- (<.>) = (<*>)- (<. ) = (<* )- ( .>) = ( *>)--instance Apply ZipList where- (<.>) = (<*>)- (<. ) = (<* )- ( .>) = ( *>)--instance Apply [] where- (<.>) = (<*>)- (<. ) = (<* )- ( .>) = ( *>)--instance Apply IO where- (<.>) = (<*>)- (<. ) = (<* )- ( .>) = ( *>)--instance Apply Maybe where- (<.>) = (<*>)- (<. ) = (<* )- ( .>) = ( *>)--#if !(MIN_VERSION_base(4,16,0))-instance Apply Option where- (<.>) = (<*>)- (<. ) = (<* )- ( .>) = ( *>)-#endif--instance Apply Identity where- (<.>) = (<*>)- (<. ) = (<* )- ( .>) = ( *>)--instance Apply w => Apply (IdentityT w) where- IdentityT wa <.> IdentityT wb = IdentityT (wa <.> wb)--instance Monad m => Apply (WrappedMonad m) where- (<.>) = (<*>)- (<. ) = (<* )- ( .>) = ( *>)--instance Arrow a => Apply (WrappedArrow a b) where- (<.>) = (<*>)- (<. ) = (<* )- ( .>) = ( *>)--instance Apply Complex where- (a :+ b) <.> (c :+ d) = a c :+ b d---- Applicative Q was only added in template-haskell 2.7 (GHC 7.4), so--- define in terms of Monad instead.-instance Apply Q where- (<.>) = ap--#ifdef MIN_VERSION_containers--- | A 'Map k' is not 'Applicative', but it is an instance of 'Apply'-instance Ord k => Apply (Map k) where- (<.>) = Map.intersectionWith id- (<. ) = Map.intersectionWith const- ( .>) = Map.intersectionWith (const id)---- | An 'IntMap' is not 'Applicative', but it is an instance of 'Apply'-instance Apply IntMap where- (<.>) = IntMap.intersectionWith id- (<. ) = IntMap.intersectionWith const- ( .>) = IntMap.intersectionWith (const id)--instance Apply Seq where- (<.>) = ap--instance Apply Tree where- (<.>) = (<*>)- (<. ) = (<* )- ( .>) = ( *>)-#endif--#ifdef MIN_VERSION_unordered_containers--- | A 'HashMap k' is not 'Applicative', but it is an instance of 'Apply'-instance (Hashable k, Eq k) => Apply (HashMap k) where- (<.>) = HashMap.intersectionWith id-#endif---- MaybeT is _not_ the same as Compose f Maybe-instance (Functor m, Monad m) => Apply (MaybeT m) where- (<.>) = apDefault--#if !(MIN_VERSION_transformers(0,6,0))--- ErrorT e is _not_ the same as Compose f (Either e)-instance (Functor m, Monad m) => Apply (ErrorT e m) where- (<.>) = apDefault--instance Apply m => Apply (ListT m) where- ListT f <.> ListT a = ListT $ (<.>) <$> f <.> a-#endif--instance (Functor m, Monad m) => Apply (ExceptT e m) where- (<.>) = apDefault--instance Apply m => Apply (ReaderT e m) where- ReaderT f <.> ReaderT a = ReaderT $ \e -> f e <.> a e---- unfortunately, WriterT has its wrapped product in the wrong order to just use (<.>) instead of flap--- | A @'Strict.WriterT' w m@ is not 'Applicative' unless its @w@ is a 'Monoid', but it is an instance of 'Apply'-instance (Apply m, Semigroup w) => Apply (Strict.WriterT w m) where- Strict.WriterT f <.> Strict.WriterT a = Strict.WriterT $ flap <$> f <.> a where- flap (x,m) (y,n) = (x y, m <> n)---- | A @'Lazy.WriterT' w m@ is not 'Applicative' unless its @w@ is a 'Monoid', but it is an instance of 'Apply'-instance (Apply m, Semigroup w) => Apply (Lazy.WriterT w m) where- Lazy.WriterT f <.> Lazy.WriterT a = Lazy.WriterT $ flap <$> f <.> a where- flap ~(x,m) ~(y,n) = (x y, m <> n)--#if MIN_VERSION_transformers(0,5,6)--- | @since 5.3.6-instance (Bind m) => Apply (CPS.WriterT w m) where- mf <.> mx = mkWriterT $ \w ->- unWriterT mf w >>- \(f, w') -> unWriterT (f <$> mx) w'-#endif--instance Bind m => Apply (Strict.StateT s m) where- (<.>) = apDefault--instance Bind m => Apply (Lazy.StateT s m) where- (<.>) = apDefault---- | An @'Strict.RWST' r w s m@ is not 'Applicative' unless its @w@ is a 'Monoid', but it is an instance of 'Apply'-instance (Bind m, Semigroup w) => Apply (Strict.RWST r w s m) where- (<.>) = apDefault---- | An @'Lazy.RWST' r w s m@ is not 'Applicative' unless its @w@ is a 'Monoid', but it is an instance of 'Apply'-instance (Bind m, Semigroup w) => Apply (Lazy.RWST r w s m) where- (<.>) = apDefault--#if MIN_VERSION_transformers(0,5,6)--- | @since 5.3.6-instance (Bind m) => Apply (CPS.RWST r w s m) where- mf <.> mx = mkRWST $ \ r s w ->- unRWST mf r s w >>- \(f, s', w') -> unRWST (f <$> mx) r s' w'-#endif--instance Apply (ContT r m) where- ContT f <.> ContT v = ContT $ \k -> f $ \g -> v (k . g)--#ifdef MIN_VERSION_comonad--- | An @'EnvT' e w@ is not 'Applicative' unless its @e@ is a 'Monoid', but it is an instance of 'Apply'-instance (Semigroup e, Apply w) => Apply (EnvT e w) where- EnvT ef wf <.> EnvT ea wa = EnvT (ef <> ea) (wf <.> wa)---- | A @'StoreT' s w@ is not 'Applicative' unless its @s@ is a 'Monoid', but it is an instance of 'Apply'-instance (Apply w, Semigroup s) => Apply (StoreT s w) where- StoreT ff m <.> StoreT fa n = StoreT ((<*>) <$> ff <.> fa) (m <> n)--instance Apply w => Apply (TracedT m w) where- TracedT wf <.> TracedT wa = TracedT (ap <$> wf <.> wa)-#endif---- | Wrap an 'Applicative' to be used as a member of 'Apply'-newtype WrappedApplicative f a = WrapApplicative { unwrapApplicative :: f a }--instance Functor f => Functor (WrappedApplicative f) where- fmap f (WrapApplicative a) = WrapApplicative (f <$> a)--instance Applicative f => Apply (WrappedApplicative f) where- WrapApplicative f <.> WrapApplicative a = WrapApplicative (f <*> a)- WrapApplicative a <. WrapApplicative b = WrapApplicative (a <* b)- WrapApplicative a .> WrapApplicative b = WrapApplicative (a *> b)--instance Applicative f => Applicative (WrappedApplicative f) where- pure = WrapApplicative . pure- WrapApplicative f <*> WrapApplicative a = WrapApplicative (f <*> a)- WrapApplicative a <* WrapApplicative b = WrapApplicative (a <* b)- WrapApplicative a *> WrapApplicative b = WrapApplicative (a *> b)--instance Alternative f => Alternative (WrappedApplicative f) where- empty = WrapApplicative empty- WrapApplicative a <|> WrapApplicative b = WrapApplicative (a <|> b)---- | Transform an Apply into an Applicative by adding a unit.-newtype MaybeApply f a = MaybeApply { runMaybeApply :: Either (f a) a }---- | Apply a non-empty container of functions to a possibly-empty-with-unit container of values.-(<.*>) :: (Apply f) => f (a -> b) -> MaybeApply f a -> f b-ff <.*> MaybeApply (Left fa) = ff <.> fa-ff <.*> MaybeApply (Right a) = ($ a) <$> ff-infixl 4 <.*>---- | Apply a possibly-empty-with-unit container of functions to a non-empty container of values.-(<*.>) :: (Apply f) => MaybeApply f (a -> b) -> f a -> f b-MaybeApply (Left ff) <*.> fa = ff <.> fa-MaybeApply (Right f) <*.> fa = f <$> fa-infixl 4 <*.>---- | Traverse a 'Traversable' using 'Apply', getting the results back in a 'MaybeApply'.-traverse1Maybe :: (Traversable t, Apply f) => (a -> f b) -> t a -> MaybeApply f (t b)-traverse1Maybe f = traverse (MaybeApply . Left . f)--instance Functor f => Functor (MaybeApply f) where- fmap f (MaybeApply (Right a)) = MaybeApply (Right (f a ))- fmap f (MaybeApply (Left fa)) = MaybeApply (Left (f <$> fa))--instance Apply f => Apply (MaybeApply f) where- MaybeApply (Right f) <.> MaybeApply (Right a) = MaybeApply (Right (f a ))- MaybeApply (Right f) <.> MaybeApply (Left fa) = MaybeApply (Left (f <$> fa))- MaybeApply (Left ff) <.> MaybeApply (Right a) = MaybeApply (Left (($ a) <$> ff))- MaybeApply (Left ff) <.> MaybeApply (Left fa) = MaybeApply (Left (ff <.> fa))-- MaybeApply a <. MaybeApply (Right _) = MaybeApply a- MaybeApply (Right a) <. MaybeApply (Left fb) = MaybeApply (Left (a <$ fb))- MaybeApply (Left fa) <. MaybeApply (Left fb) = MaybeApply (Left (fa <. fb))-- MaybeApply (Right _) .> MaybeApply b = MaybeApply b- MaybeApply (Left fa) .> MaybeApply (Right b) = MaybeApply (Left (fa $> b ))- MaybeApply (Left fa) .> MaybeApply (Left fb) = MaybeApply (Left (fa .> fb))--instance Apply f => Applicative (MaybeApply f) where- pure a = MaybeApply (Right a)- (<*>) = (<.>)- (<* ) = (<. )- ( *>) = ( .>)--instance Extend f => Extend (MaybeApply f) where- duplicated w@(MaybeApply Right{}) = MaybeApply (Right w)- duplicated (MaybeApply (Left fa)) = MaybeApply (Left (extended (MaybeApply . Left) fa))--#ifdef MIN_VERSION_comonad-instance Comonad f => Comonad (MaybeApply f) where- duplicate w@(MaybeApply Right{}) = MaybeApply (Right w)- duplicate (MaybeApply (Left fa)) = MaybeApply (Left (extend (MaybeApply . Left) fa))- extract (MaybeApply (Left fa)) = extract fa- extract (MaybeApply (Right a)) = a--instance Apply (Cokleisli w a) where- Cokleisli f <.> Cokleisli a = Cokleisli (\w -> (f w) (a w))-#endif--instance Apply Down where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)--instance Apply Monoid.Sum where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)-instance Apply Monoid.Product where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)-instance Apply Monoid.Dual where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)-instance Apply Monoid.First where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)-instance Apply Monoid.Last where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)-deriving instance Apply f => Apply (Monoid.Alt f)--- in GHC 8.6 we'll have to deal with Apply f => Apply (Ap f) the same way-instance Apply Semigroup.First where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)-instance Apply Semigroup.Last where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)-instance Apply Semigroup.Min where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)-instance Apply Semigroup.Max where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)--instance (Apply f, Apply g) => Apply (f :*: g) where- (a :*: b) <.> (c :*: d) = (a <.> c) :*: (b <.> d)--deriving instance Apply f => Apply (M1 i t f)-deriving instance Apply f => Apply (Rec1 f)--instance (Apply f, Apply g) => Apply (f :.: g) where- Comp1 m <.> Comp1 n = Comp1 $ (<.>) <$> m <.> n--instance Apply U1 where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)---- | A @'K1' i c@ is not 'Applicative' unless its @c@ is a 'Monoid', but it is an instance of 'Apply'-instance Semigroup c => Apply (K1 i c) where- K1 a <.> K1 b = K1 (a <> b)- K1 a <. K1 b = K1 (a <> b)- K1 a .> K1 b = K1 (a <> b)-instance Apply Par1 where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)---- | A 'V1' is not 'Applicative', but it is an instance of 'Apply'-instance Apply Generics.V1 where- e <.> _ = case e of {}---- | A 'Monad' sans 'return'.------ Minimal definition: Either 'join' or '>>-'------ If defining both, then the following laws (the default definitions) must hold:------ > join = (>>- id)--- > m >>- f = join (fmap f m)------ Laws:------ > induced definition of <.>: f <.> x = f >>- (<$> x)------ Finally, there are two associativity conditions:------ > associativity of (>>-): (m >>- f) >>- g == m >>- (\x -> f x >>- g)--- > associativity of join: join . join = join . fmap join------ These can both be seen as special cases of the constraint that------ > associativity of (->-): (f ->- g) ->- h = f ->- (g ->- h)-----class Apply m => Bind m where- (>>-) :: m a -> (a -> m b) -> m b- m >>- f = join (fmap f m)-- join :: m (m a) -> m a- join = (>>- id)-- {-# MINIMAL (>>-) | join #-}--returning :: Functor f => f a -> (a -> b) -> f b-returning = flip fmap--apDefault :: Bind f => f (a -> b) -> f a -> f b-apDefault f x = f >>- \f' -> f' <$> x---- | A @'(,)' m@ is not a 'Monad' unless its @m@ is a 'Monoid', but it is an instance of 'Bind'-instance Semigroup m => Bind ((,) m) where- ~(m, a) >>- f = let (n, b) = f a in (m <> n, b)--#ifdef MIN_VERSION_tagged-instance Bind (Tagged a) where- Tagged a >>- f = f a- join (Tagged a) = a-#endif--instance Bind Proxy where- _ >>- _ = Proxy- join _ = Proxy--instance Bind (Either a) where- Left a >>- _ = Left a- Right a >>- f = f a--instance (Bind f, Bind g) => Bind (Functor.Product f g) where- Functor.Pair m n >>- f = Functor.Pair (m >>- fstP . f) (n >>- sndP . f) where- fstP (Functor.Pair a _) = a- sndP (Functor.Pair _ b) = b--instance Bind ((->)m) where- f >>- g = \e -> g (f e) e--instance Bind [] where- (>>-) = (>>=)--instance Bind NonEmpty where- (>>-) = (>>=)--instance Bind IO where- (>>-) = (>>=)--instance Bind Maybe where- (>>-) = (>>=)--#if !(MIN_VERSION_base(4,16,0))-instance Bind Option where- (>>-) = (>>=)-#endif--instance Bind Identity where- (>>-) = (>>=)--instance Bind Q where- (>>-) = (>>=)--instance Bind m => Bind (IdentityT m) where- IdentityT m >>- f = IdentityT (m >>- runIdentityT . f)--instance Monad m => Bind (WrappedMonad m) where- WrapMonad m >>- f = WrapMonad $ m >>= unwrapMonad . f--instance (Functor m, Monad m) => Bind (MaybeT m) where- (>>-) = (>>=) -- distributive law requires Monad to inject @Nothing@--#if !(MIN_VERSION_transformers(0,6,0))-instance (Apply m, Monad m) => Bind (ListT m) where- (>>-) = (>>=) -- distributive law requires Monad to inject @[]@--instance (Functor m, Monad m) => Bind (ErrorT e m) where- m >>- k = ErrorT $ do- a <- runErrorT m- case a of- Left l -> return (Left l)- Right r -> runErrorT (k r)-#endif--instance (Functor m, Monad m) => Bind (ExceptT e m) where- m >>- k = ExceptT $ do- a <- runExceptT m- case a of- Left l -> return (Left l)- Right r -> runExceptT (k r)--instance Bind m => Bind (ReaderT e m) where- ReaderT m >>- f = ReaderT $ \e -> m e >>- \x -> runReaderT (f x) e---- | A @'Lazy.WriterT' w m@ is not a 'Monad' unless its @w@ is a 'Monoid', but it is an instance of 'Bind'-instance (Bind m, Semigroup w) => Bind (Lazy.WriterT w m) where- m >>- k = Lazy.WriterT $- Lazy.runWriterT m >>- \ ~(a, w) ->- Lazy.runWriterT (k a) `returning` \ ~(b, w') ->- (b, w <> w')---- | A @'Strict.WriterT' w m@ is not a 'Monad' unless its @w@ is a 'Monoid', but it is an instance of 'Bind'-instance (Bind m, Semigroup w) => Bind (Strict.WriterT w m) where- m >>- k = Strict.WriterT $- Strict.runWriterT m >>- \ (a, w) ->- Strict.runWriterT (k a) `returning` \ (b, w') ->- (b, w <> w')--#if MIN_VERSION_transformers(0,5,6)--- | @since 5.3.6-instance (Bind m) => Bind (CPS.WriterT w m) where- m >>- k = mkWriterT $ \ w ->- unWriterT m w >>- \(a, w') -> unWriterT (k a) w'-#endif--instance Bind m => Bind (Lazy.StateT s m) where- m >>- k = Lazy.StateT $ \s ->- Lazy.runStateT m s >>- \ ~(a, s') ->- Lazy.runStateT (k a) s'--instance Bind m => Bind (Strict.StateT s m) where- m >>- k = Strict.StateT $ \s ->- Strict.runStateT m s >>- \ ~(a, s') ->- Strict.runStateT (k a) s'---- | An @'Lazy.RWST' r w s m@ is not a 'Monad' unless its @w@ is a 'Monoid', but it is an instance of 'Bind'-instance (Bind m, Semigroup w) => Bind (Lazy.RWST r w s m) where- m >>- k = Lazy.RWST $ \r s ->- Lazy.runRWST m r s >>- \ ~(a, s', w) ->- Lazy.runRWST (k a) r s' `returning` \ ~(b, s'', w') ->- (b, s'', w <> w')---- | An @'Strict.RWST' r w s m@ is not a 'Monad' unless its @w@ is a 'Monoid', but it is an instance of 'Bind'-instance (Bind m, Semigroup w) => Bind (Strict.RWST r w s m) where- m >>- k = Strict.RWST $ \r s ->- Strict.runRWST m r s >>- \ (a, s', w) ->- Strict.runRWST (k a) r s' `returning` \ (b, s'', w') ->- (b, s'', w <> w')--#if MIN_VERSION_transformers(0,5,6)--- | @since 5.3.6-instance (Bind m) => Bind (CPS.RWST r w s m) where- m >>- k = mkRWST $ \ r s w ->- unRWST m r s w >>- \(a, s', w') -> unRWST (k a) r s' w'-#endif--instance Bind (ContT r m) where- m >>- k = ContT $ \c -> runContT m $ \a -> runContT (k a) c--instance Bind Complex where- (a :+ b) >>- f = a' :+ b' where- a' :+ _ = f a- _ :+ b' = f b- {-# INLINE (>>-) #-}--#ifdef MIN_VERSION_containers--- | A 'Map k' is not a 'Monad', but it is an instance of 'Bind'-instance Ord k => Bind (Map k) where- m >>- f = Map.mapMaybeWithKey (\k -> Map.lookup k . f) m---- | An 'IntMap' is not a 'Monad', but it is an instance of 'Bind'-instance Bind IntMap where- m >>- f = IntMap.mapMaybeWithKey (\k -> IntMap.lookup k . f) m--instance Bind Seq where- (>>-) = (>>=)--instance Bind Tree where- (>>-) = (>>=)-#endif--#ifdef MIN_VERSION_unordered_containers--- | A 'HashMap k' is not a 'Monad', but it is an instance of 'Bind'-instance (Hashable k, Eq k) => Bind (HashMap k) where- -- this is needlessly painful- m >>- f = HashMap.fromList $ do- (k, a) <- HashMap.toList m- case HashMap.lookup k (f a) of- Just b -> [(k,b)]- Nothing -> []-#endif--instance Bind Down where Down a >>- f = f a--instance Bind Monoid.Sum where (>>-) = (>>=)-instance Bind Monoid.Product where (>>-) = (>>=)-instance Bind Monoid.Dual where (>>-) = (>>=)-instance Bind Monoid.First where (>>-) = (>>=)-instance Bind Monoid.Last where (>>-) = (>>=)-instance Bind f => Bind (Monoid.Alt f) where- Monoid.Alt m >>- k = Monoid.Alt (m >>- Monoid.getAlt . k)--- in GHC 8.6 we'll have to deal with Bind f => Bind (Ap f) the same way-instance Bind Semigroup.First where (>>-) = (>>=)-instance Bind Semigroup.Last where (>>-) = (>>=)-instance Bind Semigroup.Min where (>>-) = (>>=)-instance Bind Semigroup.Max where (>>-) = (>>=)--- | A 'V1' is not a 'Monad', but it is an instance of 'Bind'-instance Bind Generics.V1 where- m >>- _ = case m of {}---- | @since 5.3.8-instance Bind Generics.U1 where (>>-)=(>>=)---- | @since 5.3.8-instance Bind f => Bind (Generics.M1 i c f) where- M1 m >>- f = M1 $ m >>- \a -> case f a of- M1 m' -> m'---- | @since 5.3.8-instance Bind m => Bind (Generics.Rec1 m) where- Rec1 m >>- f = Rec1 $ m >>- \a -> case f a of- Rec1 m' -> m'---- | @since 5.3.8-instance Bind Generics.Par1 where- Par1 m >>- f = f m---- | @since 5.3.8-instance (Bind f, Bind g) => Bind (f :*: g) where- m :*: n >>- f = (m >>- fstP . f) :*: (n >>- sndP . f) where- fstP (a :*: _) = a- sndP (_ :*: b) = b--infixl 4 <<.>>, <<., .>>--class Bifunctor p => Biapply p where- (<<.>>) :: p (a -> b) (c -> d) -> p a c -> p b d-- -- |- -- @- -- a '.>' b ≡ 'const' 'id' '<$>' a '<.>' b- -- @- (.>>) :: p a b -> p c d -> p c d- a .>> b = bimap (const id) (const id) <<$>> a <<.>> b- {-# INLINE (.>>) #-}-- -- |- -- @- -- a '<.' b ≡ 'const' '<$>' a '<.>' b- -- @- (<<.) :: p a b -> p c d -> p a b- a <<. b = bimap const const <<$>> a <<.>> b- {-# INLINE (<<.) #-}--instance Biapply (,) where- (f, g) <<.>> (a, b) = (f a, g b)- {-# INLINE (<<.>>) #-}--instance Biapply Arg where- Arg f g <<.>> Arg a b = Arg (f a) (g b)- {-# INLINE (<<.>>) #-}--instance Semigroup x => Biapply ((,,) x) where- (x, f, g) <<.>> (x', a, b) = (x <> x', f a, g b)- {-# INLINE (<<.>>) #-}--instance (Semigroup x, Semigroup y) => Biapply ((,,,) x y) where- (x, y, f, g) <<.>> (x', y', a, b) = (x <> x', y <> y', f a, g b)- {-# INLINE (<<.>>) #-}--instance (Semigroup x, Semigroup y, Semigroup z) => Biapply ((,,,,) x y z) where- (x, y, z, f, g) <<.>> (x', y', z', a, b) = (x <> x', y <> y', z <> z', f a, g b)- {-# INLINE (<<.>>) #-}--instance Biapply Const where- Const f <<.>> Const x = Const (f x)- {-# INLINE (<<.>>) #-}--#ifdef MIN_VERSION_tagged-instance Biapply Tagged where- Tagged f <<.>> Tagged x = Tagged (f x)- {-# INLINE (<<.>>) #-}-#endif--instance (Biapply p, Apply f, Apply g) => Biapply (Biff p f g) where- Biff fg <<.>> Biff xy = Biff (bimap (<.>) (<.>) fg <<.>> xy)- {-# INLINE (<<.>>) #-}--instance Apply f => Biapply (Clown f) where- Clown fg <<.>> Clown xy = Clown (fg <.> xy)- {-# INLINE (<<.>>) #-}--instance Biapply p => Biapply (Flip p) where- Flip fg <<.>> Flip xy = Flip (fg <<.>> xy)- {-# INLINE (<<.>>) #-}--instance Apply g => Biapply (Joker g) where- Joker fg <<.>> Joker xy = Joker (fg <.> xy)- {-# INLINE (<<.>>) #-}---- orphan mess-instance Biapply p => Apply (Join p) where- Join f <.> Join a = Join (f <<.>> a)- {-# INLINE (<.>) #-}- Join a .> Join b = Join (a .>> b)- {-# INLINE (.>) #-}- Join a <. Join b = Join (a <<. b)- {-# INLINE (<.) #-}--instance (Biapply p, Biapply q) => Biapply (Bifunctor.Product p q) where- Bifunctor.Pair w x <<.>> Bifunctor.Pair y z = Bifunctor.Pair (w <<.>> y) (x <<.>> z)- {-# INLINE (<<.>>) #-}--instance (Apply f, Biapply p) => Biapply (Tannen f p) where- Tannen fg <<.>> Tannen xy = Tannen ((<<.>>) <$> fg <.> xy)- {-# INLINE (<<.>>) #-}--instance Biapply p => Biapply (WrappedBifunctor p) where- WrapBifunctor fg <<.>> WrapBifunctor xy = WrapBifunctor (fg <<.>> xy)- {-# INLINE (<<.>>) #-}+{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_HADDOCK not-home #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2018 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +-- This module is used to resolve the cyclic we get from defining these +-- classes here rather than in a package upstream. Otherwise we'd get +-- orphaned heads for many instances on the types in @transformers@ and @bifunctors@. +---------------------------------------------------------------------------- +module Data.Functor.Bind.Class ( + -- * Applyable functors + Apply(..) + -- * Wrappers + , WrappedApplicative(..) + , MaybeApply(..) + , (<.*>) + , (<*.>) + , traverse1Maybe + -- * Bindable functors + , Bind(..) + , apDefault + , returning + -- * Biappliable bifunctors + , Biapply(..) + ) where + +import Data.Semigroup +import Control.Applicative +import Control.Applicative.Backwards +import Control.Applicative.Lift +import Control.Arrow +import Control.Category +import Control.Monad (ap) +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Except +import Control.Monad.Trans.Identity +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +#if MIN_VERSION_transformers(0,5,6) +import qualified Control.Monad.Trans.RWS.CPS as CPS +import qualified Control.Monad.Trans.Writer.CPS as CPS +import Semigroupoids.Internal +#endif +import qualified Control.Monad.Trans.RWS.Lazy as Lazy +import qualified Control.Monad.Trans.State.Lazy as Lazy +import qualified Control.Monad.Trans.Writer.Lazy as Lazy +import qualified Control.Monad.Trans.RWS.Strict as Strict +import qualified Control.Monad.Trans.State.Strict as Strict +import qualified Control.Monad.Trans.Writer.Strict as Strict +import Data.Biapplicative +import Data.Bifunctor.Biff +import Data.Bifunctor.Clown +import Data.Bifunctor.Flip +import Data.Bifunctor.Joker +import Data.Bifunctor.Join +import Data.Bifunctor.Product as Bifunctor +import Data.Bifunctor.Tannen +import Data.Bifunctor.Wrapped +import Data.Complex +import Data.Functor.Compose +import Data.Functor.Constant +import Data.Functor.Identity +import Data.Functor.Product as Functor +import Data.Functor.Reverse +import Data.Functor.Extend +import Data.List.NonEmpty (NonEmpty) +import Data.Ord (Down (..)) +import Data.Proxy +import Data.Semigroup as Semigroup +import qualified Data.Monoid as Monoid +import Data.Orphans () +import GHC.Generics as Generics +import Language.Haskell.TH (Q) +import Prelude hiding (id, (.)) + +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.Error +import Control.Monad.Trans.List +#endif + +#ifdef MIN_VERSION_containers +import qualified Data.IntMap as IntMap +import Data.IntMap (IntMap) +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Sequence (Seq) +import Data.Tree (Tree) +#endif + +#ifdef MIN_VERSION_tagged +import Data.Tagged +#endif + +#ifdef MIN_VERSION_unordered_containers +import Data.Hashable +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as HashMap +#endif + +#ifdef MIN_VERSION_comonad +import Control.Comonad +import Control.Comonad.Trans.Env +import Control.Comonad.Trans.Store +import Control.Comonad.Trans.Traced +#else +($>) :: Functor f => f a -> b -> f b +($>) = flip (<$) +#endif + +infixl 1 >>- +infixl 4 <.>, <., .> + +-- | A strong lax semi-monoidal endofunctor. +-- This is equivalent to an 'Applicative' without 'pure'. +-- +-- Laws: +-- +-- @ +-- ('.') '<$>' u '<.>' v '<.>' w = u '<.>' (v '<.>' w) +-- x '<.>' (f '<$>' y) = ('.' f) '<$>' x '<.>' y +-- f '<$>' (x '<.>' y) = (f '.') '<$>' x '<.>' y +-- @ +-- +-- The laws imply that `.>` and `<.` really ignore their +-- left and right results, respectively, and really +-- return their right and left results, respectively. +-- Specifically, +-- +-- @ +-- (mf '<$>' m) '.>' (nf '<$>' n) = nf '<$>' (m '.>' n) +-- (mf '<$>' m) '<.' (nf '<$>' n) = mf '<$>' (m '<.' n) +-- @ +class Functor f => Apply f where + (<.>) :: f (a -> b) -> f a -> f b + (<.>) = liftF2 id + + -- | @ a '.>' b = 'const' 'id' '<$>' a '<.>' b @ + (.>) :: f a -> f b -> f b + a .> b = const id <$> a <.> b + + -- | @ a '<.' b = 'const' '<$>' a '<.>' b @ + (<.) :: f a -> f b -> f a + a <. b = const <$> a <.> b + + -- | Lift a binary function into a comonad with zipping + liftF2 :: (a -> b -> c) -> f a -> f b -> f c + liftF2 f a b = f <$> a <.> b + {-# INLINE liftF2 #-} + + {-# MINIMAL (<.>) | liftF2 #-} + +#ifdef MIN_VERSION_tagged +instance Apply (Tagged a) where + (<.>) = (<*>) + (<.) = (<*) + (.>) = (*>) +#endif + +instance Apply Proxy where + (<.>) = (<*>) + (<.) = (<*) + (.>) = (*>) + +instance Apply f => Apply (Backwards f) where + Backwards f <.> Backwards a = Backwards (flip id <$> a <.> f) + +instance (Apply f, Apply g) => Apply (Compose f g) where + Compose f <.> Compose x = Compose ((<.>) <$> f <.> x) + +-- | A @'Constant' f@ is not 'Applicative' unless its @f@ is a 'Monoid', but it is an instance of 'Apply' +instance Semigroup f => Apply (Constant f) where + Constant a <.> Constant b = Constant (a <> b) + Constant a <. Constant b = Constant (a <> b) + Constant a .> Constant b = Constant (a <> b) + +instance Apply f => Apply (Lift f) where + Pure f <.> Pure x = Pure (f x) + Pure f <.> Other y = Other (f <$> y) + Other f <.> Pure x = Other (($ x) <$> f) + Other f <.> Other y = Other (f <.> y) + +instance (Apply f, Apply g) => Apply (Functor.Product f g) where + Functor.Pair f g <.> Functor.Pair x y = Functor.Pair (f <.> x) (g <.> y) + +instance Apply f => Apply (Reverse f) where + Reverse a <.> Reverse b = Reverse (a <.> b) + +-- | A @'(,)' m@ is not 'Applicative' unless its @m@ is a 'Monoid', but it is an instance of 'Apply' +instance Semigroup m => Apply ((,)m) where + (m, f) <.> (n, a) = (m <> n, f a) + (m, a) <. (n, _) = (m <> n, a) + (m, _) .> (n, b) = (m <> n, b) + +instance Apply NonEmpty where + (<.>) = ap + +instance Apply (Either a) where + Left a <.> _ = Left a + Right _ <.> Left a = Left a + Right f <.> Right b = Right (f b) + + Left a <. _ = Left a + Right _ <. Left a = Left a + Right a <. Right _ = Right a + + Left a .> _ = Left a + Right _ .> Left a = Left a + Right _ .> Right b = Right b + +-- | A @'Const' m@ is not 'Applicative' unless its @m@ is a 'Monoid', but it is an instance of 'Apply' +instance Semigroup m => Apply (Const m) where + Const m <.> Const n = Const (m <> n) + Const m <. Const n = Const (m <> n) + Const m .> Const n = Const (m <> n) + +instance Apply ((->)m) where + (<.>) = (<*>) + (<. ) = (<* ) + ( .>) = ( *>) + +instance Apply ZipList where + (<.>) = (<*>) + (<. ) = (<* ) + ( .>) = ( *>) + +instance Apply [] where + (<.>) = (<*>) + (<. ) = (<* ) + ( .>) = ( *>) + +instance Apply IO where + (<.>) = (<*>) + (<. ) = (<* ) + ( .>) = ( *>) + +instance Apply Maybe where + (<.>) = (<*>) + (<. ) = (<* ) + ( .>) = ( *>) + +#if !(MIN_VERSION_base(4,16,0)) +instance Apply Option where + (<.>) = (<*>) + (<. ) = (<* ) + ( .>) = ( *>) +#endif + +instance Apply Identity where + (<.>) = (<*>) + (<. ) = (<* ) + ( .>) = ( *>) + +instance Apply w => Apply (IdentityT w) where + IdentityT wa <.> IdentityT wb = IdentityT (wa <.> wb) + +instance Monad m => Apply (WrappedMonad m) where + (<.>) = (<*>) + (<. ) = (<* ) + ( .>) = ( *>) + +instance Arrow a => Apply (WrappedArrow a b) where + (<.>) = (<*>) + (<. ) = (<* ) + ( .>) = ( *>) + +instance Apply Complex where + (a :+ b) <.> (c :+ d) = a c :+ b d + +-- Applicative Q was only added in template-haskell 2.7 (GHC 7.4), so +-- define in terms of Monad instead. +instance Apply Q where + (<.>) = ap + +#ifdef MIN_VERSION_containers +-- | A 'Map k' is not 'Applicative', but it is an instance of 'Apply' +instance Ord k => Apply (Map k) where + (<.>) = Map.intersectionWith id + (<. ) = Map.intersectionWith const + ( .>) = Map.intersectionWith (const id) + +-- | An 'IntMap' is not 'Applicative', but it is an instance of 'Apply' +instance Apply IntMap where + (<.>) = IntMap.intersectionWith id + (<. ) = IntMap.intersectionWith const + ( .>) = IntMap.intersectionWith (const id) + +instance Apply Seq where + (<.>) = ap + +instance Apply Tree where + (<.>) = (<*>) + (<. ) = (<* ) + ( .>) = ( *>) +#endif + +#ifdef MIN_VERSION_unordered_containers +-- | A 'HashMap k' is not 'Applicative', but it is an instance of 'Apply' +instance (Hashable k, Eq k) => Apply (HashMap k) where + (<.>) = HashMap.intersectionWith id +#endif + +-- MaybeT is _not_ the same as Compose f Maybe +instance (Functor m, Monad m) => Apply (MaybeT m) where + (<.>) = apDefault + +#if !(MIN_VERSION_transformers(0,6,0)) +-- ErrorT e is _not_ the same as Compose f (Either e) +instance (Functor m, Monad m) => Apply (ErrorT e m) where + (<.>) = apDefault + +instance Apply m => Apply (ListT m) where + ListT f <.> ListT a = ListT $ (<.>) <$> f <.> a +#endif + +instance (Functor m, Monad m) => Apply (ExceptT e m) where + (<.>) = apDefault + +instance Apply m => Apply (ReaderT e m) where + ReaderT f <.> ReaderT a = ReaderT $ \e -> f e <.> a e + +-- unfortunately, WriterT has its wrapped product in the wrong order to just use (<.>) instead of flap +-- | A @'Strict.WriterT' w m@ is not 'Applicative' unless its @w@ is a 'Monoid', but it is an instance of 'Apply' +instance (Apply m, Semigroup w) => Apply (Strict.WriterT w m) where + Strict.WriterT f <.> Strict.WriterT a = Strict.WriterT $ flap <$> f <.> a where + flap (x,m) (y,n) = (x y, m <> n) + +-- | A @'Lazy.WriterT' w m@ is not 'Applicative' unless its @w@ is a 'Monoid', but it is an instance of 'Apply' +instance (Apply m, Semigroup w) => Apply (Lazy.WriterT w m) where + Lazy.WriterT f <.> Lazy.WriterT a = Lazy.WriterT $ flap <$> f <.> a where + flap ~(x,m) ~(y,n) = (x y, m <> n) + +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance (Bind m) => Apply (CPS.WriterT w m) where + mf <.> mx = mkWriterT $ \w -> + unWriterT mf w >>- \(f, w') -> unWriterT (f <$> mx) w' +#endif + +instance Bind m => Apply (Strict.StateT s m) where + (<.>) = apDefault + +instance Bind m => Apply (Lazy.StateT s m) where + (<.>) = apDefault + +-- | An @'Strict.RWST' r w s m@ is not 'Applicative' unless its @w@ is a 'Monoid', but it is an instance of 'Apply' +instance (Bind m, Semigroup w) => Apply (Strict.RWST r w s m) where + (<.>) = apDefault + +-- | An @'Lazy.RWST' r w s m@ is not 'Applicative' unless its @w@ is a 'Monoid', but it is an instance of 'Apply' +instance (Bind m, Semigroup w) => Apply (Lazy.RWST r w s m) where + (<.>) = apDefault + +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance (Bind m) => Apply (CPS.RWST r w s m) where + mf <.> mx = mkRWST $ \ r s w -> + unRWST mf r s w >>- \(f, s', w') -> unRWST (f <$> mx) r s' w' +#endif + +instance Apply (ContT r m) where + ContT f <.> ContT v = ContT $ \k -> f $ \g -> v (k . g) + +#ifdef MIN_VERSION_comonad +-- | An @'EnvT' e w@ is not 'Applicative' unless its @e@ is a 'Monoid', but it is an instance of 'Apply' +instance (Semigroup e, Apply w) => Apply (EnvT e w) where + EnvT ef wf <.> EnvT ea wa = EnvT (ef <> ea) (wf <.> wa) + +-- | A @'StoreT' s w@ is not 'Applicative' unless its @s@ is a 'Monoid', but it is an instance of 'Apply' +instance (Apply w, Semigroup s) => Apply (StoreT s w) where + StoreT ff m <.> StoreT fa n = StoreT ((<*>) <$> ff <.> fa) (m <> n) + +instance Apply w => Apply (TracedT m w) where + TracedT wf <.> TracedT wa = TracedT (ap <$> wf <.> wa) +#endif + +-- | Wrap an 'Applicative' to be used as a member of 'Apply' +newtype WrappedApplicative f a = WrapApplicative { unwrapApplicative :: f a } + +instance Functor f => Functor (WrappedApplicative f) where + fmap f (WrapApplicative a) = WrapApplicative (f <$> a) + +instance Applicative f => Apply (WrappedApplicative f) where + WrapApplicative f <.> WrapApplicative a = WrapApplicative (f <*> a) + WrapApplicative a <. WrapApplicative b = WrapApplicative (a <* b) + WrapApplicative a .> WrapApplicative b = WrapApplicative (a *> b) + +instance Applicative f => Applicative (WrappedApplicative f) where + pure = WrapApplicative . pure + WrapApplicative f <*> WrapApplicative a = WrapApplicative (f <*> a) + WrapApplicative a <* WrapApplicative b = WrapApplicative (a <* b) + WrapApplicative a *> WrapApplicative b = WrapApplicative (a *> b) + +instance Alternative f => Alternative (WrappedApplicative f) where + empty = WrapApplicative empty + WrapApplicative a <|> WrapApplicative b = WrapApplicative (a <|> b) + +-- | Transform an Apply into an Applicative by adding a unit. +newtype MaybeApply f a = MaybeApply { runMaybeApply :: Either (f a) a } + +-- | Apply a non-empty container of functions to a possibly-empty-with-unit container of values. +(<.*>) :: (Apply f) => f (a -> b) -> MaybeApply f a -> f b +ff <.*> MaybeApply (Left fa) = ff <.> fa +ff <.*> MaybeApply (Right a) = ($ a) <$> ff +infixl 4 <.*> + +-- | Apply a possibly-empty-with-unit container of functions to a non-empty container of values. +(<*.>) :: (Apply f) => MaybeApply f (a -> b) -> f a -> f b +MaybeApply (Left ff) <*.> fa = ff <.> fa +MaybeApply (Right f) <*.> fa = f <$> fa +infixl 4 <*.> + +-- | Traverse a 'Traversable' using 'Apply', getting the results back in a 'MaybeApply'. +traverse1Maybe :: (Traversable t, Apply f) => (a -> f b) -> t a -> MaybeApply f (t b) +traverse1Maybe f = traverse (MaybeApply . Left . f) + +instance Functor f => Functor (MaybeApply f) where + fmap f (MaybeApply (Right a)) = MaybeApply (Right (f a )) + fmap f (MaybeApply (Left fa)) = MaybeApply (Left (f <$> fa)) + +instance Apply f => Apply (MaybeApply f) where + MaybeApply (Right f) <.> MaybeApply (Right a) = MaybeApply (Right (f a )) + MaybeApply (Right f) <.> MaybeApply (Left fa) = MaybeApply (Left (f <$> fa)) + MaybeApply (Left ff) <.> MaybeApply (Right a) = MaybeApply (Left (($ a) <$> ff)) + MaybeApply (Left ff) <.> MaybeApply (Left fa) = MaybeApply (Left (ff <.> fa)) + + MaybeApply a <. MaybeApply (Right _) = MaybeApply a + MaybeApply (Right a) <. MaybeApply (Left fb) = MaybeApply (Left (a <$ fb)) + MaybeApply (Left fa) <. MaybeApply (Left fb) = MaybeApply (Left (fa <. fb)) + + MaybeApply (Right _) .> MaybeApply b = MaybeApply b + MaybeApply (Left fa) .> MaybeApply (Right b) = MaybeApply (Left (fa $> b )) + MaybeApply (Left fa) .> MaybeApply (Left fb) = MaybeApply (Left (fa .> fb)) + +instance Apply f => Applicative (MaybeApply f) where + pure a = MaybeApply (Right a) + (<*>) = (<.>) + (<* ) = (<. ) + ( *>) = ( .>) + +instance Extend f => Extend (MaybeApply f) where + duplicated w@(MaybeApply Right{}) = MaybeApply (Right w) + duplicated (MaybeApply (Left fa)) = MaybeApply (Left (extended (MaybeApply . Left) fa)) + +#ifdef MIN_VERSION_comonad +instance Comonad f => Comonad (MaybeApply f) where + duplicate w@(MaybeApply Right{}) = MaybeApply (Right w) + duplicate (MaybeApply (Left fa)) = MaybeApply (Left (extend (MaybeApply . Left) fa)) + extract (MaybeApply (Left fa)) = extract fa + extract (MaybeApply (Right a)) = a + +instance Apply (Cokleisli w a) where + Cokleisli f <.> Cokleisli a = Cokleisli (\w -> (f w) (a w)) +#endif + +instance Apply Down where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) + +instance Apply Monoid.Sum where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) +instance Apply Monoid.Product where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) +instance Apply Monoid.Dual where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) +instance Apply Monoid.First where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) +instance Apply Monoid.Last where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) +deriving instance Apply f => Apply (Monoid.Alt f) +-- in GHC 8.6 we'll have to deal with Apply f => Apply (Ap f) the same way +instance Apply Semigroup.First where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) +instance Apply Semigroup.Last where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) +instance Apply Semigroup.Min where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) +instance Apply Semigroup.Max where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) + +instance (Apply f, Apply g) => Apply (f :*: g) where + (a :*: b) <.> (c :*: d) = (a <.> c) :*: (b <.> d) + +deriving instance Apply f => Apply (M1 i t f) +deriving instance Apply f => Apply (Rec1 f) + +instance (Apply f, Apply g) => Apply (f :.: g) where + Comp1 m <.> Comp1 n = Comp1 $ (<.>) <$> m <.> n + +instance Apply U1 where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) + +-- | A @'K1' i c@ is not 'Applicative' unless its @c@ is a 'Monoid', but it is an instance of 'Apply' +instance Semigroup c => Apply (K1 i c) where + K1 a <.> K1 b = K1 (a <> b) + K1 a <. K1 b = K1 (a <> b) + K1 a .> K1 b = K1 (a <> b) +instance Apply Par1 where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) + +-- | A 'V1' is not 'Applicative', but it is an instance of 'Apply' +instance Apply Generics.V1 where + e <.> _ = case e of {} + +-- | A 'Monad' sans 'return'. +-- +-- Minimal definition: Either 'join' or '>>-' +-- +-- If defining both, then the following laws (the default definitions) must hold: +-- +-- > join = (>>- id) +-- > m >>- f = join (fmap f m) +-- +-- Laws: +-- +-- > induced definition of <.>: f <.> x = f >>- (<$> x) +-- +-- Finally, there are two associativity conditions: +-- +-- > associativity of (>>-): (m >>- f) >>- g == m >>- (\x -> f x >>- g) +-- > associativity of join: join . join = join . fmap join +-- +-- These can both be seen as special cases of the constraint that +-- +-- > associativity of (->-): (f ->- g) ->- h = f ->- (g ->- h) +-- + +class Apply m => Bind m where + (>>-) :: m a -> (a -> m b) -> m b + m >>- f = join (fmap f m) + + join :: m (m a) -> m a + join = (>>- id) + + {-# MINIMAL (>>-) | join #-} + +returning :: Functor f => f a -> (a -> b) -> f b +returning = flip fmap + +apDefault :: Bind f => f (a -> b) -> f a -> f b +apDefault f x = f >>- \f' -> f' <$> x + +-- | A @'(,)' m@ is not a 'Monad' unless its @m@ is a 'Monoid', but it is an instance of 'Bind' +instance Semigroup m => Bind ((,) m) where + ~(m, a) >>- f = let (n, b) = f a in (m <> n, b) + +#ifdef MIN_VERSION_tagged +instance Bind (Tagged a) where + Tagged a >>- f = f a + join (Tagged a) = a +#endif + +instance Bind Proxy where + _ >>- _ = Proxy + join _ = Proxy + +instance Bind (Either a) where + Left a >>- _ = Left a + Right a >>- f = f a + +instance (Bind f, Bind g) => Bind (Functor.Product f g) where + Functor.Pair m n >>- f = Functor.Pair (m >>- fstP . f) (n >>- sndP . f) where + fstP (Functor.Pair a _) = a + sndP (Functor.Pair _ b) = b + +instance Bind ((->)m) where + f >>- g = \e -> g (f e) e + +instance Bind [] where + (>>-) = (>>=) + +instance Bind NonEmpty where + (>>-) = (>>=) + +instance Bind IO where + (>>-) = (>>=) + +instance Bind Maybe where + (>>-) = (>>=) + +#if !(MIN_VERSION_base(4,16,0)) +instance Bind Option where + (>>-) = (>>=) +#endif + +instance Bind Identity where + (>>-) = (>>=) + +instance Bind Q where + (>>-) = (>>=) + +instance Bind m => Bind (IdentityT m) where + IdentityT m >>- f = IdentityT (m >>- runIdentityT . f) + +instance Monad m => Bind (WrappedMonad m) where + WrapMonad m >>- f = WrapMonad $ m >>= unwrapMonad . f + +instance (Functor m, Monad m) => Bind (MaybeT m) where + (>>-) = (>>=) -- distributive law requires Monad to inject @Nothing@ + +#if !(MIN_VERSION_transformers(0,6,0)) +instance (Apply m, Monad m) => Bind (ListT m) where + (>>-) = (>>=) -- distributive law requires Monad to inject @[]@ + +instance (Functor m, Monad m) => Bind (ErrorT e m) where + m >>- k = ErrorT $ do + a <- runErrorT m + case a of + Left l -> return (Left l) + Right r -> runErrorT (k r) +#endif + +instance (Functor m, Monad m) => Bind (ExceptT e m) where + m >>- k = ExceptT $ do + a <- runExceptT m + case a of + Left l -> return (Left l) + Right r -> runExceptT (k r) + +instance Bind m => Bind (ReaderT e m) where + ReaderT m >>- f = ReaderT $ \e -> m e >>- \x -> runReaderT (f x) e + +-- | A @'Lazy.WriterT' w m@ is not a 'Monad' unless its @w@ is a 'Monoid', but it is an instance of 'Bind' +instance (Bind m, Semigroup w) => Bind (Lazy.WriterT w m) where + m >>- k = Lazy.WriterT $ + Lazy.runWriterT m >>- \ ~(a, w) -> + Lazy.runWriterT (k a) `returning` \ ~(b, w') -> + (b, w <> w') + +-- | A @'Strict.WriterT' w m@ is not a 'Monad' unless its @w@ is a 'Monoid', but it is an instance of 'Bind' +instance (Bind m, Semigroup w) => Bind (Strict.WriterT w m) where + m >>- k = Strict.WriterT $ + Strict.runWriterT m >>- \ (a, w) -> + Strict.runWriterT (k a) `returning` \ (b, w') -> + (b, w <> w') + +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance (Bind m) => Bind (CPS.WriterT w m) where + m >>- k = mkWriterT $ \ w -> + unWriterT m w >>- \(a, w') -> unWriterT (k a) w' +#endif + +instance Bind m => Bind (Lazy.StateT s m) where + m >>- k = Lazy.StateT $ \s -> + Lazy.runStateT m s >>- \ ~(a, s') -> + Lazy.runStateT (k a) s' + +instance Bind m => Bind (Strict.StateT s m) where + m >>- k = Strict.StateT $ \s -> + Strict.runStateT m s >>- \ ~(a, s') -> + Strict.runStateT (k a) s' + +-- | An @'Lazy.RWST' r w s m@ is not a 'Monad' unless its @w@ is a 'Monoid', but it is an instance of 'Bind' +instance (Bind m, Semigroup w) => Bind (Lazy.RWST r w s m) where + m >>- k = Lazy.RWST $ \r s -> + Lazy.runRWST m r s >>- \ ~(a, s', w) -> + Lazy.runRWST (k a) r s' `returning` \ ~(b, s'', w') -> + (b, s'', w <> w') + +-- | An @'Strict.RWST' r w s m@ is not a 'Monad' unless its @w@ is a 'Monoid', but it is an instance of 'Bind' +instance (Bind m, Semigroup w) => Bind (Strict.RWST r w s m) where + m >>- k = Strict.RWST $ \r s -> + Strict.runRWST m r s >>- \ (a, s', w) -> + Strict.runRWST (k a) r s' `returning` \ (b, s'', w') -> + (b, s'', w <> w') + +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance (Bind m) => Bind (CPS.RWST r w s m) where + m >>- k = mkRWST $ \ r s w -> + unRWST m r s w >>- \(a, s', w') -> unRWST (k a) r s' w' +#endif + +instance Bind (ContT r m) where + m >>- k = ContT $ \c -> runContT m $ \a -> runContT (k a) c + +instance Bind Complex where + (a :+ b) >>- f = a' :+ b' where + a' :+ _ = f a + _ :+ b' = f b + {-# INLINE (>>-) #-} + +#ifdef MIN_VERSION_containers +-- | A 'Map k' is not a 'Monad', but it is an instance of 'Bind' +instance Ord k => Bind (Map k) where + m >>- f = Map.mapMaybeWithKey (\k -> Map.lookup k . f) m + +-- | An 'IntMap' is not a 'Monad', but it is an instance of 'Bind' +instance Bind IntMap where + m >>- f = IntMap.mapMaybeWithKey (\k -> IntMap.lookup k . f) m + +instance Bind Seq where + (>>-) = (>>=) + +instance Bind Tree where + (>>-) = (>>=) +#endif + +#ifdef MIN_VERSION_unordered_containers +-- | A 'HashMap k' is not a 'Monad', but it is an instance of 'Bind' +instance (Hashable k, Eq k) => Bind (HashMap k) where + -- this is needlessly painful + m >>- f = HashMap.fromList $ do + (k, a) <- HashMap.toList m + case HashMap.lookup k (f a) of + Just b -> [(k,b)] + Nothing -> [] +#endif + +instance Bind Down where Down a >>- f = f a + +instance Bind Monoid.Sum where (>>-) = (>>=) +instance Bind Monoid.Product where (>>-) = (>>=) +instance Bind Monoid.Dual where (>>-) = (>>=) +instance Bind Monoid.First where (>>-) = (>>=) +instance Bind Monoid.Last where (>>-) = (>>=) +instance Bind f => Bind (Monoid.Alt f) where + Monoid.Alt m >>- k = Monoid.Alt (m >>- Monoid.getAlt . k) +-- in GHC 8.6 we'll have to deal with Bind f => Bind (Ap f) the same way +instance Bind Semigroup.First where (>>-) = (>>=) +instance Bind Semigroup.Last where (>>-) = (>>=) +instance Bind Semigroup.Min where (>>-) = (>>=) +instance Bind Semigroup.Max where (>>-) = (>>=) +-- | A 'V1' is not a 'Monad', but it is an instance of 'Bind' +instance Bind Generics.V1 where + m >>- _ = case m of {} + +-- | @since 5.3.8 +instance Bind Generics.U1 where (>>-)=(>>=) + +-- | @since 5.3.8 +instance Bind f => Bind (Generics.M1 i c f) where + M1 m >>- f = M1 $ m >>- \a -> case f a of + M1 m' -> m' + +-- | @since 5.3.8 +instance Bind m => Bind (Generics.Rec1 m) where + Rec1 m >>- f = Rec1 $ m >>- \a -> case f a of + Rec1 m' -> m' + +-- | @since 5.3.8 +instance Bind Generics.Par1 where + Par1 m >>- f = f m + +-- | @since 5.3.8 +instance (Bind f, Bind g) => Bind (f :*: g) where + m :*: n >>- f = (m >>- fstP . f) :*: (n >>- sndP . f) where + fstP (a :*: _) = a + sndP (_ :*: b) = b + +infixl 4 <<.>>, <<., .>> + +class Bifunctor p => Biapply p where + (<<.>>) :: p (a -> b) (c -> d) -> p a c -> p b d + + -- | + -- @ + -- a '.>' b ≡ 'const' 'id' '<$>' a '<.>' b + -- @ + (.>>) :: p a b -> p c d -> p c d + a .>> b = bimap (const id) (const id) <<$>> a <<.>> b + {-# INLINE (.>>) #-} + + -- | + -- @ + -- a '<.' b ≡ 'const' '<$>' a '<.>' b + -- @ + (<<.) :: p a b -> p c d -> p a b + a <<. b = bimap const const <<$>> a <<.>> b + {-# INLINE (<<.) #-} + +instance Biapply (,) where + (f, g) <<.>> (a, b) = (f a, g b) + {-# INLINE (<<.>>) #-} + +instance Biapply Arg where + Arg f g <<.>> Arg a b = Arg (f a) (g b) + {-# INLINE (<<.>>) #-} + +instance Semigroup x => Biapply ((,,) x) where + (x, f, g) <<.>> (x', a, b) = (x <> x', f a, g b) + {-# INLINE (<<.>>) #-} + +instance (Semigroup x, Semigroup y) => Biapply ((,,,) x y) where + (x, y, f, g) <<.>> (x', y', a, b) = (x <> x', y <> y', f a, g b) + {-# INLINE (<<.>>) #-} + +instance (Semigroup x, Semigroup y, Semigroup z) => Biapply ((,,,,) x y z) where + (x, y, z, f, g) <<.>> (x', y', z', a, b) = (x <> x', y <> y', z <> z', f a, g b) + {-# INLINE (<<.>>) #-} + +instance Biapply Const where + Const f <<.>> Const x = Const (f x) + {-# INLINE (<<.>>) #-} + +#ifdef MIN_VERSION_tagged +instance Biapply Tagged where + Tagged f <<.>> Tagged x = Tagged (f x) + {-# INLINE (<<.>>) #-} +#endif + +instance (Biapply p, Apply f, Apply g) => Biapply (Biff p f g) where + Biff fg <<.>> Biff xy = Biff (bimap (<.>) (<.>) fg <<.>> xy) + {-# INLINE (<<.>>) #-} + +instance Apply f => Biapply (Clown f) where + Clown fg <<.>> Clown xy = Clown (fg <.> xy) + {-# INLINE (<<.>>) #-} + +instance Biapply p => Biapply (Flip p) where + Flip fg <<.>> Flip xy = Flip (fg <<.>> xy) + {-# INLINE (<<.>>) #-} + +instance Apply g => Biapply (Joker g) where + Joker fg <<.>> Joker xy = Joker (fg <.> xy) + {-# INLINE (<<.>>) #-} + +-- orphan mess +instance Biapply p => Apply (Join p) where + Join f <.> Join a = Join (f <<.>> a) + {-# INLINE (<.>) #-} + Join a .> Join b = Join (a .>> b) + {-# INLINE (.>) #-} + Join a <. Join b = Join (a <<. b) + {-# INLINE (<.) #-} + +instance (Biapply p, Biapply q) => Biapply (Bifunctor.Product p q) where + Bifunctor.Pair w x <<.>> Bifunctor.Pair y z = Bifunctor.Pair (w <<.>> y) (x <<.>> z) + {-# INLINE (<<.>>) #-} + +instance (Apply f, Biapply p) => Biapply (Tannen f p) where + Tannen fg <<.>> Tannen xy = Tannen ((<<.>>) <$> fg <.> xy) + {-# INLINE (<<.>>) #-} + +instance Biapply p => Biapply (WrappedBifunctor p) where + WrapBifunctor fg <<.>> WrapBifunctor xy = WrapBifunctor (fg <<.>> xy) + {-# INLINE (<<.>>) #-}
src/Data/Functor/Bind/Trans.hs view
@@ -1,85 +1,85 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE Safe #-}--------------------------------------------------------------------------------- |--- Module : Data.Functor.Bind.Trans--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Functor.Bind.Trans (- BindTrans(..)- ) where---- import _everything_-import Control.Category-import Control.Monad.Trans.Class-import Control.Monad.Trans.Cont--- import Control.Monad.Trans.Error-import Control.Monad.Trans.Identity--- import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Reader--- import Control.Monad.Trans.List-#if MIN_VERSION_transformers(0,5,6)-import qualified Control.Monad.Trans.RWS.CPS as CPS-import qualified Control.Monad.Trans.Writer.CPS as CPS-#endif-import qualified Control.Monad.Trans.RWS.Lazy as Lazy-import qualified Control.Monad.Trans.State.Lazy as Lazy-import qualified Control.Monad.Trans.Writer.Lazy as Lazy-import qualified Control.Monad.Trans.RWS.Strict as Strict-import qualified Control.Monad.Trans.State.Strict as Strict-import qualified Control.Monad.Trans.Writer.Strict as Strict-import Data.Functor.Bind-import Data.Orphans ()-#if !(MIN_VERSION_base(4,11,0))-import Data.Semigroup hiding (Product)-#endif-import Prelude hiding (id, (.))---- | A subset of monad transformers can transform any 'Bind' as well.-class MonadTrans t => BindTrans t where- liftB :: Bind b => b a -> t b a--instance BindTrans IdentityT where- liftB = IdentityT--instance BindTrans (ReaderT e) where- liftB = ReaderT . const--instance Monoid w => BindTrans (Lazy.WriterT w) where- liftB = Lazy.WriterT . fmap (\a -> (a, mempty))--instance Monoid w => BindTrans (Strict.WriterT w) where- liftB = Strict.WriterT . fmap (\a -> (a, mempty))--#if MIN_VERSION_transformers(0,5,6)--- | @since 5.3.6-instance Monoid w => BindTrans (CPS.WriterT w) where- liftB = CPS.writerT . fmap (\a -> (a, mempty))-#endif--instance BindTrans (Lazy.StateT s) where- liftB m = Lazy.StateT $ \s -> fmap (\a -> (a, s)) m--instance BindTrans (Strict.StateT s) where- liftB m = Strict.StateT $ \s -> fmap (\a -> (a, s)) m--instance Monoid w => BindTrans (Lazy.RWST r w s) where- liftB m = Lazy.RWST $ \ _r s -> fmap (\a -> (a, s, mempty)) m--instance Monoid w => BindTrans (Strict.RWST r w s) where- liftB m = Strict.RWST $ \ _r s -> fmap (\a -> (a, s, mempty)) m--#if MIN_VERSION_transformers(0,5,6)--- | @since 5.3.6-instance Monoid w => BindTrans (CPS.RWST r w s) where- liftB m = CPS.rwsT $ \ _r s -> fmap (\a -> (a, s, mempty)) m-#endif--instance BindTrans (ContT r) where- liftB m = ContT (m >>-)+{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Bind.Trans +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Functor.Bind.Trans ( + BindTrans(..) + ) where + +-- import _everything_ +import Control.Category +import Control.Monad.Trans.Class +import Control.Monad.Trans.Cont +-- import Control.Monad.Trans.Error +import Control.Monad.Trans.Identity +-- import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +-- import Control.Monad.Trans.List +#if MIN_VERSION_transformers(0,5,6) +import qualified Control.Monad.Trans.RWS.CPS as CPS +import qualified Control.Monad.Trans.Writer.CPS as CPS +#endif +import qualified Control.Monad.Trans.RWS.Lazy as Lazy +import qualified Control.Monad.Trans.State.Lazy as Lazy +import qualified Control.Monad.Trans.Writer.Lazy as Lazy +import qualified Control.Monad.Trans.RWS.Strict as Strict +import qualified Control.Monad.Trans.State.Strict as Strict +import qualified Control.Monad.Trans.Writer.Strict as Strict +import Data.Functor.Bind +import Data.Orphans () +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup hiding (Product) +#endif +import Prelude hiding (id, (.)) + +-- | A subset of monad transformers can transform any 'Bind' as well. +class MonadTrans t => BindTrans t where + liftB :: Bind b => b a -> t b a + +instance BindTrans IdentityT where + liftB = IdentityT + +instance BindTrans (ReaderT e) where + liftB = ReaderT . const + +instance Monoid w => BindTrans (Lazy.WriterT w) where + liftB = Lazy.WriterT . fmap (\a -> (a, mempty)) + +instance Monoid w => BindTrans (Strict.WriterT w) where + liftB = Strict.WriterT . fmap (\a -> (a, mempty)) + +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance Monoid w => BindTrans (CPS.WriterT w) where + liftB = CPS.writerT . fmap (\a -> (a, mempty)) +#endif + +instance BindTrans (Lazy.StateT s) where + liftB m = Lazy.StateT $ \s -> fmap (\a -> (a, s)) m + +instance BindTrans (Strict.StateT s) where + liftB m = Strict.StateT $ \s -> fmap (\a -> (a, s)) m + +instance Monoid w => BindTrans (Lazy.RWST r w s) where + liftB m = Lazy.RWST $ \ _r s -> fmap (\a -> (a, s, mempty)) m + +instance Monoid w => BindTrans (Strict.RWST r w s) where + liftB m = Strict.RWST $ \ _r s -> fmap (\a -> (a, s, mempty)) m + +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance Monoid w => BindTrans (CPS.RWST r w s) where + liftB m = CPS.rwsT $ \ _r s -> fmap (\a -> (a, s, mempty)) m +#endif + +instance BindTrans (ContT r) where + liftB m = ContT (m >>-)
src/Data/Functor/Contravariant/Conclude.hs view
@@ -1,222 +1,222 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE Safe #-}---------------------------------------------------------------------------------- |--- Copyright : (C) 2021 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Functor.Contravariant.Conclude (- Conclude(..)- , gconclude- , concluded- , gconcluded- ) where--import Control.Applicative.Backwards-import Control.Monad.Trans.Identity-import Control.Monad.Trans.Maybe-import qualified Control.Monad.Trans.RWS.Lazy as Lazy-import qualified Control.Monad.Trans.RWS.Strict as Strict-import Control.Monad.Trans.Reader-import qualified Control.Monad.Trans.State.Lazy as Lazy-import qualified Control.Monad.Trans.State.Strict as Strict-import qualified Control.Monad.Trans.Writer.Lazy as Lazy-import qualified Control.Monad.Trans.Writer.Strict as Strict--import Data.Functor.Apply-import Data.Functor.Compose-import Data.Functor.Contravariant-import Data.Functor.Contravariant.Decide-import Data.Functor.Contravariant.Divise-import Data.Functor.Contravariant.Divisible-import Data.Functor.Product-import Data.Functor.Reverse-import Data.Monoid (Alt(..))-import Data.Proxy-import Data.Void-import GHC.Generics--#if !(MIN_VERSION_transformers(0,6,0))-import Control.Monad.Trans.List-#endif--#ifdef MIN_VERSION_StateVar-import Data.StateVar-#endif---- | The contravariant analogue of 'Plus'. Adds on to 'Decide' the ability--- to express a combinator that rejects all input, to act as the dead-end.--- Essentially 'Decidable' without a superclass constraint on 'Divisible'.------ If one thinks of @f a@ as a consumer of @a@s, then 'conclude' defines--- a consumer that cannot ever receive /any/ input.------ Conclude acts as an identity with 'decide', because any decision that--- involves 'conclude' must necessarily /always/ pick the other option.------ That is, for, say,------ @--- 'decide' f x 'concluded'--- @------ @f@ is the deciding function that picks which of the inputs of @decide@--- to direct input to; in the situation above, @f@ must /always/ direct all--- input to @x@, and never 'concluded'.------ Mathematically, a functor being an instance of 'Decide' means that it is--- \"monoidal\" with respect to the contravariant "either-based" Day--- convolution described in the documentation of 'Decide'. On top of--- 'Decide', it adds a way to construct an \"identity\" @conclude@ where--- @decide f x (conclude q) == x@, and @decide g (conclude r) y == y@.------ @since 5.3.6-class Decide f => Conclude f where- -- | The consumer that cannot ever receive /any/ input.- conclude :: (a -> Void) -> f a---- | Generic 'conclude'. Caveats:------ 1. Will not compile if @f@ is a sum type.--- 2. Will not compile if @f@ contains fields that do not mention its type variable.------ @since 5.3.8-gconclude :: (Generic1 f, Conclude (Rep1 f)) => (a -> Void) -> f a-gconclude f = to1 $ conclude f---- | A potentially more meaningful form of 'conclude', the consumer that cannot--- ever receive /any/ input. That is because it expects only input of type--- 'Void', but such a type has no values.------ @--- 'concluded' = 'conclude' 'id'--- @------ @since 5.3.6-concluded :: Conclude f => f Void-concluded = conclude id---- | Generic 'concluded'. Caveats are the same as for 'gconclude'.------ @since 5.3.8-gconcluded :: (Generic1 f, Conclude (Rep1 f)) => f Void-gconcluded = to1 concluded---- | @since 5.3.6-instance Decidable f => Conclude (WrappedDivisible f) where- conclude f = WrapDivisible (lose f)---- | @since 5.3.6-instance Conclude Comparison where conclude = lose---- | @since 5.3.6-instance Conclude Equivalence where conclude = lose---- | @since 5.3.6-instance Conclude Predicate where conclude = lose---- | @since 5.3.6-instance Conclude (Op r) where- conclude f = Op $ absurd . f---- | @since 5.3.6-instance Conclude Proxy where conclude = lose--#ifdef MIN_VERSION_StateVar--- | @since 5.3.6-instance Conclude SettableStateVar where conclude = lose-#endif---- | @since 5.3.6-instance Conclude f => Conclude (Alt f) where- conclude = Alt . conclude---- | @since 5.3.6-instance Conclude U1 where conclude = lose---- | @since 5.3.6-instance Conclude f => Conclude (Rec1 f) where- conclude = Rec1 . conclude---- | @since 5.3.6-instance Conclude f => Conclude (M1 i c f) where- conclude = M1 . conclude---- | @since 5.3.6-instance (Conclude f, Conclude g) => Conclude (f :*: g) where- conclude f = conclude f :*: conclude f---- | @since 5.3.6-instance (Apply f, Applicative f, Conclude g) => Conclude (f :.: g) where- conclude = Comp1 . pure . conclude---- | @since 5.3.6-instance Conclude f => Conclude (Backwards f) where- conclude = Backwards . conclude---- | @since 5.3.6-instance Conclude f => Conclude (IdentityT f) where- conclude = IdentityT . conclude---- | @since 5.3.6-instance Conclude m => Conclude (ReaderT r m) where- conclude f = ReaderT $ \_ -> conclude f---- | @since 5.3.6-instance Conclude m => Conclude (Lazy.RWST r w s m) where- conclude f = Lazy.RWST $ \_ _ -> contramap (\ ~(a, _, _) -> a) (conclude f)---- | @since 5.3.6-instance Conclude m => Conclude (Strict.RWST r w s m) where- conclude f = Strict.RWST $ \_ _ -> contramap (\(a, _, _) -> a) (conclude f)--#if !(MIN_VERSION_transformers(0,6,0))--- | @since 5.3.6-instance (Divisible m, Divise m) => Conclude (ListT m) where- conclude _ = ListT conquer-#endif---- | @since 5.3.6-instance (Divisible m, Divise m) => Conclude (MaybeT m) where- conclude _ = MaybeT conquer---- | @since 5.3.6-instance Conclude m => Conclude (Lazy.StateT s m) where- conclude f = Lazy.StateT $ \_ -> contramap lazyFst (conclude f)---- | @since 5.3.6-instance Conclude m => Conclude (Strict.StateT s m) where- conclude f = Strict.StateT $ \_ -> contramap fst (conclude f)---- | @since 5.3.6-instance Conclude m => Conclude (Lazy.WriterT w m) where- conclude f = Lazy.WriterT $ contramap lazyFst (conclude f)---- | @since 5.3.6-instance Conclude m => Conclude (Strict.WriterT w m) where- conclude f = Strict.WriterT $ contramap fst (conclude f)---- | @since 5.3.6-instance (Apply f, Applicative f, Conclude g) => Conclude (Compose f g) where- conclude = Compose . pure . conclude---- | @since 5.3.6-instance (Conclude f, Conclude g) => Conclude (Product f g) where- conclude f = Pair (conclude f) (conclude f)---- | @since 5.3.6-instance Conclude f => Conclude (Reverse f) where- conclude = Reverse . conclude---- Helpers--lazyFst :: (a, b) -> a-lazyFst ~(a, _) = a+{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Safe #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2021 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Functor.Contravariant.Conclude ( + Conclude(..) + , gconclude + , concluded + , gconcluded + ) where + +import Control.Applicative.Backwards +import Control.Monad.Trans.Identity +import Control.Monad.Trans.Maybe +import qualified Control.Monad.Trans.RWS.Lazy as Lazy +import qualified Control.Monad.Trans.RWS.Strict as Strict +import Control.Monad.Trans.Reader +import qualified Control.Monad.Trans.State.Lazy as Lazy +import qualified Control.Monad.Trans.State.Strict as Strict +import qualified Control.Monad.Trans.Writer.Lazy as Lazy +import qualified Control.Monad.Trans.Writer.Strict as Strict + +import Data.Functor.Apply +import Data.Functor.Compose +import Data.Functor.Contravariant +import Data.Functor.Contravariant.Decide +import Data.Functor.Contravariant.Divise +import Data.Functor.Contravariant.Divisible +import Data.Functor.Product +import Data.Functor.Reverse +import Data.Monoid (Alt(..)) +import Data.Proxy +import Data.Void +import GHC.Generics + +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.List +#endif + +#ifdef MIN_VERSION_StateVar +import Data.StateVar +#endif + +-- | The contravariant analogue of 'Plus'. Adds on to 'Decide' the ability +-- to express a combinator that rejects all input, to act as the dead-end. +-- Essentially 'Decidable' without a superclass constraint on 'Divisible'. +-- +-- If one thinks of @f a@ as a consumer of @a@s, then 'conclude' defines +-- a consumer that cannot ever receive /any/ input. +-- +-- Conclude acts as an identity with 'decide', because any decision that +-- involves 'conclude' must necessarily /always/ pick the other option. +-- +-- That is, for, say, +-- +-- @ +-- 'decide' f x 'concluded' +-- @ +-- +-- @f@ is the deciding function that picks which of the inputs of @decide@ +-- to direct input to; in the situation above, @f@ must /always/ direct all +-- input to @x@, and never 'concluded'. +-- +-- Mathematically, a functor being an instance of 'Decide' means that it is +-- \"monoidal\" with respect to the contravariant "either-based" Day +-- convolution described in the documentation of 'Decide'. On top of +-- 'Decide', it adds a way to construct an \"identity\" @conclude@ where +-- @decide f x (conclude q) == x@, and @decide g (conclude r) y == y@. +-- +-- @since 5.3.6 +class Decide f => Conclude f where + -- | The consumer that cannot ever receive /any/ input. + conclude :: (a -> Void) -> f a + +-- | Generic 'conclude'. Caveats: +-- +-- 1. Will not compile if @f@ is a sum type. +-- 2. Will not compile if @f@ contains fields that do not mention its type variable. +-- +-- @since 5.3.8 +gconclude :: (Generic1 f, Conclude (Rep1 f)) => (a -> Void) -> f a +gconclude f = to1 $ conclude f + +-- | A potentially more meaningful form of 'conclude', the consumer that cannot +-- ever receive /any/ input. That is because it expects only input of type +-- 'Void', but such a type has no values. +-- +-- @ +-- 'concluded' = 'conclude' 'id' +-- @ +-- +-- @since 5.3.6 +concluded :: Conclude f => f Void +concluded = conclude id + +-- | Generic 'concluded'. Caveats are the same as for 'gconclude'. +-- +-- @since 5.3.8 +gconcluded :: (Generic1 f, Conclude (Rep1 f)) => f Void +gconcluded = to1 concluded + +-- | @since 5.3.6 +instance Decidable f => Conclude (WrappedDivisible f) where + conclude f = WrapDivisible (lose f) + +-- | @since 5.3.6 +instance Conclude Comparison where conclude = lose + +-- | @since 5.3.6 +instance Conclude Equivalence where conclude = lose + +-- | @since 5.3.6 +instance Conclude Predicate where conclude = lose + +-- | @since 5.3.6 +instance Conclude (Op r) where + conclude f = Op $ absurd . f + +-- | @since 5.3.6 +instance Conclude Proxy where conclude = lose + +#ifdef MIN_VERSION_StateVar +-- | @since 5.3.6 +instance Conclude SettableStateVar where conclude = lose +#endif + +-- | @since 5.3.6 +instance Conclude f => Conclude (Alt f) where + conclude = Alt . conclude + +-- | @since 5.3.6 +instance Conclude U1 where conclude = lose + +-- | @since 5.3.6 +instance Conclude f => Conclude (Rec1 f) where + conclude = Rec1 . conclude + +-- | @since 5.3.6 +instance Conclude f => Conclude (M1 i c f) where + conclude = M1 . conclude + +-- | @since 5.3.6 +instance (Conclude f, Conclude g) => Conclude (f :*: g) where + conclude f = conclude f :*: conclude f + +-- | @since 5.3.6 +instance (Apply f, Applicative f, Conclude g) => Conclude (f :.: g) where + conclude = Comp1 . pure . conclude + +-- | @since 5.3.6 +instance Conclude f => Conclude (Backwards f) where + conclude = Backwards . conclude + +-- | @since 5.3.6 +instance Conclude f => Conclude (IdentityT f) where + conclude = IdentityT . conclude + +-- | @since 5.3.6 +instance Conclude m => Conclude (ReaderT r m) where + conclude f = ReaderT $ \_ -> conclude f + +-- | @since 5.3.6 +instance Conclude m => Conclude (Lazy.RWST r w s m) where + conclude f = Lazy.RWST $ \_ _ -> contramap (\ ~(a, _, _) -> a) (conclude f) + +-- | @since 5.3.6 +instance Conclude m => Conclude (Strict.RWST r w s m) where + conclude f = Strict.RWST $ \_ _ -> contramap (\(a, _, _) -> a) (conclude f) + +#if !(MIN_VERSION_transformers(0,6,0)) +-- | @since 5.3.6 +instance (Divisible m, Divise m) => Conclude (ListT m) where + conclude _ = ListT conquer +#endif + +-- | @since 5.3.6 +instance (Divisible m, Divise m) => Conclude (MaybeT m) where + conclude _ = MaybeT conquer + +-- | @since 5.3.6 +instance Conclude m => Conclude (Lazy.StateT s m) where + conclude f = Lazy.StateT $ \_ -> contramap lazyFst (conclude f) + +-- | @since 5.3.6 +instance Conclude m => Conclude (Strict.StateT s m) where + conclude f = Strict.StateT $ \_ -> contramap fst (conclude f) + +-- | @since 5.3.6 +instance Conclude m => Conclude (Lazy.WriterT w m) where + conclude f = Lazy.WriterT $ contramap lazyFst (conclude f) + +-- | @since 5.3.6 +instance Conclude m => Conclude (Strict.WriterT w m) where + conclude f = Strict.WriterT $ contramap fst (conclude f) + +-- | @since 5.3.6 +instance (Apply f, Applicative f, Conclude g) => Conclude (Compose f g) where + conclude = Compose . pure . conclude + +-- | @since 5.3.6 +instance (Conclude f, Conclude g) => Conclude (Product f g) where + conclude f = Pair (conclude f) (conclude f) + +-- | @since 5.3.6 +instance Conclude f => Conclude (Reverse f) where + conclude = Reverse . conclude + +-- Helpers + +lazyFst :: (a, b) -> a +lazyFst ~(a, _) = a
src/Data/Functor/Contravariant/Decide.hs view
@@ -1,245 +1,245 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Safe #-}-{-# LANGUAGE TypeOperators #-}---------------------------------------------------------------------------------- |--- Copyright : (C) 2021 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Functor.Contravariant.Decide (- Decide(..)- , gdecide- , decided- , gdecided- ) where--import Control.Applicative.Backwards-import Control.Monad.Trans.Identity-import Control.Monad.Trans.Maybe-import qualified Control.Monad.Trans.RWS.Lazy as Lazy-import qualified Control.Monad.Trans.RWS.Strict as Strict-import Control.Monad.Trans.Reader-import qualified Control.Monad.Trans.State.Lazy as Lazy-import qualified Control.Monad.Trans.State.Strict as Strict-import qualified Control.Monad.Trans.Writer.Lazy as Lazy-import qualified Control.Monad.Trans.Writer.Strict as Strict--import Data.Functor.Apply-import Data.Functor.Compose-import Data.Functor.Contravariant-import Data.Functor.Contravariant.Divise-import Data.Functor.Contravariant.Divisible-import Data.Functor.Product-import Data.Functor.Reverse-import Data.Monoid (Alt(..))-import Data.Proxy-import GHC.Generics--#if !(MIN_VERSION_transformers(0,6,0))-import Control.Arrow-import Control.Monad.Trans.List-import Data.Either-#endif--#ifdef MIN_VERSION_StateVar-import Data.StateVar-#endif---- | The contravariant analogue of 'Alt'.------ If one thinks of @f a@ as a consumer of @a@s, then 'decide' allows one--- to handle the consumption of a value by choosing to handle it via--- exactly one of two independent consumers. It redirects the input--- completely into one of two consumers.------ 'decide' takes the \"decision\" method and the two potential consumers,--- and returns the wrapped/combined consumer.------ Mathematically, a functor being an instance of 'Decide' means that it is--- \"semigroupoidal\" with respect to the contravariant \"either-based\" Day--- convolution (@data EitherDay f g a = forall b c. EitherDay (f b) (g c) (a -> Either b c)@).--- That is, it is possible to define a function @(f `EitherDay` f) a ->--- f a@ in a way that is associative.------ @since 5.3.6-class Contravariant f => Decide f where- -- | Takes the \"decision\" method and the two potential consumers, and- -- returns the wrapped/combined consumer.- decide :: (a -> Either b c) -> f b -> f c -> f a---- | Generic 'decide'. Caveats:------ 1. Will not compile if @f@ is a sum type.--- 2. Will not compile if @f@ contains fields that do not mention its type variable.--- 3. @-XDeriveGeneric@ is not smart enough to make instances where the type variable appears in negative position.------ @since 5.3.8-gdecide :: (Generic1 f, Decide (Rep1 f)) => (a -> Either b c) -> f b -> f c -> f a-gdecide f fb fc = to1 $ decide f (from1 fb) (from1 fc)---- | For @'decided' x y@, the resulting @f ('Either' b c)@ will direct--- 'Left's to be consumed by @x@, and 'Right's to be consumed by y.------ @since 5.3.6-decided :: Decide f => f b -> f c -> f (Either b c)-decided = decide id---- | Generic 'decided'. Caveats are the same as for 'gdecide'.------ @since 5.3.8-gdecided :: (Generic1 f, Decide (Rep1 f)) => f b -> f c -> f (Either b c)-gdecided fb fc = gdecide id fb fc---- | @since 5.3.6-instance Decidable f => Decide (WrappedDivisible f) where- decide f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (choose f x y)---- | @since 5.3.6-instance Decide Comparison where decide = choose---- | @since 5.3.6-instance Decide Equivalence where decide = choose---- | @since 5.3.6-instance Decide Predicate where decide = choose---- | Unlike 'Decidable', requires no constraint on @r@.------ @since 5.3.6-instance Decide (Op r) where- decide f (Op g) (Op h) = Op $ either g h . f---- | @since 5.3.6-instance Decide f => Decide (Alt f) where- decide f (Alt l) (Alt r) = Alt $ decide f l r---- | @since 5.3.6-instance Decide U1 where decide = choose---- | Has no 'Decidable' or 'Conclude' instance.------ @since 5.3.6-instance Decide V1 where decide _ x = case x of {}---- | @since 5.3.6-instance Decide f => Decide (Rec1 f) where- decide f (Rec1 l) (Rec1 r) = Rec1 $ decide f l r---- | @since 5.3.6-instance Decide f => Decide (M1 i c f) where- decide f (M1 l) (M1 r) = M1 $ decide f l r---- | @since 5.3.6-instance (Decide f, Decide g) => Decide (f :*: g) where- decide f (l1 :*: r1) (l2 :*: r2) = decide f l1 l2 :*: decide f r1 r2---- | Unlike 'Decidable', requires only 'Apply' on @f@.------ @since 5.3.6-instance (Apply f, Decide g) => Decide (f :.: g) where- decide f (Comp1 l) (Comp1 r) = Comp1 (liftF2 (decide f) l r)---- | @since 5.3.6-instance Decide f => Decide (Backwards f) where- decide f (Backwards l) (Backwards r) = Backwards $ decide f l r---- | @since 5.3.6-instance Decide f => Decide (IdentityT f) where- decide f (IdentityT l) (IdentityT r) = IdentityT $ decide f l r---- | @since 5.3.6-instance Decide m => Decide (ReaderT r m) where- decide abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> decide abc (rmb r) (rmc r)---- | @since 5.3.6-instance Decide m => Decide (Lazy.RWST r w s m) where- decide abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s ->- decide (\ ~(a, s', w) -> either (Left . betuple3 s' w)- (Right . betuple3 s' w)- (abc a))- (rsmb r s) (rsmc r s)---- | @since 5.3.6-instance Decide m => Decide (Strict.RWST r w s m) where- decide abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s ->- decide (\(a, s', w) -> either (Left . betuple3 s' w)- (Right . betuple3 s' w)- (abc a))- (rsmb r s) (rsmc r s)--#if !(MIN_VERSION_transformers(0,6,0))--- | @since 5.3.6-instance Divise m => Decide (ListT m) where- decide f (ListT l) (ListT r) = ListT $ divise ((lefts &&& rights) . map f) l r-#endif---- | @since 5.3.6-instance Divise m => Decide (MaybeT m) where- decide f (MaybeT l) (MaybeT r) = MaybeT $- divise ( maybe (Nothing, Nothing)- (either (\b -> (Just b, Nothing))- (\c -> (Nothing, Just c)) . f)- ) l r---- | @since 5.3.6-instance Decide m => Decide (Lazy.StateT s m) where- decide f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s ->- decide (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a))- (l s) (r s)---- | @since 5.3.6-instance Decide m => Decide (Strict.StateT s m) where- decide f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s ->- decide (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a))- (l s) (r s)---- | @since 5.3.6-instance Decide m => Decide (Lazy.WriterT w m) where- decide f (Lazy.WriterT l) (Lazy.WriterT r) = Lazy.WriterT $- decide (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r---- | @since 5.3.6-instance Decide m => Decide (Strict.WriterT w m) where- decide f (Strict.WriterT l) (Strict.WriterT r) = Strict.WriterT $- decide (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r---- | Unlike 'Decidable', requires only 'Apply' on @f@.------ @since 5.3.6-instance (Apply f, Decide g) => Decide (Compose f g) where- decide f (Compose l) (Compose r) = Compose (liftF2 (decide f) l r)---- | @since 5.3.6-instance (Decide f, Decide g) => Decide (Product f g) where- decide f (Pair l1 r1) (Pair l2 r2) = Pair (decide f l1 l2) (decide f r1 r2)---- | @since 5.3.6-instance Decide f => Decide (Reverse f) where- decide f (Reverse l) (Reverse r) = Reverse $ decide f l r--betuple :: s -> a -> (a, s)-betuple s a = (a, s)--betuple3 :: s -> w -> a -> (a, s, w)-betuple3 s w a = (a, s, w)---- | @since 5.3.6-instance Decide Proxy where- decide _ Proxy Proxy = Proxy--#ifdef MIN_VERSION_StateVar--- | @since 5.3.6-instance Decide SettableStateVar where- decide k (SettableStateVar l) (SettableStateVar r) = SettableStateVar $ \ a -> case k a of- Left b -> l b- Right c -> r c-#endif+{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2021 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Functor.Contravariant.Decide ( + Decide(..) + , gdecide + , decided + , gdecided + ) where + +import Control.Applicative.Backwards +import Control.Monad.Trans.Identity +import Control.Monad.Trans.Maybe +import qualified Control.Monad.Trans.RWS.Lazy as Lazy +import qualified Control.Monad.Trans.RWS.Strict as Strict +import Control.Monad.Trans.Reader +import qualified Control.Monad.Trans.State.Lazy as Lazy +import qualified Control.Monad.Trans.State.Strict as Strict +import qualified Control.Monad.Trans.Writer.Lazy as Lazy +import qualified Control.Monad.Trans.Writer.Strict as Strict + +import Data.Functor.Apply +import Data.Functor.Compose +import Data.Functor.Contravariant +import Data.Functor.Contravariant.Divise +import Data.Functor.Contravariant.Divisible +import Data.Functor.Product +import Data.Functor.Reverse +import Data.Monoid (Alt(..)) +import Data.Proxy +import GHC.Generics + +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Arrow +import Control.Monad.Trans.List +import Data.Either +#endif + +#ifdef MIN_VERSION_StateVar +import Data.StateVar +#endif + +-- | The contravariant analogue of 'Alt'. +-- +-- If one thinks of @f a@ as a consumer of @a@s, then 'decide' allows one +-- to handle the consumption of a value by choosing to handle it via +-- exactly one of two independent consumers. It redirects the input +-- completely into one of two consumers. +-- +-- 'decide' takes the \"decision\" method and the two potential consumers, +-- and returns the wrapped/combined consumer. +-- +-- Mathematically, a functor being an instance of 'Decide' means that it is +-- \"semigroupoidal\" with respect to the contravariant \"either-based\" Day +-- convolution (@data EitherDay f g a = forall b c. EitherDay (f b) (g c) (a -> Either b c)@). +-- That is, it is possible to define a function @(f `EitherDay` f) a -> +-- f a@ in a way that is associative. +-- +-- @since 5.3.6 +class Contravariant f => Decide f where + -- | Takes the \"decision\" method and the two potential consumers, and + -- returns the wrapped/combined consumer. + decide :: (a -> Either b c) -> f b -> f c -> f a + +-- | Generic 'decide'. Caveats: +-- +-- 1. Will not compile if @f@ is a sum type. +-- 2. Will not compile if @f@ contains fields that do not mention its type variable. +-- 3. @-XDeriveGeneric@ is not smart enough to make instances where the type variable appears in negative position. +-- +-- @since 5.3.8 +gdecide :: (Generic1 f, Decide (Rep1 f)) => (a -> Either b c) -> f b -> f c -> f a +gdecide f fb fc = to1 $ decide f (from1 fb) (from1 fc) + +-- | For @'decided' x y@, the resulting @f ('Either' b c)@ will direct +-- 'Left's to be consumed by @x@, and 'Right's to be consumed by y. +-- +-- @since 5.3.6 +decided :: Decide f => f b -> f c -> f (Either b c) +decided = decide id + +-- | Generic 'decided'. Caveats are the same as for 'gdecide'. +-- +-- @since 5.3.8 +gdecided :: (Generic1 f, Decide (Rep1 f)) => f b -> f c -> f (Either b c) +gdecided fb fc = gdecide id fb fc + +-- | @since 5.3.6 +instance Decidable f => Decide (WrappedDivisible f) where + decide f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (choose f x y) + +-- | @since 5.3.6 +instance Decide Comparison where decide = choose + +-- | @since 5.3.6 +instance Decide Equivalence where decide = choose + +-- | @since 5.3.6 +instance Decide Predicate where decide = choose + +-- | Unlike 'Decidable', requires no constraint on @r@. +-- +-- @since 5.3.6 +instance Decide (Op r) where + decide f (Op g) (Op h) = Op $ either g h . f + +-- | @since 5.3.6 +instance Decide f => Decide (Alt f) where + decide f (Alt l) (Alt r) = Alt $ decide f l r + +-- | @since 5.3.6 +instance Decide U1 where decide = choose + +-- | Has no 'Decidable' or 'Conclude' instance. +-- +-- @since 5.3.6 +instance Decide V1 where decide _ x = case x of {} + +-- | @since 5.3.6 +instance Decide f => Decide (Rec1 f) where + decide f (Rec1 l) (Rec1 r) = Rec1 $ decide f l r + +-- | @since 5.3.6 +instance Decide f => Decide (M1 i c f) where + decide f (M1 l) (M1 r) = M1 $ decide f l r + +-- | @since 5.3.6 +instance (Decide f, Decide g) => Decide (f :*: g) where + decide f (l1 :*: r1) (l2 :*: r2) = decide f l1 l2 :*: decide f r1 r2 + +-- | Unlike 'Decidable', requires only 'Apply' on @f@. +-- +-- @since 5.3.6 +instance (Apply f, Decide g) => Decide (f :.: g) where + decide f (Comp1 l) (Comp1 r) = Comp1 (liftF2 (decide f) l r) + +-- | @since 5.3.6 +instance Decide f => Decide (Backwards f) where + decide f (Backwards l) (Backwards r) = Backwards $ decide f l r + +-- | @since 5.3.6 +instance Decide f => Decide (IdentityT f) where + decide f (IdentityT l) (IdentityT r) = IdentityT $ decide f l r + +-- | @since 5.3.6 +instance Decide m => Decide (ReaderT r m) where + decide abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> decide abc (rmb r) (rmc r) + +-- | @since 5.3.6 +instance Decide m => Decide (Lazy.RWST r w s m) where + decide abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s -> + decide (\ ~(a, s', w) -> either (Left . betuple3 s' w) + (Right . betuple3 s' w) + (abc a)) + (rsmb r s) (rsmc r s) + +-- | @since 5.3.6 +instance Decide m => Decide (Strict.RWST r w s m) where + decide abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s -> + decide (\(a, s', w) -> either (Left . betuple3 s' w) + (Right . betuple3 s' w) + (abc a)) + (rsmb r s) (rsmc r s) + +#if !(MIN_VERSION_transformers(0,6,0)) +-- | @since 5.3.6 +instance Divise m => Decide (ListT m) where + decide f (ListT l) (ListT r) = ListT $ divise ((lefts &&& rights) . map f) l r +#endif + +-- | @since 5.3.6 +instance Divise m => Decide (MaybeT m) where + decide f (MaybeT l) (MaybeT r) = MaybeT $ + divise ( maybe (Nothing, Nothing) + (either (\b -> (Just b, Nothing)) + (\c -> (Nothing, Just c)) . f) + ) l r + +-- | @since 5.3.6 +instance Decide m => Decide (Lazy.StateT s m) where + decide f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s -> + decide (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) + (l s) (r s) + +-- | @since 5.3.6 +instance Decide m => Decide (Strict.StateT s m) where + decide f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s -> + decide (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) + (l s) (r s) + +-- | @since 5.3.6 +instance Decide m => Decide (Lazy.WriterT w m) where + decide f (Lazy.WriterT l) (Lazy.WriterT r) = Lazy.WriterT $ + decide (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r + +-- | @since 5.3.6 +instance Decide m => Decide (Strict.WriterT w m) where + decide f (Strict.WriterT l) (Strict.WriterT r) = Strict.WriterT $ + decide (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r + +-- | Unlike 'Decidable', requires only 'Apply' on @f@. +-- +-- @since 5.3.6 +instance (Apply f, Decide g) => Decide (Compose f g) where + decide f (Compose l) (Compose r) = Compose (liftF2 (decide f) l r) + +-- | @since 5.3.6 +instance (Decide f, Decide g) => Decide (Product f g) where + decide f (Pair l1 r1) (Pair l2 r2) = Pair (decide f l1 l2) (decide f r1 r2) + +-- | @since 5.3.6 +instance Decide f => Decide (Reverse f) where + decide f (Reverse l) (Reverse r) = Reverse $ decide f l r + +betuple :: s -> a -> (a, s) +betuple s a = (a, s) + +betuple3 :: s -> w -> a -> (a, s, w) +betuple3 s w a = (a, s, w) + +-- | @since 5.3.6 +instance Decide Proxy where + decide _ Proxy Proxy = Proxy + +#ifdef MIN_VERSION_StateVar +-- | @since 5.3.6 +instance Decide SettableStateVar where + decide k (SettableStateVar l) (SettableStateVar r) = SettableStateVar $ \ a -> case k a of + Left b -> l b + Right c -> r c +#endif
src/Data/Functor/Contravariant/Divise.hs view
@@ -1,289 +1,289 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Safe #-}-{-# LANGUAGE TypeOperators #-}---------------------------------------------------------------------------------- |--- Copyright : (C) 2021 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Functor.Contravariant.Divise (- Divise(..)- , gdivise- , divised- , gdivised- , WrappedDivisible(..)- ) where--import Control.Applicative-import Control.Applicative.Backwards-import Control.Arrow-import Control.Monad.Trans.Except-import Control.Monad.Trans.Identity-import Control.Monad.Trans.Maybe-import qualified Control.Monad.Trans.RWS.Lazy as Lazy-import qualified Control.Monad.Trans.RWS.Strict as Strict-import Control.Monad.Trans.Reader-import qualified Control.Monad.Trans.State.Lazy as Lazy-import qualified Control.Monad.Trans.State.Strict as Strict-import qualified Control.Monad.Trans.Writer.Lazy as Lazy-import qualified Control.Monad.Trans.Writer.Strict as Strict--import Data.Functor.Apply-import Data.Functor.Compose-import Data.Functor.Constant-import Data.Functor.Contravariant-import Data.Functor.Contravariant.Divisible-import Data.Functor.Product-import Data.Functor.Reverse-import Data.Monoid (Alt(..))-import Data.Proxy-import GHC.Generics--#if !(MIN_VERSION_transformers(0,6,0))-import Control.Monad.Trans.Error-import Control.Monad.Trans.List-#endif--#if !MIN_VERSION_base(4,12,0)-import Data.Semigroup (Semigroup(..))-#endif--#ifdef MIN_VERSION_StateVar-import Data.StateVar-#endif---- | The contravariant analogue of 'Apply'; it is--- 'Divisible' without 'conquer'.------ If one thinks of @f a@ as a consumer of @a@s, then 'divise' allows one--- to handle the consumption of a value by splitting it between two--- consumers that consume separate parts of @a@.------ 'divise' takes the \"splitting\" method and the two sub-consumers, and--- returns the wrapped/combined consumer.------ All instances of 'Divisible' should be instances of 'Divise' with--- @'divise' = 'divide'@.------ If a function is polymorphic over @'Divise' f@ (as opposed to @'Divisible'--- f@), we can provide a stronger guarantee: namely, that any input consumed--- will be passed to at least one sub-consumer. With @'Divisible' f@, said input--- could potentially disappear into the void, as this is possible with--- 'conquer'.------ Mathematically, a functor being an instance of 'Divise' means that it is--- \"semigroupoidal\" with respect to the contravariant (tupling) Day--- convolution. That is, it is possible to define a function @(f `Day` f)--- a -> f a@ in a way that is associative.------ @since 5.3.6-class Contravariant f => Divise f where- -- | Takes a \"splitting\" method and the two sub-consumers, and- -- returns the wrapped/combined consumer.- divise :: (a -> (b, c)) -> f b -> f c -> f a---- | Generic 'divise'. Caveats:------ 1. Will not compile if @f@ is a sum type.--- 2. Will not compile if @f@ contains fields that do not mention its type variable.--- 3. @-XDeriveGeneric@ is not smart enough to make instances where the type variable appears in negative position.------ @since 5.3.8-gdivise :: (Divise (Rep1 f), Generic1 f) => (a -> (b, c)) -> f b -> f c -> f a-gdivise f x y = to1 $ divise f (from1 x) (from1 y)---- | Combine a consumer of @a@ with a consumer of @b@ to get a consumer of--- @(a, b)@.------ @--- 'divised' = 'divise' 'id'--- @------ @since 5.3.6-divised :: Divise f => f a -> f b -> f (a, b)-divised = divise id---- | Generic 'divised'. Caveats are the same as for 'gdivise'.------ @since 5.3.8-gdivised :: (Generic1 f, Divise (Rep1 f)) => f a -> f b -> f (a, b)-gdivised fa fb = gdivise id fa fb---- | Wrap a 'Divisible' to be used as a member of 'Divise'------ @since 5.3.6-newtype WrappedDivisible f a = WrapDivisible { unwrapDivisible :: f a }---- | @since 5.3.6-instance Contravariant f => Contravariant (WrappedDivisible f) where- contramap f (WrapDivisible a) = WrapDivisible (contramap f a)---- | @since 5.3.6-instance Divisible f => Divise (WrappedDivisible f) where- divise f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (divide f x y)---- | Unlike 'Divisible', requires only 'Semigroup' on @r@.------ @since 5.3.6-instance Semigroup r => Divise (Op r) where- divise f (Op g) (Op h) = Op $ \a -> case f a of- (b, c) -> g b <> h c---- | Unlike 'Divisible', requires only 'Semigroup' on @m@.------ @since 5.3.6-instance Semigroup m => Divise (Const m) where- divise _ (Const a) (Const b) = Const (a <> b)---- | Unlike 'Divisible', requires only 'Semigroup' on @m@.------ @since 5.3.6-instance Semigroup m => Divise (Constant m) where- divise _ (Constant a) (Constant b) = Constant (a <> b)---- | @since 5.3.6-instance Divise Comparison where divise = divide---- | @since 5.3.6-instance Divise Equivalence where divise = divide---- | @since 5.3.6-instance Divise Predicate where divise = divide---- | @since 5.3.6-instance Divise Proxy where divise = divide--#ifdef MIN_VERSION_StateVar--- | @since 5.3.6-instance Divise SettableStateVar where divise = divide-#endif---- | @since 5.3.6-instance Divise f => Divise (Alt f) where- divise f (Alt l) (Alt r) = Alt $ divise f l r---- | @since 5.3.6-instance Divise U1 where divise = divide---- | Has no 'Divisible' instance.------ @since 5.3.6-instance Divise V1 where divise _ x = case x of {}---- | @since 5.3.6-instance Divise f => Divise (Rec1 f) where- divise f (Rec1 l) (Rec1 r) = Rec1 $ divise f l r---- | @since 5.3.6-instance Divise f => Divise (M1 i c f) where- divise f (M1 l) (M1 r) = M1 $ divise f l r---- | @since 5.3.6-instance (Divise f, Divise g) => Divise (f :*: g) where- divise f (l1 :*: r1) (l2 :*: r2) = divise f l1 l2 :*: divise f r1 r2---- | Unlike 'Divisible', requires only 'Apply' on @f@.------ @since 5.3.6-instance (Apply f, Divise g) => Divise (f :.: g) where- divise f (Comp1 l) (Comp1 r) = Comp1 (liftF2 (divise f) l r)---- | @since 5.3.6-instance Divise f => Divise (Backwards f) where- divise f (Backwards l) (Backwards r) = Backwards $ divise f l r--#if !(MIN_VERSION_transformers(0,6,0))--- | @since 5.3.6-instance Divise m => Divise (ErrorT e m) where- divise f (ErrorT l) (ErrorT r) = ErrorT $ divise (funzip . fmap f) l r---- | @since 5.3.6-instance Divise m => Divise (ListT m) where- divise f (ListT l) (ListT r) = ListT $ divise (funzip . map f) l r-#endif---- | @since 5.3.6-instance Divise m => Divise (ExceptT e m) where- divise f (ExceptT l) (ExceptT r) = ExceptT $ divise (funzip . fmap f) l r---- | @since 5.3.6-instance Divise f => Divise (IdentityT f) where- divise f (IdentityT l) (IdentityT r) = IdentityT $ divise f l r---- | @since 5.3.6-instance Divise m => Divise (MaybeT m) where- divise f (MaybeT l) (MaybeT r) = MaybeT $ divise (funzip . fmap f) l r---- | @since 5.3.6-instance Divise m => Divise (ReaderT r m) where- divise abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> divise abc (rmb r) (rmc r)---- | @since 5.3.6-instance Divise m => Divise (Lazy.RWST r w s m) where- divise abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s ->- divise (\ ~(a, s', w) -> case abc a of- ~(b, c) -> ((b, s', w), (c, s', w)))- (rsmb r s) (rsmc r s)---- | @since 5.3.6-instance Divise m => Divise (Strict.RWST r w s m) where- divise abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s ->- divise (\(a, s', w) -> case abc a of- (b, c) -> ((b, s', w), (c, s', w)))- (rsmb r s) (rsmc r s)---- | @since 5.3.6-instance Divise m => Divise (Lazy.StateT s m) where- divise f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s ->- divise (lazyFanout f) (l s) (r s)---- | @since 5.3.6-instance Divise m => Divise (Strict.StateT s m) where- divise f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s ->- divise (strictFanout f) (l s) (r s)---- | @since 5.3.6-instance Divise m => Divise (Lazy.WriterT w m) where- divise f (Lazy.WriterT l) (Lazy.WriterT r) = Lazy.WriterT $- divise (lazyFanout f) l r---- | @since 5.3.6-instance Divise m => Divise (Strict.WriterT w m) where- divise f (Strict.WriterT l) (Strict.WriterT r) = Strict.WriterT $- divise (strictFanout f) l r---- | Unlike 'Divisible', requires only 'Apply' on @f@.------ @since 5.3.6-instance (Apply f, Divise g) => Divise (Compose f g) where- divise f (Compose l) (Compose r) = Compose (liftF2 (divise f) l r)---- | @since 5.3.6-instance (Divise f, Divise g) => Divise (Product f g) where- divise f (Pair l1 r1) (Pair l2 r2) = Pair (divise f l1 l2) (divise f r1 r2)---- | @since 5.3.6-instance Divise f => Divise (Reverse f) where- divise f (Reverse l) (Reverse r) = Reverse $ divise f l r---- Helpers--lazyFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s))-lazyFanout f ~(a, s) = case f a of- ~(b, c) -> ((b, s), (c, s))--strictFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s))-strictFanout f (a, s) = case f a of- (b, c) -> ((b, s), (c, s))--funzip :: Functor f => f (a, b) -> (f a, f b)-funzip = fmap fst &&& fmap snd+{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2021 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Functor.Contravariant.Divise ( + Divise(..) + , gdivise + , divised + , gdivised + , WrappedDivisible(..) + ) where + +import Control.Applicative +import Control.Applicative.Backwards +import Control.Arrow +import Control.Monad.Trans.Except +import Control.Monad.Trans.Identity +import Control.Monad.Trans.Maybe +import qualified Control.Monad.Trans.RWS.Lazy as Lazy +import qualified Control.Monad.Trans.RWS.Strict as Strict +import Control.Monad.Trans.Reader +import qualified Control.Monad.Trans.State.Lazy as Lazy +import qualified Control.Monad.Trans.State.Strict as Strict +import qualified Control.Monad.Trans.Writer.Lazy as Lazy +import qualified Control.Monad.Trans.Writer.Strict as Strict + +import Data.Functor.Apply +import Data.Functor.Compose +import Data.Functor.Constant +import Data.Functor.Contravariant +import Data.Functor.Contravariant.Divisible +import Data.Functor.Product +import Data.Functor.Reverse +import Data.Monoid (Alt(..)) +import Data.Proxy +import GHC.Generics + +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.Error +import Control.Monad.Trans.List +#endif + +#if !MIN_VERSION_base(4,12,0) +import Data.Semigroup (Semigroup(..)) +#endif + +#ifdef MIN_VERSION_StateVar +import Data.StateVar +#endif + +-- | The contravariant analogue of 'Apply'; it is +-- 'Divisible' without 'conquer'. +-- +-- If one thinks of @f a@ as a consumer of @a@s, then 'divise' allows one +-- to handle the consumption of a value by splitting it between two +-- consumers that consume separate parts of @a@. +-- +-- 'divise' takes the \"splitting\" method and the two sub-consumers, and +-- returns the wrapped/combined consumer. +-- +-- All instances of 'Divisible' should be instances of 'Divise' with +-- @'divise' = 'divide'@. +-- +-- If a function is polymorphic over @'Divise' f@ (as opposed to @'Divisible' +-- f@), we can provide a stronger guarantee: namely, that any input consumed +-- will be passed to at least one sub-consumer. With @'Divisible' f@, said input +-- could potentially disappear into the void, as this is possible with +-- 'conquer'. +-- +-- Mathematically, a functor being an instance of 'Divise' means that it is +-- \"semigroupoidal\" with respect to the contravariant (tupling) Day +-- convolution. That is, it is possible to define a function @(f `Day` f) +-- a -> f a@ in a way that is associative. +-- +-- @since 5.3.6 +class Contravariant f => Divise f where + -- | Takes a \"splitting\" method and the two sub-consumers, and + -- returns the wrapped/combined consumer. + divise :: (a -> (b, c)) -> f b -> f c -> f a + +-- | Generic 'divise'. Caveats: +-- +-- 1. Will not compile if @f@ is a sum type. +-- 2. Will not compile if @f@ contains fields that do not mention its type variable. +-- 3. @-XDeriveGeneric@ is not smart enough to make instances where the type variable appears in negative position. +-- +-- @since 5.3.8 +gdivise :: (Divise (Rep1 f), Generic1 f) => (a -> (b, c)) -> f b -> f c -> f a +gdivise f x y = to1 $ divise f (from1 x) (from1 y) + +-- | Combine a consumer of @a@ with a consumer of @b@ to get a consumer of +-- @(a, b)@. +-- +-- @ +-- 'divised' = 'divise' 'id' +-- @ +-- +-- @since 5.3.6 +divised :: Divise f => f a -> f b -> f (a, b) +divised = divise id + +-- | Generic 'divised'. Caveats are the same as for 'gdivise'. +-- +-- @since 5.3.8 +gdivised :: (Generic1 f, Divise (Rep1 f)) => f a -> f b -> f (a, b) +gdivised fa fb = gdivise id fa fb + +-- | Wrap a 'Divisible' to be used as a member of 'Divise' +-- +-- @since 5.3.6 +newtype WrappedDivisible f a = WrapDivisible { unwrapDivisible :: f a } + +-- | @since 5.3.6 +instance Contravariant f => Contravariant (WrappedDivisible f) where + contramap f (WrapDivisible a) = WrapDivisible (contramap f a) + +-- | @since 5.3.6 +instance Divisible f => Divise (WrappedDivisible f) where + divise f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (divide f x y) + +-- | Unlike 'Divisible', requires only 'Semigroup' on @r@. +-- +-- @since 5.3.6 +instance Semigroup r => Divise (Op r) where + divise f (Op g) (Op h) = Op $ \a -> case f a of + (b, c) -> g b <> h c + +-- | Unlike 'Divisible', requires only 'Semigroup' on @m@. +-- +-- @since 5.3.6 +instance Semigroup m => Divise (Const m) where + divise _ (Const a) (Const b) = Const (a <> b) + +-- | Unlike 'Divisible', requires only 'Semigroup' on @m@. +-- +-- @since 5.3.6 +instance Semigroup m => Divise (Constant m) where + divise _ (Constant a) (Constant b) = Constant (a <> b) + +-- | @since 5.3.6 +instance Divise Comparison where divise = divide + +-- | @since 5.3.6 +instance Divise Equivalence where divise = divide + +-- | @since 5.3.6 +instance Divise Predicate where divise = divide + +-- | @since 5.3.6 +instance Divise Proxy where divise = divide + +#ifdef MIN_VERSION_StateVar +-- | @since 5.3.6 +instance Divise SettableStateVar where divise = divide +#endif + +-- | @since 5.3.6 +instance Divise f => Divise (Alt f) where + divise f (Alt l) (Alt r) = Alt $ divise f l r + +-- | @since 5.3.6 +instance Divise U1 where divise = divide + +-- | Has no 'Divisible' instance. +-- +-- @since 5.3.6 +instance Divise V1 where divise _ x = case x of {} + +-- | @since 5.3.6 +instance Divise f => Divise (Rec1 f) where + divise f (Rec1 l) (Rec1 r) = Rec1 $ divise f l r + +-- | @since 5.3.6 +instance Divise f => Divise (M1 i c f) where + divise f (M1 l) (M1 r) = M1 $ divise f l r + +-- | @since 5.3.6 +instance (Divise f, Divise g) => Divise (f :*: g) where + divise f (l1 :*: r1) (l2 :*: r2) = divise f l1 l2 :*: divise f r1 r2 + +-- | Unlike 'Divisible', requires only 'Apply' on @f@. +-- +-- @since 5.3.6 +instance (Apply f, Divise g) => Divise (f :.: g) where + divise f (Comp1 l) (Comp1 r) = Comp1 (liftF2 (divise f) l r) + +-- | @since 5.3.6 +instance Divise f => Divise (Backwards f) where + divise f (Backwards l) (Backwards r) = Backwards $ divise f l r + +#if !(MIN_VERSION_transformers(0,6,0)) +-- | @since 5.3.6 +instance Divise m => Divise (ErrorT e m) where + divise f (ErrorT l) (ErrorT r) = ErrorT $ divise (funzip . fmap f) l r + +-- | @since 5.3.6 +instance Divise m => Divise (ListT m) where + divise f (ListT l) (ListT r) = ListT $ divise (funzip . map f) l r +#endif + +-- | @since 5.3.6 +instance Divise m => Divise (ExceptT e m) where + divise f (ExceptT l) (ExceptT r) = ExceptT $ divise (funzip . fmap f) l r + +-- | @since 5.3.6 +instance Divise f => Divise (IdentityT f) where + divise f (IdentityT l) (IdentityT r) = IdentityT $ divise f l r + +-- | @since 5.3.6 +instance Divise m => Divise (MaybeT m) where + divise f (MaybeT l) (MaybeT r) = MaybeT $ divise (funzip . fmap f) l r + +-- | @since 5.3.6 +instance Divise m => Divise (ReaderT r m) where + divise abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> divise abc (rmb r) (rmc r) + +-- | @since 5.3.6 +instance Divise m => Divise (Lazy.RWST r w s m) where + divise abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s -> + divise (\ ~(a, s', w) -> case abc a of + ~(b, c) -> ((b, s', w), (c, s', w))) + (rsmb r s) (rsmc r s) + +-- | @since 5.3.6 +instance Divise m => Divise (Strict.RWST r w s m) where + divise abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s -> + divise (\(a, s', w) -> case abc a of + (b, c) -> ((b, s', w), (c, s', w))) + (rsmb r s) (rsmc r s) + +-- | @since 5.3.6 +instance Divise m => Divise (Lazy.StateT s m) where + divise f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s -> + divise (lazyFanout f) (l s) (r s) + +-- | @since 5.3.6 +instance Divise m => Divise (Strict.StateT s m) where + divise f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s -> + divise (strictFanout f) (l s) (r s) + +-- | @since 5.3.6 +instance Divise m => Divise (Lazy.WriterT w m) where + divise f (Lazy.WriterT l) (Lazy.WriterT r) = Lazy.WriterT $ + divise (lazyFanout f) l r + +-- | @since 5.3.6 +instance Divise m => Divise (Strict.WriterT w m) where + divise f (Strict.WriterT l) (Strict.WriterT r) = Strict.WriterT $ + divise (strictFanout f) l r + +-- | Unlike 'Divisible', requires only 'Apply' on @f@. +-- +-- @since 5.3.6 +instance (Apply f, Divise g) => Divise (Compose f g) where + divise f (Compose l) (Compose r) = Compose (liftF2 (divise f) l r) + +-- | @since 5.3.6 +instance (Divise f, Divise g) => Divise (Product f g) where + divise f (Pair l1 r1) (Pair l2 r2) = Pair (divise f l1 l2) (divise f r1 r2) + +-- | @since 5.3.6 +instance Divise f => Divise (Reverse f) where + divise f (Reverse l) (Reverse r) = Reverse $ divise f l r + +-- Helpers + +lazyFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s)) +lazyFanout f ~(a, s) = case f a of + ~(b, c) -> ((b, s), (c, s)) + +strictFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s)) +strictFanout f (a, s) = case f a of + (b, c) -> ((b, s), (c, s)) + +funzip :: Functor f => f (a, b) -> (f a, f b) +funzip = fmap fst &&& fmap snd
src/Data/Functor/Extend.hs view
@@ -1,242 +1,242 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeOperators #-}---------------------------------------------------------------------------------- |--- Module : Data.Functor.Extend--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Functor.Extend- ( -- * Extendable Functors- -- $definition- Extend(..)- , gduplicated- , gextended- ) where--import Prelude hiding (id, (.))-import Control.Category-import Control.Monad.Trans.Identity-import Data.Functor.Identity-import Data.Functor.Sum as Functor (Sum(..))-import Data.List (tails)-import Data.List.NonEmpty (NonEmpty(..), toList)-import Data.Orphans ()-import qualified Data.Monoid as Monoid-import Data.Proxy-import Data.Semigroup as Semigroup-import GHC.Generics as Generics--#ifdef MIN_VERSION_containers-import Data.Sequence (Seq)-import qualified Data.Sequence as Seq-import Data.Tree-#endif--#ifdef MIN_VERSION_comonad-import Control.Comonad.Trans.Env-import Control.Comonad.Trans.Store-import Control.Comonad.Trans.Traced-#endif--#ifdef MIN_VERSION_tagged-import Data.Tagged-#endif--class Functor w => Extend w where- -- |- -- > duplicated = extended id- -- > fmap (fmap f) . duplicated = duplicated . fmap f- duplicated :: w a -> w (w a)- -- |- -- > extended f = fmap f . duplicated- extended :: (w a -> b) -> w a -> w b-- extended f = fmap f . duplicated- duplicated = extended id-- {-# MINIMAL duplicated | extended #-}---- | Generic 'duplicated'. Caveats:------ 1. Will not compile if @w@ is a product type.--- 2. Will not compile if @w@ contains fields where the type variable appears underneath the composition of type constructors (e.g., @f (g a)@).------ @since 5.3.8-gduplicated :: (Extend (Rep1 w), Generic1 w) => w a -> w (w a)-gduplicated = to1 . fmap to1 . duplicated . from1---- | Generic 'extended'. Caveats are the same as for 'gduplicated'.------ @since 5.3.8-gextended :: (Extend (Rep1 w), Generic1 w) => (w a -> b) -> w a -> w b-gextended f = to1 . extended (f . to1) . from1---- * Extends for Prelude types:------ Instances: While Data.Functor.Extend.Instances would be symmetric--- to the definition of Control.Monad.Instances in base, the reason--- the latter exists is because of Haskell 98 specifying the types--- @'Either' a@, @((,)m)@ and @((->)e)@ and the class Monad without--- having the foresight to require or allow instances between them.------ Here Haskell 98 says nothing about Extend, so we can include the--- instances directly avoiding the wart of orphan instances.--instance Extend [] where- duplicated = init . tails--#ifdef MIN_VERSION_tagged-instance Extend (Tagged a) where- duplicated = Tagged-#endif--instance Extend Proxy where- duplicated _ = Proxy- extended _ _ = Proxy--instance Extend Maybe where- duplicated Nothing = Nothing- duplicated j = Just j--instance Extend (Either a) where- duplicated (Left a) = Left a- duplicated r = Right r--instance Extend ((,)e) where- duplicated p = (fst p, p)--instance Semigroup m => Extend ((->)m) where- duplicated f m = f . (<>) m--#ifdef MIN_VERSION_containers-instance Extend Seq where- duplicated l = Seq.take (Seq.length l) (Seq.tails l)--instance Extend Tree where- duplicated w@(Node _ as) = Node w (map duplicated as)-#endif--#ifdef MIN_VERSION_comonad-{--instance (Extend f, Extend g) => Extend (Coproduct f g) where- extended f = Coproduct . coproduct- (Left . extended (f . Coproduct . Left))- (Right . extended (f . Coproduct . Right))--}--instance Extend w => Extend (EnvT e w) where- duplicated (EnvT e wa) = EnvT e (extended (EnvT e) wa)--instance Extend w => Extend (StoreT s w) where- duplicated (StoreT wf s) = StoreT (extended StoreT wf) s- extended f (StoreT wf s) = StoreT (extended (\wf' s' -> f (StoreT wf' s')) wf) s--instance (Extend w, Semigroup m) => Extend (TracedT m w) where- extended f = TracedT . extended (\wf m -> f (TracedT (fmap (. (<>) m) wf))) . runTracedT-#endif---- I can't fix the world--- instance (Monoid m, Extend n) => Extend (ReaderT m n)--- duplicate f m = f . mappend m---- * Extends for types from 'transformers'.------ This isn't really a transformer, so i have no compunction about including the instance here.------ TODO: Petition to move Data.Functor.Identity into base-instance Extend Identity where- duplicated = Identity---- Provided to avoid an orphan instance. Not proposed to standardize.--- If Extend moved to base, consider moving instance into transformers?-instance Extend w => Extend (IdentityT w) where- extended f (IdentityT m) = IdentityT (extended (f . IdentityT) m)--instance Extend NonEmpty where- extended f w@(~(_ :| aas)) =- f w :| case aas of- [] -> []- (a:as) -> toList (extended f (a :| as))--instance (Extend f, Extend g) => Extend (Functor.Sum f g) where- extended f (InL l) = InL (extended (f . InL) l)- extended f (InR r) = InR (extended (f . InR) r)--instance (Extend f, Extend g) => Extend (f :+: g) where- extended f (L1 l) = L1 (extended (f . L1) l)- extended f (R1 r) = R1 (extended (f . R1) r)---- | @since 5.3.8-instance Extend (Generics.K1 i c) where- duplicated (K1 c) = K1 c--instance Extend Generics.U1 where- extended _ U1 = U1--instance Extend Generics.V1 where- extended _ e = case e of {}--instance Extend f => Extend (Generics.M1 i t f) where- extended f = M1 . extended (f . M1) . unM1--instance Extend Par1 where- extended f w@Par1{} = Par1 (f w)--instance Extend f => Extend (Rec1 f) where- extended f = Rec1 . extended (f . Rec1) . unRec1--instance Extend Monoid.Sum where- extended f w@Monoid.Sum{} = Monoid.Sum (f w)--instance Extend Monoid.Product where- extended f w@Monoid.Product{} = Monoid.Product (f w)--instance Extend Monoid.Dual where- extended f w@Monoid.Dual{} = Monoid.Dual (f w)--instance Extend f => Extend (Monoid.Alt f) where- extended f = Monoid.Alt . extended (f . Monoid.Alt) . Monoid.getAlt---- in GHC 8.6 we'll have to deal with Apply f => Apply (Ap f) the same way-instance Extend Semigroup.First where- extended f w@Semigroup.First{} = Semigroup.First (f w)--instance Extend Semigroup.Last where- extended f w@Semigroup.Last{} = Semigroup.Last (f w)--instance Extend Semigroup.Min where- extended f w@Semigroup.Min{} = Semigroup.Min (f w)--instance Extend Semigroup.Max where- extended f w@Semigroup.Max{} = Semigroup.Max (f w)---- $definition--- There are two ways to define an 'Extend' instance:------ I. Provide definitions for 'extended'--- satisfying this law:------ > extended f . extended g = extended (f . extended g)------ II. Alternately, you may choose to provide definitions for 'duplicated'--- satisfying this law:------ > duplicated . duplicated = fmap duplicated . duplicated------ You may of course, choose to define both 'duplicated' /and/ 'extended'.--- In that case you must also satisfy these laws:------ > extended f = fmap f . duplicated--- > duplicated = extended id------ These are the default definitions of 'extended' and 'duplicated'.+{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Extend +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Functor.Extend + ( -- * Extendable Functors + -- $definition + Extend(..) + , gduplicated + , gextended + ) where + +import Prelude hiding (id, (.)) +import Control.Category +import Control.Monad.Trans.Identity +import Data.Functor.Identity +import Data.Functor.Sum as Functor (Sum(..)) +import Data.List (tails) +import Data.List.NonEmpty (NonEmpty(..), toList) +import Data.Orphans () +import qualified Data.Monoid as Monoid +import Data.Proxy +import Data.Semigroup as Semigroup +import GHC.Generics as Generics + +#ifdef MIN_VERSION_containers +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Tree +#endif + +#ifdef MIN_VERSION_comonad +import Control.Comonad.Trans.Env +import Control.Comonad.Trans.Store +import Control.Comonad.Trans.Traced +#endif + +#ifdef MIN_VERSION_tagged +import Data.Tagged +#endif + +class Functor w => Extend w where + -- | + -- > duplicated = extended id + -- > fmap (fmap f) . duplicated = duplicated . fmap f + duplicated :: w a -> w (w a) + -- | + -- > extended f = fmap f . duplicated + extended :: (w a -> b) -> w a -> w b + + extended f = fmap f . duplicated + duplicated = extended id + + {-# MINIMAL duplicated | extended #-} + +-- | Generic 'duplicated'. Caveats: +-- +-- 1. Will not compile if @w@ is a product type. +-- 2. Will not compile if @w@ contains fields where the type variable appears underneath the composition of type constructors (e.g., @f (g a)@). +-- +-- @since 5.3.8 +gduplicated :: (Extend (Rep1 w), Generic1 w) => w a -> w (w a) +gduplicated = to1 . fmap to1 . duplicated . from1 + +-- | Generic 'extended'. Caveats are the same as for 'gduplicated'. +-- +-- @since 5.3.8 +gextended :: (Extend (Rep1 w), Generic1 w) => (w a -> b) -> w a -> w b +gextended f = to1 . extended (f . to1) . from1 + +-- * Extends for Prelude types: +-- +-- Instances: While Data.Functor.Extend.Instances would be symmetric +-- to the definition of Control.Monad.Instances in base, the reason +-- the latter exists is because of Haskell 98 specifying the types +-- @'Either' a@, @((,)m)@ and @((->)e)@ and the class Monad without +-- having the foresight to require or allow instances between them. +-- +-- Here Haskell 98 says nothing about Extend, so we can include the +-- instances directly avoiding the wart of orphan instances. + +instance Extend [] where + duplicated = init . tails + +#ifdef MIN_VERSION_tagged +instance Extend (Tagged a) where + duplicated = Tagged +#endif + +instance Extend Proxy where + duplicated _ = Proxy + extended _ _ = Proxy + +instance Extend Maybe where + duplicated Nothing = Nothing + duplicated j = Just j + +instance Extend (Either a) where + duplicated (Left a) = Left a + duplicated r = Right r + +instance Extend ((,)e) where + duplicated p = (fst p, p) + +instance Semigroup m => Extend ((->)m) where + duplicated f m = f . (<>) m + +#ifdef MIN_VERSION_containers +instance Extend Seq where + duplicated l = Seq.take (Seq.length l) (Seq.tails l) + +instance Extend Tree where + duplicated w@(Node _ as) = Node w (map duplicated as) +#endif + +#ifdef MIN_VERSION_comonad +{- +instance (Extend f, Extend g) => Extend (Coproduct f g) where + extended f = Coproduct . coproduct + (Left . extended (f . Coproduct . Left)) + (Right . extended (f . Coproduct . Right)) +-} + +instance Extend w => Extend (EnvT e w) where + duplicated (EnvT e wa) = EnvT e (extended (EnvT e) wa) + +instance Extend w => Extend (StoreT s w) where + duplicated (StoreT wf s) = StoreT (extended StoreT wf) s + extended f (StoreT wf s) = StoreT (extended (\wf' s' -> f (StoreT wf' s')) wf) s + +instance (Extend w, Semigroup m) => Extend (TracedT m w) where + extended f = TracedT . extended (\wf m -> f (TracedT (fmap (. (<>) m) wf))) . runTracedT +#endif + +-- I can't fix the world +-- instance (Monoid m, Extend n) => Extend (ReaderT m n) +-- duplicate f m = f . mappend m + +-- * Extends for types from 'transformers'. +-- +-- This isn't really a transformer, so i have no compunction about including the instance here. +-- +-- TODO: Petition to move Data.Functor.Identity into base +instance Extend Identity where + duplicated = Identity + +-- Provided to avoid an orphan instance. Not proposed to standardize. +-- If Extend moved to base, consider moving instance into transformers? +instance Extend w => Extend (IdentityT w) where + extended f (IdentityT m) = IdentityT (extended (f . IdentityT) m) + +instance Extend NonEmpty where + extended f w@(~(_ :| aas)) = + f w :| case aas of + [] -> [] + (a:as) -> toList (extended f (a :| as)) + +instance (Extend f, Extend g) => Extend (Functor.Sum f g) where + extended f (InL l) = InL (extended (f . InL) l) + extended f (InR r) = InR (extended (f . InR) r) + +instance (Extend f, Extend g) => Extend (f :+: g) where + extended f (L1 l) = L1 (extended (f . L1) l) + extended f (R1 r) = R1 (extended (f . R1) r) + +-- | @since 5.3.8 +instance Extend (Generics.K1 i c) where + duplicated (K1 c) = K1 c + +instance Extend Generics.U1 where + extended _ U1 = U1 + +instance Extend Generics.V1 where + extended _ e = case e of {} + +instance Extend f => Extend (Generics.M1 i t f) where + extended f = M1 . extended (f . M1) . unM1 + +instance Extend Par1 where + extended f w@Par1{} = Par1 (f w) + +instance Extend f => Extend (Rec1 f) where + extended f = Rec1 . extended (f . Rec1) . unRec1 + +instance Extend Monoid.Sum where + extended f w@Monoid.Sum{} = Monoid.Sum (f w) + +instance Extend Monoid.Product where + extended f w@Monoid.Product{} = Monoid.Product (f w) + +instance Extend Monoid.Dual where + extended f w@Monoid.Dual{} = Monoid.Dual (f w) + +instance Extend f => Extend (Monoid.Alt f) where + extended f = Monoid.Alt . extended (f . Monoid.Alt) . Monoid.getAlt + +-- in GHC 8.6 we'll have to deal with Apply f => Apply (Ap f) the same way +instance Extend Semigroup.First where + extended f w@Semigroup.First{} = Semigroup.First (f w) + +instance Extend Semigroup.Last where + extended f w@Semigroup.Last{} = Semigroup.Last (f w) + +instance Extend Semigroup.Min where + extended f w@Semigroup.Min{} = Semigroup.Min (f w) + +instance Extend Semigroup.Max where + extended f w@Semigroup.Max{} = Semigroup.Max (f w) + +-- $definition +-- There are two ways to define an 'Extend' instance: +-- +-- I. Provide definitions for 'extended' +-- satisfying this law: +-- +-- > extended f . extended g = extended (f . extended g) +-- +-- II. Alternately, you may choose to provide definitions for 'duplicated' +-- satisfying this law: +-- +-- > duplicated . duplicated = fmap duplicated . duplicated +-- +-- You may of course, choose to define both 'duplicated' /and/ 'extended'. +-- In that case you must also satisfy these laws: +-- +-- > extended f = fmap f . duplicated +-- > duplicated = extended id +-- +-- These are the default definitions of 'extended' and 'duplicated'.
src/Data/Functor/Plus.hs view
@@ -1,235 +1,235 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeOperators #-}--------------------------------------------------------------------------------- |--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Functor.Plus- ( Plus(..)- , psum- , gzero- , module Data.Functor.Alt- ) where--import Control.Applicative hiding (some, many)-import Control.Applicative.Backwards-import Control.Applicative.Lift-import Control.Arrow-import Control.Monad-import Control.Monad.Trans.Identity-import Control.Monad.Trans.Except-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Reader-#if MIN_VERSION_transformers(0,5,6)-import qualified Control.Monad.Trans.RWS.CPS as CPS-import qualified Control.Monad.Trans.Writer.CPS as CPS-import Semigroupoids.Internal-#endif-import qualified Control.Monad.Trans.RWS.Strict as Strict-import qualified Control.Monad.Trans.State.Strict as Strict-import qualified Control.Monad.Trans.Writer.Strict as Strict-import qualified Control.Monad.Trans.RWS.Lazy as Lazy-import qualified Control.Monad.Trans.State.Lazy as Lazy-import qualified Control.Monad.Trans.Writer.Lazy as Lazy-import Data.Foldable hiding (asum)-import Data.Functor.Apply-import Data.Functor.Alt-import Data.Functor.Compose-import Data.Functor.Product-import Data.Functor.Reverse-import qualified Data.Monoid as Monoid-import Data.Proxy-import Data.Semigroup hiding (Product)-import GHC.Generics-import Prelude hiding (id, (.), foldr)--#if !(MIN_VERSION_transformers(0,6,0))-import Control.Monad.Trans.Error-import Control.Monad.Trans.List-#endif--#ifdef MIN_VERSION_containers-import qualified Data.IntMap as IntMap-import Data.IntMap (IntMap)-import Data.Sequence (Seq)-import qualified Data.Map as Map-import Data.Map (Map)-#endif--#ifdef MIN_VERSION_unordered_containers-import Data.Hashable-import Data.HashMap.Lazy (HashMap)-import qualified Data.HashMap.Lazy as HashMap-#endif---- | Laws:------ > zero <!> m = m--- > m <!> zero = m------ If extended to an 'Alternative' then 'zero' should equal 'empty'.-class Alt f => Plus f where- zero :: f a---- | The sum of a collection of actions, generalizing 'concat'.------ >>> psum [Just "Hello", Nothing, Just "World"]--- Just "Hello"------ @since 5.3.6-psum :: (Foldable t, Plus f) => t (f a) -> f a-psum = foldr (<!>) zero---- | Generic 'zero'. Caveats:------ 1. Will not compile if @f@ is a sum type.--- 2. Any types where the @a@ does not appear must have a 'Monoid' instance.------ @since 5.3.8-gzero :: (Plus (Rep1 f), Generic1 f) => f a-gzero = to1 zero--instance Plus Proxy where- zero = Proxy--instance Plus U1 where- zero = U1---- | @since 5.3.8-instance (Monoid c-#if !(MIN_VERSION_base(4,11,0))- , Semigroup c-#endif- ) => Plus (K1 i c) where- zero = K1 mempty--instance (Plus f, Plus g) => Plus (f :*: g) where- zero = zero :*: zero---- | @since 5.3.8-instance (Plus f, Functor g) => Plus (f :.: g) where- zero = Comp1 zero--instance Plus f => Plus (M1 i c f) where- zero = M1 zero--instance Plus f => Plus (Rec1 f) where- zero = Rec1 zero--instance Plus IO where- zero = error "zero"--instance Plus [] where- zero = []--instance Plus Maybe where- zero = Nothing--#if !(MIN_VERSION_base(4,16,0))-instance Plus Option where- zero = empty-#endif--instance MonadPlus m => Plus (WrappedMonad m) where- zero = empty--instance ArrowPlus a => Plus (WrappedArrow a b) where- zero = empty--#ifdef MIN_VERSION_containers-instance Ord k => Plus (Map k) where- zero = Map.empty--instance Plus IntMap where- zero = IntMap.empty--instance Plus Seq where- zero = mempty-#endif--#ifdef MIN_VERSION_unordered_containers-instance (Hashable k, Eq k) => Plus (HashMap k) where- zero = HashMap.empty-#endif--instance Alternative f => Plus (WrappedApplicative f) where- zero = empty--instance Plus f => Plus (IdentityT f) where- zero = IdentityT zero--instance Plus f => Plus (ReaderT e f) where- zero = ReaderT $ \_ -> zero--instance (Functor f, Monad f) => Plus (MaybeT f) where- zero = MaybeT $ return zero--#if !(MIN_VERSION_transformers(0,6,0))-instance (Functor f, Monad f, Error e) => Plus (ErrorT e f) where- zero = ErrorT $ return $ Left noMsg--instance (Apply f, Applicative f) => Plus (ListT f) where- zero = ListT $ pure []-#endif--instance (Functor f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f) where- zero = ExceptT $ return $ Left mempty--instance Plus f => Plus (Strict.StateT e f) where- zero = Strict.StateT $ \_ -> zero--instance Plus f => Plus (Lazy.StateT e f) where- zero = Lazy.StateT $ \_ -> zero--instance Plus f => Plus (Strict.WriterT w f) where- zero = Strict.WriterT zero--instance Plus f => Plus (Lazy.WriterT w f) where- zero = Lazy.WriterT zero--#if MIN_VERSION_transformers(0,5,6)--- | @since 5.3.6-instance (Plus f) => Plus (CPS.WriterT w f) where- zero = mkWriterT $ const zero-#endif--instance Plus f => Plus (Strict.RWST r w s f) where- zero = Strict.RWST $ \_ _ -> zero--instance Plus f => Plus (Lazy.RWST r w s f) where- zero = Lazy.RWST $ \_ _ -> zero--#if MIN_VERSION_transformers(0,5,6)--- | @since 5.3.6-instance (Plus f) => Plus (CPS.RWST r w s f) where- zero = mkRWST $ \_ _ _ -> zero-#endif--instance Plus f => Plus (Backwards f) where- zero = Backwards zero--instance (Plus f, Functor g) => Plus (Compose f g) where- zero = Compose zero--instance Plus f => Plus (Lift f) where- zero = Other zero--instance (Plus f, Plus g) => Plus (Product f g) where- zero = Pair zero zero--instance Plus f => Plus (Reverse f) where- zero = Reverse zero--instance Plus Monoid.First where- zero = Monoid.First Nothing--instance Plus Monoid.Last where- zero = Monoid.Last Nothing+{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Functor.Plus + ( Plus(..) + , psum + , gzero + , module Data.Functor.Alt + ) where + +import Control.Applicative hiding (some, many) +import Control.Applicative.Backwards +import Control.Applicative.Lift +import Control.Arrow +import Control.Monad +import Control.Monad.Trans.Identity +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +#if MIN_VERSION_transformers(0,5,6) +import qualified Control.Monad.Trans.RWS.CPS as CPS +import qualified Control.Monad.Trans.Writer.CPS as CPS +import Semigroupoids.Internal +#endif +import qualified Control.Monad.Trans.RWS.Strict as Strict +import qualified Control.Monad.Trans.State.Strict as Strict +import qualified Control.Monad.Trans.Writer.Strict as Strict +import qualified Control.Monad.Trans.RWS.Lazy as Lazy +import qualified Control.Monad.Trans.State.Lazy as Lazy +import qualified Control.Monad.Trans.Writer.Lazy as Lazy +import Data.Foldable hiding (asum) +import Data.Functor.Apply +import Data.Functor.Alt +import Data.Functor.Compose +import Data.Functor.Product +import Data.Functor.Reverse +import qualified Data.Monoid as Monoid +import Data.Proxy +import Data.Semigroup hiding (Product) +import GHC.Generics +import Prelude hiding (id, (.), foldr) + +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.Error +import Control.Monad.Trans.List +#endif + +#ifdef MIN_VERSION_containers +import qualified Data.IntMap as IntMap +import Data.IntMap (IntMap) +import Data.Sequence (Seq) +import qualified Data.Map as Map +import Data.Map (Map) +#endif + +#ifdef MIN_VERSION_unordered_containers +import Data.Hashable +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as HashMap +#endif + +-- | Laws: +-- +-- > zero <!> m = m +-- > m <!> zero = m +-- +-- If extended to an 'Alternative' then 'zero' should equal 'empty'. +class Alt f => Plus f where + zero :: f a + +-- | The sum of a collection of actions, generalizing 'concat'. +-- +-- >>> psum [Just "Hello", Nothing, Just "World"] +-- Just "Hello" +-- +-- @since 5.3.6 +psum :: (Foldable t, Plus f) => t (f a) -> f a +psum = foldr (<!>) zero + +-- | Generic 'zero'. Caveats: +-- +-- 1. Will not compile if @f@ is a sum type. +-- 2. Any types where the @a@ does not appear must have a 'Monoid' instance. +-- +-- @since 5.3.8 +gzero :: (Plus (Rep1 f), Generic1 f) => f a +gzero = to1 zero + +instance Plus Proxy where + zero = Proxy + +instance Plus U1 where + zero = U1 + +-- | @since 5.3.8 +instance (Monoid c +#if !(MIN_VERSION_base(4,11,0)) + , Semigroup c +#endif + ) => Plus (K1 i c) where + zero = K1 mempty + +instance (Plus f, Plus g) => Plus (f :*: g) where + zero = zero :*: zero + +-- | @since 5.3.8 +instance (Plus f, Functor g) => Plus (f :.: g) where + zero = Comp1 zero + +instance Plus f => Plus (M1 i c f) where + zero = M1 zero + +instance Plus f => Plus (Rec1 f) where + zero = Rec1 zero + +instance Plus IO where + zero = error "zero" + +instance Plus [] where + zero = [] + +instance Plus Maybe where + zero = Nothing + +#if !(MIN_VERSION_base(4,16,0)) +instance Plus Option where + zero = empty +#endif + +instance MonadPlus m => Plus (WrappedMonad m) where + zero = empty + +instance ArrowPlus a => Plus (WrappedArrow a b) where + zero = empty + +#ifdef MIN_VERSION_containers +instance Ord k => Plus (Map k) where + zero = Map.empty + +instance Plus IntMap where + zero = IntMap.empty + +instance Plus Seq where + zero = mempty +#endif + +#ifdef MIN_VERSION_unordered_containers +instance (Hashable k, Eq k) => Plus (HashMap k) where + zero = HashMap.empty +#endif + +instance Alternative f => Plus (WrappedApplicative f) where + zero = empty + +instance Plus f => Plus (IdentityT f) where + zero = IdentityT zero + +instance Plus f => Plus (ReaderT e f) where + zero = ReaderT $ \_ -> zero + +instance (Functor f, Monad f) => Plus (MaybeT f) where + zero = MaybeT $ return zero + +#if !(MIN_VERSION_transformers(0,6,0)) +instance (Functor f, Monad f, Error e) => Plus (ErrorT e f) where + zero = ErrorT $ return $ Left noMsg + +instance (Apply f, Applicative f) => Plus (ListT f) where + zero = ListT $ pure [] +#endif + +instance (Functor f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f) where + zero = ExceptT $ return $ Left mempty + +instance Plus f => Plus (Strict.StateT e f) where + zero = Strict.StateT $ \_ -> zero + +instance Plus f => Plus (Lazy.StateT e f) where + zero = Lazy.StateT $ \_ -> zero + +instance Plus f => Plus (Strict.WriterT w f) where + zero = Strict.WriterT zero + +instance Plus f => Plus (Lazy.WriterT w f) where + zero = Lazy.WriterT zero + +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance (Plus f) => Plus (CPS.WriterT w f) where + zero = mkWriterT $ const zero +#endif + +instance Plus f => Plus (Strict.RWST r w s f) where + zero = Strict.RWST $ \_ _ -> zero + +instance Plus f => Plus (Lazy.RWST r w s f) where + zero = Lazy.RWST $ \_ _ -> zero + +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance (Plus f) => Plus (CPS.RWST r w s f) where + zero = mkRWST $ \_ _ _ -> zero +#endif + +instance Plus f => Plus (Backwards f) where + zero = Backwards zero + +instance (Plus f, Functor g) => Plus (Compose f g) where + zero = Compose zero + +instance Plus f => Plus (Lift f) where + zero = Other zero + +instance (Plus f, Plus g) => Plus (Product f g) where + zero = Pair zero zero + +instance Plus f => Plus (Reverse f) where + zero = Reverse zero + +instance Plus Monoid.First where + zero = Monoid.First Nothing + +instance Plus Monoid.Last where + zero = Monoid.Last Nothing
src/Data/Groupoid.hs view
@@ -1,42 +1,42 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE Trustworthy #-}--------------------------------------------------------------------------------- |--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : polykinds----------------------------------------------------------------------------------module Data.Groupoid- ( Groupoid(..)- ) where--import Data.Semigroupoid-import Data.Semigroupoid.Dual-import qualified Data.Type.Coercion as Co-import qualified Data.Type.Equality as Eq---- | semigroupoid with inverses. This technically should be a category with inverses, except we need to use Ob to define the valid objects for the category-class Semigroupoid k => Groupoid k where- inv :: k a b -> k b a--instance Groupoid k => Groupoid (Dual k) where- inv (Dual k) = Dual (inv k)--instance Groupoid Co.Coercion where- inv = Co.sym--instance Groupoid (Eq.:~:) where- inv = Eq.sym--#if MIN_VERSION_base(4,10,0)-instance Groupoid (Eq.:~~:) where- inv Eq.HRefl = Eq.HRefl-#endif+{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Trustworthy #-} +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : polykinds +-- +---------------------------------------------------------------------------- + +module Data.Groupoid + ( Groupoid(..) + ) where + +import Data.Semigroupoid +import Data.Semigroupoid.Dual +import qualified Data.Type.Coercion as Co +import qualified Data.Type.Equality as Eq + +-- | semigroupoid with inverses. This technically should be a category with inverses, except we need to use Ob to define the valid objects for the category +class Semigroupoid k => Groupoid k where + inv :: k a b -> k b a + +instance Groupoid k => Groupoid (Dual k) where + inv (Dual k) = Dual (inv k) + +instance Groupoid Co.Coercion where + inv = Co.sym + +instance Groupoid (Eq.:~:) where + inv = Eq.sym + +#if MIN_VERSION_base(4,10,0) +instance Groupoid (Eq.:~~:) where + inv Eq.HRefl = Eq.HRefl +#endif
src/Data/Isomorphism.hs view
@@ -1,33 +1,33 @@-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE Safe #-}--------------------------------------------------------------------------------- |--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : polykinds----------------------------------------------------------------------------------module Data.Isomorphism- ( Iso(..)- ) where--import Control.Category-import Data.Semigroupoid-import Data.Groupoid-import Prelude ()--data Iso k a b = Iso { embed :: k a b, project :: k b a }--instance Semigroupoid k => Semigroupoid (Iso k) where- Iso f g `o` Iso h i = Iso (f `o` h) (i `o` g)--instance Semigroupoid k => Groupoid (Iso k) where- inv (Iso f g) = Iso g f--instance Category k => Category (Iso k) where- Iso f g . Iso h i = Iso (f . h) (i . g)- id = Iso id id+{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : polykinds +-- +---------------------------------------------------------------------------- + +module Data.Isomorphism + ( Iso(..) + ) where + +import Control.Category +import Data.Semigroupoid +import Data.Groupoid +import Prelude () + +data Iso k a b = Iso { embed :: k a b, project :: k b a } + +instance Semigroupoid k => Semigroupoid (Iso k) where + Iso f g `o` Iso h i = Iso (f `o` h) (i `o` g) + +instance Semigroupoid k => Groupoid (Iso k) where + inv (Iso f g) = Iso g f + +instance Category k => Category (Iso k) where + Iso f g . Iso h i = Iso (f . h) (i . g) + id = Iso id id
src/Data/Semigroup/Bifoldable.hs view
@@ -1,64 +1,64 @@-{-# LANGUAGE Safe #-}--------------------------------------------------------------------------------- |--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ Re-exports a subset of the "Data.Bifoldable1" module along with some--- additional combinators that require 'Bifoldable1' constraints.---------------------------------------------------------------------------------module Data.Semigroup.Bifoldable- ( -- @Data.Bifoldable1@ re-exports- Bifoldable1(bifold1, bifoldMap1)-- -- Additional @Bifoldable1@ functionality- , bitraverse1_- , bifor1_- , bisequenceA1_- , bifoldMapDefault1- ) where--import Control.Applicative-import Data.Bifoldable-import Data.Bifoldable1-import Data.Functor.Apply-import Data.Semigroup-import Prelude hiding (foldr)--newtype Act f a = Act { getAct :: f a }--instance Apply f => Semigroup (Act f a) where- Act a <> Act b = Act (a .> b)- {-# INLINE (<>) #-}--instance Functor f => Functor (Act f) where- fmap f (Act a) = Act (f <$> a)- {-# INLINE fmap #-}- b <$ Act a = Act (b <$ a)- {-# INLINE (<$) #-}--bitraverse1_ :: (Bifoldable1 t, Apply f) => (a -> f b) -> (c -> f d) -> t a c -> f ()-bitraverse1_ f g t = getAct (bifoldMap1 (Act . ignore . f) (Act . ignore . g) t)-{-# INLINE bitraverse1_ #-}--bifor1_ :: (Bifoldable1 t, Apply f) => t a c -> (a -> f b) -> (c -> f d) -> f ()-bifor1_ t f g = bitraverse1_ f g t-{-# INLINE bifor1_ #-}--ignore :: Functor f => f a -> f ()-ignore = (() <$)-{-# INLINE ignore #-}--bisequenceA1_ :: (Bifoldable1 t, Apply f) => t (f a) (f b) -> f ()-bisequenceA1_ t = getAct (bifoldMap1 (Act . ignore) (Act . ignore) t)-{-# INLINE bisequenceA1_ #-}---- | Usable default for foldMap, but only if you define bifoldMap1 yourself-bifoldMapDefault1 :: (Bifoldable1 t, Monoid m) => (a -> m) -> (b -> m) -> t a b -> m-bifoldMapDefault1 f g = unwrapMonoid . bifoldMap (WrapMonoid . f) (WrapMonoid . g)-{-# INLINE bifoldMapDefault1 #-}+{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +-- Re-exports a subset of the "Data.Bifoldable1" module along with some +-- additional combinators that require 'Bifoldable1' constraints. +-- +---------------------------------------------------------------------------- +module Data.Semigroup.Bifoldable + ( -- @Data.Bifoldable1@ re-exports + Bifoldable1(bifold1, bifoldMap1) + + -- Additional @Bifoldable1@ functionality + , bitraverse1_ + , bifor1_ + , bisequenceA1_ + , bifoldMapDefault1 + ) where + +import Control.Applicative +import Data.Bifoldable +import Data.Bifoldable1 +import Data.Functor.Apply +import Data.Semigroup +import Prelude hiding (foldr) + +newtype Act f a = Act { getAct :: f a } + +instance Apply f => Semigroup (Act f a) where + Act a <> Act b = Act (a .> b) + {-# INLINE (<>) #-} + +instance Functor f => Functor (Act f) where + fmap f (Act a) = Act (f <$> a) + {-# INLINE fmap #-} + b <$ Act a = Act (b <$ a) + {-# INLINE (<$) #-} + +bitraverse1_ :: (Bifoldable1 t, Apply f) => (a -> f b) -> (c -> f d) -> t a c -> f () +bitraverse1_ f g t = getAct (bifoldMap1 (Act . ignore . f) (Act . ignore . g) t) +{-# INLINE bitraverse1_ #-} + +bifor1_ :: (Bifoldable1 t, Apply f) => t a c -> (a -> f b) -> (c -> f d) -> f () +bifor1_ t f g = bitraverse1_ f g t +{-# INLINE bifor1_ #-} + +ignore :: Functor f => f a -> f () +ignore = (() <$) +{-# INLINE ignore #-} + +bisequenceA1_ :: (Bifoldable1 t, Apply f) => t (f a) (f b) -> f () +bisequenceA1_ t = getAct (bifoldMap1 (Act . ignore) (Act . ignore) t) +{-# INLINE bisequenceA1_ #-} + +-- | Usable default for foldMap, but only if you define bifoldMap1 yourself +bifoldMapDefault1 :: (Bifoldable1 t, Monoid m) => (a -> m) -> (b -> m) -> t a b -> m +bifoldMapDefault1 f g = unwrapMonoid . bifoldMap (WrapMonoid . f) (WrapMonoid . g) +{-# INLINE bifoldMapDefault1 #-}
src/Data/Semigroup/Bitraversable.hs view
@@ -1,26 +1,26 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE Safe #-}--------------------------------------------------------------------------------- |--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Semigroup.Bitraversable- ( Bitraversable1(..)- , bifoldMap1Default- ) where--import Control.Applicative-#if !(MIN_VERSION_base(4,11,0))-import Data.Semigroup-#endif-import Data.Semigroup.Traversable.Class--bifoldMap1Default :: (Bitraversable1 t, Semigroup m) => (a -> m) -> (b -> m) -> t a b -> m-bifoldMap1Default f g = getConst . bitraverse1 (Const . f) (Const . g)-{-# INLINE bifoldMap1Default #-}+{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Semigroup.Bitraversable + ( Bitraversable1(..) + , bifoldMap1Default + ) where + +import Control.Applicative +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup +#endif +import Data.Semigroup.Traversable.Class + +bifoldMap1Default :: (Bitraversable1 t, Semigroup m) => (a -> m) -> (b -> m) -> t a b -> m +bifoldMap1Default f g = getConst . bitraverse1 (Const . f) (Const . g) +{-# INLINE bifoldMap1Default #-}
src/Data/Semigroup/Foldable.hs view
@@ -1,126 +1,126 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Safe #-}--------------------------------------------------------------------------------- |--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ Re-exports a subset of the "Data.Foldable1" module along with some additional--- combinators that require 'Foldable1' constraints.---------------------------------------------------------------------------------module Data.Semigroup.Foldable- ( -- @Data.Foldable1@ re-exports- Foldable1(fold1, foldMap1, toNonEmpty)- , intercalate1- , foldrM1- , foldlM1-- -- Additional @Foldable1@ functionality- , intercalateMap1- , traverse1_- , for1_- , sequenceA1_- , foldMapDefault1- , asum1-- -- Generic defaults- , gfold1- , gfoldMap1- , gtoNonEmpty- ) where--import Data.Foldable-import Data.Foldable1-import Data.Functor.Alt (Alt(..))-import Data.Functor.Apply-import Data.List.NonEmpty (NonEmpty(..))-import Data.Traversable.Instances ()-import Data.Semigroup hiding (Product, Sum)-import GHC.Generics-import Prelude hiding (foldr)---- $setup--- >>> import Data.List.NonEmpty (NonEmpty (..))--- >>> import Data.Monoid (Monoid (..))--newtype JoinWith a = JoinWith {joinee :: (a -> a)}--instance Semigroup a => Semigroup (JoinWith a) where- JoinWith a <> JoinWith b = JoinWith $ \j -> a j <> j <> b j---- | Insert @m@ between each pair of @m@ derived from @a@.------ >>> intercalateMap1 " " show $ True :| [False, True]--- "True False True"------ >>> intercalateMap1 " " show $ True :| []--- "True"-intercalateMap1 :: (Foldable1 t, Semigroup m) => m -> (a -> m) -> t a -> m-intercalateMap1 j f = flip joinee j . foldMap1 (JoinWith . const . f)-{-# INLINE intercalateMap1 #-}--newtype Act f a = Act { getAct :: f a }--instance Apply f => Semigroup (Act f a) where- Act a <> Act b = Act (a .> b)--instance Functor f => Functor (Act f) where- fmap f (Act a) = Act (f <$> a)- b <$ Act a = Act (b <$ a)--traverse1_ :: (Foldable1 t, Apply f) => (a -> f b) -> t a -> f ()-traverse1_ f t = () <$ getAct (foldMap1 (Act . f) t)-{-# INLINE traverse1_ #-}--for1_ :: (Foldable1 t, Apply f) => t a -> (a -> f b) -> f ()-for1_ = flip traverse1_-{-# INLINE for1_ #-}--sequenceA1_ :: (Foldable1 t, Apply f) => t (f a) -> f ()-sequenceA1_ t = () <$ getAct (foldMap1 Act t)-{-# INLINE sequenceA1_ #-}---- | Usable default for foldMap, but only if you define foldMap1 yourself-foldMapDefault1 :: (Foldable1 t, Monoid m) => (a -> m) -> t a -> m-foldMapDefault1 f = unwrapMonoid . foldMap (WrapMonoid . f)-{-# INLINE foldMapDefault1 #-}---- toStream :: Foldable1 t => t a -> Stream a--- concat1 :: Foldable1 t => t (Stream a) -> Stream a--- concatMap1 :: Foldable1 t => (a -> Stream b) -> t a -> Stream b--newtype Alt_ f a = Alt_ { getAlt_ :: f a }--instance Alt f => Semigroup (Alt_ f a) where- Alt_ a <> Alt_ b = Alt_ (a <!> b)--asum1 :: (Foldable1 t, Alt m) => t (m a) -> m a-asum1 = getAlt_ . foldMap1 Alt_-{-# INLINE asum1 #-}---- | Generic 'fold1'. Caveats:------ 1. Will not compile if @t@ is an empty constructor.--- 2. Will not compile if @t@ has some fields that don't mention @a@, for exmaple @data Bar a = MkBar a Int@------ @since 5.3.8-gfold1 :: (Foldable1 (Rep1 t), Generic1 t, Semigroup m) => t m -> m-gfold1 = fold1 . from1---- | Generic 'foldMap1'. Caveats are the same as for 'gfold1'.------ @since 5.3.8-gfoldMap1 :: (Foldable1 (Rep1 t), Generic1 t, Semigroup m) => (a -> m) -> t a -> m-gfoldMap1 f = foldMap1 f . from1---- | Generic 'toNonEmpty'. Caveats are the same as for 'gfold1'.------ @since 5.3.8-gtoNonEmpty :: (Foldable1 (Rep1 t), Generic1 t) => t a -> NonEmpty a-gtoNonEmpty = toNonEmpty . from1+{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +-- Re-exports a subset of the "Data.Foldable1" module along with some additional +-- combinators that require 'Foldable1' constraints. +-- +---------------------------------------------------------------------------- +module Data.Semigroup.Foldable + ( -- @Data.Foldable1@ re-exports + Foldable1(fold1, foldMap1, toNonEmpty) + , intercalate1 + , foldrM1 + , foldlM1 + + -- Additional @Foldable1@ functionality + , intercalateMap1 + , traverse1_ + , for1_ + , sequenceA1_ + , foldMapDefault1 + , asum1 + + -- Generic defaults + , gfold1 + , gfoldMap1 + , gtoNonEmpty + ) where + +import Data.Foldable +import Data.Foldable1 +import Data.Functor.Alt (Alt(..)) +import Data.Functor.Apply +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Traversable.Instances () +import Data.Semigroup hiding (Product, Sum) +import GHC.Generics +import Prelude hiding (foldr) + +-- $setup +-- >>> import Data.List.NonEmpty (NonEmpty (..)) +-- >>> import Data.Monoid (Monoid (..)) + +newtype JoinWith a = JoinWith {joinee :: (a -> a)} + +instance Semigroup a => Semigroup (JoinWith a) where + JoinWith a <> JoinWith b = JoinWith $ \j -> a j <> j <> b j + +-- | Insert @m@ between each pair of @m@ derived from @a@. +-- +-- >>> intercalateMap1 " " show $ True :| [False, True] +-- "True False True" +-- +-- >>> intercalateMap1 " " show $ True :| [] +-- "True" +intercalateMap1 :: (Foldable1 t, Semigroup m) => m -> (a -> m) -> t a -> m +intercalateMap1 j f = flip joinee j . foldMap1 (JoinWith . const . f) +{-# INLINE intercalateMap1 #-} + +newtype Act f a = Act { getAct :: f a } + +instance Apply f => Semigroup (Act f a) where + Act a <> Act b = Act (a .> b) + +instance Functor f => Functor (Act f) where + fmap f (Act a) = Act (f <$> a) + b <$ Act a = Act (b <$ a) + +traverse1_ :: (Foldable1 t, Apply f) => (a -> f b) -> t a -> f () +traverse1_ f t = () <$ getAct (foldMap1 (Act . f) t) +{-# INLINE traverse1_ #-} + +for1_ :: (Foldable1 t, Apply f) => t a -> (a -> f b) -> f () +for1_ = flip traverse1_ +{-# INLINE for1_ #-} + +sequenceA1_ :: (Foldable1 t, Apply f) => t (f a) -> f () +sequenceA1_ t = () <$ getAct (foldMap1 Act t) +{-# INLINE sequenceA1_ #-} + +-- | Usable default for foldMap, but only if you define foldMap1 yourself +foldMapDefault1 :: (Foldable1 t, Monoid m) => (a -> m) -> t a -> m +foldMapDefault1 f = unwrapMonoid . foldMap (WrapMonoid . f) +{-# INLINE foldMapDefault1 #-} + +-- toStream :: Foldable1 t => t a -> Stream a +-- concat1 :: Foldable1 t => t (Stream a) -> Stream a +-- concatMap1 :: Foldable1 t => (a -> Stream b) -> t a -> Stream b + +newtype Alt_ f a = Alt_ { getAlt_ :: f a } + +instance Alt f => Semigroup (Alt_ f a) where + Alt_ a <> Alt_ b = Alt_ (a <!> b) + +asum1 :: (Foldable1 t, Alt m) => t (m a) -> m a +asum1 = getAlt_ . foldMap1 Alt_ +{-# INLINE asum1 #-} + +-- | Generic 'fold1'. Caveats: +-- +-- 1. Will not compile if @t@ is an empty constructor. +-- 2. Will not compile if @t@ has some fields that don't mention @a@, for exmaple @data Bar a = MkBar a Int@ +-- +-- @since 5.3.8 +gfold1 :: (Foldable1 (Rep1 t), Generic1 t, Semigroup m) => t m -> m +gfold1 = fold1 . from1 + +-- | Generic 'foldMap1'. Caveats are the same as for 'gfold1'. +-- +-- @since 5.3.8 +gfoldMap1 :: (Foldable1 (Rep1 t), Generic1 t, Semigroup m) => (a -> m) -> t a -> m +gfoldMap1 f = foldMap1 f . from1 + +-- | Generic 'toNonEmpty'. Caveats are the same as for 'gfold1'. +-- +-- @since 5.3.8 +gtoNonEmpty :: (Foldable1 (Rep1 t), Generic1 t) => t a -> NonEmpty a +gtoNonEmpty = toNonEmpty . from1
src/Data/Semigroup/Foldable/Class.hs view
@@ -1,28 +1,28 @@-{-# LANGUAGE Trustworthy #-}---------------------------------------------------------------------------------- |--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Semigroup.Foldable.Class- {-# DEPRECATED- [ "This module re-exports a limited subset of the class methods in the "- , "Foldable1 and Bifoldable1 classes, which are now located in the "- , "Data.Foldable1 and Data.Bifoldable1 modules in base-4.18. "- , "(On older versions of base, these can be found in the "- , "foldable1-classes-compat library.) "- , "Import from these modules instead."- ]- #-}- ( Foldable1(fold1, foldMap1, toNonEmpty)- , Bifoldable1(bifold1, bifoldMap1)- ) where--import Data.Bifoldable1-import Data.Foldable1+{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Semigroup.Foldable.Class + {-# DEPRECATED + [ "This module re-exports a limited subset of the class methods in the " + , "Foldable1 and Bifoldable1 classes, which are now located in the " + , "Data.Foldable1 and Data.Bifoldable1 modules in base-4.18. " + , "(On older versions of base, these can be found in the " + , "foldable1-classes-compat library.) " + , "Import from these modules instead." + ] + #-} + ( Foldable1(fold1, foldMap1, toNonEmpty) + , Bifoldable1(bifold1, bifoldMap1) + ) where + +import Data.Bifoldable1 +import Data.Foldable1
src/Data/Semigroup/Traversable.hs view
@@ -1,68 +1,68 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Safe #-}--------------------------------------------------------------------------------- |--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Semigroup.Traversable- ( Traversable1(..)- -- * Defining Traversable1 instances- -- $traversable1instances- , traverse1Maybe- , gtraverse1- , gsequence1- -- * Default superclass instance helpers- , foldMap1Default- ) where--import Control.Applicative-#if !(MIN_VERSION_base(4,11,0))-import Data.Semigroup-#endif-import Data.Semigroup.Traversable.Class-import Data.Functor.Bind.Class-import GHC.Generics---- | Default implementation of 'foldMap1' given an implementation of 'Traversable1'.-foldMap1Default :: (Traversable1 f, Semigroup m) => (a -> m) -> f a -> m-foldMap1Default f = getConst . traverse1 (Const . f)---- | Generic 'traverse1'. Caveats:------ 1. Will not compile if @t@ is an empty constructor.--- 2. Will not compile if @t@ has some fields that don't mention @a@, for exmaple @data Bar a = MkBar a Int@------ @since 5.3.8-gtraverse1 ::- (Traversable1 (Rep1 t), Apply f, Generic1 t) =>- (a -> f b) ->- t a ->- f (t b)-gtraverse1 f x = to1 <$> traverse1 f (from1 x)---- | Generic 'sequence1'. Caveats are the same for 'gtraverse1'.------ @since 5.3.8-gsequence1 ::- (Traversable1 (Rep1 t), Apply f, Generic1 t) =>- t (f b) ->- f (t b)-gsequence1 = fmap to1 . sequence1 . from1---- $traversable1instances--- Defining 'Traversable1' instances for types with both 'Traversable1' and 'Traversable'--- substructures can be done with 'traverse1Maybe', '(<*.>)', and '(<.*>)'.------ > data Foo a = Foo (Maybe a) (Maybe a) a [a]--- > deriving (Functor, Traversable, Foldable)--- > instance Traversable1 Foo where--- > traverse1 f (Foo ma ma' a as) = Foo <$> traverseMaybe ma <*> traverseMaybe ma' <*.> f a <.*> traverseMaybe as--- > instance Foldable1 Foo where--- > foldMap1 = foldMap1Default+{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Semigroup.Traversable + ( Traversable1(..) + -- * Defining Traversable1 instances + -- $traversable1instances + , traverse1Maybe + , gtraverse1 + , gsequence1 + -- * Default superclass instance helpers + , foldMap1Default + ) where + +import Control.Applicative +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup +#endif +import Data.Semigroup.Traversable.Class +import Data.Functor.Bind.Class +import GHC.Generics + +-- | Default implementation of 'foldMap1' given an implementation of 'Traversable1'. +foldMap1Default :: (Traversable1 f, Semigroup m) => (a -> m) -> f a -> m +foldMap1Default f = getConst . traverse1 (Const . f) + +-- | Generic 'traverse1'. Caveats: +-- +-- 1. Will not compile if @t@ is an empty constructor. +-- 2. Will not compile if @t@ has some fields that don't mention @a@, for exmaple @data Bar a = MkBar a Int@ +-- +-- @since 5.3.8 +gtraverse1 :: + (Traversable1 (Rep1 t), Apply f, Generic1 t) => + (a -> f b) -> + t a -> + f (t b) +gtraverse1 f x = to1 <$> traverse1 f (from1 x) + +-- | Generic 'sequence1'. Caveats are the same for 'gtraverse1'. +-- +-- @since 5.3.8 +gsequence1 :: + (Traversable1 (Rep1 t), Apply f, Generic1 t) => + t (f b) -> + f (t b) +gsequence1 = fmap to1 . sequence1 . from1 + +-- $traversable1instances +-- Defining 'Traversable1' instances for types with both 'Traversable1' and 'Traversable' +-- substructures can be done with 'traverse1Maybe', '(<*.>)', and '(<.*>)'. +-- +-- > data Foo a = Foo (Maybe a) (Maybe a) a [a] +-- > deriving (Functor, Traversable, Foldable) +-- > instance Traversable1 Foo where +-- > traverse1 f (Foo ma ma' a as) = Foo <$> traverseMaybe ma <*> traverseMaybe ma' <*.> f a <.*> traverseMaybe as +-- > instance Foldable1 Foo where +-- > foldMap1 = foldMap1Default
src/Data/Semigroup/Traversable/Class.hs view
@@ -1,262 +1,243 @@-{-# LANGUAGE CPP, TypeOperators #-}-{-# LANGUAGE Trustworthy #-}--#ifdef MIN_VERSION_containers-# if MIN_VERSION_base(4,18,0)-# define HAS_FOLDABLE1_CONTAINERS MIN_VERSION_containers(0,6,7)-# else-# define HAS_FOLDABLE1_CONTAINERS 1-# endif-#else-# define HAS_FOLDABLE1_CONTAINERS 0-#endif--#if MIN_VERSION_base(4,18,0)-# define HAS_FOLDABLE1_TRANSFORMERS MIN_VERSION_transformers(0,6,1)-#else-# define HAS_FOLDABLE1_TRANSFORMERS 1-#endif---------------------------------------------------------------------------------- |--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Semigroup.Traversable.Class- ( Bitraversable1(..)- , Traversable1(..)- ) where--import Control.Applicative-import Data.Bitraversable-import Data.Bifunctor-import Data.Bifunctor.Biff-import Data.Bifunctor.Clown-import Data.Bifunctor.Flip-import Data.Bifunctor.Joker-import Data.Bifunctor.Join-import Data.Bifunctor.Product as Bifunctor-import Data.Bifunctor.Tannen-import Data.Bifunctor.Wrapped-import Data.Functor.Apply-import Data.Functor.Compose--import Data.Complex-import Data.Functor.Identity-import Data.Functor.Product as Functor-import Data.Functor.Sum as Functor-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.Monoid as Monoid-import Data.Orphans ()-import Data.Semigroup as Semigroup-import Data.Semigroup.Foldable-import Data.Semigroup.Bifoldable-#ifdef MIN_VERSION_tagged-import Data.Tagged-#endif-import Data.Traversable.Instances ()-import GHC.Generics--#if HAS_FOLDABLE1_CONTAINERS-import Data.Tree-#endif--#if HAS_FOLDABLE1_TRANSFORMERS-import Control.Applicative.Backwards-import Control.Applicative.Lift-import Control.Monad.Trans.Identity-import Data.Functor.Reverse-#endif--class (Bifoldable1 t, Bitraversable t) => Bitraversable1 t where- bitraverse1 :: Apply f => (a -> f b) -> (c -> f d) -> t a c -> f (t b d)- bitraverse1 f g = bisequence1 . bimap f g- {-# INLINE bitraverse1 #-}-- bisequence1 :: Apply f => t (f a) (f b) -> f (t a b)- bisequence1 = bitraverse1 id id- {-# INLINE bisequence1 #-}-- {-# MINIMAL bitraverse1 | bisequence1 #-}--instance Bitraversable1 Arg where- bitraverse1 f g (Arg a b) = Arg <$> f a <.> g b--instance Bitraversable1 Either where- bitraverse1 f _ (Left a) = Left <$> f a- bitraverse1 _ g (Right b) = Right <$> g b- {-# INLINE bitraverse1 #-}--instance Bitraversable1 (,) where- bitraverse1 f g (a, b) = (,) <$> f a <.> g b- {-# INLINE bitraverse1 #-}--instance Bitraversable1 ((,,) x) where- bitraverse1 f g (x, a, b) = (,,) x <$> f a <.> g b- {-# INLINE bitraverse1 #-}--instance Bitraversable1 ((,,,) x y) where- bitraverse1 f g (x, y, a, b) = (,,,) x y <$> f a <.> g b- {-# INLINE bitraverse1 #-}--instance Bitraversable1 ((,,,,) x y z) where- bitraverse1 f g (x, y, z, a, b) = (,,,,) x y z <$> f a <.> g b- {-# INLINE bitraverse1 #-}--instance Bitraversable1 Const where- bitraverse1 f _ (Const a) = Const <$> f a- {-# INLINE bitraverse1 #-}--#ifdef MIN_VERSION_tagged-instance Bitraversable1 Tagged where- bitraverse1 _ g (Tagged b) = Tagged <$> g b- {-# INLINE bitraverse1 #-}-#endif--instance (Bitraversable1 p, Traversable1 f, Traversable1 g) => Bitraversable1 (Biff p f g) where- bitraverse1 f g = fmap Biff . bitraverse1 (traverse1 f) (traverse1 g) . runBiff- {-# INLINE bitraverse1 #-}--instance Traversable1 f => Bitraversable1 (Clown f) where- bitraverse1 f _ = fmap Clown . traverse1 f . runClown- {-# INLINE bitraverse1 #-}--instance Bitraversable1 p => Bitraversable1 (Flip p) where- bitraverse1 f g = fmap Flip . bitraverse1 g f . runFlip- {-# INLINE bitraverse1 #-}--instance Bitraversable1 p => Traversable1 (Join p) where- traverse1 f (Join a) = fmap Join (bitraverse1 f f a)- {-# INLINE traverse1 #-}- sequence1 (Join a) = fmap Join (bisequence1 a)- {-# INLINE sequence1 #-}--instance Traversable1 g => Bitraversable1 (Joker g) where- bitraverse1 _ g = fmap Joker . traverse1 g . runJoker- {-# INLINE bitraverse1 #-}--instance (Bitraversable1 f, Bitraversable1 g) => Bitraversable1 (Bifunctor.Product f g) where- bitraverse1 f g (Bifunctor.Pair x y) = Bifunctor.Pair <$> bitraverse1 f g x <.> bitraverse1 f g y- {-# INLINE bitraverse1 #-}--instance (Traversable1 f, Bitraversable1 p) => Bitraversable1 (Tannen f p) where- bitraverse1 f g = fmap Tannen . traverse1 (bitraverse1 f g) . runTannen- {-# INLINE bitraverse1 #-}--instance Bitraversable1 p => Bitraversable1 (WrappedBifunctor p) where- bitraverse1 f g = fmap WrapBifunctor . bitraverse1 f g . unwrapBifunctor- {-# INLINE bitraverse1 #-}---class (Foldable1 t, Traversable t) => Traversable1 t where- traverse1 :: Apply f => (a -> f b) -> t a -> f (t b)- sequence1 :: Apply f => t (f b) -> f (t b)-- sequence1 = traverse1 id- traverse1 f = sequence1 . fmap f-- {-# MINIMAL traverse1 | sequence1 #-}--instance Traversable1 f => Traversable1 (Rec1 f) where- traverse1 f (Rec1 as) = Rec1 <$> traverse1 f as--instance Traversable1 f => Traversable1 (M1 i c f) where- traverse1 f (M1 as) = M1 <$> traverse1 f as--instance Traversable1 Par1 where- traverse1 f (Par1 a) = Par1 <$> f a--instance Traversable1 V1 where- traverse1 _ v = v `seq` undefined--instance (Traversable1 f, Traversable1 g) => Traversable1 (f :*: g) where- traverse1 f (as :*: bs) = (:*:) <$> traverse1 f as <.> traverse1 f bs--instance (Traversable1 f, Traversable1 g) => Traversable1 (f :+: g) where- traverse1 f (L1 as) = L1 <$> traverse1 f as- traverse1 f (R1 bs) = R1 <$> traverse1 f bs--instance (Traversable1 f, Traversable1 g) => Traversable1 (f :.: g) where- traverse1 f (Comp1 m) = Comp1 <$> traverse1 (traverse1 f) m--instance Traversable1 Identity where- traverse1 f = fmap Identity . f . runIdentity--instance (Traversable1 f, Traversable1 g) => Traversable1 (Functor.Product f g) where- traverse1 f (Functor.Pair a b) = Functor.Pair <$> traverse1 f a <.> traverse1 f b--instance (Traversable1 f, Traversable1 g) => Traversable1 (Functor.Sum f g) where- traverse1 f (Functor.InL x) = Functor.InL <$> traverse1 f x- traverse1 f (Functor.InR y) = Functor.InR <$> traverse1 f y--instance (Traversable1 f, Traversable1 g) => Traversable1 (Compose f g) where- traverse1 f = fmap Compose . traverse1 (traverse1 f) . getCompose--#if HAS_FOLDABLE1_TRANSFORMERS-instance Traversable1 f => Traversable1 (IdentityT f) where- traverse1 f = fmap IdentityT . traverse1 f . runIdentityT--instance Traversable1 f => Traversable1 (Backwards f) where- traverse1 f = fmap Backwards . traverse1 f . forwards--instance Traversable1 f => Traversable1 (Lift f) where- traverse1 f (Pure x) = Pure <$> f x- traverse1 f (Other y) = Other <$> traverse1 f y--instance Traversable1 f => Traversable1 (Reverse f) where- traverse1 f = fmap Reverse . forwards . traverse1 (Backwards . f) . getReverse-#endif--instance Traversable1 Complex where- traverse1 f (a :+ b) = (:+) <$> f a <.> f b- {-# INLINE traverse1 #-}--#ifdef MIN_VERSION_tagged-instance Traversable1 (Tagged a) where- traverse1 f (Tagged a) = Tagged <$> f a-#endif--#if HAS_FOLDABLE1_CONTAINERS-instance Traversable1 Tree where- traverse1 f (Node a []) = (`Node`[]) <$> f a- traverse1 f (Node a (x:xs)) = (\b (y:|ys) -> Node b (y:ys)) <$> f a <.> traverse1 (traverse1 f) (x :| xs)-#endif--instance Traversable1 NonEmpty where- traverse1 f (a :| as) = foldr (\b g x -> (\a' (b':| bs') -> a' :| b': bs') <$> f x <.> g b) (fmap (:|[]) . f) as a--instance Traversable1 ((,) a) where- traverse1 f (a, b) = (,) a <$> f b--instance Traversable1 g => Traversable1 (Joker g a) where- traverse1 g = fmap Joker . traverse1 g . runJoker- {-# INLINE traverse1 #-}--instance Traversable1 Monoid.Sum where- traverse1 g (Monoid.Sum a) = Monoid.Sum <$> g a--instance Traversable1 Monoid.Product where- traverse1 g (Monoid.Product a) = Monoid.Product <$> g a--instance Traversable1 Monoid.Dual where- traverse1 g (Monoid.Dual a) = Monoid.Dual <$> g a--instance Traversable1 f => Traversable1 (Monoid.Alt f) where- traverse1 g (Monoid.Alt m) = Monoid.Alt <$> traverse1 g m--instance Traversable1 Semigroup.First where- traverse1 g (Semigroup.First a) = Semigroup.First <$> g a--instance Traversable1 Semigroup.Last where- traverse1 g (Semigroup.Last a) = Semigroup.Last <$> g a--instance Traversable1 Semigroup.Min where- traverse1 g (Semigroup.Min a) = Semigroup.Min <$> g a--instance Traversable1 Semigroup.Max where- traverse1 g (Semigroup.Max a) = Semigroup.Max <$> g a+{-# LANGUAGE CPP, TypeOperators #-} +{-# LANGUAGE Trustworthy #-} + + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Semigroup.Traversable.Class + ( Bitraversable1(..) + , Traversable1(..) + ) where + +import Control.Applicative +import Data.Bitraversable +import Data.Bifunctor +import Data.Bifunctor.Biff +import Data.Bifunctor.Clown +import Data.Bifunctor.Flip +import Data.Bifunctor.Joker +import Data.Bifunctor.Join +import Data.Bifunctor.Product as Bifunctor +import Data.Bifunctor.Tannen +import Data.Bifunctor.Wrapped +import Data.Functor.Apply +import Data.Functor.Compose + +import Data.Complex +import Data.Functor.Identity +import Data.Functor.Product as Functor +import Data.Functor.Sum as Functor +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.Monoid as Monoid +import Data.Orphans () +import Data.Semigroup as Semigroup +import Data.Semigroup.Foldable +import Data.Semigroup.Bifoldable +#ifdef MIN_VERSION_tagged +import Data.Tagged +#endif +import Data.Traversable.Instances () +import GHC.Generics + +#ifdef MIN_VERSION_containers +import Data.Tree +#endif + +import Control.Applicative.Backwards +import Control.Applicative.Lift +import Control.Monad.Trans.Identity +import Data.Functor.Reverse + +class (Bifoldable1 t, Bitraversable t) => Bitraversable1 t where + bitraverse1 :: Apply f => (a -> f b) -> (c -> f d) -> t a c -> f (t b d) + bitraverse1 f g = bisequence1 . bimap f g + {-# INLINE bitraverse1 #-} + + bisequence1 :: Apply f => t (f a) (f b) -> f (t a b) + bisequence1 = bitraverse1 id id + {-# INLINE bisequence1 #-} + + {-# MINIMAL bitraverse1 | bisequence1 #-} + +instance Bitraversable1 Arg where + bitraverse1 f g (Arg a b) = Arg <$> f a <.> g b + +instance Bitraversable1 Either where + bitraverse1 f _ (Left a) = Left <$> f a + bitraverse1 _ g (Right b) = Right <$> g b + {-# INLINE bitraverse1 #-} + +instance Bitraversable1 (,) where + bitraverse1 f g (a, b) = (,) <$> f a <.> g b + {-# INLINE bitraverse1 #-} + +instance Bitraversable1 ((,,) x) where + bitraverse1 f g (x, a, b) = (,,) x <$> f a <.> g b + {-# INLINE bitraverse1 #-} + +instance Bitraversable1 ((,,,) x y) where + bitraverse1 f g (x, y, a, b) = (,,,) x y <$> f a <.> g b + {-# INLINE bitraverse1 #-} + +instance Bitraversable1 ((,,,,) x y z) where + bitraverse1 f g (x, y, z, a, b) = (,,,,) x y z <$> f a <.> g b + {-# INLINE bitraverse1 #-} + +instance Bitraversable1 Const where + bitraverse1 f _ (Const a) = Const <$> f a + {-# INLINE bitraverse1 #-} + +#ifdef MIN_VERSION_tagged +instance Bitraversable1 Tagged where + bitraverse1 _ g (Tagged b) = Tagged <$> g b + {-# INLINE bitraverse1 #-} +#endif + +instance (Bitraversable1 p, Traversable1 f, Traversable1 g) => Bitraversable1 (Biff p f g) where + bitraverse1 f g = fmap Biff . bitraverse1 (traverse1 f) (traverse1 g) . runBiff + {-# INLINE bitraverse1 #-} + +instance Traversable1 f => Bitraversable1 (Clown f) where + bitraverse1 f _ = fmap Clown . traverse1 f . runClown + {-# INLINE bitraverse1 #-} + +instance Bitraversable1 p => Bitraversable1 (Flip p) where + bitraverse1 f g = fmap Flip . bitraverse1 g f . runFlip + {-# INLINE bitraverse1 #-} + +instance Bitraversable1 p => Traversable1 (Join p) where + traverse1 f (Join a) = fmap Join (bitraverse1 f f a) + {-# INLINE traverse1 #-} + sequence1 (Join a) = fmap Join (bisequence1 a) + {-# INLINE sequence1 #-} + +instance Traversable1 g => Bitraversable1 (Joker g) where + bitraverse1 _ g = fmap Joker . traverse1 g . runJoker + {-# INLINE bitraverse1 #-} + +instance (Bitraversable1 f, Bitraversable1 g) => Bitraversable1 (Bifunctor.Product f g) where + bitraverse1 f g (Bifunctor.Pair x y) = Bifunctor.Pair <$> bitraverse1 f g x <.> bitraverse1 f g y + {-# INLINE bitraverse1 #-} + +instance (Traversable1 f, Bitraversable1 p) => Bitraversable1 (Tannen f p) where + bitraverse1 f g = fmap Tannen . traverse1 (bitraverse1 f g) . runTannen + {-# INLINE bitraverse1 #-} + +instance Bitraversable1 p => Bitraversable1 (WrappedBifunctor p) where + bitraverse1 f g = fmap WrapBifunctor . bitraverse1 f g . unwrapBifunctor + {-# INLINE bitraverse1 #-} + + +class (Foldable1 t, Traversable t) => Traversable1 t where + traverse1 :: Apply f => (a -> f b) -> t a -> f (t b) + sequence1 :: Apply f => t (f b) -> f (t b) + + sequence1 = traverse1 id + traverse1 f = sequence1 . fmap f + + {-# MINIMAL traverse1 | sequence1 #-} + +instance Traversable1 f => Traversable1 (Rec1 f) where + traverse1 f (Rec1 as) = Rec1 <$> traverse1 f as + +instance Traversable1 f => Traversable1 (M1 i c f) where + traverse1 f (M1 as) = M1 <$> traverse1 f as + +instance Traversable1 Par1 where + traverse1 f (Par1 a) = Par1 <$> f a + +instance Traversable1 V1 where + traverse1 _ v = v `seq` undefined + +instance (Traversable1 f, Traversable1 g) => Traversable1 (f :*: g) where + traverse1 f (as :*: bs) = (:*:) <$> traverse1 f as <.> traverse1 f bs + +instance (Traversable1 f, Traversable1 g) => Traversable1 (f :+: g) where + traverse1 f (L1 as) = L1 <$> traverse1 f as + traverse1 f (R1 bs) = R1 <$> traverse1 f bs + +instance (Traversable1 f, Traversable1 g) => Traversable1 (f :.: g) where + traverse1 f (Comp1 m) = Comp1 <$> traverse1 (traverse1 f) m + +instance Traversable1 Identity where + traverse1 f = fmap Identity . f . runIdentity + +instance (Traversable1 f, Traversable1 g) => Traversable1 (Functor.Product f g) where + traverse1 f (Functor.Pair a b) = Functor.Pair <$> traverse1 f a <.> traverse1 f b + +instance (Traversable1 f, Traversable1 g) => Traversable1 (Functor.Sum f g) where + traverse1 f (Functor.InL x) = Functor.InL <$> traverse1 f x + traverse1 f (Functor.InR y) = Functor.InR <$> traverse1 f y + +instance (Traversable1 f, Traversable1 g) => Traversable1 (Compose f g) where + traverse1 f = fmap Compose . traverse1 (traverse1 f) . getCompose + +instance Traversable1 f => Traversable1 (IdentityT f) where + traverse1 f = fmap IdentityT . traverse1 f . runIdentityT + +instance Traversable1 f => Traversable1 (Backwards f) where + traverse1 f = fmap Backwards . traverse1 f . forwards + +instance Traversable1 f => Traversable1 (Lift f) where + traverse1 f (Pure x) = Pure <$> f x + traverse1 f (Other y) = Other <$> traverse1 f y + +instance Traversable1 f => Traversable1 (Reverse f) where + traverse1 f = fmap Reverse . forwards . traverse1 (Backwards . f) . getReverse + +instance Traversable1 Complex where + traverse1 f (a :+ b) = (:+) <$> f a <.> f b + {-# INLINE traverse1 #-} + +#ifdef MIN_VERSION_tagged +instance Traversable1 (Tagged a) where + traverse1 f (Tagged a) = Tagged <$> f a +#endif + +#ifdef MIN_VERSION_containers +instance Traversable1 Tree where + traverse1 f (Node a []) = (`Node`[]) <$> f a + traverse1 f (Node a (x:xs)) = (\b (y:|ys) -> Node b (y:ys)) <$> f a <.> traverse1 (traverse1 f) (x :| xs) +#endif + +instance Traversable1 NonEmpty where + traverse1 f (a :| as) = foldr (\b g x -> (\a' (b':| bs') -> a' :| b': bs') <$> f x <.> g b) (fmap (:|[]) . f) as a + +instance Traversable1 ((,) a) where + traverse1 f (a, b) = (,) a <$> f b + +instance Traversable1 g => Traversable1 (Joker g a) where + traverse1 g = fmap Joker . traverse1 g . runJoker + {-# INLINE traverse1 #-} + +instance Traversable1 Monoid.Sum where + traverse1 g (Monoid.Sum a) = Monoid.Sum <$> g a + +instance Traversable1 Monoid.Product where + traverse1 g (Monoid.Product a) = Monoid.Product <$> g a + +instance Traversable1 Monoid.Dual where + traverse1 g (Monoid.Dual a) = Monoid.Dual <$> g a + +instance Traversable1 f => Traversable1 (Monoid.Alt f) where + traverse1 g (Monoid.Alt m) = Monoid.Alt <$> traverse1 g m + +instance Traversable1 Semigroup.First where + traverse1 g (Semigroup.First a) = Semigroup.First <$> g a + +instance Traversable1 Semigroup.Last where + traverse1 g (Semigroup.Last a) = Semigroup.Last <$> g a + +instance Traversable1 Semigroup.Min where + traverse1 g (Semigroup.Min a) = Semigroup.Min <$> g a + +instance Traversable1 Semigroup.Max where + traverse1 g (Semigroup.Max a) = Semigroup.Max <$> g a
src/Data/Semigroupoid.hs view
@@ -1,106 +1,106 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE Trustworthy #-}---------------------------------------------------------------------------------- |--- Module : Data.Semigroupoid--- Copyright : (C) 2007-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ A semigroupoid satisfies all of the requirements to be a Category except--- for the existence of identity arrows.------------------------------------------------------------------------------module Data.Semigroupoid- ( Semigroupoid(..)- , WrappedCategory(..)- , Semi(..)- ) where--import Control.Applicative-import Control.Arrow-import Control.Category-import Data.Functor.Bind-import Data.Semigroup-import qualified Data.Type.Coercion as Co-import qualified Data.Type.Equality as Eq-import Prelude hiding (id, (.))--#ifdef MIN_VERSION_contravariant-import Data.Functor.Contravariant-#endif--#ifdef MIN_VERSION_comonad-import Data.Functor.Extend-import Control.Comonad-#endif--#ifdef MIN_VERSION_tagged-import Data.Tagged (Tagged (..))-#endif---- | 'Control.Category.Category' sans 'Control.Category.id'-class Semigroupoid c where- o :: c j k -> c i j -> c i k--instance Semigroupoid (->) where- o = (.)---- | <http://en.wikipedia.org/wiki/Band_(mathematics)#Rectangular_bands>-instance Semigroupoid (,) where- o (_,k) (i,_) = (i,k)--instance Bind m => Semigroupoid (Kleisli m) where- Kleisli g `o` Kleisli f = Kleisli $ \a -> f a >>- g--#ifdef MIN_VERSION_comonad-instance Extend w => Semigroupoid (Cokleisli w) where- Cokleisli f `o` Cokleisli g = Cokleisli $ f . extended g-#endif--#ifdef MIN_VERSION_contravariant-instance Semigroupoid Op where- Op f `o` Op g = Op (g `o` f)-#endif--newtype WrappedCategory k a b = WrapCategory { unwrapCategory :: k a b }--instance Category k => Semigroupoid (WrappedCategory k) where- WrapCategory f `o` WrapCategory g = WrapCategory (f . g)--instance Category k => Category (WrappedCategory k) where- id = WrapCategory id- WrapCategory f . WrapCategory g = WrapCategory (f . g)--newtype Semi m a b = Semi { getSemi :: m }--instance Semigroup m => Semigroupoid (Semi m) where- Semi m `o` Semi n = Semi (m <> n)--instance Monoid m => Category (Semi m) where- id = Semi mempty- Semi m . Semi n = Semi (m `mappend` n)--instance Semigroupoid Const where- _ `o` Const a = Const a--#ifdef MIN_VERSION_tagged-instance Semigroupoid Tagged where- Tagged b `o` _ = Tagged b-#endif--instance Semigroupoid Co.Coercion where- o = flip Co.trans--instance Semigroupoid (Eq.:~:) where- o = flip Eq.trans--#if MIN_VERSION_base(4,10,0)-instance Semigroupoid (Eq.:~~:) where- o Eq.HRefl Eq.HRefl = Eq.HRefl-#endif+{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Semigroupoid +-- Copyright : (C) 2007-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +-- A semigroupoid satisfies all of the requirements to be a Category except +-- for the existence of identity arrows. +---------------------------------------------------------------------------- +module Data.Semigroupoid + ( Semigroupoid(..) + , WrappedCategory(..) + , Semi(..) + ) where + +import Control.Applicative +import Control.Arrow +import Control.Category +import Data.Functor.Bind +import Data.Semigroup +import qualified Data.Type.Coercion as Co +import qualified Data.Type.Equality as Eq +import Prelude hiding (id, (.)) + +#ifdef MIN_VERSION_contravariant +import Data.Functor.Contravariant +#endif + +#ifdef MIN_VERSION_comonad +import Data.Functor.Extend +import Control.Comonad +#endif + +#ifdef MIN_VERSION_tagged +import Data.Tagged (Tagged (..)) +#endif + +-- | 'Control.Category.Category' sans 'Control.Category.id' +class Semigroupoid c where + o :: c j k -> c i j -> c i k + +instance Semigroupoid (->) where + o = (.) + +-- | <http://en.wikipedia.org/wiki/Band_(mathematics)#Rectangular_bands> +instance Semigroupoid (,) where + o (_,k) (i,_) = (i,k) + +instance Bind m => Semigroupoid (Kleisli m) where + Kleisli g `o` Kleisli f = Kleisli $ \a -> f a >>- g + +#ifdef MIN_VERSION_comonad +instance Extend w => Semigroupoid (Cokleisli w) where + Cokleisli f `o` Cokleisli g = Cokleisli $ f . extended g +#endif + +#ifdef MIN_VERSION_contravariant +instance Semigroupoid Op where + Op f `o` Op g = Op (g `o` f) +#endif + +newtype WrappedCategory k a b = WrapCategory { unwrapCategory :: k a b } + +instance Category k => Semigroupoid (WrappedCategory k) where + WrapCategory f `o` WrapCategory g = WrapCategory (f . g) + +instance Category k => Category (WrappedCategory k) where + id = WrapCategory id + WrapCategory f . WrapCategory g = WrapCategory (f . g) + +newtype Semi m a b = Semi { getSemi :: m } + +instance Semigroup m => Semigroupoid (Semi m) where + Semi m `o` Semi n = Semi (m <> n) + +instance Monoid m => Category (Semi m) where + id = Semi mempty + Semi m . Semi n = Semi (m `mappend` n) + +instance Semigroupoid Const where + _ `o` Const a = Const a + +#ifdef MIN_VERSION_tagged +instance Semigroupoid Tagged where + Tagged b `o` _ = Tagged b +#endif + +instance Semigroupoid Co.Coercion where + o = flip Co.trans + +instance Semigroupoid (Eq.:~:) where + o = flip Eq.trans + +#if MIN_VERSION_base(4,10,0) +instance Semigroupoid (Eq.:~~:) where + o Eq.HRefl Eq.HRefl = Eq.HRefl +#endif
src/Data/Semigroupoid/Categorical.hs view
@@ -1,48 +1,48 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}---------------------------------------------------------------------------------- |--- Copyright : (C) 2021 Koz Ross--- License : BSD-style (see the file LICENSE)------ Maintainer : Koz Ross <koz.ross@retro-freedom.nz>--- Stability : Experimental--- Portability : GHC only------ Provides a way to attach an identity to any semigroupoid.------------------------------------------------------------------------------module Data.Semigroupoid.Categorical (- Categorical(..),- runCategorical- ) where--import Control.Category (Category (id, (.)))-import Data.Semigroupoid (Semigroupoid (o))-import Prelude ()---- | Attaches an identity.------ @since 5.3.6-data Categorical s a b where- Id :: Categorical s a a- Embed :: s a b -> Categorical s a b---- | @since 5.3.6-instance (Semigroupoid s) => Semigroupoid (Categorical s) where- Id `o` y = y- x `o` Id = x- Embed x `o` Embed y = Embed (x `o` y)---- | @since 5.3.6-instance (Semigroupoid s) => Category (Categorical s) where- id = Id- (.) = o---- | @since 5.3.6-runCategorical :: (a ~ b => r) -> (s a b -> r) -> Categorical s a b -> r-runCategorical r _ Id = r-runCategorical _ f (Embed x) = f x+{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2021 Koz Ross +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Koz Ross <koz.ross@retro-freedom.nz> +-- Stability : Experimental +-- Portability : GHC only +-- +-- Provides a way to attach an identity to any semigroupoid. +---------------------------------------------------------------------------- +module Data.Semigroupoid.Categorical ( + Categorical(..), + runCategorical + ) where + +import Control.Category (Category (id, (.))) +import Data.Semigroupoid (Semigroupoid (o)) +import Prelude () + +-- | Attaches an identity. +-- +-- @since 5.3.6 +data Categorical s a b where + Id :: Categorical s a a + Embed :: s a b -> Categorical s a b + +-- | @since 5.3.6 +instance (Semigroupoid s) => Semigroupoid (Categorical s) where + Id `o` y = y + x `o` Id = x + Embed x `o` Embed y = Embed (x `o` y) + +-- | @since 5.3.6 +instance (Semigroupoid s) => Category (Categorical s) where + id = Id + (.) = o + +-- | @since 5.3.6 +runCategorical :: (a ~ b => r) -> (s a b -> r) -> Categorical s a b -> r +runCategorical r _ Id = r +runCategorical _ f (Embed x) = f x
src/Data/Semigroupoid/Dual.hs view
@@ -1,28 +1,28 @@-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE Safe #-}--------------------------------------------------------------------------------- |--- Copyright : (C) 2007-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ A semigroupoid satisfies all of the requirements to be a Category except--- for the existence of identity arrows.------------------------------------------------------------------------------module Data.Semigroupoid.Dual (Dual(..)) where--import Data.Semigroupoid-import Control.Category-import Prelude ()--newtype Dual k a b = Dual { getDual :: k b a }--instance Semigroupoid k => Semigroupoid (Dual k) where- Dual f `o` Dual g = Dual (g `o` f)--instance Category k => Category (Dual k) where- id = Dual id- Dual f . Dual g = Dual (g . f)+{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2007-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +-- A semigroupoid satisfies all of the requirements to be a Category except +-- for the existence of identity arrows. +---------------------------------------------------------------------------- +module Data.Semigroupoid.Dual (Dual(..)) where + +import Data.Semigroupoid +import Control.Category +import Prelude () + +newtype Dual k a b = Dual { getDual :: k b a } + +instance Semigroupoid k => Semigroupoid (Dual k) where + Dual f `o` Dual g = Dual (g `o` f) + +instance Category k => Category (Dual k) where + id = Dual id + Dual f . Dual g = Dual (g . f)
src/Data/Semigroupoid/Ob.hs view
@@ -1,41 +1,41 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE Safe #-}--------------------------------------------------------------------------------- |--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : experimental--- Portability : non-portable (flexible MPTCs)---------------------------------------------------------------------------------module Data.Semigroupoid.Ob where--import Data.Semigroupoid-import Data.Functor.Bind-import Control.Arrow---#ifdef MIN_VERSION_comonad-import Data.Functor.Extend-import Control.Comonad-#endif--class Semigroupoid k => Ob k a where- semiid :: k a a--instance (Bind m, Monad m) => Ob (Kleisli m) a where- semiid = Kleisli return--#ifdef MIN_VERSION_comonad-instance (Extend w, Comonad w) => Ob (Cokleisli w) a where- semiid = Cokleisli extract-#endif--instance Ob (->) a where- semiid = id+{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : experimental +-- Portability : non-portable (flexible MPTCs) +-- +---------------------------------------------------------------------------- +module Data.Semigroupoid.Ob where + +import Data.Semigroupoid +import Data.Functor.Bind +import Control.Arrow + + +#ifdef MIN_VERSION_comonad +import Data.Functor.Extend +import Control.Comonad +#endif + +class Semigroupoid k => Ob k a where + semiid :: k a a + +instance (Bind m, Monad m) => Ob (Kleisli m) a where + semiid = Kleisli return + +#ifdef MIN_VERSION_comonad +instance (Extend w, Comonad w) => Ob (Cokleisli w) a where + semiid = Cokleisli extract +#endif + +instance Ob (->) a where + semiid = id
src/Data/Semigroupoid/Static.hs view
@@ -1,87 +1,87 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE Trustworthy #-}---------------------------------------------------------------------------------- |--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : polykinds----------------------------------------------------------------------------------module Data.Semigroupoid.Static- ( Static(..)- ) where--import Control.Arrow-import Control.Applicative-import Control.Category-import Control.Monad (ap)-import Data.Functor.Apply-import Data.Functor.Plus-import Data.Functor.Extend-import Data.Orphans ()-import Data.Semigroup-import Data.Semigroupoid-import Prelude hiding ((.), id)--#ifdef MIN_VERSION_comonad-import Control.Comonad-#endif--newtype Static f a b = Static { runStatic :: f (a -> b) }--instance Functor f => Functor (Static f a) where- fmap f = Static . fmap (f .) . runStatic--instance Apply f => Apply (Static f a) where- Static f <.> Static g = Static (ap <$> f <.> g)--instance Alt f => Alt (Static f a) where- Static f <!> Static g = Static (f <!> g)--instance Plus f => Plus (Static f a) where- zero = Static zero--instance Applicative f => Applicative (Static f a) where- pure = Static . pure . const- Static f <*> Static g = Static (ap <$> f <*> g)--instance (Extend f, Semigroup a) => Extend (Static f a) where- extended f = Static . extended (\wf m -> f (Static (fmap (. (<>) m) wf))) . runStatic--#ifdef MIN_VERSION_comonad-instance (Comonad f, Monoid a) => Comonad (Static f a) where- extend f = Static . extend (\wf m -> f (Static (fmap (. mappend m) wf))) . runStatic- extract (Static g) = extract g mempty-#endif--instance Apply f => Semigroupoid (Static f) where- Static f `o` Static g = Static ((.) <$> f <.> g)--instance Applicative f => Category (Static f) where- id = Static (pure id)- Static f . Static g = Static ((.) <$> f <*> g)--instance Applicative f => Arrow (Static f) where- arr = Static . pure- first (Static g) = Static (first <$> g)- second (Static g) = Static (second <$> g)- Static g *** Static h = Static ((***) <$> g <*> h)- Static g &&& Static h = Static ((&&&) <$> g <*> h)--instance Alternative f => ArrowZero (Static f) where- zeroArrow = Static empty--instance Alternative f => ArrowPlus (Static f) where- Static f <+> Static g = Static (f <|> g)--instance Applicative f => ArrowChoice (Static f) where- left (Static g) = Static (left <$> g)- right (Static g) = Static (right <$> g)- Static g +++ Static h = Static ((+++) <$> g <*> h)- Static g ||| Static h = Static ((|||) <$> g <*> h)-+{-# LANGUAGE CPP #-} +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : polykinds +-- +---------------------------------------------------------------------------- + +module Data.Semigroupoid.Static + ( Static(..) + ) where + +import Control.Arrow +import Control.Applicative +import Control.Category +import Control.Monad (ap) +import Data.Functor.Apply +import Data.Functor.Plus +import Data.Functor.Extend +import Data.Orphans () +import Data.Semigroup +import Data.Semigroupoid +import Prelude hiding ((.), id) + +#ifdef MIN_VERSION_comonad +import Control.Comonad +#endif + +newtype Static f a b = Static { runStatic :: f (a -> b) } + +instance Functor f => Functor (Static f a) where + fmap f = Static . fmap (f .) . runStatic + +instance Apply f => Apply (Static f a) where + Static f <.> Static g = Static (ap <$> f <.> g) + +instance Alt f => Alt (Static f a) where + Static f <!> Static g = Static (f <!> g) + +instance Plus f => Plus (Static f a) where + zero = Static zero + +instance Applicative f => Applicative (Static f a) where + pure = Static . pure . const + Static f <*> Static g = Static (ap <$> f <*> g) + +instance (Extend f, Semigroup a) => Extend (Static f a) where + extended f = Static . extended (\wf m -> f (Static (fmap (. (<>) m) wf))) . runStatic + +#ifdef MIN_VERSION_comonad +instance (Comonad f, Monoid a) => Comonad (Static f a) where + extend f = Static . extend (\wf m -> f (Static (fmap (. mappend m) wf))) . runStatic + extract (Static g) = extract g mempty +#endif + +instance Apply f => Semigroupoid (Static f) where + Static f `o` Static g = Static ((.) <$> f <.> g) + +instance Applicative f => Category (Static f) where + id = Static (pure id) + Static f . Static g = Static ((.) <$> f <*> g) + +instance Applicative f => Arrow (Static f) where + arr = Static . pure + first (Static g) = Static (first <$> g) + second (Static g) = Static (second <$> g) + Static g *** Static h = Static ((***) <$> g <*> h) + Static g &&& Static h = Static ((&&&) <$> g <*> h) + +instance Alternative f => ArrowZero (Static f) where + zeroArrow = Static empty + +instance Alternative f => ArrowPlus (Static f) where + Static f <+> Static g = Static (f <|> g) + +instance Applicative f => ArrowChoice (Static f) where + left (Static g) = Static (left <$> g) + right (Static g) = Static (right <$> g) + Static g +++ Static h = Static ((+++) <$> g <*> h) + Static g ||| Static h = Static ((|||) <$> g <*> h) +
src/Data/Traversable/Instances.hs view
@@ -1,16 +1,16 @@-{-# LANGUAGE Safe #-}--------------------------------------------------------------------------------- |--- Copyright : (C) 2011-2015,2018 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : polykinds------ Re-exports from the `base-orphans` and `transformers-compat` packages.------------------------------------------------------------------------------module Data.Traversable.Instances where--import Control.Monad.Trans.Instances ()-import Data.Orphans ()+{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015,2018 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : polykinds +-- +-- Re-exports from the `base-orphans` and `transformers-compat` packages. +---------------------------------------------------------------------------- +module Data.Traversable.Instances where + +import Control.Monad.Trans.Instances () +import Data.Orphans ()
src/Semigroupoids/Do.hs view
@@ -1,81 +1,81 @@-{-# LANGUAGE Safe #-}--{-|--This module re-exports operators from "Data.Functor.Apply" and-"Data.Functor.Bind", but under the same-names as their 'Applicative' and 'Monad' counterparts. This makes it convenient-to use do-notation on a type that is a 'Bind' but not a monad (or an 'Apply'-but not an 'Applicative' with @ApplicativeDo@), either using the-@QualifiedDo@ extension or the more traditional @RebindableSyntax@.--@-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE QualifiedDo #-}--foo :: Apply f => f a -> f b -> f (a, b)-foo as bs = Semi.do- a <- as- b <- bs- pure (a, b)---bar :: Bind m => (a -> b -> m c) -> m a -> m b -> m c-bar f as bs = Semi.do- a <- as- b <- bs- f a b-@---}-module Semigroupoids.Do- ( fmap- , (<*)- , (*>)- , (<*>)- , (>>)- , (>>=)- , join- , pure- , return- , fail- )-where--import Prelude (String, fmap, pure, return)-import Data.Functor.Apply (Apply, (<.), (.>), (<.>))-import Data.Functor.Bind (Bind, (>>-), join)-import Data.Functor.Plus (Plus, zero)---- | @since 5.3.6-(<*) :: Apply f => f a -> f b -> f a-(<*) = (<.)---- | @since 5.3.6-(*>) :: Apply f => f a -> f b -> f b-(*>) = (.>)---- | @since 5.3.6-(<*>) :: Apply f => f (a -> b) -> f a -> f b-(<*>) = (<.>)---- | @since 5.3.6-(>>) :: Bind m => m a -> m b -> m b-(>>) = (.>)---- | @since 5.3.6-(>>=) :: Bind m => m a -> (a -> m b) -> m b-(>>=) = (>>-)---- | = Important note------ This /ignores/ whatever 'String' you give it. It is a bad idea to use 'fail'--- as a form of labelled error; instead, it should only be defaulted to when a--- pattern match fails.------ @since 5.3.6-fail ::- (Plus m) =>- String ->- m a-fail _ = zero+{-# LANGUAGE Safe #-} + +{-| + +This module re-exports operators from "Data.Functor.Apply" and +"Data.Functor.Bind", but under the same +names as their 'Applicative' and 'Monad' counterparts. This makes it convenient +to use do-notation on a type that is a 'Bind' but not a monad (or an 'Apply' +but not an 'Applicative' with @ApplicativeDo@), either using the +@QualifiedDo@ extension or the more traditional @RebindableSyntax@. + +@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE QualifiedDo #-} + +foo :: Apply f => f a -> f b -> f (a, b) +foo as bs = Semi.do + a <- as + b <- bs + pure (a, b) + + +bar :: Bind m => (a -> b -> m c) -> m a -> m b -> m c +bar f as bs = Semi.do + a <- as + b <- bs + f a b +@ + +-} +module Semigroupoids.Do + ( fmap + , (<*) + , (*>) + , (<*>) + , (>>) + , (>>=) + , join + , pure + , return + , fail + ) +where + +import Prelude (String, fmap, pure, return) +import Data.Functor.Apply (Apply, (<.), (.>), (<.>)) +import Data.Functor.Bind (Bind, (>>-), join) +import Data.Functor.Plus (Plus, zero) + +-- | @since 5.3.6 +(<*) :: Apply f => f a -> f b -> f a +(<*) = (<.) + +-- | @since 5.3.6 +(*>) :: Apply f => f a -> f b -> f b +(*>) = (.>) + +-- | @since 5.3.6 +(<*>) :: Apply f => f (a -> b) -> f a -> f b +(<*>) = (<.>) + +-- | @since 5.3.6 +(>>) :: Bind m => m a -> m b -> m b +(>>) = (.>) + +-- | @since 5.3.6 +(>>=) :: Bind m => m a -> (a -> m b) -> m b +(>>=) = (>>-) + +-- | = Important note +-- +-- This /ignores/ whatever 'String' you give it. It is a bad idea to use 'fail' +-- as a form of labelled error; instead, it should only be defaulted to when a +-- pattern match fails. +-- +-- @since 5.3.6 +fail :: + (Plus m) => + String -> + m a +fail _ = zero
src/Semigroupoids/Internal.hs view
@@ -1,28 +1,28 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE Trustworthy #-}--module Semigroupoids.Internal where--#if MIN_VERSION_transformers(0,5,6)-import qualified Control.Monad.Trans.RWS.CPS as CPS-import qualified Control.Monad.Trans.Writer.CPS as CPS-import Unsafe.Coerce (unsafeCoerce)-#endif---- This is designed to avoid both https://hub.darcs.net/ross/transformers/issue/67--- and also the unnecessary Monoid constraints that the CPS versions of WriterT--- and RWST require.--#if MIN_VERSION_transformers(0,5,6)-mkWriterT :: (w -> m (a, w)) -> CPS.WriterT w m a-mkWriterT = unsafeCoerce--unWriterT :: CPS.WriterT w m a -> w -> m (a, w)-unWriterT = unsafeCoerce--mkRWST :: (r -> s -> w -> m (a, s, w)) -> CPS.RWST r w s m a-mkRWST = unsafeCoerce--unRWST :: CPS.RWST r w s m a -> r -> s -> w -> m (a, s, w)-unRWST = unsafeCoerce-#endif+{-# LANGUAGE CPP #-} +{-# LANGUAGE Trustworthy #-} + +module Semigroupoids.Internal where + +#if MIN_VERSION_transformers(0,5,6) +import qualified Control.Monad.Trans.RWS.CPS as CPS +import qualified Control.Monad.Trans.Writer.CPS as CPS +import Unsafe.Coerce (unsafeCoerce) +#endif + +-- This is designed to avoid both https://hub.darcs.net/ross/transformers/issue/67 +-- and also the unnecessary Monoid constraints that the CPS versions of WriterT +-- and RWST require. + +#if MIN_VERSION_transformers(0,5,6) +mkWriterT :: (w -> m (a, w)) -> CPS.WriterT w m a +mkWriterT = unsafeCoerce + +unWriterT :: CPS.WriterT w m a -> w -> m (a, w) +unWriterT = unsafeCoerce + +mkRWST :: (r -> s -> w -> m (a, s, w)) -> CPS.RWST r w s m a +mkRWST = unsafeCoerce + +unRWST :: CPS.RWST r w s m a -> r -> s -> w -> m (a, s, w) +unRWST = unsafeCoerce +#endif