diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -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 diff --git a/.vim.custom b/.vim.custom --- a/.vim.custom +++ b/.vim.custom @@ -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 :exec ":!hasktags -x -c --ignore src" - -" 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 :exec ":!hasktags -x -c --ignore src" + +" 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" diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,276 +1,283 @@ -6 [2023.03.12] --------------- -* Drop support for GHC 7.10 and earlier. -* The `Foldable1` and `Bifoldable1` classes have been migrated: - * When building with `base-4.18` or later, `semigroupoids` re-exports - `Foldable1` and `Bifoldable1` from `base`. (These classes were added to - `base-4.18` as a result of - [this Core Libraries proposal](haskell/core-libraries-committee#9).) - * When building with older versions of `base`, `semigroupoids` re-exports - `Foldable1` and `Bifoldable1` from the - [`foldable1-classes-compat`](https://github.com/haskell-compat/foldable1-classes-compat) - compatibility package. - - Note that the version of `Foldable1` that `semigroupoids` defined in previous - releases only had three class methods: `fold1`, `foldMap1`, and `toNonEmpty`. - Moreover, `foldMap1` had a default implementation in terms of a `Foldable` - constraint. `base`'s version of `Foldable1`, however, has some notable - differences: - - 1. It has many more methods than the three listed above, such as the - `foldrMap1` method. - 2. `foldMap1` now has a default implementation in terms of `foldrMap1` instead - of in terms of a `Foldable` constraint. - - To avoid (1) causing issues when upgrading to `semigroupoids-6`, - `Data.Semigroup.Foldable` only re-exports the `fold1`, `foldMap1`, and - `toNonEmpty` methods, which reflects the API in previous `semigroupoids` - releases. If you want to use the other, new class methods of `Foldable1`, - consider importing it from `Data.Foldable1` (its home in `base`) instead. - - Difference (2) is trickier, because it is possible that existing code that - defines valid `Foldable1` instances will need to be migrated. If you have an - instance like this: - - ```hs - import Data.Semigroup.Foldable - - data T a = MkT a - - instance Foldable T where - foldMap f (MkT x) = f x - - instance Foldable1 T -- Relying on Foldable-based defaults - ``` - - Then calling `foldMap1` on `T` will throw an error with `semigroupoids-6`, as - `foldMap1`'s default implementation no longer uses `Foldable`. To migrate this - code, change the instance to explicitly define `foldMap1`: - - ```hs - instance Foldable1 T where - foldMap1 f (MkT x) = f x - ``` - - This approach should be backwards-compatible with previous `semigroupoids` - releases. - - Some other side effects of this migration include: - - * The `Data.Semigroup.Foldable.Class` module has been deprecated. It no - longer serves a useful role, as it simply re-exports a limited subset of - the `Data.Foldable1` and `Data.Bifoldable1` API. - * All of the `Foldable1` and `Bifoldable1` instances that were previously - defined in `semigroupoids` have now been migrated to downstream libraries - (`base`, `bifunctors`, `containers`, `tagged`, and `transformers`), so it - is no longer strictly necessary to depend on `semigroupoids` to make use of - these instances. -* Add `Generic1`-based functions for many classes, useful for writing instances: - - `Data.Functor.Alt.()` -> `Data.Functor.Alt.galt` - - `Data.Functor.Apply.{liftF2,liftF3}` -> `Data.Functor.Apply.{gliftF2,gliftF3}` - - `Data.Functor.Bind.(>>-)` -> `Data.Functor.Bind.gbind` - - `Data.Functor.Contravariant.Conclude.{conclude,concluded}` -> `Data.Functor.Contravariant.Conclude.{gconclude,gconcluded}` - - `Data.Functor.Contravariant.Decide.{decide,decided}` -> `Data.Functor.Contravariant.Decide.{gdecide,gdecided}` - - `Data.Functor.Contravariant.Divise.{divise,divised}` -> `Data.Functor.Contravariant.Divise.{gdivise,gdivised}` - - `Data.Functor.Extend.{duplicated,extended}` -> `Data.Functor.Extend.{gduplicated,gextended}` - - `Data.Functor.Plus.zero` -> `Data.Functor.Plus.gzero` - - `Data.Semigroup.Foldable.{fold1,foldMap1,toNonEmpty}` -> `Data.Semigroup.Foldable.{gfold1,gfoldMap1,gtoNonEmpty}` - - `Data.Semigroup.Traversable.{traverse1,sequence1}` -> `Data.Semigroup.Traversable.{gtraverse1,gsequence1}` - -5.3.7 [2022.01.09] ------------------- -* Relax the `Bind` constraints in the following instances to `Functor`: - - ```diff - -instance (Bind f, Monad f) => Alt (MaybeT f) - -instance (Bind f, Monad f) => Plus (MaybeT f) - +instance (Functor f, Monad f) => Alt (MaybeT f) - +instance (Functor f, Monad f) => Plus (MaybeT f) - - -instance (Bind f, Monad f, Semigroup e) => Alt (ExceptT e f) - -instance (Bind f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f) - +instance (Functor f, Monad f, Semigroup e) => Alt (ExceptT e f) - +instance (Functor f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f) - - -- If building with transformers-0.5.* or older - -instance (Bind f, Monad f) => Alt (ErrorT e f) - -instance (Bind f, Monad f, Error e) => Plus (ErrorT e f - +instance (Functor f, Monad f) => Alt (ErrorT e f) - +instance (Functor f, Monad f, Error e) => Plus (ErrorT e f) - ``` - -5.3.6 [2021.10.07] ------------------- -* Allow building with GHC 9.2. -* Allow building with `transformers-0.6.*`. -* Add `Alt` instance for `Identity`. -* Add `Conclude`, `Decide` and `Divise` type classes and instances. -* Add `(<.*>)`, `(<*.>)`, and `traverseMaybe` functions, which make it easier - to defined `Traversable1` instances for data types that have fields with a - combination of `Traversable` and `Traversable1` instances. -* Add `Semigroupoids.Do` module with overloads for use with `QualifiedDo`. -* Add `Apply`, `Alt`, `Plus`, `Bind` and `BindTrans` instances for the CPS - versions of `WriterT` and `RWST`. -* Add `psum` function to `Data.Functor.Plus`. -* Add `Categorical` data type. - -5.3.5 [2020.12.31] ------------------- -* The build-type has been changed from `Custom` to `Simple`. - To achieve this, the `doctests` test suite has been removed in favor of using - [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) - to run the doctests. -* Explicitly mark modules as `Safe`. - -5.3.4 [2019.11.26] ------------------- -* Achieve forward compatibility with - [GHC proposal 229](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst). - -5.3.3 [2019.08.27] ------------------- -* Add `Alt` and `Plus` instances for `HashMap` from the `unordered-containers` - package. - -5.3.2 [2019.01.04] ------------------- -* Bump the lower bound on `semigroups` to 0.16.2, and avoid incurring - the dependency entirely on recent GHCs. -* Fix the build on GHC 7.0 and 7.2. - -5.3.1 [2018.07.02] ------------------- -* Fix a regression introduced in `semigroupoids-5.3` in which some modules - regressed from `Trustworthy` to `Unsafe`. - -5.3 [2018.07.02] ----------------- -* Allow building with `containers-0.6`. -* Add `Alt` instances for `First` and `Last` from `Data.Semigroup`, and - `Alt` and `Plus` instances for `First` and `Last` from `Data.Monoid`. -* Add missing `Apply`, `Bind`, `Extend`, `Foldable1` and `Traversable1` - instances for `Data.Semigroups`, `Data.Monoid` and `GHC.Generics`. - -5.2.2 [2018.01.18] ------------------- -* Add `optional` to `Data.Functor.Alt` (analogous to the `optional` function - in `Control.Applicative`) -* `liftF2` is now a class method of `Apply` (mirroring the fact that `liftA2` - is now a class method of `Applicative`). `liftF2` and `(<.>)` have default - definitions in terms of the other. -* Allow building with GHC 8.4 -* `Apply` and `Bind` instances for `Q`, from the `template-haskell` package. - (As a consequence, `Data.Semigroup.Foldable` is no longer a `Trustworthy` - module.) -* Add instances for `(:~:)` and `(:~~:)` from `Data.Type.Equality`, and - `Coercion` from `Data.Type.Coercion` - -5.2.1 ------ -* Add the `toNonEmpty` method to `Foldable1`. Add `foldrM1` and `foldlM1` - functions to `Data.Semigroup.Foldable` that are defined in terms of `toNonEmpty`. -* Add `Apply`, `Bind`, `Foldable1`, and `Traversable1` instances for `Complex` -* Add `Apply` and `Bind` instances for `HashMap` from the `unordered-containers` package - (on which `semigroupoids` now depends) -* Add `Semigroupoid` instances for `Tagged` and `Const` - -5.2 ---- -* Revamp `Setup.hs` to use `cabal-doctest`. This makes it build - with `Cabal-1.25`, and makes the `doctest`s work with `cabal new-build` and - sandboxes. -* Added instances to `Alt`, `Plus`, `Apply`, `Bind` and `Extend` for `GHC.Generics`, `Tagged` and `Proxy` where appropriate. - -5.1 ---- -* The remaining orphan instances in `Data.Traversable.Instances` have been replaced in favor of the orphan instances from `transformers-compat-0.5`. -* The documentation now states laws that instances of `Apply` are expected to uphold. -* `doctest-0.11` support -* Fixed compilation of tests with `stack` - -5.0.1 -------- -* `transformers-compat` 0.5 support -* Removed some redundant constraints. -* GHC 8 support - -5.0.0.4 -------- -* `doctest` 0.10 support - -5.0.0.2 -------- -* Bugfix for GHC 7.4. PolyKinds on 7.4 cause all sorts of haskell interface file errors. One of the #if guards that turned it off on 7.4 was missing and has been fixed. - -5.0.0.1 -------- -* Added the CHANGELOG to the distribution so that `hackage` can link to it in the haddocks. - -5 -- -* Absorbed `Data.Bifunctor.Apply`, `Data.Semigroup.Bifoldable` and `Data.Semigroup.Traversable` from `bifunctors`. -* This caused us to pick up a dependency on `tagged`. -* Exiled `Data.Semifunctor.*`, `Data.Semigroupoid.Product` and `Data.Semigroupoid.Coproduct` to `semigroupoid-extras`. -* This let us open up to older versions of GHC again. -* Set an explicit fixity for `-<-` and `->-`. - -4.5 ---- -* Major changes to the API to support PolyKinds and DataKinds. This necessarily shuts off GHC <= 7.4. -* Orphan instances have moved upstream into a common `base-orphans` package. - -4.3.1 ------ -* Added `asum1` to `Data.Semigroup.Foldable`. - -4.3.0.1 -------- -* Support for 'ConstrainedClassMethods' is currently required for GHC HEAD. - -4.3 ------ -* Added missing instances for `ExceptT`. Obtain it via `transformers-compat` if need be for old `transformers` versions. -* Several `Bind` and `Apply` instances now require somewhat more minimal contexts. - -4.2 ---- -* Backported `Foldable`/`Traversable` instances from `lens` - -4.1 ---- -* `Foldable1`/`Traversable1` for tuples - -4.0.4 ------ -* `contravariant` 1.0 support. - -4.0.3 ---- -* Added flags to provide unsupported cabal sandbox build modes. - -4.0.1 ------ -* Fixed bitrot in the `Data.Functor.Extend` documentation. -* Fixed warnings on GHC 7.8.1rc2 caused by importing `Control.Monad.Instances`. - -4.0 ---- -* Merged in the contents of the `groupoids` and `semigroupoid-extras` packages. - -3.1 ---- -* Added the [rectangular band](http://en.wikipedia.org/wiki/Band_(mathematics)#Rectangular_bands) `Semigroupoid` for `(,)`. Would that make it a Bandoid? - -3.0.3 ------ -* Claim to be `Trustworthy` where necessary - -3.0.2 ------ -* Tightened the upper bounds slightly to enable PVP compliance while retaining a flexible development cycle. -* Raised the upper bound on `contravariant`. - -3.0.1 ------ -* Removed upper bounds relative to my other packages -* Refactored directory layout +6.0.0.1 [2023.03.16] +-------------------- +* When building with GHC 9.6, require `transformers >= 0.6.1` and + `containers >= 0.6.7`. This ensures that `semigroupoids` always provides + `Traversable1` instances for data types from `transformers` and `containers` + unconditionally. + +6 [2023.03.12] +-------------- +* Drop support for GHC 7.10 and earlier. +* The `Foldable1` and `Bifoldable1` classes have been migrated: + * When building with `base-4.18` or later, `semigroupoids` re-exports + `Foldable1` and `Bifoldable1` from `base`. (These classes were added to + `base-4.18` as a result of + [this Core Libraries proposal](haskell/core-libraries-committee#9).) + * When building with older versions of `base`, `semigroupoids` re-exports + `Foldable1` and `Bifoldable1` from the + [`foldable1-classes-compat`](https://github.com/haskell-compat/foldable1-classes-compat) + compatibility package. + + Note that the version of `Foldable1` that `semigroupoids` defined in previous + releases only had three class methods: `fold1`, `foldMap1`, and `toNonEmpty`. + Moreover, `foldMap1` had a default implementation in terms of a `Foldable` + constraint. `base`'s version of `Foldable1`, however, has some notable + differences: + + 1. It has many more methods than the three listed above, such as the + `foldrMap1` method. + 2. `foldMap1` now has a default implementation in terms of `foldrMap1` instead + of in terms of a `Foldable` constraint. + + To avoid (1) causing issues when upgrading to `semigroupoids-6`, + `Data.Semigroup.Foldable` only re-exports the `fold1`, `foldMap1`, and + `toNonEmpty` methods, which reflects the API in previous `semigroupoids` + releases. If you want to use the other, new class methods of `Foldable1`, + consider importing it from `Data.Foldable1` (its home in `base`) instead. + + Difference (2) is trickier, because it is possible that existing code that + defines valid `Foldable1` instances will need to be migrated. If you have an + instance like this: + + ```hs + import Data.Semigroup.Foldable + + data T a = MkT a + + instance Foldable T where + foldMap f (MkT x) = f x + + instance Foldable1 T -- Relying on Foldable-based defaults + ``` + + Then calling `foldMap1` on `T` will throw an error with `semigroupoids-6`, as + `foldMap1`'s default implementation no longer uses `Foldable`. To migrate this + code, change the instance to explicitly define `foldMap1`: + + ```hs + instance Foldable1 T where + foldMap1 f (MkT x) = f x + ``` + + This approach should be backwards-compatible with previous `semigroupoids` + releases. + + Some other side effects of this migration include: + + * The `Data.Semigroup.Foldable.Class` module has been deprecated. It no + longer serves a useful role, as it simply re-exports a limited subset of + the `Data.Foldable1` and `Data.Bifoldable1` API. + * All of the `Foldable1` and `Bifoldable1` instances that were previously + defined in `semigroupoids` have now been migrated to downstream libraries + (`base`, `bifunctors`, `containers`, `tagged`, and `transformers`), so it + is no longer strictly necessary to depend on `semigroupoids` to make use of + these instances. +* Add `Generic1`-based functions for many classes, useful for writing instances: + - `Data.Functor.Alt.()` -> `Data.Functor.Alt.galt` + - `Data.Functor.Apply.{liftF2,liftF3}` -> `Data.Functor.Apply.{gliftF2,gliftF3}` + - `Data.Functor.Bind.(>>-)` -> `Data.Functor.Bind.gbind` + - `Data.Functor.Contravariant.Conclude.{conclude,concluded}` -> `Data.Functor.Contravariant.Conclude.{gconclude,gconcluded}` + - `Data.Functor.Contravariant.Decide.{decide,decided}` -> `Data.Functor.Contravariant.Decide.{gdecide,gdecided}` + - `Data.Functor.Contravariant.Divise.{divise,divised}` -> `Data.Functor.Contravariant.Divise.{gdivise,gdivised}` + - `Data.Functor.Extend.{duplicated,extended}` -> `Data.Functor.Extend.{gduplicated,gextended}` + - `Data.Functor.Plus.zero` -> `Data.Functor.Plus.gzero` + - `Data.Semigroup.Foldable.{fold1,foldMap1,toNonEmpty}` -> `Data.Semigroup.Foldable.{gfold1,gfoldMap1,gtoNonEmpty}` + - `Data.Semigroup.Traversable.{traverse1,sequence1}` -> `Data.Semigroup.Traversable.{gtraverse1,gsequence1}` + +5.3.7 [2022.01.09] +------------------ +* Relax the `Bind` constraints in the following instances to `Functor`: + + ```diff + -instance (Bind f, Monad f) => Alt (MaybeT f) + -instance (Bind f, Monad f) => Plus (MaybeT f) + +instance (Functor f, Monad f) => Alt (MaybeT f) + +instance (Functor f, Monad f) => Plus (MaybeT f) + + -instance (Bind f, Monad f, Semigroup e) => Alt (ExceptT e f) + -instance (Bind f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f) + +instance (Functor f, Monad f, Semigroup e) => Alt (ExceptT e f) + +instance (Functor f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f) + + -- If building with transformers-0.5.* or older + -instance (Bind f, Monad f) => Alt (ErrorT e f) + -instance (Bind f, Monad f, Error e) => Plus (ErrorT e f + +instance (Functor f, Monad f) => Alt (ErrorT e f) + +instance (Functor f, Monad f, Error e) => Plus (ErrorT e f) + ``` + +5.3.6 [2021.10.07] +------------------ +* Allow building with GHC 9.2. +* Allow building with `transformers-0.6.*`. +* Add `Alt` instance for `Identity`. +* Add `Conclude`, `Decide` and `Divise` type classes and instances. +* Add `(<.*>)`, `(<*.>)`, and `traverseMaybe` functions, which make it easier + to defined `Traversable1` instances for data types that have fields with a + combination of `Traversable` and `Traversable1` instances. +* Add `Semigroupoids.Do` module with overloads for use with `QualifiedDo`. +* Add `Apply`, `Alt`, `Plus`, `Bind` and `BindTrans` instances for the CPS + versions of `WriterT` and `RWST`. +* Add `psum` function to `Data.Functor.Plus`. +* Add `Categorical` data type. + +5.3.5 [2020.12.31] +------------------ +* The build-type has been changed from `Custom` to `Simple`. + To achieve this, the `doctests` test suite has been removed in favor of using + [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) + to run the doctests. +* Explicitly mark modules as `Safe`. + +5.3.4 [2019.11.26] +------------------ +* Achieve forward compatibility with + [GHC proposal 229](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst). + +5.3.3 [2019.08.27] +------------------ +* Add `Alt` and `Plus` instances for `HashMap` from the `unordered-containers` + package. + +5.3.2 [2019.01.04] +------------------ +* Bump the lower bound on `semigroups` to 0.16.2, and avoid incurring + the dependency entirely on recent GHCs. +* Fix the build on GHC 7.0 and 7.2. + +5.3.1 [2018.07.02] +------------------ +* Fix a regression introduced in `semigroupoids-5.3` in which some modules + regressed from `Trustworthy` to `Unsafe`. + +5.3 [2018.07.02] +---------------- +* Allow building with `containers-0.6`. +* Add `Alt` instances for `First` and `Last` from `Data.Semigroup`, and + `Alt` and `Plus` instances for `First` and `Last` from `Data.Monoid`. +* Add missing `Apply`, `Bind`, `Extend`, `Foldable1` and `Traversable1` + instances for `Data.Semigroups`, `Data.Monoid` and `GHC.Generics`. + +5.2.2 [2018.01.18] +------------------ +* Add `optional` to `Data.Functor.Alt` (analogous to the `optional` function + in `Control.Applicative`) +* `liftF2` is now a class method of `Apply` (mirroring the fact that `liftA2` + is now a class method of `Applicative`). `liftF2` and `(<.>)` have default + definitions in terms of the other. +* Allow building with GHC 8.4 +* `Apply` and `Bind` instances for `Q`, from the `template-haskell` package. + (As a consequence, `Data.Semigroup.Foldable` is no longer a `Trustworthy` + module.) +* Add instances for `(:~:)` and `(:~~:)` from `Data.Type.Equality`, and + `Coercion` from `Data.Type.Coercion` + +5.2.1 +----- +* Add the `toNonEmpty` method to `Foldable1`. Add `foldrM1` and `foldlM1` + functions to `Data.Semigroup.Foldable` that are defined in terms of `toNonEmpty`. +* Add `Apply`, `Bind`, `Foldable1`, and `Traversable1` instances for `Complex` +* Add `Apply` and `Bind` instances for `HashMap` from the `unordered-containers` package + (on which `semigroupoids` now depends) +* Add `Semigroupoid` instances for `Tagged` and `Const` + +5.2 +--- +* Revamp `Setup.hs` to use `cabal-doctest`. This makes it build + with `Cabal-1.25`, and makes the `doctest`s work with `cabal new-build` and + sandboxes. +* Added instances to `Alt`, `Plus`, `Apply`, `Bind` and `Extend` for `GHC.Generics`, `Tagged` and `Proxy` where appropriate. + +5.1 +--- +* The remaining orphan instances in `Data.Traversable.Instances` have been replaced in favor of the orphan instances from `transformers-compat-0.5`. +* The documentation now states laws that instances of `Apply` are expected to uphold. +* `doctest-0.11` support +* Fixed compilation of tests with `stack` + +5.0.1 +------- +* `transformers-compat` 0.5 support +* Removed some redundant constraints. +* GHC 8 support + +5.0.0.4 +------- +* `doctest` 0.10 support + +5.0.0.2 +------- +* Bugfix for GHC 7.4. PolyKinds on 7.4 cause all sorts of haskell interface file errors. One of the #if guards that turned it off on 7.4 was missing and has been fixed. + +5.0.0.1 +------- +* Added the CHANGELOG to the distribution so that `hackage` can link to it in the haddocks. + +5 +- +* Absorbed `Data.Bifunctor.Apply`, `Data.Semigroup.Bifoldable` and `Data.Semigroup.Traversable` from `bifunctors`. +* This caused us to pick up a dependency on `tagged`. +* Exiled `Data.Semifunctor.*`, `Data.Semigroupoid.Product` and `Data.Semigroupoid.Coproduct` to `semigroupoid-extras`. +* This let us open up to older versions of GHC again. +* Set an explicit fixity for `-<-` and `->-`. + +4.5 +--- +* Major changes to the API to support PolyKinds and DataKinds. This necessarily shuts off GHC <= 7.4. +* Orphan instances have moved upstream into a common `base-orphans` package. + +4.3.1 +----- +* Added `asum1` to `Data.Semigroup.Foldable`. + +4.3.0.1 +------- +* Support for 'ConstrainedClassMethods' is currently required for GHC HEAD. + +4.3 +----- +* Added missing instances for `ExceptT`. Obtain it via `transformers-compat` if need be for old `transformers` versions. +* Several `Bind` and `Apply` instances now require somewhat more minimal contexts. + +4.2 +--- +* Backported `Foldable`/`Traversable` instances from `lens` + +4.1 +--- +* `Foldable1`/`Traversable1` for tuples + +4.0.4 +----- +* `contravariant` 1.0 support. + +4.0.3 +--- +* Added flags to provide unsupported cabal sandbox build modes. + +4.0.1 +----- +* Fixed bitrot in the `Data.Functor.Extend` documentation. +* Fixed warnings on GHC 7.8.1rc2 caused by importing `Control.Monad.Instances`. + +4.0 +--- +* Merged in the contents of the `groupoids` and `semigroupoid-extras` packages. + +3.1 +--- +* Added the [rectangular band](http://en.wikipedia.org/wiki/Band_(mathematics)#Rectangular_bands) `Semigroupoid` for `(,)`. Would that make it a Bandoid? + +3.0.3 +----- +* Claim to be `Trustworthy` where necessary + +3.0.2 +----- +* Tightened the upper bounds slightly to enable PVP compliance while retaining a flexible development cycle. +* Raised the upper bound on `contravariant`. + +3.0.1 +----- +* Removed upper bounds relative to my other packages +* Refactored directory layout diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,63 +1,63 @@ -semigroupoids -============= - -[![Hackage](https://img.shields.io/hackage/v/semigroupoids.svg)](https://hackage.haskell.org/package/semigroupoids) [![Build Status](https://github.com/ekmett/semigroupoids/workflows/Haskell-CI/badge.svg)](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. - -![A diagram of the relationships between type classes defined in this package and elsewhere.](https://raw.github.com/ekmett/semigroupoids/master/img/classes.svg) - -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 +============= + +[![Hackage](https://img.shields.io/hackage/v/semigroupoids.svg)](https://hackage.haskell.org/package/semigroupoids) [![Build Status](https://github.com/ekmett/semigroupoids/workflows/Haskell-CI/badge.svg)](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. + +![A diagram of the relationships between type classes defined in this package and elsewhere.](https://raw.github.com/ekmett/semigroupoids/master/img/classes.svg) + +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 diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -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 diff --git a/img/classes.dot b/img/classes.dot --- a/img/classes.dot +++ b/img/classes.dot @@ -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; +} diff --git a/img/classes.svg b/img/classes.svg --- a/img/classes.svg +++ b/img/classes.svg @@ -1,306 +1,306 @@ - - - - - - - - - -functor - -Functor - - - -traversable - -Traversable - - - -functor->traversable - - - - - -apply - -Apply - - - -functor->apply - - - - - -alt - -Alt - - - -functor->alt - - - - - -foldable - -Foldable - - - -foldable->traversable - - - - - -foldable1 - -Foldable1 - - - -foldable->foldable1 - - - - - -traversable1 - -Traversable1 - - - -traversable->traversable1 - - - - - -bind - -Bind - - - -apply->bind - - - - - -applicative - -Applicative - - - -apply->applicative - - - - - -monad - -Monad - - - -bind->monad - - - - - -alternative - -Alternative - - - -applicative->alternative - - - - - -applicative->monad - - - - - -plus - -Plus - - - -alt->plus - - - - - -plus->alternative - - - - - -monad_plus - -MonadPlus - - - -alternative->monad_plus - - - - - -monad->monad_plus - - - - - -foldable1->traversable1 - - - - - -bifunctor - -Bifunctor - - - -biapply - -Biapply - - - -bifunctor->biapply - - - - - -contravariant - -Contravariant - - - -divise - -Divise - - - -contravariant->divise - - - - - -decide - -Decide - - - -contravariant->decide - - - - - -divisible - -Divisible - - - -divise->divisible - - - - - -decidable - -Decidable - - - -decide->decidable - - - - - -conclude - -Conclude - - - -decide->conclude - - - - - -conclude->decidable - - - - - -semigroupoid - -Semigroupoid - - - -category - -Category - - - -semigroupoid->category - - - - - -arrow - -Arrow - - - -category->arrow - - - - - + + + + + + + + + +functor + +Functor + + + +traversable + +Traversable + + + +functor->traversable + + + + + +apply + +Apply + + + +functor->apply + + + + + +alt + +Alt + + + +functor->alt + + + + + +foldable + +Foldable + + + +foldable->traversable + + + + + +foldable1 + +Foldable1 + + + +foldable->foldable1 + + + + + +traversable1 + +Traversable1 + + + +traversable->traversable1 + + + + + +bind + +Bind + + + +apply->bind + + + + + +applicative + +Applicative + + + +apply->applicative + + + + + +monad + +Monad + + + +bind->monad + + + + + +alternative + +Alternative + + + +applicative->alternative + + + + + +applicative->monad + + + + + +plus + +Plus + + + +alt->plus + + + + + +plus->alternative + + + + + +monad_plus + +MonadPlus + + + +alternative->monad_plus + + + + + +monad->monad_plus + + + + + +foldable1->traversable1 + + + + + +bifunctor + +Bifunctor + + + +biapply + +Biapply + + + +bifunctor->biapply + + + + + +contravariant + +Contravariant + + + +divise + +Divise + + + +contravariant->divise + + + + + +decide + +Decide + + + +contravariant->decide + + + + + +divisible + +Divisible + + + +divise->divisible + + + + + +decidable + +Decidable + + + +decide->decidable + + + + + +conclude + +Conclude + + + +decide->conclude + + + + + +conclude->decidable + + + + + +semigroupoid + +Semigroupoid + + + +category + +Category + + + +semigroupoid->category + + + + + +arrow + +Arrow + + + +category->arrow + + + + + diff --git a/semigroupoids.cabal b/semigroupoids.cabal --- a/semigroupoids.cabal +++ b/semigroupoids.cabal @@ -1,196 +1,203 @@ -cabal-version: 1.24 -name: semigroupoids -category: Control, Comonads -version: 6 -license: BSD2 -license-file: LICENSE -author: Edward A. Kmett -maintainer: Edward A. Kmett -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. - . - <> - . - Apply, Bind, and Extend (not shown) give rise the Static, Kleisli and Cokleisli semigroupoids respectively. - . - This lets us remove many of the restrictions from various monad transformers - as in many cases the binding operation or @\<*\>@ operation does not require them. - . - Finally, to work with these weaker structures it is beneficial to have containers - that can provide stronger guarantees about their contents, so versions of 'Traversable' - and 'Foldable' that can be folded with just a 'Semigroup' are added. - -source-repository head - type: git - location: git://github.com/ekmett/semigroupoids.git - -flag containers - description: - You can disable the use of the `containers` package using `-f-containers`. - . - Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. - default: True - manual: True - -flag contravariant - description: - You can disable the use of the `contravariant` package using `-f-contravariant`. - . - Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. - . - If disabled we will not supply instances of `Contravariant` - . - default: True - manual: True - -flag distributive - description: - You can disable the use of the `distributive` package using `-f-distributive`. - . - Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. - . - If disabled we will not supply instances of `Distributive` - . - default: True - manual: True - -flag comonad - description: - You can disable the use of the `comonad` package using `-f-comonad`. - . - Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. - . - If disabled we will not supply instances of `Comonad` - . - default: True - manual: True - -flag tagged - description: - You can disable the use of the `tagged` package using `-f-tagged`. - . - Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. - default: True - manual: True - -flag unordered-containers - description: - You can disable the use of the `unordered-containers` package (and also its dependency `hashable`) using `-f-unordered-containers`. - . - Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. - default: True - manual: True - -library - build-depends: - base >= 4.9 && < 5, - base-orphans >= 0.8.4 && < 1, - bifunctors >= 5.6 && < 6, - template-haskell >= 0.2.11, - transformers >= 0.5 && < 0.7, - transformers-compat >= 0.6 && < 0.8 - - if !impl(ghc >= 9.6) - build-depends: foldable1-classes-compat >= 0.1 && < 0.2 - - if flag(containers) - build-depends: containers >= 0.5.7.1 && < 0.7 - - if flag(contravariant) - build-depends: contravariant >= 1.5.3 && < 2 - - if flag(distributive) - build-depends: distributive >= 0.5.2 && < 1 - - if flag(comonad) - build-depends: comonad >= 5.0.8 && < 6 - - if flag(tagged) - build-depends: tagged >= 0.8.7 && < 1 - - if flag(unordered-containers) - build-depends: hashable >= 1.2.7.0 && < 1.5, - unordered-containers >= 0.2.8.0 && < 0.3 - - hs-source-dirs: src - - exposed-modules: - Data.Bifunctor.Apply - Data.Functor.Alt - Data.Functor.Apply - Data.Functor.Bind - Data.Functor.Bind.Class - Data.Functor.Bind.Trans - Data.Functor.Contravariant.Conclude - Data.Functor.Contravariant.Decide - Data.Functor.Contravariant.Divise - Data.Functor.Extend - Data.Functor.Plus - Data.Groupoid - Data.Isomorphism - Data.Semigroup.Bifoldable - Data.Semigroup.Bitraversable - Data.Semigroup.Foldable - Data.Semigroup.Foldable.Class - Data.Semigroup.Traversable - Data.Semigroup.Traversable.Class - Data.Semigroupoid - Data.Semigroupoid.Categorical - Data.Semigroupoid.Dual - Data.Semigroupoid.Ob - Data.Semigroupoid.Static - Data.Traversable.Instances - Semigroupoids.Do - other-modules: - Semigroupoids.Internal - - ghc-options: -Wall -Wno-warnings-deprecations -Wno-trustworthy-safe - - if impl(ghc >= 9.0) - -- these flags may abort compilation with GHC-8.10 - -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295 - ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode - - default-language: Haskell2010 +cabal-version: 1.24 +name: semigroupoids +category: Control, Comonads +version: 6.0.0.1 +license: BSD2 +license-file: LICENSE +author: Edward A. Kmett +maintainer: Edward A. Kmett +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. + . + <> + . + 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 diff --git a/src/Data/Bifunctor/Apply.hs b/src/Data/Bifunctor/Apply.hs --- a/src/Data/Bifunctor/Apply.hs +++ b/src/Data/Bifunctor/Apply.hs @@ -1,39 +1,39 @@ -{-# LANGUAGE Safe #-} ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2011-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- 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 +-- 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 #-} diff --git a/src/Data/Functor/Alt.hs b/src/Data/Functor/Alt.hs --- a/src/Data/Functor/Alt.hs +++ b/src/Data/Functor/Alt.hs @@ -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 --- 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 +-- 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 diff --git a/src/Data/Functor/Apply.hs b/src/Data/Functor/Apply.hs --- a/src/Data/Functor/Apply.hs +++ b/src/Data/Functor/Apply.hs @@ -1,64 +1,64 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Trustworthy #-} ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2011-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- 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 +-- 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) diff --git a/src/Data/Functor/Bind.hs b/src/Data/Functor/Bind.hs --- a/src/Data/Functor/Bind.hs +++ b/src/Data/Functor/Bind.hs @@ -1,59 +1,59 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Trustworthy #-} ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2011-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- 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 +-- 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 diff --git a/src/Data/Functor/Bind/Class.hs b/src/Data/Functor/Bind/Class.hs --- a/src/Data/Functor/Bind/Class.hs +++ b/src/Data/Functor/Bind/Class.hs @@ -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 --- 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 +-- 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 (<<.>>) #-} diff --git a/src/Data/Functor/Bind/Trans.hs b/src/Data/Functor/Bind/Trans.hs --- a/src/Data/Functor/Bind/Trans.hs +++ b/src/Data/Functor/Bind/Trans.hs @@ -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 --- 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 +-- 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 >>-) diff --git a/src/Data/Functor/Contravariant/Conclude.hs b/src/Data/Functor/Contravariant/Conclude.hs --- a/src/Data/Functor/Contravariant/Conclude.hs +++ b/src/Data/Functor/Contravariant/Conclude.hs @@ -1,222 +1,222 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE Safe #-} - ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2021 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- 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 +-- 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 diff --git a/src/Data/Functor/Contravariant/Decide.hs b/src/Data/Functor/Contravariant/Decide.hs --- a/src/Data/Functor/Contravariant/Decide.hs +++ b/src/Data/Functor/Contravariant/Decide.hs @@ -1,245 +1,245 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Safe #-} -{-# LANGUAGE TypeOperators #-} - ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2021 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- 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 +-- 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 diff --git a/src/Data/Functor/Contravariant/Divise.hs b/src/Data/Functor/Contravariant/Divise.hs --- a/src/Data/Functor/Contravariant/Divise.hs +++ b/src/Data/Functor/Contravariant/Divise.hs @@ -1,289 +1,289 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Safe #-} -{-# LANGUAGE TypeOperators #-} - ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2021 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- 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 +-- 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 diff --git a/src/Data/Functor/Extend.hs b/src/Data/Functor/Extend.hs --- a/src/Data/Functor/Extend.hs +++ b/src/Data/Functor/Extend.hs @@ -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 --- 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 +-- 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'. diff --git a/src/Data/Functor/Plus.hs b/src/Data/Functor/Plus.hs --- a/src/Data/Functor/Plus.hs +++ b/src/Data/Functor/Plus.hs @@ -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 --- 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 +-- 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 diff --git a/src/Data/Groupoid.hs b/src/Data/Groupoid.hs --- a/src/Data/Groupoid.hs +++ b/src/Data/Groupoid.hs @@ -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 --- 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 +-- 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 diff --git a/src/Data/Isomorphism.hs b/src/Data/Isomorphism.hs --- a/src/Data/Isomorphism.hs +++ b/src/Data/Isomorphism.hs @@ -1,33 +1,33 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE Safe #-} ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2011-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- 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 +-- 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 diff --git a/src/Data/Semigroup/Bifoldable.hs b/src/Data/Semigroup/Bifoldable.hs --- a/src/Data/Semigroup/Bifoldable.hs +++ b/src/Data/Semigroup/Bifoldable.hs @@ -1,64 +1,64 @@ -{-# LANGUAGE Safe #-} ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2011-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- 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 +-- 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 #-} diff --git a/src/Data/Semigroup/Bitraversable.hs b/src/Data/Semigroup/Bitraversable.hs --- a/src/Data/Semigroup/Bitraversable.hs +++ b/src/Data/Semigroup/Bitraversable.hs @@ -1,26 +1,26 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE Safe #-} ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2011-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- 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 +-- 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 #-} diff --git a/src/Data/Semigroup/Foldable.hs b/src/Data/Semigroup/Foldable.hs --- a/src/Data/Semigroup/Foldable.hs +++ b/src/Data/Semigroup/Foldable.hs @@ -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 --- 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 +-- 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 diff --git a/src/Data/Semigroup/Foldable/Class.hs b/src/Data/Semigroup/Foldable/Class.hs --- a/src/Data/Semigroup/Foldable/Class.hs +++ b/src/Data/Semigroup/Foldable/Class.hs @@ -1,28 +1,28 @@ -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2011-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- 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 +-- 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 diff --git a/src/Data/Semigroup/Traversable.hs b/src/Data/Semigroup/Traversable.hs --- a/src/Data/Semigroup/Traversable.hs +++ b/src/Data/Semigroup/Traversable.hs @@ -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 --- 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 +-- 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 diff --git a/src/Data/Semigroup/Traversable/Class.hs b/src/Data/Semigroup/Traversable/Class.hs --- a/src/Data/Semigroup/Traversable/Class.hs +++ b/src/Data/Semigroup/Traversable/Class.hs @@ -1,262 +1,243 @@ -{-# LANGUAGE CPP, TypeOperators #-} -{-# LANGUAGE Trustworthy #-} - -#ifdef MIN_VERSION_containers -# if MIN_VERSION_base(4,18,0) -# define HAS_FOLDABLE1_CONTAINERS MIN_VERSION_containers(0,6,7) -# else -# define HAS_FOLDABLE1_CONTAINERS 1 -# endif -#else -# define HAS_FOLDABLE1_CONTAINERS 0 -#endif - -#if MIN_VERSION_base(4,18,0) -# define HAS_FOLDABLE1_TRANSFORMERS MIN_VERSION_transformers(0,6,1) -#else -# define HAS_FOLDABLE1_TRANSFORMERS 1 -#endif - ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2011-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable --- ----------------------------------------------------------------------------- -module Data.Semigroup.Traversable.Class - ( Bitraversable1(..) - , Traversable1(..) - ) where - -import Control.Applicative -import Data.Bitraversable -import Data.Bifunctor -import Data.Bifunctor.Biff -import Data.Bifunctor.Clown -import Data.Bifunctor.Flip -import Data.Bifunctor.Joker -import Data.Bifunctor.Join -import Data.Bifunctor.Product as Bifunctor -import Data.Bifunctor.Tannen -import Data.Bifunctor.Wrapped -import Data.Functor.Apply -import Data.Functor.Compose - -import Data.Complex -import Data.Functor.Identity -import Data.Functor.Product as Functor -import Data.Functor.Sum as Functor -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.Monoid as Monoid -import Data.Orphans () -import Data.Semigroup as Semigroup -import Data.Semigroup.Foldable -import Data.Semigroup.Bifoldable -#ifdef MIN_VERSION_tagged -import Data.Tagged -#endif -import Data.Traversable.Instances () -import GHC.Generics - -#if HAS_FOLDABLE1_CONTAINERS -import Data.Tree -#endif - -#if HAS_FOLDABLE1_TRANSFORMERS -import Control.Applicative.Backwards -import Control.Applicative.Lift -import Control.Monad.Trans.Identity -import Data.Functor.Reverse -#endif - -class (Bifoldable1 t, Bitraversable t) => Bitraversable1 t where - bitraverse1 :: Apply f => (a -> f b) -> (c -> f d) -> t a c -> f (t b d) - bitraverse1 f g = bisequence1 . bimap f g - {-# INLINE bitraverse1 #-} - - bisequence1 :: Apply f => t (f a) (f b) -> f (t a b) - bisequence1 = bitraverse1 id id - {-# INLINE bisequence1 #-} - - {-# MINIMAL bitraverse1 | bisequence1 #-} - -instance Bitraversable1 Arg where - bitraverse1 f g (Arg a b) = Arg <$> f a <.> g b - -instance Bitraversable1 Either where - bitraverse1 f _ (Left a) = Left <$> f a - bitraverse1 _ g (Right b) = Right <$> g b - {-# INLINE bitraverse1 #-} - -instance Bitraversable1 (,) where - bitraverse1 f g (a, b) = (,) <$> f a <.> g b - {-# INLINE bitraverse1 #-} - -instance Bitraversable1 ((,,) x) where - bitraverse1 f g (x, a, b) = (,,) x <$> f a <.> g b - {-# INLINE bitraverse1 #-} - -instance Bitraversable1 ((,,,) x y) where - bitraverse1 f g (x, y, a, b) = (,,,) x y <$> f a <.> g b - {-# INLINE bitraverse1 #-} - -instance Bitraversable1 ((,,,,) x y z) where - bitraverse1 f g (x, y, z, a, b) = (,,,,) x y z <$> f a <.> g b - {-# INLINE bitraverse1 #-} - -instance Bitraversable1 Const where - bitraverse1 f _ (Const a) = Const <$> f a - {-# INLINE bitraverse1 #-} - -#ifdef MIN_VERSION_tagged -instance Bitraversable1 Tagged where - bitraverse1 _ g (Tagged b) = Tagged <$> g b - {-# INLINE bitraverse1 #-} -#endif - -instance (Bitraversable1 p, Traversable1 f, Traversable1 g) => Bitraversable1 (Biff p f g) where - bitraverse1 f g = fmap Biff . bitraverse1 (traverse1 f) (traverse1 g) . runBiff - {-# INLINE bitraverse1 #-} - -instance Traversable1 f => Bitraversable1 (Clown f) where - bitraverse1 f _ = fmap Clown . traverse1 f . runClown - {-# INLINE bitraverse1 #-} - -instance Bitraversable1 p => Bitraversable1 (Flip p) where - bitraverse1 f g = fmap Flip . bitraverse1 g f . runFlip - {-# INLINE bitraverse1 #-} - -instance Bitraversable1 p => Traversable1 (Join p) where - traverse1 f (Join a) = fmap Join (bitraverse1 f f a) - {-# INLINE traverse1 #-} - sequence1 (Join a) = fmap Join (bisequence1 a) - {-# INLINE sequence1 #-} - -instance Traversable1 g => Bitraversable1 (Joker g) where - bitraverse1 _ g = fmap Joker . traverse1 g . runJoker - {-# INLINE bitraverse1 #-} - -instance (Bitraversable1 f, Bitraversable1 g) => Bitraversable1 (Bifunctor.Product f g) where - bitraverse1 f g (Bifunctor.Pair x y) = Bifunctor.Pair <$> bitraverse1 f g x <.> bitraverse1 f g y - {-# INLINE bitraverse1 #-} - -instance (Traversable1 f, Bitraversable1 p) => Bitraversable1 (Tannen f p) where - bitraverse1 f g = fmap Tannen . traverse1 (bitraverse1 f g) . runTannen - {-# INLINE bitraverse1 #-} - -instance Bitraversable1 p => Bitraversable1 (WrappedBifunctor p) where - bitraverse1 f g = fmap WrapBifunctor . bitraverse1 f g . unwrapBifunctor - {-# INLINE bitraverse1 #-} - - -class (Foldable1 t, Traversable t) => Traversable1 t where - traverse1 :: Apply f => (a -> f b) -> t a -> f (t b) - sequence1 :: Apply f => t (f b) -> f (t b) - - sequence1 = traverse1 id - traverse1 f = sequence1 . fmap f - - {-# MINIMAL traverse1 | sequence1 #-} - -instance Traversable1 f => Traversable1 (Rec1 f) where - traverse1 f (Rec1 as) = Rec1 <$> traverse1 f as - -instance Traversable1 f => Traversable1 (M1 i c f) where - traverse1 f (M1 as) = M1 <$> traverse1 f as - -instance Traversable1 Par1 where - traverse1 f (Par1 a) = Par1 <$> f a - -instance Traversable1 V1 where - traverse1 _ v = v `seq` undefined - -instance (Traversable1 f, Traversable1 g) => Traversable1 (f :*: g) where - traverse1 f (as :*: bs) = (:*:) <$> traverse1 f as <.> traverse1 f bs - -instance (Traversable1 f, Traversable1 g) => Traversable1 (f :+: g) where - traverse1 f (L1 as) = L1 <$> traverse1 f as - traverse1 f (R1 bs) = R1 <$> traverse1 f bs - -instance (Traversable1 f, Traversable1 g) => Traversable1 (f :.: g) where - traverse1 f (Comp1 m) = Comp1 <$> traverse1 (traverse1 f) m - -instance Traversable1 Identity where - traverse1 f = fmap Identity . f . runIdentity - -instance (Traversable1 f, Traversable1 g) => Traversable1 (Functor.Product f g) where - traverse1 f (Functor.Pair a b) = Functor.Pair <$> traverse1 f a <.> traverse1 f b - -instance (Traversable1 f, Traversable1 g) => Traversable1 (Functor.Sum f g) where - traverse1 f (Functor.InL x) = Functor.InL <$> traverse1 f x - traverse1 f (Functor.InR y) = Functor.InR <$> traverse1 f y - -instance (Traversable1 f, Traversable1 g) => Traversable1 (Compose f g) where - traverse1 f = fmap Compose . traverse1 (traverse1 f) . getCompose - -#if HAS_FOLDABLE1_TRANSFORMERS -instance Traversable1 f => Traversable1 (IdentityT f) where - traverse1 f = fmap IdentityT . traverse1 f . runIdentityT - -instance Traversable1 f => Traversable1 (Backwards f) where - traverse1 f = fmap Backwards . traverse1 f . forwards - -instance Traversable1 f => Traversable1 (Lift f) where - traverse1 f (Pure x) = Pure <$> f x - traverse1 f (Other y) = Other <$> traverse1 f y - -instance Traversable1 f => Traversable1 (Reverse f) where - traverse1 f = fmap Reverse . forwards . traverse1 (Backwards . f) . getReverse -#endif - -instance Traversable1 Complex where - traverse1 f (a :+ b) = (:+) <$> f a <.> f b - {-# INLINE traverse1 #-} - -#ifdef MIN_VERSION_tagged -instance Traversable1 (Tagged a) where - traverse1 f (Tagged a) = Tagged <$> f a -#endif - -#if HAS_FOLDABLE1_CONTAINERS -instance Traversable1 Tree where - traverse1 f (Node a []) = (`Node`[]) <$> f a - traverse1 f (Node a (x:xs)) = (\b (y:|ys) -> Node b (y:ys)) <$> f a <.> traverse1 (traverse1 f) (x :| xs) -#endif - -instance Traversable1 NonEmpty where - traverse1 f (a :| as) = foldr (\b g x -> (\a' (b':| bs') -> a' :| b': bs') <$> f x <.> g b) (fmap (:|[]) . f) as a - -instance Traversable1 ((,) a) where - traverse1 f (a, b) = (,) a <$> f b - -instance Traversable1 g => Traversable1 (Joker g a) where - traverse1 g = fmap Joker . traverse1 g . runJoker - {-# INLINE traverse1 #-} - -instance Traversable1 Monoid.Sum where - traverse1 g (Monoid.Sum a) = Monoid.Sum <$> g a - -instance Traversable1 Monoid.Product where - traverse1 g (Monoid.Product a) = Monoid.Product <$> g a - -instance Traversable1 Monoid.Dual where - traverse1 g (Monoid.Dual a) = Monoid.Dual <$> g a - -instance Traversable1 f => Traversable1 (Monoid.Alt f) where - traverse1 g (Monoid.Alt m) = Monoid.Alt <$> traverse1 g m - -instance Traversable1 Semigroup.First where - traverse1 g (Semigroup.First a) = Semigroup.First <$> g a - -instance Traversable1 Semigroup.Last where - traverse1 g (Semigroup.Last a) = Semigroup.Last <$> g a - -instance Traversable1 Semigroup.Min where - traverse1 g (Semigroup.Min a) = Semigroup.Min <$> g a - -instance Traversable1 Semigroup.Max where - traverse1 g (Semigroup.Max a) = Semigroup.Max <$> g a +{-# LANGUAGE CPP, TypeOperators #-} +{-# LANGUAGE Trustworthy #-} + + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- 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 diff --git a/src/Data/Semigroupoid.hs b/src/Data/Semigroupoid.hs --- a/src/Data/Semigroupoid.hs +++ b/src/Data/Semigroupoid.hs @@ -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 --- 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 = (.) - --- | -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 +-- 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 = (.) + +-- | +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 diff --git a/src/Data/Semigroupoid/Categorical.hs b/src/Data/Semigroupoid/Categorical.hs --- a/src/Data/Semigroupoid/Categorical.hs +++ b/src/Data/Semigroupoid/Categorical.hs @@ -1,48 +1,48 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2021 Koz Ross --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Koz Ross --- Stability : Experimental --- Portability : GHC only --- --- Provides a way to attach an identity to any semigroupoid. ----------------------------------------------------------------------------- -module Data.Semigroupoid.Categorical ( - Categorical(..), - runCategorical - ) where - -import Control.Category (Category (id, (.))) -import Data.Semigroupoid (Semigroupoid (o)) -import Prelude () - --- | Attaches an identity. --- --- @since 5.3.6 -data Categorical s a b where - Id :: Categorical s a a - Embed :: s a b -> Categorical s a b - --- | @since 5.3.6 -instance (Semigroupoid s) => Semigroupoid (Categorical s) where - Id `o` y = y - x `o` Id = x - Embed x `o` Embed y = Embed (x `o` y) - --- | @since 5.3.6 -instance (Semigroupoid s) => Category (Categorical s) where - id = Id - (.) = o - --- | @since 5.3.6 -runCategorical :: (a ~ b => r) -> (s a b -> r) -> Categorical s a b -> r -runCategorical r _ Id = r -runCategorical _ f (Embed x) = f x +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2021 Koz Ross +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Koz Ross +-- 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 diff --git a/src/Data/Semigroupoid/Dual.hs b/src/Data/Semigroupoid/Dual.hs --- a/src/Data/Semigroupoid/Dual.hs +++ b/src/Data/Semigroupoid/Dual.hs @@ -1,28 +1,28 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE Safe #-} ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2007-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- 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 +-- 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) diff --git a/src/Data/Semigroupoid/Ob.hs b/src/Data/Semigroupoid/Ob.hs --- a/src/Data/Semigroupoid/Ob.hs +++ b/src/Data/Semigroupoid/Ob.hs @@ -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 --- 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 +-- 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 diff --git a/src/Data/Semigroupoid/Static.hs b/src/Data/Semigroupoid/Static.hs --- a/src/Data/Semigroupoid/Static.hs +++ b/src/Data/Semigroupoid/Static.hs @@ -1,87 +1,87 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2011-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- 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 +-- 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) + diff --git a/src/Data/Traversable/Instances.hs b/src/Data/Traversable/Instances.hs --- a/src/Data/Traversable/Instances.hs +++ b/src/Data/Traversable/Instances.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE Safe #-} ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2011-2015,2018 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- 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 +-- 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 () diff --git a/src/Semigroupoids/Do.hs b/src/Semigroupoids/Do.hs --- a/src/Semigroupoids/Do.hs +++ b/src/Semigroupoids/Do.hs @@ -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 diff --git a/src/Semigroupoids/Internal.hs b/src/Semigroupoids/Internal.hs --- a/src/Semigroupoids/Internal.hs +++ b/src/Semigroupoids/Internal.hs @@ -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