diff --git a/.ghci b/.ghci deleted file mode 100644 --- a/.ghci +++ /dev/null @@ -1,1 +0,0 @@ -:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ +.ghc.environment.* dist docs wiki @@ -11,3 +12,19 @@ *.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/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -1,8 +0,0 @@ -language: haskell -notifications: - irc: - channels: - - "irc.freenode.org#haskell-lens" - skip_join: true - template: - - "\x0313semigroupoids\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -0,0 +1,292 @@ +6.0.2 [2026.01.10] +------------------ +* Add `Apply` and `Bind` instances for strict and lazy `ST`. +* Remove unused `distributive` dependency. + +6.0.1 [2024.05.04] +------------------ +* Fix a build error when compiling with `-f-contravariant`. + +6.0.0.1 [2023.03.16] +-------------------- +* When building with GHC 9.6, require `transformers >= 0.6.1` and + `containers >= 0.6.7`. This ensures that `semigroupoids` always provides + `Traversable1` instances for data types from `transformers` and `containers` + unconditionally. + +6 [2023.03.12] +-------------- +* Drop support for GHC 7.10 and earlier. +* The `Foldable1` and `Bifoldable1` classes have been migrated: + * When building with `base-4.18` or later, `semigroupoids` re-exports + `Foldable1` and `Bifoldable1` from `base`. (These classes were added to + `base-4.18` as a result of + [this Core Libraries proposal](haskell/core-libraries-committee#9).) + * When building with older versions of `base`, `semigroupoids` re-exports + `Foldable1` and `Bifoldable1` from the + [`foldable1-classes-compat`](https://github.com/haskell-compat/foldable1-classes-compat) + compatibility package. + + Note that the version of `Foldable1` that `semigroupoids` defined in previous + releases only had three class methods: `fold1`, `foldMap1`, and `toNonEmpty`. + Moreover, `foldMap1` had a default implementation in terms of a `Foldable` + constraint. `base`'s version of `Foldable1`, however, has some notable + differences: + + 1. It has many more methods than the three listed above, such as the + `foldrMap1` method. + 2. `foldMap1` now has a default implementation in terms of `foldrMap1` instead + of in terms of a `Foldable` constraint. + + To avoid (1) causing issues when upgrading to `semigroupoids-6`, + `Data.Semigroup.Foldable` only re-exports the `fold1`, `foldMap1`, and + `toNonEmpty` methods, which reflects the API in previous `semigroupoids` + releases. If you want to use the other, new class methods of `Foldable1`, + consider importing it from `Data.Foldable1` (its home in `base`) instead. + + Difference (2) is trickier, because it is possible that existing code that + defines valid `Foldable1` instances will need to be migrated. If you have an + instance like this: + + ```hs + import Data.Semigroup.Foldable + + data T a = MkT a + + instance Foldable T where + foldMap f (MkT x) = f x + + instance Foldable1 T -- Relying on Foldable-based defaults + ``` + + Then calling `foldMap1` on `T` will throw an error with `semigroupoids-6`, as + `foldMap1`'s default implementation no longer uses `Foldable`. To migrate this + code, change the instance to explicitly define `foldMap1`: + + ```hs + instance Foldable1 T where + foldMap1 f (MkT x) = f x + ``` + + This approach should be backwards-compatible with previous `semigroupoids` + releases. + + Some other side effects of this migration include: + + * The `Data.Semigroup.Foldable.Class` module has been deprecated. It no + longer serves a useful role, as it simply re-exports a limited subset of + the `Data.Foldable1` and `Data.Bifoldable1` API. + * All of the `Foldable1` and `Bifoldable1` instances that were previously + defined in `semigroupoids` have now been migrated to downstream libraries + (`base`, `bifunctors`, `containers`, `tagged`, and `transformers`), so it + is no longer strictly necessary to depend on `semigroupoids` to make use of + these instances. +* Add `Generic1`-based functions for many classes, useful for writing instances: + - `Data.Functor.Alt.()` -> `Data.Functor.Alt.galt` + - `Data.Functor.Apply.{liftF2,liftF3}` -> `Data.Functor.Apply.{gliftF2,gliftF3}` + - `Data.Functor.Bind.(>>-)` -> `Data.Functor.Bind.gbind` + - `Data.Functor.Contravariant.Conclude.{conclude,concluded}` -> `Data.Functor.Contravariant.Conclude.{gconclude,gconcluded}` + - `Data.Functor.Contravariant.Decide.{decide,decided}` -> `Data.Functor.Contravariant.Decide.{gdecide,gdecided}` + - `Data.Functor.Contravariant.Divise.{divise,divised}` -> `Data.Functor.Contravariant.Divise.{gdivise,gdivised}` + - `Data.Functor.Extend.{duplicated,extended}` -> `Data.Functor.Extend.{gduplicated,gextended}` + - `Data.Functor.Plus.zero` -> `Data.Functor.Plus.gzero` + - `Data.Semigroup.Foldable.{fold1,foldMap1,toNonEmpty}` -> `Data.Semigroup.Foldable.{gfold1,gfoldMap1,gtoNonEmpty}` + - `Data.Semigroup.Traversable.{traverse1,sequence1}` -> `Data.Semigroup.Traversable.{gtraverse1,gsequence1}` + +5.3.7 [2022.01.09] +------------------ +* Relax the `Bind` constraints in the following instances to `Functor`: + + ```diff + -instance (Bind f, Monad f) => Alt (MaybeT f) + -instance (Bind f, Monad f) => Plus (MaybeT f) + +instance (Functor f, Monad f) => Alt (MaybeT f) + +instance (Functor f, Monad f) => Plus (MaybeT f) + + -instance (Bind f, Monad f, Semigroup e) => Alt (ExceptT e f) + -instance (Bind f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f) + +instance (Functor f, Monad f, Semigroup e) => Alt (ExceptT e f) + +instance (Functor f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f) + + -- If building with transformers-0.5.* or older + -instance (Bind f, Monad f) => Alt (ErrorT e f) + -instance (Bind f, Monad f, Error e) => Plus (ErrorT e f + +instance (Functor f, Monad f) => Alt (ErrorT e f) + +instance (Functor f, Monad f, Error e) => Plus (ErrorT e f) + ``` + +5.3.6 [2021.10.07] +------------------ +* Allow building with GHC 9.2. +* Allow building with `transformers-0.6.*`. +* Add `Alt` instance for `Identity`. +* Add `Conclude`, `Decide` and `Divise` type classes and instances. +* Add `(<.*>)`, `(<*.>)`, and `traverseMaybe` functions, which make it easier + to defined `Traversable1` instances for data types that have fields with a + combination of `Traversable` and `Traversable1` instances. +* Add `Semigroupoids.Do` module with overloads for use with `QualifiedDo`. +* Add `Apply`, `Alt`, `Plus`, `Bind` and `BindTrans` instances for the CPS + versions of `WriterT` and `RWST`. +* Add `psum` function to `Data.Functor.Plus`. +* Add `Categorical` data type. + +5.3.5 [2020.12.31] +------------------ +* The build-type has been changed from `Custom` to `Simple`. + To achieve this, the `doctests` test suite has been removed in favor of using + [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) + to run the doctests. +* Explicitly mark modules as `Safe`. + +5.3.4 [2019.11.26] +------------------ +* Achieve forward compatibility with + [GHC proposal 229](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst). + +5.3.3 [2019.08.27] +------------------ +* Add `Alt` and `Plus` instances for `HashMap` from the `unordered-containers` + package. + +5.3.2 [2019.01.04] +------------------ +* Bump the lower bound on `semigroups` to 0.16.2, and avoid incurring + the dependency entirely on recent GHCs. +* Fix the build on GHC 7.0 and 7.2. + +5.3.1 [2018.07.02] +------------------ +* Fix a regression introduced in `semigroupoids-5.3` in which some modules + regressed from `Trustworthy` to `Unsafe`. + +5.3 [2018.07.02] +---------------- +* Allow building with `containers-0.6`. +* Add `Alt` instances for `First` and `Last` from `Data.Semigroup`, and + `Alt` and `Plus` instances for `First` and `Last` from `Data.Monoid`. +* Add missing `Apply`, `Bind`, `Extend`, `Foldable1` and `Traversable1` + instances for `Data.Semigroups`, `Data.Monoid` and `GHC.Generics`. + +5.2.2 [2018.01.18] +------------------ +* Add `optional` to `Data.Functor.Alt` (analogous to the `optional` function + in `Control.Applicative`) +* `liftF2` is now a class method of `Apply` (mirroring the fact that `liftA2` + is now a class method of `Applicative`). `liftF2` and `(<.>)` have default + definitions in terms of the other. +* Allow building with GHC 8.4 +* `Apply` and `Bind` instances for `Q`, from the `template-haskell` package. + (As a consequence, `Data.Semigroup.Foldable` is no longer a `Trustworthy` + module.) +* Add instances for `(:~:)` and `(:~~:)` from `Data.Type.Equality`, and + `Coercion` from `Data.Type.Coercion` + +5.2.1 +----- +* Add the `toNonEmpty` method to `Foldable1`. Add `foldrM1` and `foldlM1` + functions to `Data.Semigroup.Foldable` that are defined in terms of `toNonEmpty`. +* Add `Apply`, `Bind`, `Foldable1`, and `Traversable1` instances for `Complex` +* Add `Apply` and `Bind` instances for `HashMap` from the `unordered-containers` package + (on which `semigroupoids` now depends) +* Add `Semigroupoid` instances for `Tagged` and `Const` + +5.2 +--- +* Revamp `Setup.hs` to use `cabal-doctest`. This makes it build + with `Cabal-1.25`, and makes the `doctest`s work with `cabal new-build` and + sandboxes. +* Added instances to `Alt`, `Plus`, `Apply`, `Bind` and `Extend` for `GHC.Generics`, `Tagged` and `Proxy` where appropriate. + +5.1 +--- +* The remaining orphan instances in `Data.Traversable.Instances` have been replaced in favor of the orphan instances from `transformers-compat-0.5`. +* The documentation now states laws that instances of `Apply` are expected to uphold. +* `doctest-0.11` support +* Fixed compilation of tests with `stack` + +5.0.1 +------- +* `transformers-compat` 0.5 support +* Removed some redundant constraints. +* GHC 8 support + +5.0.0.4 +------- +* `doctest` 0.10 support + +5.0.0.2 +------- +* Bugfix for GHC 7.4. PolyKinds on 7.4 cause all sorts of haskell interface file errors. One of the #if guards that turned it off on 7.4 was missing and has been fixed. + +5.0.0.1 +------- +* Added the CHANGELOG to the distribution so that `hackage` can link to it in the haddocks. + +5 +- +* Absorbed `Data.Bifunctor.Apply`, `Data.Semigroup.Bifoldable` and `Data.Semigroup.Traversable` from `bifunctors`. +* This caused us to pick up a dependency on `tagged`. +* Exiled `Data.Semifunctor.*`, `Data.Semigroupoid.Product` and `Data.Semigroupoid.Coproduct` to `semigroupoid-extras`. +* This let us open up to older versions of GHC again. +* Set an explicit fixity for `-<-` and `->-`. + +4.5 +--- +* Major changes to the API to support PolyKinds and DataKinds. This necessarily shuts off GHC <= 7.4. +* Orphan instances have moved upstream into a common `base-orphans` package. + +4.3.1 +----- +* Added `asum1` to `Data.Semigroup.Foldable`. + +4.3.0.1 +------- +* Support for 'ConstrainedClassMethods' is currently required for GHC HEAD. + +4.3 +----- +* Added missing instances for `ExceptT`. Obtain it via `transformers-compat` if need be for old `transformers` versions. +* Several `Bind` and `Apply` instances now require somewhat more minimal contexts. + +4.2 +--- +* Backported `Foldable`/`Traversable` instances from `lens` + +4.1 +--- +* `Foldable1`/`Traversable1` for tuples + +4.0.4 +----- +* `contravariant` 1.0 support. + +4.0.3 +--- +* Added flags to provide unsupported cabal sandbox build modes. + +4.0.1 +----- +* Fixed bitrot in the `Data.Functor.Extend` documentation. +* Fixed warnings on GHC 7.8.1rc2 caused by importing `Control.Monad.Instances`. + +4.0 +--- +* Merged in the contents of the `groupoids` and `semigroupoid-extras` packages. + +3.1 +--- +* Added the [rectangular band](http://en.wikipedia.org/wiki/Band_(mathematics)#Rectangular_bands) `Semigroupoid` for `(,)`. Would that make it a Bandoid? + +3.0.3 +----- +* Claim to be `Trustworthy` where necessary + +3.0.2 +----- +* Tightened the upper bounds slightly to enable PVP compliance while retaining a flexible development cycle. +* Raised the upper bound on `contravariant`. + +3.0.1 +----- +* Removed upper bounds relative to my other packages +* Refactored directory layout diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright 2011 Edward Kmett +Copyright 2011-2015 Edward Kmett All rights reserved. @@ -12,10 +12,6 @@ 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +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 diff --git a/img/classes.dot b/img/classes.dot new file mode 100644 --- /dev/null +++ b/img/classes.dot @@ -0,0 +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; +} diff --git a/img/classes.svg b/img/classes.svg new file mode 100644 --- /dev/null +++ b/img/classes.svg @@ -0,0 +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 + + + + + diff --git a/semigroupoids.cabal b/semigroupoids.cabal --- a/semigroupoids.cabal +++ b/semigroupoids.cabal @@ -1,44 +1,61 @@ +cabal-version: 1.24 name: semigroupoids category: Control, Comonads -version: 3.1 -license: BSD3 -cabal-version: >= 1.6 +version: 6.0.2 +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 Edward A. Kmett +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.8 + , GHC == 9.4.8 + , GHC == 9.6.7 + , GHC == 9.8.4 + , GHC == 9.10.3 + , GHC == 9.12.2 + , GHC == 9.14.1 build-type: Simple -synopsis: Haskell 98 semigroupoids: Category sans id +synopsis: Semigroupoids: Category sans id extra-source-files: - .ghci - .travis.yml .gitignore .vim.custom + README.markdown + CHANGELOG.markdown + img/classes.dot +extra-doc-files: + img/classes.svg + description: - Provides a wide array of semigroupoids and operations for working with semigroupds. + 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 '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. . - . - Ideally the following relationships would hold: + 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. . - > Traversable <---- Foldable <--- Functor ------> Alt ---------> Plus Semigroupoid - > | | | | | - > v v v v v - > Traversable1 <--- Foldable1 Apply --------> Applicative -> Alternative Category - > | | | | - > v v v v - > Bind ---------> Monad -------> MonadPlus Arrow - > + <> . Apply, Bind, and Extend (not shown) give rise the Static, Kleisli and Cokleisli semigroupoids respectively. . @@ -51,31 +68,129 @@ source-repository head type: git - location: git://github.com/ekmett/semigroupoids.git + location: https://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 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 && < 5, - transformers >= 0.2 && < 0.4, - containers >= 0.3 && < 0.6, - contravariant >= 0.2.0.1 && < 1, - comonad == 3.* && < 4, - semigroups >= 0.8.3.1 && < 1 + 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.9 + + if flag(contravariant) + build-depends: contravariant >= 1.5.3 && < 2 + + 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.6, + 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.Plus 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 + if impl(ghc >= 8.6) || flag(contravariant) + exposed-modules: + Data.Functor.Contravariant.Conclude + Data.Functor.Contravariant.Decide + Data.Functor.Contravariant.Divise + + ghc-options: -Wall -Wno-warnings-deprecations -Wno-trustworthy-safe + + if impl(ghc >= 9.0) + -- these flags may abort compilation with GHC-8.10 + -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295 + ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode + + default-language: Haskell2010 diff --git a/src/Data/Bifunctor/Apply.hs b/src/Data/Bifunctor/Apply.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bifunctor/Apply.hs @@ -0,0 +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 #-} 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,11 +1,15 @@ {-# LANGUAGE CPP #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# options_ghc -Wno-deprecations #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Alt --- Copyright : (C) 2011 Edward Kmett, +-- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -15,18 +19,26 @@ ---------------------------------------------------------------------------- module Data.Functor.Alt ( Alt(..) + , optional + , galt , module Data.Functor.Apply ) where -import Control.Applicative hiding (some, many) +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.Error -import Control.Monad.Trans.List +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 @@ -34,16 +46,44 @@ 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.Bind +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.Semigroup -import Data.List.NonEmpty (NonEmpty(..)) import Data.Sequence (Seq) import qualified Data.Map as Map import Data.Map (Map) -import Prelude (($),Either(..),Maybe(..),const,IO,Ord,(++)) +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: @@ -53,18 +93,20 @@ -- -- If extended to an 'Alternative' then '' should equal '<|>'. -- --- Ideally, an instance of 'Alt' also satisfies the \"left distributon\" law of --- MonadPlus with respect to <.>: +-- 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) -- --- But 'Maybe', 'IO', @'Either' a@, @'ErrorT' e m@, and 'STM' satisfy the alternative --- \"left catch\" law instead: +-- 'IO', @'Either' a@, @'ExceptT' e m@ and 'GHC.Conc.STM' instead satisfy the +-- \"left catch\" law: -- -- > pure a b = pure a -- --- However, this variation cannot be stated purely in terms of the dependencies of 'Alt'. +-- '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. -- @@ -75,7 +117,7 @@ -- > (m n) >>= f = (m >>= f) (m >>= f) class Functor f => Alt f where - -- | @(<|>)@ without a required @empty@ + -- | '<|>' without a required @empty@ () :: f a -> f a -> f a some :: Applicative f => f a -> f [a] @@ -88,18 +130,78 @@ 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 +-- | 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 () = (++) @@ -107,8 +209,10 @@ Nothing b = b a _ = a +#if !(MIN_VERSION_base(4,16,0)) instance Alt Option where () = (<|>) +#endif instance MonadPlus m => Alt (WrappedMonad m) where () = (<|>) @@ -116,6 +220,7 @@ instance ArrowPlus a => Alt (WrappedArrow a b) where () = (<|>) +#ifdef MIN_VERSION_containers instance Ord k => Alt (Map k) where () = Map.union @@ -124,7 +229,13 @@ 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) @@ -137,14 +248,15 @@ instance Alt f => Alt (ReaderT e f) where ReaderT a ReaderT b = ReaderT $ \e -> a e b e -instance (Bind f, Monad f) => Alt (MaybeT f) where +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 -instance (Bind f, Monad f) => Alt (ErrorT e f) where +#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 @@ -153,7 +265,16 @@ 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 @@ -166,8 +287,49 @@ 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,11 +1,8 @@ -{-# LANGUAGE CPP #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | --- Module : Data.Functor.Apply --- Copyright : (C) 2011 Edward Kmett, +-- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -13,22 +10,55 @@ -- Portability : portable -- ---------------------------------------------------------------------------- -module Data.Functor.Apply ( +module Data.Functor.Apply ( -- * Functors Functor(..) , (<$>) -- :: Functor f => (a -> b) -> f a -> f b - , ( $>) -- :: Functor f => f a -> b -> 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 - , liftF2 -- :: Apply w => (a -> b -> c) -> w a -> w b -> w c , liftF3 -- :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d + , gliftF2 + , gliftF3 -- * Wrappers , WrappedApplicative(..) , MaybeApply(..) + , (<.*>) + , (<*.>) ) where -import Data.Functor.Bind +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,29 +1,14 @@ -{-# LANGUAGE CPP #-} -#ifndef MIN_VERSION_comonad -#define MIN_VERSION_comonad(x,y,z) 1 -#endif - -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 -#if __GLASGOW_HASKELL__ >= 707 && (MIN_VERSION_comonad(3,0,3)) -{-# LANGUAGE Safe #-} -#else +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Trustworthy #-} -#endif -#endif -{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | --- Module : Data.Functor.Bind --- Copyright : (C) 2011 Edward Kmett, +-- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- --- NB: The definitions exported through "Data.Functor.Apply" need to be --- included here because otherwise the instances for the transformers package --- have orphaned heads. ---------------------------------------------------------------------------- module Data.Functor.Bind ( -- * Functors @@ -33,13 +18,13 @@ -- * Applyable functors , Apply(..) , (<..>) -- :: Apply w => w a -> w (a -> b) -> w b - , liftF2 -- :: Apply w => (a -> b -> c) -> w a -> w b -> w c , liftF3 -- :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d -- * Wrappers , WrappedApplicative(..) , MaybeApply(..) -- * Bindable functors , Bind(..) + , gbind , (-<<) , (-<-) , (->-) @@ -47,306 +32,22 @@ , returning ) where --- import _everything_ -import Control.Applicative -import Control.Arrow -import Control.Category -import Control.Comonad -import Control.Monad (ap) -import Control.Monad.Instances -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 -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.Compose -import Data.Functor.Identity -import Data.Functor.Product -import Data.Functor.Extend -import qualified Data.IntMap as IntMap -import Data.IntMap (IntMap) -import qualified Data.Map as Map -import Data.Map (Map) -import Data.List.NonEmpty -import Data.Semigroup hiding (Product) -import Data.Sequence (Seq) -import Data.Tree (Tree) -import Prelude hiding (id, (.)) - -infixl 1 >>- -infixr 1 -<< -infixl 4 <.>, <., .>, <..> - --- | A strong lax semi-monoidal endofunctor. --- This is equivalent to an 'Applicative' without 'pure'. --- --- Laws: --- --- > associative composition: (.) <$> u <.> v <.> w = u <.> (v <.> w) -class Functor f => Apply f where - (<.>) :: f (a -> b) -> f a -> f b - - -- | > 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 - -instance (Apply f, Apply g) => Apply (Compose f g) where - Compose f <.> Compose x = Compose ((<.>) <$> f <.> x) - -instance (Apply f, Apply g) => Apply (Product f g) where - Pair f g <.> Pair x y = Pair (f <.> x) (g <.> y) - -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 - -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 - (<.>) = (<*>) - (<. ) = (<* ) - ( .>) = ( *>) - -instance Apply Option where - (<.>) = (<*>) - (<. ) = (<* ) - ( .>) = ( *>) - -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 - (<.>) = (<*>) - (<. ) = (<* ) - ( .>) = ( *>) - --- | A Map 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 - (<.>) = (<*>) - (<. ) = (<* ) - ( .>) = ( *>) - --- MaybeT is _not_ the same as Compose f Maybe -instance (Bind m, Monad m) => Apply (MaybeT m) where - (<.>) = apDefault - --- ErrorT e is _not_ the same as Compose f (Either e) -instance (Bind m, Monad m) => Apply (ErrorT e m) where - (<.>) = apDefault - -instance Apply m => Apply (ReaderT e m) where - ReaderT f <.> ReaderT a = ReaderT $ \e -> f e <.> a e - -instance Apply m => Apply (ListT m) where - ListT f <.> ListT a = ListT $ (<.>) <$> f <.> a - --- unfortunately, WriterT has its wrapped product in the wrong order to just use (<.>) instead of flap -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) - -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) - -instance Bind m => Apply (Strict.StateT s m) where - (<.>) = apDefault - -instance Bind m => Apply (Lazy.StateT s m) where - (<.>) = apDefault - -instance (Bind m, Semigroup w) => Apply (Strict.RWST r w s m) where - (<.>) = apDefault - -instance (Bind m, Semigroup w) => Apply (Lazy.RWST r w s m) where - (<.>) = apDefault - -instance Apply (ContT r m) where - ContT f <.> ContT v = ContT $ \k -> f $ \g -> v (k . g) - --- | 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 a Apply into an Applicative by adding a unit. -newtype MaybeApply f a = MaybeApply { runMaybeApply :: Either (f a) a } - -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) - (<*>) = (<.>) - (<* ) = (<. ) - ( *>) = ( .>) - --- | A variant of '<.>' with the arguments reversed. -(<..>) :: Apply w => w a -> w (a -> b) -> w b -(<..>) = liftF2 (flip id) -{-# INLINE (<..>) #-} - --- | Lift a binary function into a comonad with zipping -liftF2 :: Apply w => (a -> b -> c) -> w a -> w b -> w c -liftF2 f a b = f <$> a <.> b -{-# INLINE liftF2 #-} - --- | 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 #-} - -instance Extend f => Extend (MaybeApply f) where - duplicated w@(MaybeApply Right{}) = MaybeApply (Right w) - duplicated (MaybeApply (Left fa)) = MaybeApply (Left (extended (MaybeApply . Left) fa)) - -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)) +import Data.Functor.Apply +import Data.Functor.Bind.Class +import GHC.Generics --- | 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 +-- | Generic '(>>-)'. Caveats: -- --- > associativity of (->-): (f ->- g) ->- h = f ->- (g ->- h) +-- 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 (':*:') -- - -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) +-- @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) -returning :: Functor f => f a -> (a -> b) -> f b -returning = flip fmap +infixr 1 -<<, -<-, ->- (-<<) :: Bind m => (a -> m b) -> m a -> m b (-<<) = flip (>>-) @@ -356,117 +57,3 @@ (-<-) :: Bind m => (b -> m c) -> (a -> m b) -> a -> m c g -<- f = \a -> f a >>- g - -apDefault :: Bind f => f (a -> b) -> f a -> f b -apDefault f x = f >>- \f' -> f' <$> x - -instance Semigroup m => Bind ((,)m) where - ~(m, a) >>- f = let (n, b) = f a in (m <> n, b) - -instance Bind (Either a) where - Left a >>- _ = Left a - Right a >>- f = f a - -instance (Bind f, Bind g) => Bind (Product f g) where - Pair m n >>- f = Pair (m >>- fstP . f) (n >>- sndP . f) where - fstP (Pair a _) = a - sndP (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 - (>>-) = (>>=) - -instance Bind Option where - (>>-) = (>>=) - -instance Bind Identity 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 (Bind m, Monad m) => Bind (MaybeT m) where - (>>-) = (>>=) -- distributive law requires Monad to inject @Nothing@ - -instance (Bind m, Monad m) => Bind (ListT m) where - (>>-) = (>>=) -- distributive law requires Monad to inject @[]@ - -instance (Bind 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) - -instance Bind m => Bind (ReaderT e m) where - ReaderT m >>- f = ReaderT $ \e -> m e >>- \x -> runReaderT (f x) e - -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') - -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') - -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' - -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') - -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') - -instance Bind (ContT r m) where - m >>- k = ContT $ \c -> runContT m $ \a -> runContT (k a) c - -{- -instance ArrowApply a => Bind (WrappedArrow a b) where - (>>-) = (>>=) --} - --- | A 'Map' 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 - (>>-) = (>>=) diff --git a/src/Data/Functor/Bind/Class.hs b/src/Data/Functor/Bind/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Bind/Class.hs @@ -0,0 +1,856 @@ +{-# 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.ST +import qualified Control.Monad.ST.Lazy as Lazy +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) + +instance Apply (ST s) where + (<.>) = (<*>) + (<.) = (<*) + (.>) = (*>) + +instance Apply (Lazy.ST s) where + (<.>) = (<*>) + (<.) = (<*) + (.>) = (*>) + + +#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 (ST s) where + (>>-) = (>>=) + +instance Bind (Lazy.ST s) 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,7 +1,9 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Bind.Trans --- Copyright : (C) 2011 Edward Kmett, +-- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -9,13 +11,12 @@ -- Portability : portable -- ---------------------------------------------------------------------------- -module Data.Functor.Bind.Trans ( +module Data.Functor.Bind.Trans ( BindTrans(..) ) where -- import _everything_ import Control.Category -import Control.Monad.Instances import Control.Monad.Trans.Class import Control.Monad.Trans.Cont -- import Control.Monad.Trans.Error @@ -23,6 +24,10 @@ -- 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 @@ -30,7 +35,10 @@ 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. @@ -41,25 +49,37 @@ liftB = IdentityT instance BindTrans (ReaderT e) where - liftB = ReaderT . const + liftB = ReaderT . const -instance (Semigroup w, Monoid w) => BindTrans (Lazy.WriterT w) where +instance Monoid w => BindTrans (Lazy.WriterT w) where liftB = Lazy.WriterT . fmap (\a -> (a, mempty)) -instance (Semigroup w, Monoid w) => BindTrans (Strict.WriterT w) where +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 + 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 + liftB m = Strict.StateT $ \s -> fmap (\a -> (a, s)) m -instance (Semigroup w, Monoid w) => BindTrans (Lazy.RWST r w s) where +instance Monoid w => BindTrans (Lazy.RWST r w s) where liftB m = Lazy.RWST $ \ _r s -> fmap (\a -> (a, s, mempty)) m - -instance (Semigroup w, Monoid w) => BindTrans (Strict.RWST r w s) where + +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 new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Contravariant/Conclude.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Safe #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2021 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +-- This module is only available if building with GHC 8.6 or later, or if the +-- @+contravariant@ @cabal@ build flag is available. +---------------------------------------------------------------------------- +module Data.Functor.Contravariant.Conclude ( + Conclude(..) + , gconclude + , concluded + , gconcluded + ) where + +import Control.Applicative.Backwards +import Control.Monad.Trans.Identity +import qualified Control.Monad.Trans.RWS.Lazy as Lazy +import qualified Control.Monad.Trans.RWS.Strict as Strict +import Control.Monad.Trans.Reader +import qualified Control.Monad.Trans.State.Lazy as Lazy +import qualified Control.Monad.Trans.State.Strict as Strict +import qualified Control.Monad.Trans.Writer.Lazy as Lazy +import qualified Control.Monad.Trans.Writer.Strict as Strict + +import Data.Functor.Apply +import Data.Functor.Compose +import Data.Functor.Contravariant +import Data.Functor.Contravariant.Decide +import Data.Functor.Product +import Data.Functor.Reverse +import Data.Monoid (Alt(..)) +import Data.Proxy +import Data.Void +import GHC.Generics + +#if defined(MIN_VERSION_contravariant) +# if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.List +# endif +import Control.Monad.Trans.Maybe +import Data.Functor.Contravariant.Divise +import Data.Functor.Contravariant.Divisible +#endif + +#ifdef MIN_VERSION_StateVar +import Data.StateVar +#endif + +-- | The contravariant analogue of 'Plus'. Adds on to 'Decide' the ability +-- to express a combinator that rejects all input, to act as the dead-end. +-- Essentially 'Decidable' without a superclass constraint on 'Divisible'. +-- +-- If one thinks of @f a@ as a consumer of @a@s, then 'conclude' defines +-- a consumer that cannot ever receive /any/ input. +-- +-- Conclude acts as an identity with 'decide', because any decision that +-- involves 'conclude' must necessarily /always/ pick the other option. +-- +-- That is, for, say, +-- +-- @ +-- 'decide' f x 'concluded' +-- @ +-- +-- @f@ is the deciding function that picks which of the inputs of @decide@ +-- to direct input to; in the situation above, @f@ must /always/ direct all +-- input to @x@, and never 'concluded'. +-- +-- Mathematically, a functor being an instance of 'Decide' means that it is +-- \"monoidal\" with respect to the contravariant "either-based" Day +-- convolution described in the documentation of 'Decide'. On top of +-- 'Decide', it adds a way to construct an \"identity\" @conclude@ where +-- @decide f x (conclude q) == x@, and @decide g (conclude r) y == y@. +-- +-- @since 5.3.6 +class Decide f => Conclude f where + -- | The consumer that cannot ever receive /any/ input. + conclude :: (a -> Void) -> f a + +-- | Generic 'conclude'. Caveats: +-- +-- 1. Will not compile if @f@ is a sum type. +-- 2. Will not compile if @f@ contains fields that do not mention its type variable. +-- +-- @since 5.3.8 +gconclude :: (Generic1 f, Conclude (Rep1 f)) => (a -> Void) -> f a +gconclude f = to1 $ conclude f + +-- | A potentially more meaningful form of 'conclude', the consumer that cannot +-- ever receive /any/ input. That is because it expects only input of type +-- 'Void', but such a type has no values. +-- +-- @ +-- 'concluded' = 'conclude' 'id' +-- @ +-- +-- @since 5.3.6 +concluded :: Conclude f => f Void +concluded = conclude id + +-- | Generic 'concluded'. Caveats are the same as for 'gconclude'. +-- +-- @since 5.3.8 +gconcluded :: (Generic1 f, Conclude (Rep1 f)) => f Void +gconcluded = to1 concluded + +#if defined(MIN_VERSION_contravariant) +-- | This instance is only available if the @+contravariant@ @cabal@ flag is +-- enabled. +-- +-- @since 5.3.6 +instance Decidable f => Conclude (WrappedDivisible f) where + conclude f = WrapDivisible (lose f) +#endif + +-- | @since 5.3.6 +instance Conclude Comparison where + conclude f = Comparison $ \a _ -> absurd (f a) + +-- | @since 5.3.6 +instance Conclude Equivalence where + conclude f = Equivalence $ absurd . f + +-- | @since 5.3.6 +instance Conclude Predicate where + conclude f = Predicate $ absurd . f + +-- | @since 5.3.6 +instance Conclude (Op r) where + conclude f = Op $ absurd . f + +-- | @since 5.3.6 +instance Conclude Proxy where + conclude _ = Proxy + +#ifdef MIN_VERSION_StateVar +-- | @since 5.3.6 +instance Conclude SettableStateVar where + conclude k = SettableStateVar (absurd . k) +#endif + +-- | @since 5.3.6 +instance Conclude f => Conclude (Alt f) where + conclude = Alt . conclude + +-- | @since 5.3.6 +instance Conclude U1 where + conclude _ = U1 + +-- | @since 5.3.6 +instance Conclude f => Conclude (Rec1 f) where + conclude = Rec1 . conclude + +-- | @since 5.3.6 +instance Conclude f => Conclude (M1 i c f) where + conclude = M1 . conclude + +-- | @since 5.3.6 +instance (Conclude f, Conclude g) => Conclude (f :*: g) where + conclude f = conclude f :*: conclude f + +-- | @since 5.3.6 +instance (Apply f, Applicative f, Conclude g) => Conclude (f :.: g) where + conclude = Comp1 . pure . conclude + +-- | @since 5.3.6 +instance Conclude f => Conclude (Backwards f) where + conclude = Backwards . conclude + +-- | @since 5.3.6 +instance Conclude f => Conclude (IdentityT f) where + conclude = IdentityT . conclude + +-- | @since 5.3.6 +instance Conclude m => Conclude (ReaderT r m) where + conclude f = ReaderT $ \_ -> conclude f + +-- | @since 5.3.6 +instance Conclude m => Conclude (Lazy.RWST r w s m) where + conclude f = Lazy.RWST $ \_ _ -> contramap (\ ~(a, _, _) -> a) (conclude f) + +-- | @since 5.3.6 +instance Conclude m => Conclude (Strict.RWST r w s m) where + conclude f = Strict.RWST $ \_ _ -> contramap (\(a, _, _) -> a) (conclude f) + +#if defined(MIN_VERSION_contravariant) +# if !(MIN_VERSION_transformers(0,6,0)) +-- | This instance is only available if the @+contravariant@ @cabal@ flag is +-- enabled. +-- +-- @since 5.3.6 +instance (Divisible m, Divise m) => Conclude (ListT m) where + conclude _ = ListT conquer +# endif + +-- | This instance is only available if the @+contravariant@ @cabal@ flag is +-- enabled. +-- +-- @since 5.3.6 +instance (Divisible m, Divise m) => Conclude (MaybeT m) where + conclude _ = MaybeT conquer +#endif + +-- | @since 5.3.6 +instance Conclude m => Conclude (Lazy.StateT s m) where + conclude f = Lazy.StateT $ \_ -> contramap lazyFst (conclude f) + +-- | @since 5.3.6 +instance Conclude m => Conclude (Strict.StateT s m) where + conclude f = Strict.StateT $ \_ -> contramap fst (conclude f) + +-- | @since 5.3.6 +instance Conclude m => Conclude (Lazy.WriterT w m) where + conclude f = Lazy.WriterT $ contramap lazyFst (conclude f) + +-- | @since 5.3.6 +instance Conclude m => Conclude (Strict.WriterT w m) where + conclude f = Strict.WriterT $ contramap fst (conclude f) + +-- | @since 5.3.6 +instance (Apply f, Applicative f, Conclude g) => Conclude (Compose f g) where + conclude = Compose . pure . conclude + +-- | @since 5.3.6 +instance (Conclude f, Conclude g) => Conclude (Product f g) where + conclude f = Pair (conclude f) (conclude f) + +-- | @since 5.3.6 +instance Conclude f => Conclude (Reverse f) where + conclude = Reverse . conclude + +-- Helpers + +lazyFst :: (a, b) -> a +lazyFst ~(a, _) = a diff --git a/src/Data/Functor/Contravariant/Decide.hs b/src/Data/Functor/Contravariant/Decide.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Contravariant/Decide.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2021 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +-- This module is only available if building with GHC 8.6 or later, or if the +-- @+contravariant@ @cabal@ build flag is available. +---------------------------------------------------------------------------- +module Data.Functor.Contravariant.Decide ( + Decide(..) + , gdecide + , decided + , gdecided + ) where + +import Control.Applicative.Backwards +import Control.Monad.Trans.Identity +import Control.Monad.Trans.Maybe +import qualified Control.Monad.Trans.RWS.Lazy as Lazy +import qualified Control.Monad.Trans.RWS.Strict as Strict +import Control.Monad.Trans.Reader +import qualified Control.Monad.Trans.State.Lazy as Lazy +import qualified Control.Monad.Trans.State.Strict as Strict +import qualified Control.Monad.Trans.Writer.Lazy as Lazy +import qualified Control.Monad.Trans.Writer.Strict as Strict + +import Data.Functor.Apply +import Data.Functor.Compose +import Data.Functor.Contravariant +import Data.Functor.Contravariant.Divise +import Data.Functor.Product +import Data.Functor.Reverse +import Data.Monoid (Alt(..)) +import Data.Proxy +import GHC.Generics + +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Arrow +import Control.Monad.Trans.List +import Data.Either +#endif + +#if defined(MIN_VERSION_contravariant) +import Data.Functor.Contravariant.Divisible +#endif + +#ifdef MIN_VERSION_StateVar +import Data.StateVar +#endif + +-- | The contravariant analogue of 'Alt'. +-- +-- If one thinks of @f a@ as a consumer of @a@s, then 'decide' allows one +-- to handle the consumption of a value by choosing to handle it via +-- exactly one of two independent consumers. It redirects the input +-- completely into one of two consumers. +-- +-- 'decide' takes the \"decision\" method and the two potential consumers, +-- and returns the wrapped/combined consumer. +-- +-- Mathematically, a functor being an instance of 'Decide' means that it is +-- \"semigroupoidal\" with respect to the contravariant \"either-based\" Day +-- convolution (@data EitherDay f g a = forall b c. EitherDay (f b) (g c) (a -> Either b c)@). +-- That is, it is possible to define a function @(f `EitherDay` f) a -> +-- f a@ in a way that is associative. +-- +-- @since 5.3.6 +class Contravariant f => Decide f where + -- | Takes the \"decision\" method and the two potential consumers, and + -- returns the wrapped/combined consumer. + decide :: (a -> Either b c) -> f b -> f c -> f a + +-- | Generic 'decide'. Caveats: +-- +-- 1. Will not compile if @f@ is a sum type. +-- 2. Will not compile if @f@ contains fields that do not mention its type variable. +-- 3. @-XDeriveGeneric@ is not smart enough to make instances where the type variable appears in negative position. +-- +-- @since 5.3.8 +gdecide :: (Generic1 f, Decide (Rep1 f)) => (a -> Either b c) -> f b -> f c -> f a +gdecide f fb fc = to1 $ decide f (from1 fb) (from1 fc) + +-- | For @'decided' x y@, the resulting @f ('Either' b c)@ will direct +-- 'Left's to be consumed by @x@, and 'Right's to be consumed by y. +-- +-- @since 5.3.6 +decided :: Decide f => f b -> f c -> f (Either b c) +decided = decide id + +-- | Generic 'decided'. Caveats are the same as for 'gdecide'. +-- +-- @since 5.3.8 +gdecided :: (Generic1 f, Decide (Rep1 f)) => f b -> f c -> f (Either b c) +gdecided fb fc = gdecide id fb fc + +#if defined(MIN_VERSION_contravariant) +-- | This instance is only available if the @+contravariant@ @cabal@ flag is +-- enabled. +-- +-- @since 5.3.6 +instance Decidable f => Decide (WrappedDivisible f) where + decide f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (choose f x y) +#endif + +-- | @since 5.3.6 +instance Decide Comparison where + decide f (Comparison g) (Comparison h) = Comparison $ \a b -> case f a of + Left c -> case f b of + Left d -> g c d + Right{} -> LT + Right c -> case f b of + Left{} -> GT + Right d -> h c d + +-- | @since 5.3.6 +instance Decide Equivalence where + decide f (Equivalence g) (Equivalence h) = Equivalence $ \a b -> case f a of + Left c -> case f b of + Left d -> g c d + Right{} -> False + Right c -> case f b of + Left{} -> False + Right d -> h c d + +-- | @since 5.3.6 +instance Decide Predicate where + decide f (Predicate g) (Predicate h) = Predicate $ either g h . f + +-- | Unlike 'Decidable', requires no constraint on @r@. +-- +-- @since 5.3.6 +instance Decide (Op r) where + decide f (Op g) (Op h) = Op $ either g h . f + +-- | @since 5.3.6 +instance Decide f => Decide (Alt f) where + decide f (Alt l) (Alt r) = Alt $ decide f l r + +-- | @since 5.3.6 +instance Decide U1 where + decide _ U1 U1 = U1 + +-- | Has no 'Decidable' or 'Conclude' instance. +-- +-- @since 5.3.6 +instance Decide V1 where decide _ x = case x of {} + +-- | @since 5.3.6 +instance Decide f => Decide (Rec1 f) where + decide f (Rec1 l) (Rec1 r) = Rec1 $ decide f l r + +-- | @since 5.3.6 +instance Decide f => Decide (M1 i c f) where + decide f (M1 l) (M1 r) = M1 $ decide f l r + +-- | @since 5.3.6 +instance (Decide f, Decide g) => Decide (f :*: g) where + decide f (l1 :*: r1) (l2 :*: r2) = decide f l1 l2 :*: decide f r1 r2 + +-- | Unlike 'Decidable', requires only 'Apply' on @f@. +-- +-- @since 5.3.6 +instance (Apply f, Decide g) => Decide (f :.: g) where + decide f (Comp1 l) (Comp1 r) = Comp1 (liftF2 (decide f) l r) + +-- | @since 5.3.6 +instance Decide f => Decide (Backwards f) where + decide f (Backwards l) (Backwards r) = Backwards $ decide f l r + +-- | @since 5.3.6 +instance Decide f => Decide (IdentityT f) where + decide f (IdentityT l) (IdentityT r) = IdentityT $ decide f l r + +-- | @since 5.3.6 +instance Decide m => Decide (ReaderT r m) where + decide abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> decide abc (rmb r) (rmc r) + +-- | @since 5.3.6 +instance Decide m => Decide (Lazy.RWST r w s m) where + decide abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s -> + decide (\ ~(a, s', w) -> either (Left . betuple3 s' w) + (Right . betuple3 s' w) + (abc a)) + (rsmb r s) (rsmc r s) + +-- | @since 5.3.6 +instance Decide m => Decide (Strict.RWST r w s m) where + decide abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s -> + decide (\(a, s', w) -> either (Left . betuple3 s' w) + (Right . betuple3 s' w) + (abc a)) + (rsmb r s) (rsmc r s) + +#if !(MIN_VERSION_transformers(0,6,0)) +-- | @since 5.3.6 +instance Divise m => Decide (ListT m) where + decide f (ListT l) (ListT r) = ListT $ divise ((lefts &&& rights) . map f) l r +#endif + +-- | @since 5.3.6 +instance Divise m => Decide (MaybeT m) where + decide f (MaybeT l) (MaybeT r) = MaybeT $ + divise ( maybe (Nothing, Nothing) + (either (\b -> (Just b, Nothing)) + (\c -> (Nothing, Just c)) . f) + ) l r + +-- | @since 5.3.6 +instance Decide m => Decide (Lazy.StateT s m) where + decide f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s -> + decide (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) + (l s) (r s) + +-- | @since 5.3.6 +instance Decide m => Decide (Strict.StateT s m) where + decide f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s -> + decide (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) + (l s) (r s) + +-- | @since 5.3.6 +instance Decide m => Decide (Lazy.WriterT w m) where + decide f (Lazy.WriterT l) (Lazy.WriterT r) = Lazy.WriterT $ + decide (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r + +-- | @since 5.3.6 +instance Decide m => Decide (Strict.WriterT w m) where + decide f (Strict.WriterT l) (Strict.WriterT r) = Strict.WriterT $ + decide (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r + +-- | Unlike 'Decidable', requires only 'Apply' on @f@. +-- +-- @since 5.3.6 +instance (Apply f, Decide g) => Decide (Compose f g) where + decide f (Compose l) (Compose r) = Compose (liftF2 (decide f) l r) + +-- | @since 5.3.6 +instance (Decide f, Decide g) => Decide (Product f g) where + decide f (Pair l1 r1) (Pair l2 r2) = Pair (decide f l1 l2) (decide f r1 r2) + +-- | @since 5.3.6 +instance Decide f => Decide (Reverse f) where + decide f (Reverse l) (Reverse r) = Reverse $ decide f l r + +betuple :: s -> a -> (a, s) +betuple s a = (a, s) + +betuple3 :: s -> w -> a -> (a, s, w) +betuple3 s w a = (a, s, w) + +-- | @since 5.3.6 +instance Decide Proxy where + decide _ Proxy Proxy = Proxy + +#ifdef MIN_VERSION_StateVar +-- | @since 5.3.6 +instance Decide SettableStateVar where + decide k (SettableStateVar l) (SettableStateVar r) = SettableStateVar $ \ a -> case k a of + Left b -> l b + Right c -> r c +#endif diff --git a/src/Data/Functor/Contravariant/Divise.hs b/src/Data/Functor/Contravariant/Divise.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Contravariant/Divise.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2021 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +-- This module is only available if building with GHC 8.6 or later, or if the +-- @+contravariant@ @cabal@ build flag is available. +---------------------------------------------------------------------------- +module Data.Functor.Contravariant.Divise ( + Divise(..) + , gdivise + , divised + , gdivised + , WrappedDivisible(..) + ) where + +import Control.Applicative +import Control.Applicative.Backwards +import Control.Arrow +import Control.Monad.Trans.Except +import Control.Monad.Trans.Identity +import Control.Monad.Trans.Maybe +import qualified Control.Monad.Trans.RWS.Lazy as Lazy +import qualified Control.Monad.Trans.RWS.Strict as Strict +import Control.Monad.Trans.Reader +import qualified Control.Monad.Trans.State.Lazy as Lazy +import qualified Control.Monad.Trans.State.Strict as Strict +import qualified Control.Monad.Trans.Writer.Lazy as Lazy +import qualified Control.Monad.Trans.Writer.Strict as Strict + +import Data.Functor.Apply +import Data.Functor.Compose +import Data.Functor.Constant +import Data.Functor.Contravariant +import Data.Functor.Product +import Data.Functor.Reverse +import Data.Monoid (Alt(..)) +import Data.Proxy +import GHC.Generics + +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.Error +import Control.Monad.Trans.List +#endif + +#if !MIN_VERSION_base(4,12,0) +import Data.Semigroup (Semigroup(..)) +#endif + +#if defined(MIN_VERSION_contravariant) +import Data.Functor.Contravariant.Divisible +#endif + +#ifdef MIN_VERSION_StateVar +import Data.StateVar +#endif + +-- | The contravariant analogue of 'Apply'; it is +-- 'Divisible' without 'conquer'. +-- +-- If one thinks of @f a@ as a consumer of @a@s, then 'divise' allows one +-- to handle the consumption of a value by splitting it between two +-- consumers that consume separate parts of @a@. +-- +-- 'divise' takes the \"splitting\" method and the two sub-consumers, and +-- returns the wrapped/combined consumer. +-- +-- All instances of 'Divisible' should be instances of 'Divise' with +-- @'divise' = 'divide'@. +-- +-- If a function is polymorphic over @'Divise' f@ (as opposed to @'Divisible' +-- f@), we can provide a stronger guarantee: namely, that any input consumed +-- will be passed to at least one sub-consumer. With @'Divisible' f@, said input +-- could potentially disappear into the void, as this is possible with +-- 'conquer'. +-- +-- Mathematically, a functor being an instance of 'Divise' means that it is +-- \"semigroupoidal\" with respect to the contravariant (tupling) Day +-- convolution. That is, it is possible to define a function @(f `Day` f) +-- a -> f a@ in a way that is associative. +-- +-- @since 5.3.6 +class Contravariant f => Divise f where + -- | Takes a \"splitting\" method and the two sub-consumers, and + -- returns the wrapped/combined consumer. + divise :: (a -> (b, c)) -> f b -> f c -> f a + +-- | Generic 'divise'. Caveats: +-- +-- 1. Will not compile if @f@ is a sum type. +-- 2. Will not compile if @f@ contains fields that do not mention its type variable. +-- 3. @-XDeriveGeneric@ is not smart enough to make instances where the type variable appears in negative position. +-- +-- @since 5.3.8 +gdivise :: (Divise (Rep1 f), Generic1 f) => (a -> (b, c)) -> f b -> f c -> f a +gdivise f x y = to1 $ divise f (from1 x) (from1 y) + +-- | Combine a consumer of @a@ with a consumer of @b@ to get a consumer of +-- @(a, b)@. +-- +-- @ +-- 'divised' = 'divise' 'id' +-- @ +-- +-- @since 5.3.6 +divised :: Divise f => f a -> f b -> f (a, b) +divised = divise id + +-- | Generic 'divised'. Caveats are the same as for 'gdivise'. +-- +-- @since 5.3.8 +gdivised :: (Generic1 f, Divise (Rep1 f)) => f a -> f b -> f (a, b) +gdivised fa fb = gdivise id fa fb + +-- | Wrap a 'Divisible' to be used as a member of 'Divise' +-- +-- @since 5.3.6 +newtype WrappedDivisible f a = WrapDivisible { unwrapDivisible :: f a } + +-- | @since 5.3.6 +instance Contravariant f => Contravariant (WrappedDivisible f) where + contramap f (WrapDivisible a) = WrapDivisible (contramap f a) + +#if defined(MIN_VERSION_contravariant) +-- | This instance is only available if the @+contravariant@ @cabal@ flag is +-- enabled. +-- +-- @since 5.3.6 +instance Divisible f => Divise (WrappedDivisible f) where + divise f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (divide f x y) +#endif + +-- | Unlike 'Divisible', requires only 'Semigroup' on @r@. +-- +-- @since 5.3.6 +instance Semigroup r => Divise (Op r) where + divise f (Op g) (Op h) = Op $ \a -> case f a of + (b, c) -> g b <> h c + +-- | Unlike 'Divisible', requires only 'Semigroup' on @m@. +-- +-- @since 5.3.6 +instance Semigroup m => Divise (Const m) where + divise _ (Const a) (Const b) = Const (a <> b) + +-- | Unlike 'Divisible', requires only 'Semigroup' on @m@. +-- +-- @since 5.3.6 +instance Semigroup m => Divise (Constant m) where + divise _ (Constant a) (Constant b) = Constant (a <> b) + +-- | @since 5.3.6 +instance Divise Comparison where + divise f (Comparison g) (Comparison h) = Comparison $ \a b -> case f a of + (a',a'') -> case f b of + (b',b'') -> g a' b' `mappend` h a'' b'' + +-- | @since 5.3.6 +instance Divise Equivalence where + divise f (Equivalence g) (Equivalence h) = Equivalence $ \a b -> case f a of + (a',a'') -> case f b of + (b',b'') -> g a' b' && h a'' b'' + +-- | @since 5.3.6 +instance Divise Predicate where + divise f (Predicate g) (Predicate h) = Predicate $ \a -> case f a of + (b, c) -> g b && h c + +-- | @since 5.3.6 +instance Divise Proxy where + divise _ Proxy Proxy = Proxy + +#ifdef MIN_VERSION_StateVar +-- | @since 5.3.6 +instance Divise SettableStateVar where + divise k (SettableStateVar l) (SettableStateVar r) = SettableStateVar $ \ a -> case k a of + (b, c) -> l b >> r c +#endif + +-- | @since 5.3.6 +instance Divise f => Divise (Alt f) where + divise f (Alt l) (Alt r) = Alt $ divise f l r + +-- | @since 5.3.6 +instance Divise U1 where + divise _ U1 U1 = U1 + +-- | Has no 'Divisible' instance. +-- +-- @since 5.3.6 +instance Divise V1 where divise _ x = case x of {} + +-- | @since 5.3.6 +instance Divise f => Divise (Rec1 f) where + divise f (Rec1 l) (Rec1 r) = Rec1 $ divise f l r + +-- | @since 5.3.6 +instance Divise f => Divise (M1 i c f) where + divise f (M1 l) (M1 r) = M1 $ divise f l r + +-- | @since 5.3.6 +instance (Divise f, Divise g) => Divise (f :*: g) where + divise f (l1 :*: r1) (l2 :*: r2) = divise f l1 l2 :*: divise f r1 r2 + +-- | Unlike 'Divisible', requires only 'Apply' on @f@. +-- +-- @since 5.3.6 +instance (Apply f, Divise g) => Divise (f :.: g) where + divise f (Comp1 l) (Comp1 r) = Comp1 (liftF2 (divise f) l r) + +-- | @since 5.3.6 +instance Divise f => Divise (Backwards f) where + divise f (Backwards l) (Backwards r) = Backwards $ divise f l r + +#if !(MIN_VERSION_transformers(0,6,0)) +-- | @since 5.3.6 +instance Divise m => Divise (ErrorT e m) where + divise f (ErrorT l) (ErrorT r) = ErrorT $ divise (funzip . fmap f) l r + +-- | @since 5.3.6 +instance Divise m => Divise (ListT m) where + divise f (ListT l) (ListT r) = ListT $ divise (funzip . map f) l r +#endif + +-- | @since 5.3.6 +instance Divise m => Divise (ExceptT e m) where + divise f (ExceptT l) (ExceptT r) = ExceptT $ divise (funzip . fmap f) l r + +-- | @since 5.3.6 +instance Divise f => Divise (IdentityT f) where + divise f (IdentityT l) (IdentityT r) = IdentityT $ divise f l r + +-- | @since 5.3.6 +instance Divise m => Divise (MaybeT m) where + divise f (MaybeT l) (MaybeT r) = MaybeT $ divise (funzip . fmap f) l r + +-- | @since 5.3.6 +instance Divise m => Divise (ReaderT r m) where + divise abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> divise abc (rmb r) (rmc r) + +-- | @since 5.3.6 +instance Divise m => Divise (Lazy.RWST r w s m) where + divise abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s -> + divise (\ ~(a, s', w) -> case abc a of + ~(b, c) -> ((b, s', w), (c, s', w))) + (rsmb r s) (rsmc r s) + +-- | @since 5.3.6 +instance Divise m => Divise (Strict.RWST r w s m) where + divise abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s -> + divise (\(a, s', w) -> case abc a of + (b, c) -> ((b, s', w), (c, s', w))) + (rsmb r s) (rsmc r s) + +-- | @since 5.3.6 +instance Divise m => Divise (Lazy.StateT s m) where + divise f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s -> + divise (lazyFanout f) (l s) (r s) + +-- | @since 5.3.6 +instance Divise m => Divise (Strict.StateT s m) where + divise f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s -> + divise (strictFanout f) (l s) (r s) + +-- | @since 5.3.6 +instance Divise m => Divise (Lazy.WriterT w m) where + divise f (Lazy.WriterT l) (Lazy.WriterT r) = Lazy.WriterT $ + divise (lazyFanout f) l r + +-- | @since 5.3.6 +instance Divise m => Divise (Strict.WriterT w m) where + divise f (Strict.WriterT l) (Strict.WriterT r) = Strict.WriterT $ + divise (strictFanout f) l r + +-- | Unlike 'Divisible', requires only 'Apply' on @f@. +-- +-- @since 5.3.6 +instance (Apply f, Divise g) => Divise (Compose f g) where + divise f (Compose l) (Compose r) = Compose (liftF2 (divise f) l r) + +-- | @since 5.3.6 +instance (Divise f, Divise g) => Divise (Product f g) where + divise f (Pair l1 r1) (Pair l2 r2) = Pair (divise f l1 l2) (divise f r1 r2) + +-- | @since 5.3.6 +instance Divise f => Divise (Reverse f) where + divise f (Reverse l) (Reverse r) = Reverse $ divise f l r + +-- Helpers + +lazyFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s)) +lazyFanout f ~(a, s) = case f a of + ~(b, c) -> ((b, s), (c, s)) + +strictFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s)) +strictFanout f (a, s) = case f a of + (b, c) -> ((b, s), (c, s)) + +funzip :: Functor f => f (a, b) -> (f a, f b) +funzip = fmap fst &&& fmap snd 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,11 +1,13 @@ {-# LANGUAGE CPP #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Extend --- Copyright : (C) 2011 Edward Kmett +-- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -17,19 +19,39 @@ ( -- * 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.Semigroup +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 @@ -42,6 +64,23 @@ 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 @@ -56,6 +95,15 @@ 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 @@ -70,12 +118,33 @@ 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 @@ -94,28 +163,77 @@ extended f (IdentityT m) = IdentityT (extended (f . IdentityT) m) instance Extend NonEmpty where - extended f w@ ~(_ :| aas) = f w :| case aas of + 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 'extend' +-- 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 'duplicate' +-- II. Alternately, you may choose to provide definitions for 'duplicated' -- satisfying this law: -- -- > duplicated . duplicated = fmap duplicated . duplicated -- --- These are both equivalent to the statement that (->-) is associative --- --- > (f ->- g) ->- h = f ->- (g ->- h) --- --- You may of course, choose to define both 'duplicate' /and/ 'extend'. +-- 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 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,11 +1,10 @@ {-# LANGUAGE CPP #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | --- Module : Data.Functor.Plus --- Copyright : (C) 2011 Edward Kmett +-- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -15,46 +14,116 @@ ---------------------------------------------------------------------------- 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.Exception import Control.Monad import Control.Monad.Trans.Identity --- import Control.Monad.Trans.Cont -import Control.Monad.Trans.Error -import Control.Monad.Trans.List +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.Bind +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.Semigroup import Data.Sequence (Seq) import qualified Data.Map as Map import Data.Map (Map) -import Prelude hiding (id, (.)) +#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 + 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" @@ -64,8 +133,10 @@ 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 @@ -73,6 +144,7 @@ instance ArrowPlus a => Plus (WrappedArrow a b) where zero = empty +#ifdef MIN_VERSION_containers instance Ord k => Plus (Map k) where zero = Map.empty @@ -81,7 +153,13 @@ 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 @@ -91,29 +169,67 @@ instance Plus f => Plus (ReaderT e f) where zero = ReaderT $ \_ -> zero -instance (Bind f, Monad f) => Plus (MaybeT f) where +instance (Functor f, Monad f) => Plus (MaybeT f) where zero = MaybeT $ return zero - -instance (Bind f, Monad f, Error e) => Plus (ErrorT e f) where + +#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 (Plus f) => Plus (Strict.StateT e f) where +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 + +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 + 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 new file mode 100644 --- /dev/null +++ b/src/Data/Groupoid.hs @@ -0,0 +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 diff --git a/src/Data/Isomorphism.hs b/src/Data/Isomorphism.hs new file mode 100644 --- /dev/null +++ b/src/Data/Isomorphism.hs @@ -0,0 +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 diff --git a/src/Data/Semigroup/Bifoldable.hs b/src/Data/Semigroup/Bifoldable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semigroup/Bifoldable.hs @@ -0,0 +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 #-} diff --git a/src/Data/Semigroup/Bitraversable.hs b/src/Data/Semigroup/Bitraversable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semigroup/Bitraversable.hs @@ -0,0 +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 #-} 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,60 +1,69 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | --- Module : Data.Semigroup.Foldable --- Copyright : (C) 2011 Edward Kmett +-- 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 - ( Foldable1(..) + ( -- @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 Control.Monad.Trans.Identity import Data.Foldable -import Data.Functor.Identity +import Data.Foldable1 +import Data.Functor.Alt (Alt(..)) import Data.Functor.Apply -import Data.Functor.Product -import Data.Functor.Compose -import Data.Tree import Data.List.NonEmpty (NonEmpty(..)) import Data.Traversable.Instances () -import Data.Semigroup hiding (Product) +import Data.Semigroup hiding (Product, Sum) +import GHC.Generics import Prelude hiding (foldr) -class Foldable t => Foldable1 t where - fold1 :: Semigroup m => t m -> m - foldMap1 :: Semigroup m => (a -> m) -> t a -> m - - foldMap1 f = maybe (error "foldMap1") id . getOption . foldMap (Option . Just . f) - fold1 = foldMap1 id - -instance Foldable1 Tree where - foldMap1 f (Node a []) = f a - foldMap1 f (Node a (x:xs)) = f a <> foldMap1 (foldMap1 f) (x :| xs) - -instance Foldable1 Identity where - foldMap1 f = f . runIdentity - -instance Foldable1 m => Foldable1 (IdentityT m) where - foldMap1 f = foldMap1 f . runIdentityT +-- $setup +-- >>> import Data.List.NonEmpty (NonEmpty (..)) +-- >>> import Data.Monoid (Monoid (..)) -instance (Foldable1 f, Foldable1 g) => Foldable1 (Compose f g) where - foldMap1 f = foldMap1 (foldMap1 f) . getCompose +newtype JoinWith a = JoinWith {joinee :: (a -> a)} -instance (Foldable1 f, Foldable1 g) => Foldable1 (Product f g) where - foldMap1 f (Pair a b) = foldMap1 f a <> foldMap1 f b +instance Semigroup a => Semigroup (JoinWith a) where + JoinWith a <> JoinWith b = JoinWith $ \j -> a j <> j <> b j -instance Foldable1 NonEmpty where - foldMap1 f (a :| []) = f a - foldMap1 f (a :| b : bs) = f a <> foldMap1 f (b :| bs) +-- | 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 } @@ -85,3 +94,33 @@ -- 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 example @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 new file mode 100644 --- /dev/null +++ b/src/Data/Semigroup/Foldable/Class.hs @@ -0,0 +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 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,7 +1,9 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | --- Module : Data.Semigroup.Traversable --- Copyright : (C) 2011 Edward Kmett +-- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -11,48 +13,56 @@ ---------------------------------------------------------------------------- module Data.Semigroup.Traversable ( Traversable1(..) + -- * Defining Traversable1 instances + -- $traversable1instances + , traverse1Maybe + , gtraverse1 + , gsequence1 + -- * Default superclass instance helpers , foldMap1Default ) where import Control.Applicative -import Control.Monad.Trans.Identity -import Data.Functor.Identity -import Data.Functor.Apply -import Data.Functor.Product -import Data.Functor.Compose -import Data.Semigroup.Foldable -import Data.Traversable -import Data.Traversable.Instances () -import Data.Tree -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Semigroup hiding (Product) - -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 +#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) -instance Traversable1 Identity where - traverse1 f = fmap Identity . f . runIdentity - -instance Traversable1 f => Traversable1 (IdentityT f) where - traverse1 f = fmap IdentityT . traverse1 f . runIdentityT - -instance (Traversable1 f, Traversable1 g) => Traversable1 (Compose f g) where - traverse1 f = fmap Compose . traverse1 (traverse1 f) . getCompose - -instance (Traversable1 f, Traversable1 g) => Traversable1 (Product f g) where - traverse1 f (Pair a b) = Pair <$> traverse1 f a <.> traverse1 f b +-- | 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 example @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) -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) +-- | 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 -instance Traversable1 NonEmpty where - traverse1 f (a :| []) = (:|[]) <$> f a - traverse1 f (a :| (b: bs)) = (\a' (b':| bs') -> a' :| b': bs') <$> f a <.> traverse1 f (b :| bs) +-- $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 new file mode 100644 --- /dev/null +++ b/src/Data/Semigroup/Traversable/Class.hs @@ -0,0 +1,243 @@ +{-# 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,17 +1,12 @@ {-# LANGUAGE CPP #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 -#if __GLASGOW_HASKELL__ >= 707 && (MIN_VERSION_comonad(3,0,3)) -{-# LANGUAGE Safe #-} -#else +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE Trustworthy #-} -#endif -#endif - ----------------------------------------------------------------------------- -- | -- Module : Data.Semigroupoid --- Copyright : (C) 2007-2011 Edward Kmett +-- Copyright : (C) 2007-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -27,15 +22,28 @@ , Semi(..) ) where +import Control.Applicative import Control.Arrow +import Control.Category import Data.Functor.Bind -import Data.Functor.Extend -import Data.Functor.Contravariant -import Control.Comonad import Data.Semigroup -import Control.Category +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 @@ -50,11 +58,15 @@ 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 } @@ -73,3 +85,22 @@ 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 new file mode 100644 --- /dev/null +++ b/src/Data/Semigroupoid/Categorical.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2021 Koz Ross +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Koz Ross +-- Stability : Experimental +-- Portability : GHC only +-- +-- Provides a way to attach an identity to any semigroupoid. +---------------------------------------------------------------------------- +module Data.Semigroupoid.Categorical ( + Categorical(..), + runCategorical + ) where + +import Control.Category (Category (id, (.))) +import Data.Semigroupoid (Semigroupoid (o)) +#if __GLASGOW_HASKELL__ >= 904 +import Data.Type.Equality (type (~)) +#endif +import Prelude () + +-- | Attaches an identity. +-- +-- @since 5.3.6 +data Categorical s a b where + Id :: Categorical s a a + Embed :: s a b -> Categorical s a b + +-- | @since 5.3.6 +instance (Semigroupoid s) => Semigroupoid (Categorical s) where + Id `o` y = y + x `o` Id = x + Embed x `o` Embed y = Embed (x `o` y) + +-- | @since 5.3.6 +instance (Semigroupoid s) => Category (Categorical s) where + id = Id + (.) = o + +-- | @since 5.3.6 +runCategorical :: (a ~ b => r) -> (s a b -> r) -> Categorical s a b -> r +runCategorical r _ Id = r +runCategorical _ f (Embed x) = f x 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,7 +1,8 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | --- Module : Data.Semigroupoid.Dual --- Copyright : (C) 2007-2011 Edward Kmett +-- Copyright : (C) 2007-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett diff --git a/src/Data/Semigroupoid/Ob.hs b/src/Data/Semigroupoid/Ob.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semigroupoid/Ob.hs @@ -0,0 +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 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,12 +1,17 @@ {-# LANGUAGE CPP #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 -#if __GLASGOW_HASKELL__ >= 707 && (MIN_VERSION_comonad(3,0,3)) -{-# LANGUAGE Safe #-} -#else {-# LANGUAGE Trustworthy #-} -#endif -#endif +----------------------------------------------------------------------------- +-- | +-- 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 @@ -14,24 +19,20 @@ import Control.Arrow import Control.Applicative import Control.Category -import Control.Comonad -import Control.Monad.Instances () 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 LANGUAGE_DeriveDataTypeable -import Data.Typeable +#ifdef MIN_VERSION_comonad +import Control.Comonad #endif newtype Static f a b = Static { runStatic :: f (a -> b) } -#ifdef LANGUAGE_DeriveDataTypeable - deriving (Typeable) -#endif instance Functor f => Functor (Static f a) where fmap f = Static . fmap (f .) . runStatic @@ -52,9 +53,11 @@ 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) 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 CPP #-} --- | Placeholders for missing instances of Traversable, until base catches up and adds them -{-# OPTIONS_GHC -fno-warn-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 -#if !(MIN_VERSION_transformers(0,3,0)) -import Control.Monad.Trans.Identity -import Data.Foldable -import Data.Traversable - -instance Foldable m => Foldable (IdentityT m) where - foldMap f = foldMap f . runIdentityT - -instance Traversable m => Traversable (IdentityT m) where - traverse f = fmap IdentityT . traverse f . runIdentityT -#endif +import Control.Monad.Trans.Instances () +import Data.Orphans () diff --git a/src/Semigroupoids/Do.hs b/src/Semigroupoids/Do.hs new file mode 100644 --- /dev/null +++ b/src/Semigroupoids/Do.hs @@ -0,0 +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 diff --git a/src/Semigroupoids/Internal.hs b/src/Semigroupoids/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Semigroupoids/Internal.hs @@ -0,0 +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