semigroupoids 6.0.0.1 → 6.0.1
raw patch · 36 files changed
+4800/−4718 lines, 36 filesdep ~containersdep ~hashablesetup-changed
Dependency ranges changed: containers, hashable
Files
- .gitignore +30/−30
- .vim.custom +31/−31
- CHANGELOG.markdown +287/−283
- LICENSE +26/−26
- README.markdown +63/−63
- Setup.lhs +7/−7
- img/classes.dot +52/−52
- img/classes.svg +306/−306
- semigroupoids.cabal +206/−203
- 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 +245/−222
- src/Data/Functor/Contravariant/Decide.hs +271/−245
- src/Data/Functor/Contravariant/Divise.hs +311/−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/−243
- src/Data/Semigroupoid.hs +106/−106
- src/Data/Semigroupoid/Categorical.hs +52/−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,283 +1,287 @@-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 +6.0.1 [2024.05.04]+------------------+* Fix a build error when compiling with `-f-contravariant`.++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,203 +1,206 @@-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 +cabal-version: 1.24+name: semigroupoids+category: Control, Comonads+version: 6.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.8++ 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.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++ if impl(ghc >= 8.6) || flag(contravariant)+ exposed-modules:+ Data.Functor.Contravariant.Conclude+ Data.Functor.Contravariant.Decide+ Data.Functor.Contravariant.Divise++ 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,245 @@-{-# 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+--+-- This module is only available if building with GHC 8.6 or later, or if the+-- @+contravariant@ @cabal@ build flag is available.+----------------------------------------------------------------------------+module Data.Functor.Contravariant.Conclude (+ Conclude(..)+ , gconclude+ , concluded+ , gconcluded+ ) where++import Control.Applicative.Backwards+import Control.Monad.Trans.Identity+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.Product+import Data.Functor.Reverse+import Data.Monoid (Alt(..))+import Data.Proxy+import Data.Void+import GHC.Generics++#if defined(MIN_VERSION_contravariant)+# if !(MIN_VERSION_transformers(0,6,0))+import Control.Monad.Trans.List+# endif+import Control.Monad.Trans.Maybe+import Data.Functor.Contravariant.Divise+import Data.Functor.Contravariant.Divisible+#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++#if defined(MIN_VERSION_contravariant)+-- | This instance is only available if the @+contravariant@ @cabal@ flag is+-- enabled.+--+-- @since 5.3.6+instance Decidable f => Conclude (WrappedDivisible f) where+ conclude f = WrapDivisible (lose f)+#endif++-- | @since 5.3.6+instance Conclude Comparison where+ conclude f = Comparison $ \a _ -> absurd (f a)++-- | @since 5.3.6+instance Conclude Equivalence where+ conclude f = Equivalence $ absurd . f++-- | @since 5.3.6+instance Conclude Predicate where+ conclude f = Predicate $ absurd . f++-- | @since 5.3.6+instance Conclude (Op r) where+ conclude f = Op $ absurd . f++-- | @since 5.3.6+instance Conclude Proxy where+ conclude _ = Proxy++#ifdef MIN_VERSION_StateVar+-- | @since 5.3.6+instance Conclude SettableStateVar where+ conclude k = SettableStateVar (absurd . k)+#endif++-- | @since 5.3.6+instance Conclude f => Conclude (Alt f) where+ conclude = Alt . conclude++-- | @since 5.3.6+instance Conclude U1 where+ conclude _ = U1++-- | @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 defined(MIN_VERSION_contravariant)+# if !(MIN_VERSION_transformers(0,6,0))+-- | This instance is only available if the @+contravariant@ @cabal@ flag is+-- enabled.+--+-- @since 5.3.6+instance (Divisible m, Divise m) => Conclude (ListT m) where+ conclude _ = ListT conquer+# endif++-- | This instance is only available if the @+contravariant@ @cabal@ flag is+-- enabled.+--+-- @since 5.3.6+instance (Divisible m, Divise m) => Conclude (MaybeT m) where+ conclude _ = MaybeT conquer+#endif++-- | @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,271 @@-{-# 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+--+-- This module is only available if building with GHC 8.6 or later, or if the+-- @+contravariant@ @cabal@ build flag is available.+----------------------------------------------------------------------------+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.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++#if defined(MIN_VERSION_contravariant)+import Data.Functor.Contravariant.Divisible+#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++#if defined(MIN_VERSION_contravariant)+-- | This instance is only available if the @+contravariant@ @cabal@ flag is+-- enabled.+--+-- @since 5.3.6+instance Decidable f => Decide (WrappedDivisible f) where+ decide f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (choose f x y)+#endif++-- | @since 5.3.6+instance Decide Comparison where+ decide f (Comparison g) (Comparison h) = Comparison $ \a b -> case f a of+ Left c -> case f b of+ Left d -> g c d+ Right{} -> LT+ Right c -> case f b of+ Left{} -> GT+ Right d -> h c d++-- | @since 5.3.6+instance Decide Equivalence where+ decide f (Equivalence g) (Equivalence h) = Equivalence $ \a b -> case f a of+ Left c -> case f b of+ Left d -> g c d+ Right{} -> False+ Right c -> case f b of+ Left{} -> False+ Right d -> h c d++-- | @since 5.3.6+instance Decide Predicate where+ decide f (Predicate g) (Predicate h) = Predicate $ either g h . f++-- | 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 _ U1 U1 = U1++-- | 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,311 @@-{-# 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+--+-- This module is only available if building with GHC 8.6 or later, or if the+-- @+contravariant@ @cabal@ build flag is available.+----------------------------------------------------------------------------+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.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++#if defined(MIN_VERSION_contravariant)+import Data.Functor.Contravariant.Divisible+#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)++#if defined(MIN_VERSION_contravariant)+-- | This instance is only available if the @+contravariant@ @cabal@ flag is+-- enabled.+--+-- @since 5.3.6+instance Divisible f => Divise (WrappedDivisible f) where+ divise f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (divide f x y)+#endif++-- | 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 f (Comparison g) (Comparison h) = Comparison $ \a b -> case f a of+ (a',a'') -> case f b of+ (b',b'') -> g a' b' `mappend` h a'' b''++-- | @since 5.3.6+instance Divise Equivalence where+ divise f (Equivalence g) (Equivalence h) = Equivalence $ \a b -> case f a of+ (a',a'') -> case f b of+ (b',b'') -> g a' b' && h a'' b''++-- | @since 5.3.6+instance Divise Predicate where+ divise f (Predicate g) (Predicate h) = Predicate $ \a -> case f a of+ (b, c) -> g b && h c++-- | @since 5.3.6+instance Divise Proxy where+ divise _ Proxy Proxy = Proxy++#ifdef MIN_VERSION_StateVar+-- | @since 5.3.6+instance Divise SettableStateVar where+ divise k (SettableStateVar l) (SettableStateVar r) = SettableStateVar $ \ a -> case k a of+ (b, c) -> l b >> r c+#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 _ U1 U1 = U1++-- | 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,243 +1,243 @@-{-# 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 +{-# 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,52 @@-{-# 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 CPP #-}+{-# 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))+#if __GLASGOW_HASKELL__ >= 904+import Data.Type.Equality (type (~))+#endif+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