diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ +.ghc.environment.* dist docs wiki diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -1,147 +0,0 @@ -# This Travis job script has been generated by a script via -# -# runghc make_travis_yml_2.hs '-o' '.travis.yml' '--irc-channel=irc.freenode.org#haskell-lens' '--no-no-tests-no-bench' '--no-installed' 'cabal.project' -# -# For more information, see https://github.com/hvr/multi-ghc-travis -# -language: c -sudo: false - -git: - submodules: false # whether to recursively clone submodules - -notifications: - irc: - channels: - - "irc.freenode.org#haskell-lens" - skip_join: true - template: - - "\x0313semigroupoids\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" - -cache: - directories: - - $HOME/.cabal/packages - - $HOME/.cabal/store - -before_cache: - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log - # remove files that are regenerated by 'cabal update' - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx - - - rm -rfv $HOME/.cabal/packages/head.hackage - -matrix: - include: - - compiler: "ghc-7.0.4" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}} - - compiler: "ghc-7.2.2" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.2.2], sources: [hvr-ghc]}} - - compiler: "ghc-7.4.2" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.4.2], sources: [hvr-ghc]}} - - compiler: "ghc-7.6.3" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.6.3], sources: [hvr-ghc]}} - - compiler: "ghc-7.8.4" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.8.4], sources: [hvr-ghc]}} - - compiler: "ghc-7.10.3" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.10.3], sources: [hvr-ghc]}} - - compiler: "ghc-8.0.2" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}} - - compiler: "ghc-8.2.2" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}} - - compiler: "ghc-8.4.1" - env: GHCHEAD=true - addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-8.4.1], sources: [hvr-ghc]}} - - compiler: "ghc-head" - env: GHCHEAD=true - addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-head], sources: [hvr-ghc]}} - - allow_failures: - - compiler: "ghc-7.0.4" - - compiler: "ghc-7.2.2" - - compiler: "ghc-8.4.1" - - compiler: "ghc-head" - -before_install: - - HC=${CC} - - HCPKG=${HC/ghc/ghc-pkg} - - unset CC - - ROOTDIR=$(pwd) - - mkdir -p $HOME/.local/bin - - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" - - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) - - echo $HCNUMVER - -install: - - cabal --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - BENCH=${BENCH---enable-benchmarks} - - TEST=${TEST---enable-tests} - - HADDOCK=${HADDOCK-true} - - INSTALLED=${INSTALLED-true} - - GHCHEAD=${GHCHEAD-false} - - travis_retry cabal update -v - - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" - - rm -fv cabal.project cabal.project.local - # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage - - | - if $GHCHEAD; then - sed -i.bak 's/-- allow-newer:.*/allow-newer: *:base, *:template-haskell, *:ghc, *:Cabal/' ${HOME}/.cabal/config - - echo 'repository head.hackage' >> ${HOME}/.cabal/config - echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config - echo ' secure: True' >> ${HOME}/.cabal/config - echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config - echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config - echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config - echo ' key-threshold: 3' >> ${HOME}/.cabal.config - - cabal new-update head.hackage -v - fi - - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' - - "printf 'packages: \".\"\\n' > cabal.project" - - cat cabal.project - - if [ -f "./configure.ac" ]; then - (cd "." && autoreconf -i); - fi - - rm -f cabal.project.freeze - - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all - - rm -rf "."/.ghc.environment.* "."/dist - - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) - -# Here starts the actual work to be performed for the package under test; -# any command which exits with a non-zero exit code causes the build to fail. -script: - # test that source-distributions can be generated - - (cd "." && cabal sdist) - - mv "."/dist/semigroupoids-*.tar.gz ${DISTDIR}/ - - cd ${DISTDIR} || false - - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; - - "printf 'packages: semigroupoids-*/*.cabal\\n' > cabal.project" - - cat cabal.project - - - # build & run tests, build benchmarks - - cabal new-build -w ${HC} ${TEST} ${BENCH} all - - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi - - # cabal check - - (cd semigroupoids-* && cabal check) - - # haddock - - rm -rf ./dist-newstyle - - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi - -# REGENDATA ["-o",".travis.yml","--irc-channel=irc.freenode.org#haskell-lens","--no-no-tests-no-bench","--no-installed","cabal.project"] -# EOF diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,172 @@ +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 @@ -7,6 +176,8 @@ 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` diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,15 +1,63 @@ semigroupoids -========== +============= -[![Hackage](https://img.shields.io/hackage/v/semigroupoids.svg)](https://hackage.haskell.org/package/semigroupoids) [![Build Status](https://secure.travis-ci.org/ekmett/semigroupoids.png?branch=master)](http://travis-ci.org/ekmett/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`. +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 irc.freenode.net. +Please feel free to contact me through Github or on the #haskell IRC channel on +LiberaChat. -Edward Kmett diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,34 +1,7 @@ -\begin{code} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wall #-} -module Main (main) where - -#ifndef MIN_VERSION_cabal_doctest -#define MIN_VERSION_cabal_doctest(x,y,z) 0 -#endif - -#if MIN_VERSION_cabal_doctest(1,0,0) - -import Distribution.Extra.Doctest ( defaultMainWithDoctests ) -main :: IO () -main = defaultMainWithDoctests "doctests" - -#else - -#ifdef MIN_VERSION_Cabal --- If the macro is defined, we have new cabal-install, --- but for some reason we don't have cabal-doctest in package-db --- --- Probably we are running cabal sdist, when otherwise using new-build --- workflow -import Warning () -#endif - -import Distribution.Simple - -main :: IO () -main = defaultMain +#!/usr/bin/runhaskell +> module Main (main) where -#endif +> import Distribution.Simple -\end{code} +> main :: IO () +> main = defaultMain diff --git a/Warning.hs b/Warning.hs deleted file mode 100644 --- a/Warning.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Warning - {-# WARNING ["You are configuring this package without cabal-doctest installed.", - "The doctests test-suite will not work as a result.", - "To fix this, install cabal-doctest before configuring."] #-} - () where 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,8 +1,8 @@ +cabal-version: 1.24 name: semigroupoids category: Control, Comonads -version: 5.2.2 -license: BSD3 -cabal-version: >= 1.8 +version: 6.0.2 +license: BSD2 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett @@ -10,24 +10,31 @@ homepage: http://github.com/ekmett/semigroupoids bug-reports: http://github.com/ekmett/semigroupoids/issues copyright: Copyright (C) 2011-2015 Edward A. Kmett -tested-with: GHC == 7.0.4 - , GHC == 7.2.2 - , GHC == 7.4.2 - , GHC == 7.6.3 - , GHC == 7.8.4 - , GHC == 7.10.3 - , GHC == 8.0.2 +tested-with: GHC == 8.0.2 , GHC == 8.2.2 - , GHC == 8.4.1 -build-type: Custom + , 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: Semigroupoids: Category sans id extra-source-files: - .travis.yml .gitignore .vim.custom README.markdown CHANGELOG.markdown - Warning.hs + img/classes.dot +extra-doc-files: + img/classes.svg + description: Provides a wide array of (semi)groupoids and operations for working with them. . @@ -41,16 +48,14 @@ . 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. . - > Foldable ----> Traversable <--- Functor ------> Alt ---------> Plus Semigroupoid - > | | | | | - > v v v v v - > Foldable1 ---> Traversable1 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. . @@ -63,13 +68,7 @@ source-repository head type: git - location: git://github.com/ekmett/semigroupoids.git - -custom-setup - setup-depends: - base >= 4 && < 5, - Cabal, - cabal-doctest >= 1 && < 1.1 + location: https://github.com/ekmett/semigroupoids.git flag containers description: @@ -90,23 +89,6 @@ default: True manual: True -flag distributive - description: - You can disable the use of the `distributive` package using `-f-distributive`. - . - Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. - . - If disabled we will not supply instances of `Distributive` - . - default: True - manual: True - -flag doctests - description: - You can disable testing with doctests using `-f-doctests`. - default: True - manual: True - flag comonad description: You can disable the use of the `comonad` package using `-f-comonad`. @@ -136,38 +118,38 @@ library build-depends: - base >= 4.3 && < 5, - base-orphans >= 0.5.4 && < 1, - bifunctors >= 5 && < 6, - semigroups >= 0.8.3.1 && < 1, - template-haskell, - transformers >= 0.2 && < 0.6, - transformers-compat >= 0.5 && < 0.6 + 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 >= 7.0 && < 7.2) - build-depends: generic-deriving >= 1.11 && < 1.13 + if !impl(ghc >= 9.6) + build-depends: foldable1-classes-compat >= 0.1 && < 0.2 - if impl(ghc >= 7.2 && < 7.6) - build-depends: ghc-prim + -- 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.3 && < 0.6 + build-depends: containers >= 0.5.7.1 && < 0.9 if flag(contravariant) - build-depends: contravariant >= 0.2.0.1 && < 2 - - if flag(distributive) - build-depends: distributive >= 0.2.2 && < 1 + build-depends: contravariant >= 1.5.3 && < 2 if flag(comonad) - build-depends: comonad >= 4.2.6 && < 6 + build-depends: comonad >= 5.0.8 && < 6 if flag(tagged) - build-depends: tagged >= 0.8.5 && < 1 + build-depends: tagged >= 0.8.7 && < 1 if flag(unordered-containers) - build-depends: hashable >= 1.1 && < 1.3, - unordered-containers >= 0.2 && < 0.3 + build-depends: hashable >= 1.2.7.0 && < 1.6, + unordered-containers >= 0.2.8.0 && < 0.3 hs-source-dirs: src @@ -189,23 +171,26 @@ 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 -fno-warn-warnings-deprecations + if impl(ghc >= 8.6) || flag(contravariant) + exposed-modules: + Data.Functor.Contravariant.Conclude + Data.Functor.Contravariant.Decide + Data.Functor.Contravariant.Divise -test-suite doctests - type: exitcode-stdio-1.0 - main-is: doctests.hs - hs-source-dirs: test - ghc-options: -Wall -fno-warn-warnings-deprecations + ghc-options: -Wall -Wno-warnings-deprecations -Wno-trustworthy-safe - if !flag(doctests) - buildable: False - else - build-depends: - base >= 4 && < 5, - doctest >= 0.11.1 && < 0.14, - semigroupoids + if impl(ghc >= 9.0) + -- these flags may abort compilation with GHC-8.10 + -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295 + ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode + + default-language: Haskell2010 diff --git a/src/Data/Bifunctor/Apply.hs b/src/Data/Bifunctor/Apply.hs --- a/src/Data/Bifunctor/Apply.hs +++ b/src/Data/Bifunctor/Apply.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett 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,16 +1,11 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} - -#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} -#endif - -#if __GLASGOW_HASKELL__ >= 711 -{-# LANGUAGE ConstrainedClassMethods #-} -#endif -{-# options_ghc -fno-warn-deprecations #-} +{-# options_ghc -Wno-deprecations #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Alt @@ -25,6 +20,7 @@ module Data.Functor.Alt ( Alt(..) , optional + , galt , module Data.Functor.Apply ) where @@ -35,11 +31,14 @@ import Control.Exception (catch, SomeException) import Control.Monad import Control.Monad.Trans.Identity -import Control.Monad.Trans.Error import Control.Monad.Trans.Except -import Control.Monad.Trans.List 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 @@ -47,39 +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 Data.Semigroup (Option(..), Semigroup(..)) -import Prelude (($),Either(..),Maybe(..),const,IO,Ord,(++),(.),either,seq,undefined) +import qualified Data.Monoid as Monoid +import Data.Proxy +import Data.Semigroup (Semigroup(..)) +import qualified Data.Semigroup as Semigroup +import GHC.Generics +import Prelude (($),Either(..),Maybe(..),const,IO,(++),(.),either,seq,undefined,repeat,mappend) import Unsafe.Coerce +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.Error +import Control.Monad.Trans.List +#endif + +#if !(MIN_VERSION_base(4,16,0)) +import Data.Semigroup (Option(..)) +#endif + #ifdef MIN_VERSION_containers import qualified Data.IntMap as IntMap import Data.IntMap (IntMap) import Data.Sequence (Seq) import qualified Data.Map as Map import Data.Map (Map) -# if MIN_VERSION_base(4,8,0) -import Prelude (mappend) -# else -import Data.Monoid (mappend) -# endif -#endif - -#if defined(MIN_VERSION_tagged) || (MIN_VERSION_base(4,7,0)) -import Data.Proxy +import Prelude (Ord) #endif -#ifdef MIN_VERSION_generic_deriving -import Generics.Deriving.Base -#else -import GHC.Generics +#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: @@ -89,18 +93,20 @@ -- -- If extended to an 'Alternative' then '' should equal '<|>'. -- --- Ideally, an instance of 'Alt' also satisfies the \"left distributon\" law of +-- 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. -- @@ -128,9 +134,22 @@ 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 @@ -143,6 +162,10 @@ 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 @@ -153,24 +176,32 @@ some v = v `seq` undefined many v = v `seq` undefined -#if defined(MIN_VERSION_tagged) || (MIN_VERSION_base(4,7,0)) instance Alt Proxy where _ _ = Proxy some _ = Proxy many _ = Proxy -#endif 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 +-- 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 () = (++) @@ -178,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 () = (<|>) @@ -198,6 +231,11 @@ () = 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) @@ -210,29 +248,32 @@ 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 Left _ -> n Right r -> return (Right r) -instance (Bind f, Monad f, Semigroup e) => Alt (ExceptT e f) where +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 Apply f => Alt (ListT f) where - ListT a ListT b = ListT $ () <$> a <.> b instance Alt f => Alt (Strict.StateT e f) where Strict.StateT m Strict.StateT n = Strict.StateT $ \s -> m s n s @@ -246,12 +287,24 @@ 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) @@ -268,3 +321,15 @@ 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,8 +1,5 @@ -{-# LANGUAGE CPP #-} - -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL <= 706 && defined(MIN_VERSION_comonad) && !(MIN_VERSION_comonad(3,0,3)) +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Trustworthy #-} -#endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett @@ -24,14 +21,19 @@ , Apply(..) , (<..>) -- :: Apply w => w a -> w (a -> b) -> w b , liftF3 -- :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d + , gliftF2 + , gliftF3 -- * Wrappers , WrappedApplicative(..) , MaybeApply(..) + , (<.*>) + , (<*.>) ) where -import Control.Comonad +import Data.Functor import Data.Functor.Bind.Class +import GHC.Generics infixl 4 <..> @@ -46,3 +48,17 @@ 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,12 +1,5 @@ -{-# LANGUAGE CPP #-} - -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL <= 706 && defined(MIN_VERSION_comonad) && !(MIN_VERSION_comonad(3,0,3)) +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Trustworthy #-} -#endif - -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 -{-# OPTIONS_GHC -fno-warn-amp #-} -#endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett @@ -31,6 +24,7 @@ , MaybeApply(..) -- * Bindable functors , Bind(..) + , gbind , (-<<) , (-<-) , (->-) @@ -40,7 +34,19 @@ import Data.Functor.Apply import Data.Functor.Bind.Class +import GHC.Generics +-- | Generic '(>>-)'. Caveats: +-- +-- 1. Will not compile if @m@ is a sum type. +-- 2. Will not compile if @m@ contains fields that do not mention its type variable. +-- 3. Will not compile if @m@ contains fields where the type variable appears underneath the composition of type constructors (e.g., @f (g a)@). +-- 4. May do redundant work, due to the nature of the 'Bind' instance for (':*:') +-- +-- @since 5.3.8 +gbind :: (Generic1 m, Bind (Rep1 m)) => m a -> (a -> m b) -> m b +gbind m f = to1 $ from1 m >>- (\a -> from1 $ f a) + infixr 1 -<<, -<-, ->- (-<<) :: Bind m => (a -> m b) -> m a -> m b @@ -51,5 +57,3 @@ (-<-) :: Bind m => (b -> m c) -> (a -> m b) -> a -> m c g -<- f = \a -> f a >>- g - - diff --git a/src/Data/Functor/Bind/Class.hs b/src/Data/Functor/Bind/Class.hs --- a/src/Data/Functor/Bind/Class.hs +++ b/src/Data/Functor/Bind/Class.hs @@ -1,24 +1,15 @@ {-# LANGUAGE CPP #-} - -#ifndef MIN_VERSION_semigroups -#define MIN_VERSION_semigroups(x,y,z) 1 -#endif - -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL <= 706 && defined(MIN_VERSION_comonad) && !(MIN_VERSION_comonad(3,0,3)) +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Trustworthy #-} -#endif - +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-deprecations #-} {-# OPTIONS_HADDOCK not-home #-} -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 -{-# OPTIONS_GHC -fno-warn-amp #-} -#endif - -{-# OPTIONS_GHC -fno-warn-deprecations #-} - ----------------------------------------------------------------------------- -- | --- Copyright : (C) 2011-2015 Edward Kmett +-- Copyright : (C) 2011-2018 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -35,6 +26,9 @@ -- * Wrappers , WrappedApplicative(..) , MaybeApply(..) + , (<.*>) + , (<*.>) + , traverse1Maybe -- * Bindable functors , Bind(..) , apDefault @@ -50,13 +44,18 @@ 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.Error import Control.Monad.Trans.Except import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader -import Control.Monad.Trans.List +#if MIN_VERSION_transformers(0,5,6) +import qualified Control.Monad.Trans.RWS.CPS as CPS +import qualified Control.Monad.Trans.Writer.CPS as CPS +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 @@ -72,19 +71,26 @@ 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 +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_base(4,4,0) -import Data.Complex +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.Error +import Control.Monad.Trans.List #endif #ifdef MIN_VERSION_containers @@ -100,10 +106,6 @@ import Data.Tagged #endif -#if defined(MIN_VERSION_tagged) || MIN_VERSION_base(4,7,0) -import Data.Proxy -#endif - #ifdef MIN_VERSION_unordered_containers import Data.Hashable import Data.HashMap.Lazy (HashMap) @@ -160,9 +162,7 @@ liftF2 f a b = f <$> a <.> b {-# INLINE liftF2 #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 {-# MINIMAL (<.>) | liftF2 #-} -#endif #ifdef MIN_VERSION_tagged instance Apply (Tagged a) where @@ -171,12 +171,10 @@ (.>) = (*>) #endif -#if defined(MIN_VERSION_tagged) || MIN_VERSION_base(4,7,0) instance Apply Proxy where (<.>) = (<*>) (<.) = (<*) (.>) = (*>) -#endif instance Apply f => Apply (Backwards f) where Backwards f <.> Backwards a = Backwards (flip id <$> a <.> f) @@ -184,6 +182,7 @@ 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) @@ -201,6 +200,7 @@ 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) @@ -222,6 +222,7 @@ 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) @@ -252,10 +253,12 @@ (<. ) = (<* ) ( .>) = ( *>) +#if !(MIN_VERSION_base(4,16,0)) instance Apply Option where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) +#endif instance Apply Identity where (<.>) = (<*>) @@ -275,10 +278,8 @@ (<. ) = (<* ) ( .>) = ( *>) -#if MIN_VERSION_base(4,4,0) instance Apply Complex where (a :+ b) <.> (c :+ d) = a c :+ b d -#endif -- Applicative Q was only added in template-haskell 2.7 (GHC 7.4), so -- define in terms of Monad instead. @@ -286,13 +287,13 @@ (<.>) = ap #ifdef MIN_VERSION_containers --- | A Map is not 'Applicative', but it is an instance of 'Apply' +-- | 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' +-- | An 'IntMap' is not 'Applicative', but it is an instance of 'Apply' instance Apply IntMap where (<.>) = IntMap.intersectionWith id (<. ) = IntMap.intersectionWith const @@ -308,7 +309,7 @@ #endif #ifdef MIN_VERSION_unordered_containers --- | A 'HashMap' is not 'Applicative', but it is an instance of 'Apply' +-- | 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 @@ -317,47 +318,80 @@ 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 -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 +-- | 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) @@ -386,18 +420,34 @@ empty = WrapApplicative empty WrapApplicative a <|> WrapApplicative b = WrapApplicative (a <|> b) --- | Transform a Apply into an Applicative by adding a unit. +-- | 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 (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)) @@ -428,6 +478,42 @@ 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 '>>-' @@ -458,9 +544,7 @@ join :: m (m a) -> m a join = (>>- id) -#if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL (>>-) | join #-} -#endif returning :: Functor f => f a -> (a -> b) -> f b returning = flip fmap @@ -468,7 +552,8 @@ apDefault :: Bind f => f (a -> b) -> f a -> f b apDefault f x = f >>- \f' -> f' <$> x -instance Semigroup m => Bind ((,)m) where +-- | 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 @@ -477,11 +562,9 @@ join (Tagged a) = a #endif -#if defined(MIN_VERSION_tagged) || MIN_VERSION_base(4,7,0) instance Bind Proxy where _ >>- _ = Proxy join _ = Proxy -#endif instance Bind (Either a) where Left a >>- _ = Left a @@ -504,11 +587,19 @@ 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 (>>-) = (>>=) @@ -525,6 +616,7 @@ 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 @[]@ @@ -534,6 +626,7 @@ 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 @@ -545,18 +638,27 @@ 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') -> @@ -567,36 +669,38 @@ 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 ArrowApply a => Bind (WrappedArrow a b) where - (>>-) = (>>=) --} - -#if MIN_VERSION_base(4,4,0) instance Bind Complex where (a :+ b) >>- f = a' :+ b' where a' :+ _ = f a _ :+ b' = f b {-# INLINE (>>-) #-} -#endif #ifdef MIN_VERSION_containers --- | A 'Map' is not a 'Monad', but it is an instance of 'Bind' +-- | 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 @@ -612,7 +716,7 @@ #endif #ifdef MIN_VERSION_unordered_containers --- | A 'HashMap' is not a 'Monad', but it is an instance of 'Bind' +-- | 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 @@ -622,6 +726,47 @@ 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 @@ -647,11 +792,9 @@ (f, g) <<.>> (a, b) = (f a, g b) {-# INLINE (<<.>>) #-} -#if MIN_VERSION_semigroups(0,16,2) instance Biapply Arg where Arg f g <<.>> Arg a b = Arg (f a) (g b) {-# INLINE (<<.>>) #-} -#endif instance Semigroup x => Biapply ((,,) x) where (x, f, g) <<.>> (x', a, b) = (x <> x', f a, g b) @@ -711,4 +854,3 @@ 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,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Bind.Trans @@ -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 @@ -52,6 +57,12 @@ 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 @@ -63,6 +74,12 @@ 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,8 +1,9 @@ {-# LANGUAGE CPP #-} - -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL <= 706 && defined(MIN_VERSION_comonad) && !(MIN_VERSION_comonad(3,0,3)) +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Trustworthy #-} -#endif +{-# LANGUAGE TypeOperators #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Extend @@ -18,16 +19,22 @@ ( -- * Extendable Functors -- $definition Extend(..) + , gduplicated + , gextended ) where import Prelude hiding (id, (.)) import Control.Category import Control.Monad.Trans.Identity import Data.Functor.Identity -import Data.Functor.Sum (Sum(..)) -import Data.Semigroup (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) @@ -35,7 +42,6 @@ import Data.Tree #endif - #ifdef MIN_VERSION_comonad import Control.Comonad.Trans.Env import Control.Comonad.Trans.Store @@ -46,11 +52,6 @@ import Data.Tagged #endif -#if defined(MIN_VERSION_tagged) || MIN_VERSION_base(4,7,0) -import Data.Proxy -#endif - - class Functor w => Extend w where -- | -- > duplicated = extended id @@ -63,10 +64,23 @@ extended f = fmap f . duplicated duplicated = extended id -#if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL duplicated | extended #-} -#endif +-- | 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 @@ -86,11 +100,9 @@ duplicated = Tagged #endif -#if defined(MIN_VERSION_tagged) || MIN_VERSION_base(4,7,0) instance Extend Proxy where duplicated _ = Proxy extended _ _ = Proxy -#endif instance Extend Maybe where duplicated Nothing = Nothing @@ -151,13 +163,62 @@ 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 (Sum f g) where +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: 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,9 +1,7 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE TypeOperators #-} - -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL <= 706 && defined(MIN_VERSION_comonad) && !(MIN_VERSION_comonad(3,0,3)) +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Trustworthy #-} -#endif +{-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett @@ -16,6 +14,8 @@ ---------------------------------------------------------------------------- module Data.Functor.Plus ( Plus(..) + , psum + , gzero , module Data.Functor.Alt ) where @@ -23,30 +23,39 @@ 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.Except -import Control.Monad.Trans.List 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 Prelude hiding (id, (.)) +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) @@ -55,14 +64,10 @@ import Data.Map (Map) #endif -#if defined(MIN_VERSION_tagged) || (MIN_VERSION_base(4,7,0)) -import Data.Proxy -#endif - -#ifdef MIN_VERSION_generic_deriving -import Generics.Deriving.Base -#else -import GHC.Generics +#ifdef MIN_VERSION_unordered_containers +import Data.Hashable +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as HashMap #endif -- | Laws: @@ -71,19 +76,48 @@ -- > m zero = m -- -- If extended to an 'Alternative' then 'zero' should equal 'empty'. - class Alt f => Plus f where zero :: f a +-- | The sum of a collection of actions, generalizing 'concat'. +-- +-- >>> psum [Just "Hello", Nothing, Just "World"] +-- Just "Hello" +-- +-- @since 5.3.6 +psum :: (Foldable t, Plus f) => t (f a) -> f a +psum = foldr () zero + +-- | Generic 'zero'. Caveats: +-- +-- 1. Will not compile if @f@ is a sum type. +-- 2. Any types where the @a@ does not appear must have a 'Monoid' instance. +-- +-- @since 5.3.8 +gzero :: (Plus (Rep1 f), Generic1 f) => f a +gzero = to1 zero + instance Plus Proxy where zero = Proxy instance Plus U1 where zero = U1 +-- | @since 5.3.8 +instance (Monoid c +#if !(MIN_VERSION_base(4,11,0)) + , Semigroup c +#endif + ) => Plus (K1 i c) where + zero = K1 mempty + instance (Plus f, Plus g) => Plus (f :*: g) where zero = zero :*: zero +-- | @since 5.3.8 +instance (Plus f, Functor g) => Plus (f :.: g) where + zero = Comp1 zero + instance Plus f => Plus (M1 i c f) where zero = M1 zero @@ -99,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 @@ -119,6 +155,11 @@ 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 @@ -128,18 +169,20 @@ 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 (Bind f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f) where - zero = ExceptT $ return $ Left mempty - instance (Apply f, Applicative f) => Plus (ListT f) where zero = ListT $ pure [] +#endif +instance (Functor f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f) where + zero = ExceptT $ return $ Left mempty + instance Plus f => Plus (Strict.StateT e f) where zero = Strict.StateT $ \_ -> zero @@ -152,12 +195,24 @@ instance Plus f => Plus (Lazy.WriterT w f) where zero = Lazy.WriterT zero +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance (Plus f) => Plus (CPS.WriterT w f) where + zero = mkWriterT $ const zero +#endif + instance Plus f => Plus (Strict.RWST r w s f) where zero = Strict.RWST $ \_ _ -> zero instance Plus f => Plus (Lazy.RWST r w s f) where zero = Lazy.RWST $ \_ _ -> zero +#if MIN_VERSION_transformers(0,5,6) +-- | @since 5.3.6 +instance (Plus f) => Plus (CPS.RWST r w s f) where + zero = mkRWST $ \_ _ _ -> zero +#endif + instance Plus f => Plus (Backwards f) where zero = Backwards zero @@ -172,3 +227,9 @@ instance Plus f => Plus (Reverse f) where zero = Reverse zero + +instance Plus Monoid.First where + zero = Monoid.First Nothing + +instance Plus Monoid.Last where + zero = Monoid.Last Nothing diff --git a/src/Data/Groupoid.hs b/src/Data/Groupoid.hs --- a/src/Data/Groupoid.hs +++ b/src/Data/Groupoid.hs @@ -1,10 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} -#endif - +{-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett @@ -22,11 +20,8 @@ import Data.Semigroupoid import Data.Semigroupoid.Dual - -#if MIN_VERSION_base(4,7,0) import qualified Data.Type.Coercion as Co import qualified Data.Type.Equality as Eq -#endif -- | 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 @@ -35,13 +30,11 @@ instance Groupoid k => Groupoid (Dual k) where inv (Dual k) = Dual (inv k) -#if MIN_VERSION_base(4,7,0) instance Groupoid Co.Coercion where inv = Co.sym instance Groupoid (Eq.:~:) where inv = Eq.sym -#endif #if MIN_VERSION_base(4,10,0) instance Groupoid (Eq.:~~:) where diff --git a/src/Data/Isomorphism.hs b/src/Data/Isomorphism.hs --- a/src/Data/Isomorphism.hs +++ b/src/Data/Isomorphism.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} -#endif +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett diff --git a/src/Data/Semigroup/Bifoldable.hs b/src/Data/Semigroup/Bifoldable.hs --- a/src/Data/Semigroup/Bifoldable.hs +++ b/src/Data/Semigroup/Bifoldable.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett @@ -8,9 +8,15 @@ -- 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 - ( Bifoldable1(..) + ( -- @Data.Bifoldable1@ re-exports + Bifoldable1(bifold1, bifoldMap1) + + -- Additional @Bifoldable1@ functionality , bitraverse1_ , bifor1_ , bisequenceA1_ @@ -19,9 +25,9 @@ import Control.Applicative import Data.Bifoldable +import Data.Bifoldable1 import Data.Functor.Apply import Data.Semigroup -import Data.Semigroup.Foldable.Class import Prelude hiding (foldr) newtype Act f a = Act { getAct :: f a } diff --git a/src/Data/Semigroup/Bitraversable.hs b/src/Data/Semigroup/Bitraversable.hs --- a/src/Data/Semigroup/Bitraversable.hs +++ b/src/Data/Semigroup/Bitraversable.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett 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,3 +1,6 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett @@ -7,53 +10,51 @@ -- 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 - , foldrM1 - , foldlM1 + + -- Generic defaults + , gfold1 + , gfoldMap1 + , gtoNonEmpty ) where import Data.Foldable +import Data.Foldable1 import Data.Functor.Alt (Alt(..)) import Data.Functor.Apply import Data.List.NonEmpty (NonEmpty(..)) import Data.Traversable.Instances () import Data.Semigroup hiding (Product, Sum) -import Data.Semigroup.Foldable.Class +import GHC.Generics import Prelude hiding (foldr) -- $setup --- >>> import Data.List.NonEmpty +-- >>> import Data.List.NonEmpty (NonEmpty (..)) +-- >>> import Data.Monoid (Monoid (..)) newtype JoinWith a = JoinWith {joinee :: (a -> a)} instance Semigroup a => Semigroup (JoinWith a) where JoinWith a <> JoinWith b = JoinWith $ \j -> a j <> j <> b j --- | Insert an 'm' between each pair of 't m'. Equivalent to --- 'intercalateMap1' with 'id' as the second argument. --- --- >>> intercalate1 ", " $ "hello" :| ["how", "are", "you"] --- "hello, how, are, you" --- --- >>> intercalate1 ", " $ "hello" :| [] --- "hello" --- --- >>> intercalate1 mempty $ "I" :| ["Am", "Fine", "You?"] --- "IAmFineYou?" -intercalate1 :: (Foldable1 t, Semigroup m) => m -> t m -> m -intercalate1 = flip intercalateMap1 id -{-# INLINE intercalate1 #-} - --- | Insert 'm' between each pair of 'm' derived from 'a'. +-- | Insert @m@ between each pair of @m@ derived from @a@. -- -- >>> intercalateMap1 " " show $ True :| [False, True] -- "True False True" @@ -103,29 +104,23 @@ asum1 = getAlt_ . foldMap1 Alt_ {-# INLINE asum1 #-} --- | Monadic fold over the elements of a non-empty structure, --- associating to the right, i.e. from right to left. +-- | Generic 'fold1'. Caveats: -- --- > let g = (=<<) . f --- > in foldrM1 f (x1 :| [x2, ..., xn]) == x1 `g` (x2 `g` ... (xn-1 `f` xn)...) +-- 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@ -- -foldrM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a -foldrM1 f = go . toNonEmpty - where - g = (=<<) . f - - go (e:|es) = - case es of - [] -> return e - x:xs -> e `g` (go (x:|xs)) +-- @since 5.3.8 +gfold1 :: (Foldable1 (Rep1 t), Generic1 t, Semigroup m) => t m -> m +gfold1 = fold1 . from1 --- | Monadic fold over the elements of a non-empty structure, --- associating to the left, i.e. from left to right. +-- | Generic 'foldMap1'. Caveats are the same as for 'gfold1'. -- --- > let g = flip $ (=<<) . f --- > in foldlM1 f (x1 :| [x2, ..., xn]) == (...((x1 `f` x2) `g` x2) `g`...) `g` xn +-- @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'. -- -foldlM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a -foldlM1 f t = foldlM f x xs - where - x:|xs = toNonEmpty t +-- @since 5.3.8 +gtoNonEmpty :: (Foldable1 (Rep1 t), Generic1 t) => t a -> NonEmpty a +gtoNonEmpty = toNonEmpty . from1 diff --git a/src/Data/Semigroup/Foldable/Class.hs b/src/Data/Semigroup/Foldable/Class.hs --- a/src/Data/Semigroup/Foldable/Class.hs +++ b/src/Data/Semigroup/Foldable/Class.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE CPP, TypeOperators #-} - -#ifndef MIN_VERSION_semigroups -#define MIN_VERSION_semigroups(x,y,z) 0 -#endif +{-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | @@ -15,215 +11,18 @@ -- ---------------------------------------------------------------------------- module Data.Semigroup.Foldable.Class - ( Foldable1(..) - , Bifoldable1(..) + {-# 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 Control.Applicative -import Control.Applicative.Backwards -import Control.Applicative.Lift -import Control.Monad.Trans.Identity -import Data.Bifoldable -import Data.Bifunctor.Biff -import Data.Bifunctor.Clown -import Data.Bifunctor.Flip -import Data.Bifunctor.Join -import Data.Bifunctor.Product as Bifunctor -import Data.Bifunctor.Joker -import Data.Bifunctor.Tannen -import Data.Bifunctor.Wrapped -import Data.Foldable -import Data.Functor.Compose - -import Data.Functor.Identity -import Data.Functor.Product as Functor -import Data.Functor.Reverse -import Data.Functor.Sum -import Data.List.NonEmpty (NonEmpty(..)) - -#if MIN_VERSION_base(4,4,0) -import Data.Complex -#endif - -#ifdef MIN_VERSION_tagged -import Data.Tagged -#endif - -import Data.Traversable.Instances () - -#ifdef MIN_VERSION_containers -import Data.Tree -#endif - -import Data.Semigroup hiding (Product, Sum) - -#ifdef MIN_VERSION_generic_deriving -import Generics.Deriving.Base -#else -import GHC.Generics -#endif - -import Prelude hiding (foldr) - -class Foldable t => Foldable1 t where - fold1 :: Semigroup m => t m -> m - foldMap1 :: Semigroup m => (a -> m) -> t a -> m - toNonEmpty :: t a -> NonEmpty a - - foldMap1 f = maybe (error "foldMap1") id . getOption . foldMap (Option . Just . f) - fold1 = foldMap1 id - toNonEmpty = foldMap1 (:|[]) - -instance Foldable1 f => Foldable1 (Rec1 f) where - foldMap1 f (Rec1 as) = foldMap1 f as - -instance Foldable1 f => Foldable1 (M1 i c f) where - foldMap1 f (M1 as) = foldMap1 f as - -instance Foldable1 Par1 where - foldMap1 f (Par1 a) = f a - -instance (Foldable1 f, Foldable1 g) => Foldable1 (f :*: g) where - foldMap1 f (as :*: bs) = foldMap1 f as <> foldMap1 f bs - -instance (Foldable1 f, Foldable1 g) => Foldable1 (f :+: g) where - foldMap1 f (L1 as) = foldMap1 f as - foldMap1 f (R1 bs) = foldMap1 f bs - -instance Foldable1 V1 where - foldMap1 _ v = v `seq` undefined - -instance (Foldable1 f, Foldable1 g) => Foldable1 (f :.: g) where - foldMap1 f (Comp1 m) = foldMap1 (foldMap1 f) m - -class Bifoldable t => Bifoldable1 t where - bifold1 :: Semigroup m => t m m -> m - bifold1 = bifoldMap1 id id - {-# INLINE bifold1 #-} - - bifoldMap1 :: Semigroup m => (a -> m) -> (b -> m) -> t a b -> m - bifoldMap1 f g = maybe (error "bifoldMap1") id . getOption . bifoldMap (Option . Just . f) (Option . Just . g) - {-# INLINE bifoldMap1 #-} - -#if MIN_VERSION_semigroups(0,16,2) -instance Bifoldable1 Arg where - bifoldMap1 f g (Arg a b) = f a <> g b -#endif - -instance Bifoldable1 Either where - bifoldMap1 f _ (Left a) = f a - bifoldMap1 _ g (Right b) = g b - {-# INLINE bifoldMap1 #-} - -instance Bifoldable1 (,) where - bifoldMap1 f g (a, b) = f a <> g b - {-# INLINE bifoldMap1 #-} - -instance Bifoldable1 ((,,) x) where - bifoldMap1 f g (_,a,b) = f a <> g b - {-# INLINE bifoldMap1 #-} - -instance Bifoldable1 ((,,,) x y) where - bifoldMap1 f g (_,_,a,b) = f a <> g b - {-# INLINE bifoldMap1 #-} - -instance Bifoldable1 ((,,,,) x y z) where - bifoldMap1 f g (_,_,_,a,b) = f a <> g b - {-# INLINE bifoldMap1 #-} - -instance Bifoldable1 Const where - bifoldMap1 f _ (Const a) = f a - {-# INLINE bifoldMap1 #-} - -#ifdef MIN_VERSION_tagged -instance Bifoldable1 Tagged where - bifoldMap1 _ g (Tagged b) = g b - {-# INLINE bifoldMap1 #-} -#endif - -instance (Bifoldable1 p, Foldable1 f, Foldable1 g) => Bifoldable1 (Biff p f g) where - bifoldMap1 f g = bifoldMap1 (foldMap1 f) (foldMap1 g) . runBiff - {-# INLINE bifoldMap1 #-} - -instance Foldable1 f => Bifoldable1 (Clown f) where - bifoldMap1 f _ = foldMap1 f . runClown - {-# INLINE bifoldMap1 #-} - -instance Bifoldable1 p => Bifoldable1 (Flip p) where - bifoldMap1 f g = bifoldMap1 g f . runFlip - {-# INLINE bifoldMap1 #-} - -instance Bifoldable1 p => Foldable1 (Join p) where - foldMap1 f (Join a) = bifoldMap1 f f a - {-# INLINE foldMap1 #-} - -instance Foldable1 g => Bifoldable1 (Joker g) where - bifoldMap1 _ g = foldMap1 g . runJoker - {-# INLINE bifoldMap1 #-} - -instance (Bifoldable1 f, Bifoldable1 g) => Bifoldable1 (Bifunctor.Product f g) where - bifoldMap1 f g (Bifunctor.Pair x y) = bifoldMap1 f g x <> bifoldMap1 f g y - {-# INLINE bifoldMap1 #-} - -instance (Foldable1 f, Bifoldable1 p) => Bifoldable1 (Tannen f p) where - bifoldMap1 f g = foldMap1 (bifoldMap1 f g) . runTannen - {-# INLINE bifoldMap1 #-} - -instance Bifoldable1 p => Bifoldable1 (WrappedBifunctor p) where - bifoldMap1 f g = bifoldMap1 f g . unwrapBifunctor - {-# INLINE bifoldMap1 #-} - -#if MIN_VERSION_base(4,4,0) -instance Foldable1 Complex where - foldMap1 f (a :+ b) = f a <> f b - {-# INLINE foldMap1 #-} -#endif - -#ifdef MIN_VERSION_containers -instance Foldable1 Tree where - foldMap1 f (Node a []) = f a - foldMap1 f (Node a (x:xs)) = f a <> foldMap1 (foldMap1 f) (x :| xs) -#endif - -instance Foldable1 Identity where - foldMap1 f = f . runIdentity - -#ifdef MIN_VERSION_tagged -instance Foldable1 (Tagged a) where - foldMap1 f (Tagged a) = f a -#endif - -instance Foldable1 m => Foldable1 (IdentityT m) where - foldMap1 f = foldMap1 f . runIdentityT - -instance Foldable1 f => Foldable1 (Backwards f) where - foldMap1 f = foldMap1 f . forwards - -instance (Foldable1 f, Foldable1 g) => Foldable1 (Compose f g) where - foldMap1 f = foldMap1 (foldMap1 f) . getCompose - -instance Foldable1 f => Foldable1 (Lift f) where - foldMap1 f (Pure x) = f x - foldMap1 f (Other y) = foldMap1 f y - -instance (Foldable1 f, Foldable1 g) => Foldable1 (Functor.Product f g) where - foldMap1 f (Functor.Pair a b) = foldMap1 f a <> foldMap1 f b - -instance Foldable1 f => Foldable1 (Reverse f) where - foldMap1 f = getDual . foldMap1 (Dual . f) . getReverse - -instance (Foldable1 f, Foldable1 g) => Foldable1 (Sum f g) where - foldMap1 f (InL x) = foldMap1 f x - foldMap1 f (InR y) = foldMap1 f y - -instance Foldable1 NonEmpty where - foldMap1 f (a :| []) = f a - foldMap1 f (a :| b : bs) = f a <> foldMap1 f (b :| bs) - toNonEmpty = id - -instance Foldable1 ((,) a) where - foldMap1 f (_, x) = f x - -instance Foldable1 g => Foldable1 (Joker g a) where - foldMap1 g = foldMap1 g . runJoker - {-# INLINE foldMap1 #-} +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,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett @@ -11,6 +13,12 @@ ---------------------------------------------------------------------------- module Data.Semigroup.Traversable ( Traversable1(..) + -- * Defining Traversable1 instances + -- $traversable1instances + , traverse1Maybe + , gtraverse1 + , gsequence1 + -- * Default superclass instance helpers , foldMap1Default ) where @@ -19,6 +27,42 @@ import Data.Semigroup #endif import Data.Semigroup.Traversable.Class +import Data.Functor.Bind.Class +import GHC.Generics +-- | Default implementation of 'foldMap1' given an implementation of 'Traversable1'. foldMap1Default :: (Traversable1 f, Semigroup m) => (a -> m) -> f a -> m foldMap1Default f = getConst . traverse1 (Const . f) + +-- | Generic 'traverse1'. Caveats: +-- +-- 1. Will not compile if @t@ is an empty constructor. +-- 2. Will not compile if @t@ has some fields that don't mention @a@, for 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) + +-- | Generic 'sequence1'. Caveats are the same for 'gtraverse1'. +-- +-- @since 5.3.8 +gsequence1 :: + (Traversable1 (Rep1 t), Apply f, Generic1 t) => + t (f b) -> + f (t b) +gsequence1 = fmap to1 . sequence1 . from1 + +-- $traversable1instances +-- Defining 'Traversable1' instances for types with both 'Traversable1' and 'Traversable' +-- substructures can be done with 'traverse1Maybe', '(<*.>)', and '(<.*>)'. +-- +-- > data Foo a = Foo (Maybe a) (Maybe a) a [a] +-- > deriving (Functor, Traversable, Foldable) +-- > instance Traversable1 Foo where +-- > traverse1 f (Foo ma ma' a as) = Foo <$> traverseMaybe ma <*> traverseMaybe ma' <*.> f a <.*> traverseMaybe as +-- > instance Foldable1 Foo where +-- > foldMap1 = foldMap1Default diff --git a/src/Data/Semigroup/Traversable/Class.hs b/src/Data/Semigroup/Traversable/Class.hs --- a/src/Data/Semigroup/Traversable/Class.hs +++ b/src/Data/Semigroup/Traversable/Class.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP, TypeOperators #-} +{-# LANGUAGE Trustworthy #-} + + ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett @@ -15,9 +18,6 @@ ) where import Control.Applicative -import Control.Applicative.Backwards -import Control.Applicative.Lift -import Control.Monad.Trans.Identity import Data.Bitraversable import Data.Bifunctor import Data.Bifunctor.Biff @@ -31,35 +31,30 @@ import Data.Functor.Apply import Data.Functor.Compose +import Data.Complex import Data.Functor.Identity import Data.Functor.Product as Functor -import Data.Functor.Reverse import Data.Functor.Sum as Functor import Data.List.NonEmpty (NonEmpty(..)) -import Data.Semigroup +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 -#if __GLASGOW_HASKELL__ < 710 -import Data.Traversable -#endif import Data.Traversable.Instances () - -#if MIN_VERSION_base(4,4,0) -import Data.Complex -#endif +import GHC.Generics #ifdef MIN_VERSION_containers import Data.Tree #endif -#ifdef MIN_VERSION_generic_deriving -import Generics.Deriving.Base -#else -import GHC.Generics -#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) @@ -70,14 +65,10 @@ bisequence1 = bitraverse1 id id {-# INLINE bisequence1 #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 {-# MINIMAL bitraverse1 | bisequence1 #-} -#endif -#if MIN_VERSION_semigroups(0,16,2) instance Bitraversable1 Arg where bitraverse1 f g (Arg a b) = Arg <$> f a <.> g b -#endif instance Bitraversable1 Either where bitraverse1 f _ (Left a) = Left <$> f a @@ -152,9 +143,7 @@ sequence1 = traverse1 id traverse1 f = sequence1 . fmap f -#if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL traverse1 | sequence1 #-} -#endif instance Traversable1 f => Traversable1 (Rec1 f) where traverse1 f (Rec1 as) = Rec1 <$> traverse1 f as @@ -181,34 +170,32 @@ 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 g) => Traversable1 (Compose f g) where - traverse1 f = fmap Compose . traverse1 (traverse1 f) . getCompose - 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 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 (Reverse f) where traverse1 f = fmap Reverse . forwards . traverse1 (Backwards . f) . getReverse -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 - -#if MIN_VERSION_base(4,4,0) instance Traversable1 Complex where traverse1 f (a :+ b) = (:+) <$> f a <.> f b {-# INLINE traverse1 #-} -#endif #ifdef MIN_VERSION_tagged instance Traversable1 (Tagged a) where @@ -222,8 +209,7 @@ #endif 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) + 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 @@ -231,3 +217,27 @@ 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,13 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} - -#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} -#endif - -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL <= 706 && defined(MIN_VERSION_comonad) && !(MIN_VERSION_comonad(3,0,3)) {-# LANGUAGE Trustworthy #-} -#endif ----------------------------------------------------------------------------- -- | @@ -30,9 +24,11 @@ import Control.Applicative import Control.Arrow +import Control.Category import Data.Functor.Bind 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 @@ -48,11 +44,6 @@ import Data.Tagged (Tagged (..)) #endif -#if MIN_VERSION_base(4,7,0) -import qualified Data.Type.Coercion as Co -import qualified Data.Type.Equality as Eq -#endif - -- | 'Control.Category.Category' sans 'Control.Category.id' class Semigroupoid c where o :: c j k -> c i j -> c i k @@ -103,13 +94,11 @@ Tagged b `o` _ = Tagged b #endif -#if MIN_VERSION_base(4,7,0) instance Semigroupoid Co.Coercion where o = flip Co.trans instance Semigroupoid (Eq.:~:) where o = flip Eq.trans -#endif #if MIN_VERSION_base(4,10,0) instance Semigroupoid (Eq.:~~:) where 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,5 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} -#endif +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2007-2015 Edward Kmett diff --git a/src/Data/Semigroupoid/Ob.hs b/src/Data/Semigroupoid/Ob.hs --- a/src/Data/Semigroupoid/Ob.hs +++ b/src/Data/Semigroupoid/Ob.hs @@ -1,10 +1,9 @@ {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -#endif {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett 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,8 +1,5 @@ {-# LANGUAGE CPP #-} - -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL <= 706 && defined(MIN_VERSION_comonad) && !(MIN_VERSION_comonad(3,0,3)) {-# LANGUAGE Trustworthy #-} -#endif ----------------------------------------------------------------------------- -- | @@ -31,18 +28,11 @@ import Data.Semigroupoid import Prelude hiding ((.), id) -#ifdef LANGUAGE_DeriveDataTypeable -import Data.Typeable -#endif - #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 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,6 +1,7 @@ +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | --- Copyright : (C) 2011-2015 Edward Kmett +-- Copyright : (C) 2011-2015,2018 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett 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 diff --git a/test/doctests.hs b/test/doctests.hs deleted file mode 100644 --- a/test/doctests.hs +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Main (doctests) --- Copyright : (C) 2012-14 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable --- --- This module provides doctests for a project based on the actual versions --- of the packages it was built with. It requires a corresponding Setup.lhs --- to be added to the project ------------------------------------------------------------------------------ -module Main where - -import Build_doctests (flags, pkgs, module_sources) -import Data.Foldable (traverse_) -import Test.DocTest - -main :: IO () -main = do - traverse_ putStrLn args - doctest args - where - args = flags ++ pkgs ++ module_sources