semigroupoids-6.0.1/0000755000000000000000000000000007346545000012600 5ustar0000000000000000semigroupoids-6.0.1/.gitignore0000644000000000000000000000036607346545000014575 0ustar0000000000000000.ghc.environment.* dist docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# dist-* cabal-dev *.chi *.chs.h *.dyn_o *.dyn_hi .hpc .hsenv .cabal-sandbox/ cabal.sandbox.config *.prof *.aux *.hp *.eventlog .stack-work/ cabal.project.local semigroupoids-6.0.1/.vim.custom0000644000000000000000000000137707346545000014715 0ustar0000000000000000" Add the following to your .vimrc to automatically load this on startup " if filereadable(".vim.custom") " so .vim.custom " endif function StripTrailingWhitespace() let myline=line(".") let mycolumn = col(".") silent %s/ *$// call cursor(myline, mycolumn) endfunction " enable syntax highlighting syntax on " search for the tags file anywhere between here and / set tags=TAGS;/ " highlight tabs and trailing spaces set listchars=tab:‗‗,trail:‗ set list " f2 runs hasktags map :exec ":!hasktags -x -c --ignore src" " strip trailing whitespace before saving " au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() " rebuild hasktags after saving au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" semigroupoids-6.0.1/CHANGELOG.markdown0000644000000000000000000002610007346545000015632 0ustar00000000000000006.0.1 [2024.05.04] ------------------ * Fix a build error when compiling with `-f-contravariant`. 6.0.0.1 [2023.03.16] -------------------- * When building with GHC 9.6, require `transformers >= 0.6.1` and `containers >= 0.6.7`. This ensures that `semigroupoids` always provides `Traversable1` instances for data types from `transformers` and `containers` unconditionally. 6 [2023.03.12] -------------- * Drop support for GHC 7.10 and earlier. * The `Foldable1` and `Bifoldable1` classes have been migrated: * When building with `base-4.18` or later, `semigroupoids` re-exports `Foldable1` and `Bifoldable1` from `base`. (These classes were added to `base-4.18` as a result of [this Core Libraries proposal](haskell/core-libraries-committee#9).) * When building with older versions of `base`, `semigroupoids` re-exports `Foldable1` and `Bifoldable1` from the [`foldable1-classes-compat`](https://github.com/haskell-compat/foldable1-classes-compat) compatibility package. Note that the version of `Foldable1` that `semigroupoids` defined in previous releases only had three class methods: `fold1`, `foldMap1`, and `toNonEmpty`. Moreover, `foldMap1` had a default implementation in terms of a `Foldable` constraint. `base`'s version of `Foldable1`, however, has some notable differences: 1. It has many more methods than the three listed above, such as the `foldrMap1` method. 2. `foldMap1` now has a default implementation in terms of `foldrMap1` instead of in terms of a `Foldable` constraint. To avoid (1) causing issues when upgrading to `semigroupoids-6`, `Data.Semigroup.Foldable` only re-exports the `fold1`, `foldMap1`, and `toNonEmpty` methods, which reflects the API in previous `semigroupoids` releases. If you want to use the other, new class methods of `Foldable1`, consider importing it from `Data.Foldable1` (its home in `base`) instead. Difference (2) is trickier, because it is possible that existing code that defines valid `Foldable1` instances will need to be migrated. If you have an instance like this: ```hs import Data.Semigroup.Foldable data T a = MkT a instance Foldable T where foldMap f (MkT x) = f x instance Foldable1 T -- Relying on Foldable-based defaults ``` Then calling `foldMap1` on `T` will throw an error with `semigroupoids-6`, as `foldMap1`'s default implementation no longer uses `Foldable`. To migrate this code, change the instance to explicitly define `foldMap1`: ```hs instance Foldable1 T where foldMap1 f (MkT x) = f x ``` This approach should be backwards-compatible with previous `semigroupoids` releases. Some other side effects of this migration include: * The `Data.Semigroup.Foldable.Class` module has been deprecated. It no longer serves a useful role, as it simply re-exports a limited subset of the `Data.Foldable1` and `Data.Bifoldable1` API. * All of the `Foldable1` and `Bifoldable1` instances that were previously defined in `semigroupoids` have now been migrated to downstream libraries (`base`, `bifunctors`, `containers`, `tagged`, and `transformers`), so it is no longer strictly necessary to depend on `semigroupoids` to make use of these instances. * Add `Generic1`-based functions for many classes, useful for writing instances: - `Data.Functor.Alt.()` -> `Data.Functor.Alt.galt` - `Data.Functor.Apply.{liftF2,liftF3}` -> `Data.Functor.Apply.{gliftF2,gliftF3}` - `Data.Functor.Bind.(>>-)` -> `Data.Functor.Bind.gbind` - `Data.Functor.Contravariant.Conclude.{conclude,concluded}` -> `Data.Functor.Contravariant.Conclude.{gconclude,gconcluded}` - `Data.Functor.Contravariant.Decide.{decide,decided}` -> `Data.Functor.Contravariant.Decide.{gdecide,gdecided}` - `Data.Functor.Contravariant.Divise.{divise,divised}` -> `Data.Functor.Contravariant.Divise.{gdivise,gdivised}` - `Data.Functor.Extend.{duplicated,extended}` -> `Data.Functor.Extend.{gduplicated,gextended}` - `Data.Functor.Plus.zero` -> `Data.Functor.Plus.gzero` - `Data.Semigroup.Foldable.{fold1,foldMap1,toNonEmpty}` -> `Data.Semigroup.Foldable.{gfold1,gfoldMap1,gtoNonEmpty}` - `Data.Semigroup.Traversable.{traverse1,sequence1}` -> `Data.Semigroup.Traversable.{gtraverse1,gsequence1}` 5.3.7 [2022.01.09] ------------------ * Relax the `Bind` constraints in the following instances to `Functor`: ```diff -instance (Bind f, Monad f) => Alt (MaybeT f) -instance (Bind f, Monad f) => Plus (MaybeT f) +instance (Functor f, Monad f) => Alt (MaybeT f) +instance (Functor f, Monad f) => Plus (MaybeT f) -instance (Bind f, Monad f, Semigroup e) => Alt (ExceptT e f) -instance (Bind f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f) +instance (Functor f, Monad f, Semigroup e) => Alt (ExceptT e f) +instance (Functor f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f) -- If building with transformers-0.5.* or older -instance (Bind f, Monad f) => Alt (ErrorT e f) -instance (Bind f, Monad f, Error e) => Plus (ErrorT e f +instance (Functor f, Monad f) => Alt (ErrorT e f) +instance (Functor f, Monad f, Error e) => Plus (ErrorT e f) ``` 5.3.6 [2021.10.07] ------------------ * Allow building with GHC 9.2. * Allow building with `transformers-0.6.*`. * Add `Alt` instance for `Identity`. * Add `Conclude`, `Decide` and `Divise` type classes and instances. * Add `(<.*>)`, `(<*.>)`, and `traverseMaybe` functions, which make it easier to defined `Traversable1` instances for data types that have fields with a combination of `Traversable` and `Traversable1` instances. * Add `Semigroupoids.Do` module with overloads for use with `QualifiedDo`. * Add `Apply`, `Alt`, `Plus`, `Bind` and `BindTrans` instances for the CPS versions of `WriterT` and `RWST`. * Add `psum` function to `Data.Functor.Plus`. * Add `Categorical` data type. 5.3.5 [2020.12.31] ------------------ * The build-type has been changed from `Custom` to `Simple`. To achieve this, the `doctests` test suite has been removed in favor of using [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) to run the doctests. * Explicitly mark modules as `Safe`. 5.3.4 [2019.11.26] ------------------ * Achieve forward compatibility with [GHC proposal 229](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst). 5.3.3 [2019.08.27] ------------------ * Add `Alt` and `Plus` instances for `HashMap` from the `unordered-containers` package. 5.3.2 [2019.01.04] ------------------ * Bump the lower bound on `semigroups` to 0.16.2, and avoid incurring the dependency entirely on recent GHCs. * Fix the build on GHC 7.0 and 7.2. 5.3.1 [2018.07.02] ------------------ * Fix a regression introduced in `semigroupoids-5.3` in which some modules regressed from `Trustworthy` to `Unsafe`. 5.3 [2018.07.02] ---------------- * Allow building with `containers-0.6`. * Add `Alt` instances for `First` and `Last` from `Data.Semigroup`, and `Alt` and `Plus` instances for `First` and `Last` from `Data.Monoid`. * Add missing `Apply`, `Bind`, `Extend`, `Foldable1` and `Traversable1` instances for `Data.Semigroups`, `Data.Monoid` and `GHC.Generics`. 5.2.2 [2018.01.18] ------------------ * Add `optional` to `Data.Functor.Alt` (analogous to the `optional` function in `Control.Applicative`) * `liftF2` is now a class method of `Apply` (mirroring the fact that `liftA2` is now a class method of `Applicative`). `liftF2` and `(<.>)` have default definitions in terms of the other. * Allow building with GHC 8.4 * `Apply` and `Bind` instances for `Q`, from the `template-haskell` package. (As a consequence, `Data.Semigroup.Foldable` is no longer a `Trustworthy` module.) * Add instances for `(:~:)` and `(:~~:)` from `Data.Type.Equality`, and `Coercion` from `Data.Type.Coercion` 5.2.1 ----- * Add the `toNonEmpty` method to `Foldable1`. Add `foldrM1` and `foldlM1` functions to `Data.Semigroup.Foldable` that are defined in terms of `toNonEmpty`. * Add `Apply`, `Bind`, `Foldable1`, and `Traversable1` instances for `Complex` * Add `Apply` and `Bind` instances for `HashMap` from the `unordered-containers` package (on which `semigroupoids` now depends) * Add `Semigroupoid` instances for `Tagged` and `Const` 5.2 --- * Revamp `Setup.hs` to use `cabal-doctest`. This makes it build with `Cabal-1.25`, and makes the `doctest`s work with `cabal new-build` and sandboxes. * Added instances to `Alt`, `Plus`, `Apply`, `Bind` and `Extend` for `GHC.Generics`, `Tagged` and `Proxy` where appropriate. 5.1 --- * The remaining orphan instances in `Data.Traversable.Instances` have been replaced in favor of the orphan instances from `transformers-compat-0.5`. * The documentation now states laws that instances of `Apply` are expected to uphold. * `doctest-0.11` support * Fixed compilation of tests with `stack` 5.0.1 ------- * `transformers-compat` 0.5 support * Removed some redundant constraints. * GHC 8 support 5.0.0.4 ------- * `doctest` 0.10 support 5.0.0.2 ------- * Bugfix for GHC 7.4. PolyKinds on 7.4 cause all sorts of haskell interface file errors. One of the #if guards that turned it off on 7.4 was missing and has been fixed. 5.0.0.1 ------- * Added the CHANGELOG to the distribution so that `hackage` can link to it in the haddocks. 5 - * Absorbed `Data.Bifunctor.Apply`, `Data.Semigroup.Bifoldable` and `Data.Semigroup.Traversable` from `bifunctors`. * This caused us to pick up a dependency on `tagged`. * Exiled `Data.Semifunctor.*`, `Data.Semigroupoid.Product` and `Data.Semigroupoid.Coproduct` to `semigroupoid-extras`. * This let us open up to older versions of GHC again. * Set an explicit fixity for `-<-` and `->-`. 4.5 --- * Major changes to the API to support PolyKinds and DataKinds. This necessarily shuts off GHC <= 7.4. * Orphan instances have moved upstream into a common `base-orphans` package. 4.3.1 ----- * Added `asum1` to `Data.Semigroup.Foldable`. 4.3.0.1 ------- * Support for 'ConstrainedClassMethods' is currently required for GHC HEAD. 4.3 ----- * Added missing instances for `ExceptT`. Obtain it via `transformers-compat` if need be for old `transformers` versions. * Several `Bind` and `Apply` instances now require somewhat more minimal contexts. 4.2 --- * Backported `Foldable`/`Traversable` instances from `lens` 4.1 --- * `Foldable1`/`Traversable1` for tuples 4.0.4 ----- * `contravariant` 1.0 support. 4.0.3 --- * Added flags to provide unsupported cabal sandbox build modes. 4.0.1 ----- * Fixed bitrot in the `Data.Functor.Extend` documentation. * Fixed warnings on GHC 7.8.1rc2 caused by importing `Control.Monad.Instances`. 4.0 --- * Merged in the contents of the `groupoids` and `semigroupoid-extras` packages. 3.1 --- * Added the [rectangular band](http://en.wikipedia.org/wiki/Band_(mathematics)#Rectangular_bands) `Semigroupoid` for `(,)`. Would that make it a Bandoid? 3.0.3 ----- * Claim to be `Trustworthy` where necessary 3.0.2 ----- * Tightened the upper bounds slightly to enable PVP compliance while retaining a flexible development cycle. * Raised the upper bound on `contravariant`. 3.0.1 ----- * Removed upper bounds relative to my other packages * Refactored directory layout semigroupoids-6.0.1/LICENSE0000644000000000000000000000236407346545000013612 0ustar0000000000000000Copyright 2011-2015 Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. semigroupoids-6.0.1/README.markdown0000644000000000000000000000503207346545000015301 0ustar0000000000000000semigroupoids ============= [![Hackage](https://img.shields.io/hackage/v/semigroupoids.svg)](https://hackage.haskell.org/package/semigroupoids) [![Build Status](https://github.com/ekmett/semigroupoids/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/semigroupoids/actions?query=workflow%3AHaskell-CI) A semigroupoid is a `Category` without `id`. This package provides a range of `id`-free versions of type classes, as well as some supporting functions and data types. Field Guide ----------- The diagram below describes the relationships between the type classes defined in this package, and those from `base` (with some from `contravariant` as well). Thick-bordered nodes correspond to type classes defined in this package; thin-bordered ones are from elsewhere. Solid edges represent subclass relationships that actually exist; dashed edges are those which _should_ exist in theory. ![A diagram of the relationships between type classes defined in this package and elsewhere.](https://raw.github.com/ekmett/semigroupoids/master/img/classes.svg) We also provide the following table. This is structured in superclass order - thus, for any type class `T`, all superclasses of `T` will be listed before `T` in the table. |**Name**|**Location**|**Superclass of**|**Ideally superclass of**| |--------|------------|-----------------|-------------------------| |`Functor`|`base`|`Alt`, `Apply`, `Traversable`|| |`Foldable`|`base`|`Traversable`, `Foldable1`|| |`Bifunctor`|`base`|`Biapply`|| |`Contravariant`|`base`|`Divise`, `Decide`|| |`Semigroupoid`|`semigroupoids`||`Category`| |`Alt`|`semigroupoids`|`Plus`|| |`Apply`|`semigroupoids`|`Bind`|`Applicative`| |`Traversable`|`base`|`Traversable1`|| |`Foldable1`|`semigroupoids`|`Traversable1`|| |`Biapply`|`semigroupoids`||| |`Divise`|`semigroupoids`||`Divisible`| |`Decide`|`semigroupoids`|`Conclude`|`Decidable`| |`Category`|`base`|`Arrow`|| |`Plus`|`semigroupoids`||`Alternative`| |`Applicative`|`base`|`Alternative`, `Monad`|| |`Bind`|`semigroupoids`||`Monad`| |`Traversable1`|`semigroupoids`||| |`Divisible`|`contravariant`||| |`Conclude`|`semigroupoids`||`Decidable`| |`Arrow`|`base`||| |`Alternative`|`base`|`MonadPlus`|| |`Monad`|`base`|`MonadPlus`|| |`Decidable`|`contravariant`||| |`MonadPlus`|`base`||| We omit some type class relationships from this diagram, as they are not relevant for the purposes of this package. Contact Information ------------------- Contributions and bug reports are welcome! Please feel free to contact me through Github or on the #haskell IRC channel on LiberaChat. -Edward Kmett semigroupoids-6.0.1/Setup.lhs0000644000000000000000000000016507346545000014412 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain semigroupoids-6.0.1/img/0000755000000000000000000000000007346545000013354 5ustar0000000000000000semigroupoids-6.0.1/img/classes.dot0000644000000000000000000000313707346545000015525 0ustar0000000000000000digraph { 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; } semigroupoids-6.0.1/img/classes.svg0000644000000000000000000003555707346545000015551 0ustar0000000000000000 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 semigroupoids-6.0.1/semigroupoids.cabal0000644000000000000000000001622607346545000016464 0ustar0000000000000000cabal-version: 1.24 name: semigroupoids category: Control, Comonads version: 6.0.1 license: BSD2 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/semigroupoids bug-reports: http://github.com/ekmett/semigroupoids/issues copyright: Copyright (C) 2011-2015 Edward A. Kmett tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.7 , GHC == 9.4.4 , GHC == 9.6.1 build-type: Simple synopsis: Semigroupoids: Category sans id extra-source-files: .gitignore .vim.custom README.markdown CHANGELOG.markdown img/classes.dot extra-doc-files: img/classes.svg description: Provides a wide array of (semi)groupoids and operations for working with them. . A 'Semigroupoid' is a 'Category' without the requirement of identity arrows for every object in the category. . A 'Category' is any 'Semigroupoid' for which the Yoneda lemma holds. . When working with comonads you often have the @\<*\>@ portion of an @Applicative@, but not the @pure@. This was captured in Uustalu and Vene's \"Essence of Dataflow Programming\" in the form of the @ComonadZip@ class in the days before @Applicative@. Apply provides a weaker invariant, but for the comonads used for data flow programming (found in the streams package), this invariant is preserved. Applicative function composition forms a semigroupoid. . Similarly many structures are nearly a comonad, but not quite, for instance lists provide a reasonable 'extend' operation in the form of 'tails', but do not always contain a value. . We describe the relationships between the type classes defined in this package and those from `base` (and some from `contravariant`) in the diagram below. Thick-bordered nodes correspond to type classes defined in this package; thin-bordered ones correspond to type classes from elsewhere. Solid edges indicate a subclass relationship that actually exists; dashed edges indicate a subclass relationship that /should/ exist, but currently doesn't. . <> . Apply, Bind, and Extend (not shown) give rise the Static, Kleisli and Cokleisli semigroupoids respectively. . This lets us remove many of the restrictions from various monad transformers as in many cases the binding operation or @\<*\>@ operation does not require them. . Finally, to work with these weaker structures it is beneficial to have containers that can provide stronger guarantees about their contents, so versions of 'Traversable' and 'Foldable' that can be folded with just a 'Semigroup' are added. source-repository head type: git location: git://github.com/ekmett/semigroupoids.git flag containers description: You can disable the use of the `containers` package using `-f-containers`. . Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. default: True manual: True flag contravariant description: You can disable the use of the `contravariant` package using `-f-contravariant`. . Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. . If disabled we will not supply instances of `Contravariant` . default: True manual: True flag distributive description: You can disable the use of the `distributive` package using `-f-distributive`. . Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. . If disabled we will not supply instances of `Distributive` . default: True manual: True flag comonad description: You can disable the use of the `comonad` package using `-f-comonad`. . Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. . If disabled we will not supply instances of `Comonad` . default: True manual: True flag tagged description: You can disable the use of the `tagged` package using `-f-tagged`. . Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. default: True manual: True flag unordered-containers description: You can disable the use of the `unordered-containers` package (and also its dependency `hashable`) using `-f-unordered-containers`. . Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. default: True manual: True library build-depends: base >= 4.9 && < 5, base-orphans >= 0.8.4 && < 1, bifunctors >= 5.6 && < 6, template-haskell >= 0.2.11, transformers >= 0.5 && < 0.7, transformers-compat >= 0.6 && < 0.8 if !impl(ghc >= 9.6) build-depends: foldable1-classes-compat >= 0.1 && < 0.2 -- On GHC-9.6&base-4.18 we require recent enough transformers and containers -- with Foldable1 instances. if impl(ghc >= 9.6) build-depends: transformers >= 0.6.1.0 if flag(containers) build-depends: containers >= 0.6.7 if flag(containers) build-depends: containers >= 0.5.7.1 && < 0.8 if flag(contravariant) build-depends: contravariant >= 1.5.3 && < 2 if flag(distributive) build-depends: distributive >= 0.5.2 && < 1 if flag(comonad) build-depends: comonad >= 5.0.8 && < 6 if flag(tagged) build-depends: tagged >= 0.8.7 && < 1 if flag(unordered-containers) build-depends: hashable >= 1.2.7.0 && < 1.5, unordered-containers >= 0.2.8.0 && < 0.3 hs-source-dirs: src exposed-modules: Data.Bifunctor.Apply Data.Functor.Alt Data.Functor.Apply Data.Functor.Bind Data.Functor.Bind.Class Data.Functor.Bind.Trans Data.Functor.Extend Data.Functor.Plus Data.Groupoid Data.Isomorphism Data.Semigroup.Bifoldable Data.Semigroup.Bitraversable Data.Semigroup.Foldable Data.Semigroup.Foldable.Class Data.Semigroup.Traversable Data.Semigroup.Traversable.Class Data.Semigroupoid Data.Semigroupoid.Categorical Data.Semigroupoid.Dual Data.Semigroupoid.Ob Data.Semigroupoid.Static Data.Traversable.Instances Semigroupoids.Do other-modules: Semigroupoids.Internal if impl(ghc >= 8.6) || flag(contravariant) exposed-modules: Data.Functor.Contravariant.Conclude Data.Functor.Contravariant.Decide Data.Functor.Contravariant.Divise ghc-options: -Wall -Wno-warnings-deprecations -Wno-trustworthy-safe if impl(ghc >= 9.0) -- these flags may abort compilation with GHC-8.10 -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295 ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode default-language: Haskell2010 semigroupoids-6.0.1/src/Data/Bifunctor/0000755000000000000000000000000007346545000016173 5ustar0000000000000000semigroupoids-6.0.1/src/Data/Bifunctor/Apply.hs0000644000000000000000000000215207346545000017614 0ustar0000000000000000{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Bifunctor.Apply ( -- * Biappliable bifunctors Bifunctor(..) , Biapply(..) , (<<$>>) , (<<..>>) , bilift2 , bilift3 ) where import Data.Functor.Bind.Class import Data.Biapplicative infixl 4 <<..>> (<<..>>) :: Biapply p => p a c -> p (a -> b) (c -> d) -> p b d (<<..>>) = bilift2 (flip id) (flip id) {-# INLINE (<<..>>) #-} -- | Lift binary functions bilift2 :: Biapply w => (a -> b -> c) -> (d -> e -> f) -> w a d -> w b e -> w c f bilift2 f g a b = bimap f g <<$>> a <<.>> b {-# INLINE bilift2 #-} -- | Lift ternary functions bilift3 :: Biapply w => (a -> b -> c -> d) -> (e -> f -> g -> h) -> w a e -> w b f -> w c g -> w d h bilift3 f g a b c = bimap f g <<$>> a <<.>> b <<.>> c {-# INLINE bilift3 #-} semigroupoids-6.0.1/src/Data/Functor/0000755000000000000000000000000007346545000015660 5ustar0000000000000000semigroupoids-6.0.1/src/Data/Functor/Alt.hs0000644000000000000000000002305107346545000016735 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstrainedClassMethods #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} {-# options_ghc -Wno-deprecations #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Alt -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Functor.Alt ( Alt(..) , optional , galt , module Data.Functor.Apply ) where import Control.Applicative hiding (some, many, optional) import Control.Applicative.Backwards import Control.Applicative.Lift import Control.Arrow import Control.Exception (catch, SomeException) import Control.Monad import Control.Monad.Trans.Identity import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader #if MIN_VERSION_transformers(0,5,6) import qualified Control.Monad.Trans.RWS.CPS as CPS import qualified Control.Monad.Trans.Writer.CPS as CPS import Semigroupoids.Internal #endif import qualified Control.Monad.Trans.RWS.Strict as Strict import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.Writer.Strict as Strict import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.State.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Lazy as Lazy import Data.Functor.Apply import Data.Functor.Compose import Data.Functor.Identity (Identity (Identity)) import Data.Functor.Product import Data.Functor.Reverse import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Monoid as Monoid import Data.Proxy import Data.Semigroup (Semigroup(..)) import qualified Data.Semigroup as Semigroup import GHC.Generics import Prelude (($),Either(..),Maybe(..),const,IO,(++),(.),either,seq,undefined,repeat,mappend) import Unsafe.Coerce #if !(MIN_VERSION_transformers(0,6,0)) import Control.Monad.Trans.Error import Control.Monad.Trans.List #endif #if !(MIN_VERSION_base(4,16,0)) import Data.Semigroup (Option(..)) #endif #ifdef MIN_VERSION_containers import qualified Data.IntMap as IntMap import Data.IntMap (IntMap) import Data.Sequence (Seq) import qualified Data.Map as Map import Data.Map (Map) import Prelude (Ord) #endif #ifdef MIN_VERSION_unordered_containers import Data.Hashable import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap import Prelude (Eq) #endif infixl 3 -- | Laws: -- -- > is associative: (a b) c = a (b c) -- > <$> left-distributes over : f <$> (a b) = (f <$> a) (f <$> b) -- -- If extended to an 'Alternative' then '' should equal '<|>'. -- -- Ideally, an instance of 'Alt' also satisfies the \"left distribution\" law of -- MonadPlus with respect to '<.>': -- -- > <.> right-distributes over : (a b) <.> c = (a <.> c) (b <.> c) -- -- 'IO', @'Either' a@, @'ExceptT' e m@ and 'GHC.Conc.STM' instead satisfy the -- \"left catch\" law: -- -- > pure a b = pure a -- -- 'Maybe' and 'Identity' satisfy both \"left distribution\" and \"left catch\". -- -- These variations cannot be stated purely in terms of the dependencies of 'Alt'. -- -- When and if MonadPlus is successfully refactored, this class should also -- be refactored to remove these instances. -- -- The right distributive law should extend in the cases where the a 'Bind' or 'Monad' is -- provided to yield variations of the right distributive law: -- -- > (m n) >>- f = (m >>- f) (m >>- f) -- > (m n) >>= f = (m >>= f) (m >>= f) class Functor f => Alt f where -- | '<|>' without a required @empty@ () :: f a -> f a -> f a some :: Applicative f => f a -> f [a] some v = some_v where many_v = some_v pure [] some_v = (:) <$> v <*> many_v many :: Applicative f => f a -> f [a] many v = many_v where many_v = some_v pure [] some_v = (:) <$> v <*> many_v -- | One or none. optional :: (Alt f, Applicative f) => f a -> f (Maybe a) optional v = Just <$> v pure Nothing -- | Generic (''). Caveats: -- -- 1. Will not compile if @f@ is a sum type. -- 2. Any types where the @a@ does not appear must have a 'Semigroup' instance. -- -- @since 5.3.8 galt :: (Generic1 f, Alt (Rep1 f)) => f a -> f a -> f a galt as bs = to1 $ from1 as from1 bs instance (Alt f, Alt g) => Alt (f :*: g) where (as :*: bs) (cs :*: ds) = (as cs) :*: (bs ds) -- | @since 5.3.8 instance (Alt f, Functor g) => Alt (f :.: g) where Comp1 as Comp1 bs = Comp1 (as bs) newtype Magic f = Magic { runMagic :: forall a. Applicative f => f a -> f [a] } instance Alt f => Alt (M1 i c f) where M1 f M1 g = M1 (f g) some = runMagic (unsafeCoerce (Magic some :: Magic f)) many = runMagic (unsafeCoerce (Magic many :: Magic f)) instance Alt f => Alt (Rec1 f) where Rec1 f Rec1 g = Rec1 (f g) some = runMagic (unsafeCoerce (Magic some :: Magic f)) many = runMagic (unsafeCoerce (Magic many :: Magic f)) -- | @since 5.3.8@ instance Semigroup c => Alt (K1 i c) where K1 c1 K1 c2 = K1 $ c1 <> c2 instance Alt U1 where _ _ = U1 some _ = U1 many _ = U1 instance Alt V1 where v u = v `seq` u `seq` undefined some v = v `seq` undefined many v = v `seq` undefined instance Alt Proxy where _ _ = Proxy some _ = Proxy many _ = Proxy instance Alt (Either a) where Left _ b = b a _ = a -- | This instance does not actually satisfy the ('<.>') right distributive law -- It instead satisfies the \"left catch\" law instance Alt IO where m n = catch m (go n) where go :: x -> SomeException -> x go = const -- | Choose the first option every time. While \'choose the last option\' every -- time is also valid, this instance satisfies more laws. -- -- @since 5.3.6 instance Alt Identity where {-# INLINEABLE () #-} m _ = m some (Identity x) = Identity . repeat $ x many (Identity x) = Identity . repeat $ x instance Alt [] where () = (++) instance Alt Maybe where Nothing b = b a _ = a #if !(MIN_VERSION_base(4,16,0)) instance Alt Option where () = (<|>) #endif instance MonadPlus m => Alt (WrappedMonad m) where () = (<|>) instance ArrowPlus a => Alt (WrappedArrow a b) where () = (<|>) #ifdef MIN_VERSION_containers instance Ord k => Alt (Map k) where () = Map.union instance Alt IntMap where () = IntMap.union instance Alt Seq where () = mappend #endif #ifdef MIN_VERSION_unordered_containers instance (Hashable k, Eq k) => Alt (HashMap k) where () = HashMap.union #endif instance Alt NonEmpty where (a :| as) ~(b :| bs) = a :| (as ++ b : bs) instance Alternative f => Alt (WrappedApplicative f) where WrapApplicative a WrapApplicative b = WrapApplicative (a <|> b) instance Alt f => Alt (IdentityT f) where IdentityT a IdentityT b = IdentityT (a b) instance Alt f => Alt (ReaderT e f) where ReaderT a ReaderT b = ReaderT $ \e -> a e b e instance (Functor f, Monad f) => Alt (MaybeT f) where MaybeT a MaybeT b = MaybeT $ do v <- a case v of Nothing -> b Just _ -> return v #if !(MIN_VERSION_transformers(0,6,0)) instance (Functor f, Monad f) => Alt (ErrorT e f) where ErrorT m ErrorT n = ErrorT $ do a <- m case a of Left _ -> n Right r -> return (Right r) instance Apply f => Alt (ListT f) where ListT a ListT b = ListT $ () <$> a <.> b #endif instance (Functor f, Monad f, Semigroup e) => Alt (ExceptT e f) where ExceptT m ExceptT n = ExceptT $ do a <- m case a of Left e -> liftM (either (Left . (<>) e) Right) n Right x -> return (Right x) instance Alt f => Alt (Strict.StateT e f) where Strict.StateT m Strict.StateT n = Strict.StateT $ \s -> m s n s instance Alt f => Alt (Lazy.StateT e f) where Lazy.StateT m Lazy.StateT n = Lazy.StateT $ \s -> m s n s instance Alt f => Alt (Strict.WriterT w f) where Strict.WriterT m Strict.WriterT n = Strict.WriterT $ m n instance Alt f => Alt (Lazy.WriterT w f) where Lazy.WriterT m Lazy.WriterT n = Lazy.WriterT $ m n #if MIN_VERSION_transformers(0,5,6) -- | @since 5.3.6 instance (Alt f) => Alt (CPS.WriterT w f) where m n = mkWriterT $ \w -> unWriterT m w unWriterT n w #endif instance Alt f => Alt (Strict.RWST r w s f) where Strict.RWST m Strict.RWST n = Strict.RWST $ \r s -> m r s n r s instance Alt f => Alt (Lazy.RWST r w s f) where Lazy.RWST m Lazy.RWST n = Lazy.RWST $ \r s -> m r s n r s #if MIN_VERSION_transformers(0,5,6) -- | @since 5.3.6 instance (Alt f) => Alt (CPS.RWST r w s f) where m n = mkRWST $ \r s w -> unRWST m r s w unRWST n r s w #endif instance Alt f => Alt (Backwards f) where Backwards a Backwards b = Backwards (a b) instance (Alt f, Functor g) => Alt (Compose f g) where Compose a Compose b = Compose (a b) instance Alt f => Alt (Lift f) where Pure a _ = Pure a Other _ Pure b = Pure b Other a Other b = Other (a b) instance (Alt f, Alt g) => Alt (Product f g) where Pair a1 b1 Pair a2 b2 = Pair (a1 a2) (b1 b2) instance Alt f => Alt (Reverse f) where Reverse a Reverse b = Reverse (a b) instance Alt Semigroup.First where () = (<>) instance Alt Semigroup.Last where () = (<>) instance Alt Monoid.First where () = mappend instance Alt Monoid.Last where () = mappend semigroupoids-6.0.1/src/Data/Functor/Apply.hs0000644000000000000000000000356507346545000017312 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Functor.Apply ( -- * Functors Functor(..) , (<$>) -- :: Functor f => (a -> b) -> f a -> f b , ( $>) -- :: Functor f => f a -> b -> f b -- * Apply - a strong lax semimonoidal endofunctor , Apply(..) , (<..>) -- :: Apply w => w a -> w (a -> b) -> w b , liftF3 -- :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d , gliftF2 , gliftF3 -- * Wrappers , WrappedApplicative(..) , MaybeApply(..) , (<.*>) , (<*.>) ) where import Data.Functor import Data.Functor.Bind.Class import GHC.Generics infixl 4 <..> -- | A variant of '<.>' with the arguments reversed. (<..>) :: Apply w => w a -> w (a -> b) -> w b (<..>) = liftF2 (flip id) {-# INLINE (<..>) #-} -- | Lift a ternary function into a comonad with zipping liftF3 :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d liftF3 f a b c = f <$> a <.> b <.> c {-# INLINE liftF3 #-} -- | Generic 'liftF2'. Caveats: -- -- 1. Will not compile if @w@ is a sum type. -- 2. Types in @w@ that do not mention the type variable must be instances of 'Semigroup'. -- -- @since 5.3.8 gliftF2 :: (Generic1 w, Apply (Rep1 w)) => (a -> b -> c) -> w a -> w b -> w c gliftF2 f wa wb = to1 $ liftF2 f (from1 wa) (from1 wb) -- | Generic 'liftF3'. Caveats are the same as for 'gliftF2'. -- -- @since 5.3.8 gliftF3 :: (Generic1 w, Apply (Rep1 w)) => (a -> b -> c -> d) -> w a -> w b -> w c -> w d gliftF3 f wa wb wc = to1 $ liftF3 f (from1 wa) (from1 wb) (from1 wc) semigroupoids-6.0.1/src/Data/Functor/Bind.hs0000644000000000000000000000342607346545000017075 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Functor.Bind ( -- * Functors Functor(..) , (<$>) -- :: Functor f => (a -> b) -> f a -> f b , ( $>) -- :: Functor f => f a -> b -> f b -- * Applyable functors , Apply(..) , (<..>) -- :: Apply w => w a -> w (a -> b) -> w b , liftF3 -- :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d -- * Wrappers , WrappedApplicative(..) , MaybeApply(..) -- * Bindable functors , Bind(..) , gbind , (-<<) , (-<-) , (->-) , apDefault , returning ) where import Data.Functor.Apply import Data.Functor.Bind.Class import GHC.Generics -- | Generic '(>>-)'. Caveats: -- -- 1. Will not compile if @m@ is a sum type. -- 2. Will not compile if @m@ contains fields that do not mention its type variable. -- 3. Will not compile if @m@ contains fields where the type variable appears underneath the composition of type constructors (e.g., @f (g a)@). -- 4. May do redundant work, due to the nature of the 'Bind' instance for (':*:') -- -- @since 5.3.8 gbind :: (Generic1 m, Bind (Rep1 m)) => m a -> (a -> m b) -> m b gbind m f = to1 $ from1 m >>- (\a -> from1 $ f a) infixr 1 -<<, -<-, ->- (-<<) :: Bind m => (a -> m b) -> m a -> m b (-<<) = flip (>>-) (->-) :: Bind m => (a -> m b) -> (b -> m c) -> a -> m c f ->- g = \a -> f a >>- g (-<-) :: Bind m => (b -> m c) -> (a -> m b) -> a -> m c g -<- f = \a -> f a >>- g semigroupoids-6.0.1/src/Data/Functor/Bind/0000755000000000000000000000000007346545000016534 5ustar0000000000000000semigroupoids-6.0.1/src/Data/Functor/Bind/Class.hs0000644000000000000000000006375707346545000020157 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-deprecations #-} {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2018 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- This module is used to resolve the cyclic we get from defining these -- classes here rather than in a package upstream. Otherwise we'd get -- orphaned heads for many instances on the types in @transformers@ and @bifunctors@. ---------------------------------------------------------------------------- module Data.Functor.Bind.Class ( -- * Applyable functors Apply(..) -- * Wrappers , WrappedApplicative(..) , MaybeApply(..) , (<.*>) , (<*.>) , traverse1Maybe -- * Bindable functors , Bind(..) , apDefault , returning -- * Biappliable bifunctors , Biapply(..) ) where import Data.Semigroup import Control.Applicative import Control.Applicative.Backwards import Control.Applicative.Lift import Control.Arrow import Control.Category import Control.Monad (ap) import Control.Monad.Trans.Cont import Control.Monad.Trans.Except import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader #if MIN_VERSION_transformers(0,5,6) import qualified Control.Monad.Trans.RWS.CPS as CPS import qualified Control.Monad.Trans.Writer.CPS as CPS import Semigroupoids.Internal #endif import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.State.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Lazy as Lazy import qualified Control.Monad.Trans.RWS.Strict as Strict import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.Writer.Strict as Strict import Data.Biapplicative import Data.Bifunctor.Biff import Data.Bifunctor.Clown import Data.Bifunctor.Flip import Data.Bifunctor.Joker import Data.Bifunctor.Join import Data.Bifunctor.Product as Bifunctor import Data.Bifunctor.Tannen import Data.Bifunctor.Wrapped import Data.Complex import Data.Functor.Compose import Data.Functor.Constant import Data.Functor.Identity import Data.Functor.Product as Functor import Data.Functor.Reverse import Data.Functor.Extend import Data.List.NonEmpty (NonEmpty) import Data.Ord (Down (..)) import Data.Proxy import Data.Semigroup as Semigroup import qualified Data.Monoid as Monoid import Data.Orphans () import GHC.Generics as Generics import Language.Haskell.TH (Q) import Prelude hiding (id, (.)) #if !(MIN_VERSION_transformers(0,6,0)) import Control.Monad.Trans.Error import Control.Monad.Trans.List #endif #ifdef MIN_VERSION_containers import qualified Data.IntMap as IntMap import Data.IntMap (IntMap) import qualified Data.Map as Map import Data.Map (Map) import Data.Sequence (Seq) import Data.Tree (Tree) #endif #ifdef MIN_VERSION_tagged import Data.Tagged #endif #ifdef MIN_VERSION_unordered_containers import Data.Hashable import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap #endif #ifdef MIN_VERSION_comonad import Control.Comonad import Control.Comonad.Trans.Env import Control.Comonad.Trans.Store import Control.Comonad.Trans.Traced #else ($>) :: Functor f => f a -> b -> f b ($>) = flip (<$) #endif infixl 1 >>- infixl 4 <.>, <., .> -- | A strong lax semi-monoidal endofunctor. -- This is equivalent to an 'Applicative' without 'pure'. -- -- Laws: -- -- @ -- ('.') '<$>' u '<.>' v '<.>' w = u '<.>' (v '<.>' w) -- x '<.>' (f '<$>' y) = ('.' f) '<$>' x '<.>' y -- f '<$>' (x '<.>' y) = (f '.') '<$>' x '<.>' y -- @ -- -- The laws imply that `.>` and `<.` really ignore their -- left and right results, respectively, and really -- return their right and left results, respectively. -- Specifically, -- -- @ -- (mf '<$>' m) '.>' (nf '<$>' n) = nf '<$>' (m '.>' n) -- (mf '<$>' m) '<.' (nf '<$>' n) = mf '<$>' (m '<.' n) -- @ class Functor f => Apply f where (<.>) :: f (a -> b) -> f a -> f b (<.>) = liftF2 id -- | @ a '.>' b = 'const' 'id' '<$>' a '<.>' b @ (.>) :: f a -> f b -> f b a .> b = const id <$> a <.> b -- | @ a '<.' b = 'const' '<$>' a '<.>' b @ (<.) :: f a -> f b -> f a a <. b = const <$> a <.> b -- | Lift a binary function into a comonad with zipping liftF2 :: (a -> b -> c) -> f a -> f b -> f c liftF2 f a b = f <$> a <.> b {-# INLINE liftF2 #-} {-# MINIMAL (<.>) | liftF2 #-} #ifdef MIN_VERSION_tagged instance Apply (Tagged a) where (<.>) = (<*>) (<.) = (<*) (.>) = (*>) #endif instance Apply Proxy where (<.>) = (<*>) (<.) = (<*) (.>) = (*>) instance Apply f => Apply (Backwards f) where Backwards f <.> Backwards a = Backwards (flip id <$> a <.> f) instance (Apply f, Apply g) => Apply (Compose f g) where Compose f <.> Compose x = Compose ((<.>) <$> f <.> x) -- | A @'Constant' f@ is not 'Applicative' unless its @f@ is a 'Monoid', but it is an instance of 'Apply' instance Semigroup f => Apply (Constant f) where Constant a <.> Constant b = Constant (a <> b) Constant a <. Constant b = Constant (a <> b) Constant a .> Constant b = Constant (a <> b) instance Apply f => Apply (Lift f) where Pure f <.> Pure x = Pure (f x) Pure f <.> Other y = Other (f <$> y) Other f <.> Pure x = Other (($ x) <$> f) Other f <.> Other y = Other (f <.> y) instance (Apply f, Apply g) => Apply (Functor.Product f g) where Functor.Pair f g <.> Functor.Pair x y = Functor.Pair (f <.> x) (g <.> y) instance Apply f => Apply (Reverse f) where Reverse a <.> Reverse b = Reverse (a <.> b) -- | A @'(,)' m@ is not 'Applicative' unless its @m@ is a 'Monoid', but it is an instance of 'Apply' instance Semigroup m => Apply ((,)m) where (m, f) <.> (n, a) = (m <> n, f a) (m, a) <. (n, _) = (m <> n, a) (m, _) .> (n, b) = (m <> n, b) instance Apply NonEmpty where (<.>) = ap instance Apply (Either a) where Left a <.> _ = Left a Right _ <.> Left a = Left a Right f <.> Right b = Right (f b) Left a <. _ = Left a Right _ <. Left a = Left a Right a <. Right _ = Right a Left a .> _ = Left a Right _ .> Left a = Left a Right _ .> Right b = Right b -- | A @'Const' m@ is not 'Applicative' unless its @m@ is a 'Monoid', but it is an instance of 'Apply' instance Semigroup m => Apply (Const m) where Const m <.> Const n = Const (m <> n) Const m <. Const n = Const (m <> n) Const m .> Const n = Const (m <> n) instance Apply ((->)m) where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) instance Apply ZipList where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) instance Apply [] where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) instance Apply IO where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) instance Apply Maybe where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) #if !(MIN_VERSION_base(4,16,0)) instance Apply Option where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) #endif instance Apply Identity where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) instance Apply w => Apply (IdentityT w) where IdentityT wa <.> IdentityT wb = IdentityT (wa <.> wb) instance Monad m => Apply (WrappedMonad m) where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) instance Arrow a => Apply (WrappedArrow a b) where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) instance Apply Complex where (a :+ b) <.> (c :+ d) = a c :+ b d -- Applicative Q was only added in template-haskell 2.7 (GHC 7.4), so -- define in terms of Monad instead. instance Apply Q where (<.>) = ap #ifdef MIN_VERSION_containers -- | A 'Map k' is not 'Applicative', but it is an instance of 'Apply' instance Ord k => Apply (Map k) where (<.>) = Map.intersectionWith id (<. ) = Map.intersectionWith const ( .>) = Map.intersectionWith (const id) -- | An 'IntMap' is not 'Applicative', but it is an instance of 'Apply' instance Apply IntMap where (<.>) = IntMap.intersectionWith id (<. ) = IntMap.intersectionWith const ( .>) = IntMap.intersectionWith (const id) instance Apply Seq where (<.>) = ap instance Apply Tree where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) #endif #ifdef MIN_VERSION_unordered_containers -- | A 'HashMap k' is not 'Applicative', but it is an instance of 'Apply' instance (Hashable k, Eq k) => Apply (HashMap k) where (<.>) = HashMap.intersectionWith id #endif -- MaybeT is _not_ the same as Compose f Maybe instance (Functor m, Monad m) => Apply (MaybeT m) where (<.>) = apDefault #if !(MIN_VERSION_transformers(0,6,0)) -- ErrorT e is _not_ the same as Compose f (Either e) instance (Functor m, Monad m) => Apply (ErrorT e m) where (<.>) = apDefault instance Apply m => Apply (ListT m) where ListT f <.> ListT a = ListT $ (<.>) <$> f <.> a #endif instance (Functor m, Monad m) => Apply (ExceptT e m) where (<.>) = apDefault instance Apply m => Apply (ReaderT e m) where ReaderT f <.> ReaderT a = ReaderT $ \e -> f e <.> a e -- unfortunately, WriterT has its wrapped product in the wrong order to just use (<.>) instead of flap -- | A @'Strict.WriterT' w m@ is not 'Applicative' unless its @w@ is a 'Monoid', but it is an instance of 'Apply' instance (Apply m, Semigroup w) => Apply (Strict.WriterT w m) where Strict.WriterT f <.> Strict.WriterT a = Strict.WriterT $ flap <$> f <.> a where flap (x,m) (y,n) = (x y, m <> n) -- | A @'Lazy.WriterT' w m@ is not 'Applicative' unless its @w@ is a 'Monoid', but it is an instance of 'Apply' instance (Apply m, Semigroup w) => Apply (Lazy.WriterT w m) where Lazy.WriterT f <.> Lazy.WriterT a = Lazy.WriterT $ flap <$> f <.> a where flap ~(x,m) ~(y,n) = (x y, m <> n) #if MIN_VERSION_transformers(0,5,6) -- | @since 5.3.6 instance (Bind m) => Apply (CPS.WriterT w m) where mf <.> mx = mkWriterT $ \w -> unWriterT mf w >>- \(f, w') -> unWriterT (f <$> mx) w' #endif instance Bind m => Apply (Strict.StateT s m) where (<.>) = apDefault instance Bind m => Apply (Lazy.StateT s m) where (<.>) = apDefault -- | An @'Strict.RWST' r w s m@ is not 'Applicative' unless its @w@ is a 'Monoid', but it is an instance of 'Apply' instance (Bind m, Semigroup w) => Apply (Strict.RWST r w s m) where (<.>) = apDefault -- | An @'Lazy.RWST' r w s m@ is not 'Applicative' unless its @w@ is a 'Monoid', but it is an instance of 'Apply' instance (Bind m, Semigroup w) => Apply (Lazy.RWST r w s m) where (<.>) = apDefault #if MIN_VERSION_transformers(0,5,6) -- | @since 5.3.6 instance (Bind m) => Apply (CPS.RWST r w s m) where mf <.> mx = mkRWST $ \ r s w -> unRWST mf r s w >>- \(f, s', w') -> unRWST (f <$> mx) r s' w' #endif instance Apply (ContT r m) where ContT f <.> ContT v = ContT $ \k -> f $ \g -> v (k . g) #ifdef MIN_VERSION_comonad -- | An @'EnvT' e w@ is not 'Applicative' unless its @e@ is a 'Monoid', but it is an instance of 'Apply' instance (Semigroup e, Apply w) => Apply (EnvT e w) where EnvT ef wf <.> EnvT ea wa = EnvT (ef <> ea) (wf <.> wa) -- | A @'StoreT' s w@ is not 'Applicative' unless its @s@ is a 'Monoid', but it is an instance of 'Apply' instance (Apply w, Semigroup s) => Apply (StoreT s w) where StoreT ff m <.> StoreT fa n = StoreT ((<*>) <$> ff <.> fa) (m <> n) instance Apply w => Apply (TracedT m w) where TracedT wf <.> TracedT wa = TracedT (ap <$> wf <.> wa) #endif -- | Wrap an 'Applicative' to be used as a member of 'Apply' newtype WrappedApplicative f a = WrapApplicative { unwrapApplicative :: f a } instance Functor f => Functor (WrappedApplicative f) where fmap f (WrapApplicative a) = WrapApplicative (f <$> a) instance Applicative f => Apply (WrappedApplicative f) where WrapApplicative f <.> WrapApplicative a = WrapApplicative (f <*> a) WrapApplicative a <. WrapApplicative b = WrapApplicative (a <* b) WrapApplicative a .> WrapApplicative b = WrapApplicative (a *> b) instance Applicative f => Applicative (WrappedApplicative f) where pure = WrapApplicative . pure WrapApplicative f <*> WrapApplicative a = WrapApplicative (f <*> a) WrapApplicative a <* WrapApplicative b = WrapApplicative (a <* b) WrapApplicative a *> WrapApplicative b = WrapApplicative (a *> b) instance Alternative f => Alternative (WrappedApplicative f) where empty = WrapApplicative empty WrapApplicative a <|> WrapApplicative b = WrapApplicative (a <|> b) -- | Transform an Apply into an Applicative by adding a unit. newtype MaybeApply f a = MaybeApply { runMaybeApply :: Either (f a) a } -- | Apply a non-empty container of functions to a possibly-empty-with-unit container of values. (<.*>) :: (Apply f) => f (a -> b) -> MaybeApply f a -> f b ff <.*> MaybeApply (Left fa) = ff <.> fa ff <.*> MaybeApply (Right a) = ($ a) <$> ff infixl 4 <.*> -- | Apply a possibly-empty-with-unit container of functions to a non-empty container of values. (<*.>) :: (Apply f) => MaybeApply f (a -> b) -> f a -> f b MaybeApply (Left ff) <*.> fa = ff <.> fa MaybeApply (Right f) <*.> fa = f <$> fa infixl 4 <*.> -- | Traverse a 'Traversable' using 'Apply', getting the results back in a 'MaybeApply'. traverse1Maybe :: (Traversable t, Apply f) => (a -> f b) -> t a -> MaybeApply f (t b) traverse1Maybe f = traverse (MaybeApply . Left . f) instance Functor f => Functor (MaybeApply f) where fmap f (MaybeApply (Right a)) = MaybeApply (Right (f a )) fmap f (MaybeApply (Left fa)) = MaybeApply (Left (f <$> fa)) instance Apply f => Apply (MaybeApply f) where MaybeApply (Right f) <.> MaybeApply (Right a) = MaybeApply (Right (f a )) MaybeApply (Right f) <.> MaybeApply (Left fa) = MaybeApply (Left (f <$> fa)) MaybeApply (Left ff) <.> MaybeApply (Right a) = MaybeApply (Left (($ a) <$> ff)) MaybeApply (Left ff) <.> MaybeApply (Left fa) = MaybeApply (Left (ff <.> fa)) MaybeApply a <. MaybeApply (Right _) = MaybeApply a MaybeApply (Right a) <. MaybeApply (Left fb) = MaybeApply (Left (a <$ fb)) MaybeApply (Left fa) <. MaybeApply (Left fb) = MaybeApply (Left (fa <. fb)) MaybeApply (Right _) .> MaybeApply b = MaybeApply b MaybeApply (Left fa) .> MaybeApply (Right b) = MaybeApply (Left (fa $> b )) MaybeApply (Left fa) .> MaybeApply (Left fb) = MaybeApply (Left (fa .> fb)) instance Apply f => Applicative (MaybeApply f) where pure a = MaybeApply (Right a) (<*>) = (<.>) (<* ) = (<. ) ( *>) = ( .>) instance Extend f => Extend (MaybeApply f) where duplicated w@(MaybeApply Right{}) = MaybeApply (Right w) duplicated (MaybeApply (Left fa)) = MaybeApply (Left (extended (MaybeApply . Left) fa)) #ifdef MIN_VERSION_comonad instance Comonad f => Comonad (MaybeApply f) where duplicate w@(MaybeApply Right{}) = MaybeApply (Right w) duplicate (MaybeApply (Left fa)) = MaybeApply (Left (extend (MaybeApply . Left) fa)) extract (MaybeApply (Left fa)) = extract fa extract (MaybeApply (Right a)) = a instance Apply (Cokleisli w a) where Cokleisli f <.> Cokleisli a = Cokleisli (\w -> (f w) (a w)) #endif instance Apply Down where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) instance Apply Monoid.Sum where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) instance Apply Monoid.Product where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) instance Apply Monoid.Dual where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) instance Apply Monoid.First where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) instance Apply Monoid.Last where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) deriving instance Apply f => Apply (Monoid.Alt f) -- in GHC 8.6 we'll have to deal with Apply f => Apply (Ap f) the same way instance Apply Semigroup.First where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) instance Apply Semigroup.Last where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) instance Apply Semigroup.Min where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) instance Apply Semigroup.Max where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) instance (Apply f, Apply g) => Apply (f :*: g) where (a :*: b) <.> (c :*: d) = (a <.> c) :*: (b <.> d) deriving instance Apply f => Apply (M1 i t f) deriving instance Apply f => Apply (Rec1 f) instance (Apply f, Apply g) => Apply (f :.: g) where Comp1 m <.> Comp1 n = Comp1 $ (<.>) <$> m <.> n instance Apply U1 where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) -- | A @'K1' i c@ is not 'Applicative' unless its @c@ is a 'Monoid', but it is an instance of 'Apply' instance Semigroup c => Apply (K1 i c) where K1 a <.> K1 b = K1 (a <> b) K1 a <. K1 b = K1 (a <> b) K1 a .> K1 b = K1 (a <> b) instance Apply Par1 where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) -- | A 'V1' is not 'Applicative', but it is an instance of 'Apply' instance Apply Generics.V1 where e <.> _ = case e of {} -- | A 'Monad' sans 'return'. -- -- Minimal definition: Either 'join' or '>>-' -- -- If defining both, then the following laws (the default definitions) must hold: -- -- > join = (>>- id) -- > m >>- f = join (fmap f m) -- -- Laws: -- -- > induced definition of <.>: f <.> x = f >>- (<$> x) -- -- Finally, there are two associativity conditions: -- -- > associativity of (>>-): (m >>- f) >>- g == m >>- (\x -> f x >>- g) -- > associativity of join: join . join = join . fmap join -- -- These can both be seen as special cases of the constraint that -- -- > associativity of (->-): (f ->- g) ->- h = f ->- (g ->- h) -- class Apply m => Bind m where (>>-) :: m a -> (a -> m b) -> m b m >>- f = join (fmap f m) join :: m (m a) -> m a join = (>>- id) {-# MINIMAL (>>-) | join #-} returning :: Functor f => f a -> (a -> b) -> f b returning = flip fmap apDefault :: Bind f => f (a -> b) -> f a -> f b apDefault f x = f >>- \f' -> f' <$> x -- | A @'(,)' m@ is not a 'Monad' unless its @m@ is a 'Monoid', but it is an instance of 'Bind' instance Semigroup m => Bind ((,) m) where ~(m, a) >>- f = let (n, b) = f a in (m <> n, b) #ifdef MIN_VERSION_tagged instance Bind (Tagged a) where Tagged a >>- f = f a join (Tagged a) = a #endif instance Bind Proxy where _ >>- _ = Proxy join _ = Proxy instance Bind (Either a) where Left a >>- _ = Left a Right a >>- f = f a instance (Bind f, Bind g) => Bind (Functor.Product f g) where Functor.Pair m n >>- f = Functor.Pair (m >>- fstP . f) (n >>- sndP . f) where fstP (Functor.Pair a _) = a sndP (Functor.Pair _ b) = b instance Bind ((->)m) where f >>- g = \e -> g (f e) e instance Bind [] where (>>-) = (>>=) instance Bind NonEmpty where (>>-) = (>>=) instance Bind IO where (>>-) = (>>=) instance Bind Maybe where (>>-) = (>>=) #if !(MIN_VERSION_base(4,16,0)) instance Bind Option where (>>-) = (>>=) #endif instance Bind Identity where (>>-) = (>>=) instance Bind Q where (>>-) = (>>=) instance Bind m => Bind (IdentityT m) where IdentityT m >>- f = IdentityT (m >>- runIdentityT . f) instance Monad m => Bind (WrappedMonad m) where WrapMonad m >>- f = WrapMonad $ m >>= unwrapMonad . f instance (Functor m, Monad m) => Bind (MaybeT m) where (>>-) = (>>=) -- distributive law requires Monad to inject @Nothing@ #if !(MIN_VERSION_transformers(0,6,0)) instance (Apply m, Monad m) => Bind (ListT m) where (>>-) = (>>=) -- distributive law requires Monad to inject @[]@ instance (Functor m, Monad m) => Bind (ErrorT e m) where m >>- k = ErrorT $ do a <- runErrorT m case a of Left l -> return (Left l) Right r -> runErrorT (k r) #endif instance (Functor m, Monad m) => Bind (ExceptT e m) where m >>- k = ExceptT $ do a <- runExceptT m case a of Left l -> return (Left l) Right r -> runExceptT (k r) instance Bind m => Bind (ReaderT e m) where ReaderT m >>- f = ReaderT $ \e -> m e >>- \x -> runReaderT (f x) e -- | A @'Lazy.WriterT' w m@ is not a 'Monad' unless its @w@ is a 'Monoid', but it is an instance of 'Bind' instance (Bind m, Semigroup w) => Bind (Lazy.WriterT w m) where m >>- k = Lazy.WriterT $ Lazy.runWriterT m >>- \ ~(a, w) -> Lazy.runWriterT (k a) `returning` \ ~(b, w') -> (b, w <> w') -- | A @'Strict.WriterT' w m@ is not a 'Monad' unless its @w@ is a 'Monoid', but it is an instance of 'Bind' instance (Bind m, Semigroup w) => Bind (Strict.WriterT w m) where m >>- k = Strict.WriterT $ Strict.runWriterT m >>- \ (a, w) -> Strict.runWriterT (k a) `returning` \ (b, w') -> (b, w <> w') #if MIN_VERSION_transformers(0,5,6) -- | @since 5.3.6 instance (Bind m) => Bind (CPS.WriterT w m) where m >>- k = mkWriterT $ \ w -> unWriterT m w >>- \(a, w') -> unWriterT (k a) w' #endif instance Bind m => Bind (Lazy.StateT s m) where m >>- k = Lazy.StateT $ \s -> Lazy.runStateT m s >>- \ ~(a, s') -> Lazy.runStateT (k a) s' instance Bind m => Bind (Strict.StateT s m) where m >>- k = Strict.StateT $ \s -> Strict.runStateT m s >>- \ ~(a, s') -> Strict.runStateT (k a) s' -- | An @'Lazy.RWST' r w s m@ is not a 'Monad' unless its @w@ is a 'Monoid', but it is an instance of 'Bind' instance (Bind m, Semigroup w) => Bind (Lazy.RWST r w s m) where m >>- k = Lazy.RWST $ \r s -> Lazy.runRWST m r s >>- \ ~(a, s', w) -> Lazy.runRWST (k a) r s' `returning` \ ~(b, s'', w') -> (b, s'', w <> w') -- | An @'Strict.RWST' r w s m@ is not a 'Monad' unless its @w@ is a 'Monoid', but it is an instance of 'Bind' instance (Bind m, Semigroup w) => Bind (Strict.RWST r w s m) where m >>- k = Strict.RWST $ \r s -> Strict.runRWST m r s >>- \ (a, s', w) -> Strict.runRWST (k a) r s' `returning` \ (b, s'', w') -> (b, s'', w <> w') #if MIN_VERSION_transformers(0,5,6) -- | @since 5.3.6 instance (Bind m) => Bind (CPS.RWST r w s m) where m >>- k = mkRWST $ \ r s w -> unRWST m r s w >>- \(a, s', w') -> unRWST (k a) r s' w' #endif instance Bind (ContT r m) where m >>- k = ContT $ \c -> runContT m $ \a -> runContT (k a) c instance Bind Complex where (a :+ b) >>- f = a' :+ b' where a' :+ _ = f a _ :+ b' = f b {-# INLINE (>>-) #-} #ifdef MIN_VERSION_containers -- | A 'Map k' is not a 'Monad', but it is an instance of 'Bind' instance Ord k => Bind (Map k) where m >>- f = Map.mapMaybeWithKey (\k -> Map.lookup k . f) m -- | An 'IntMap' is not a 'Monad', but it is an instance of 'Bind' instance Bind IntMap where m >>- f = IntMap.mapMaybeWithKey (\k -> IntMap.lookup k . f) m instance Bind Seq where (>>-) = (>>=) instance Bind Tree where (>>-) = (>>=) #endif #ifdef MIN_VERSION_unordered_containers -- | A 'HashMap k' is not a 'Monad', but it is an instance of 'Bind' instance (Hashable k, Eq k) => Bind (HashMap k) where -- this is needlessly painful m >>- f = HashMap.fromList $ do (k, a) <- HashMap.toList m case HashMap.lookup k (f a) of Just b -> [(k,b)] Nothing -> [] #endif instance Bind Down where Down a >>- f = f a instance Bind Monoid.Sum where (>>-) = (>>=) instance Bind Monoid.Product where (>>-) = (>>=) instance Bind Monoid.Dual where (>>-) = (>>=) instance Bind Monoid.First where (>>-) = (>>=) instance Bind Monoid.Last where (>>-) = (>>=) instance Bind f => Bind (Monoid.Alt f) where Monoid.Alt m >>- k = Monoid.Alt (m >>- Monoid.getAlt . k) -- in GHC 8.6 we'll have to deal with Bind f => Bind (Ap f) the same way instance Bind Semigroup.First where (>>-) = (>>=) instance Bind Semigroup.Last where (>>-) = (>>=) instance Bind Semigroup.Min where (>>-) = (>>=) instance Bind Semigroup.Max where (>>-) = (>>=) -- | A 'V1' is not a 'Monad', but it is an instance of 'Bind' instance Bind Generics.V1 where m >>- _ = case m of {} -- | @since 5.3.8 instance Bind Generics.U1 where (>>-)=(>>=) -- | @since 5.3.8 instance Bind f => Bind (Generics.M1 i c f) where M1 m >>- f = M1 $ m >>- \a -> case f a of M1 m' -> m' -- | @since 5.3.8 instance Bind m => Bind (Generics.Rec1 m) where Rec1 m >>- f = Rec1 $ m >>- \a -> case f a of Rec1 m' -> m' -- | @since 5.3.8 instance Bind Generics.Par1 where Par1 m >>- f = f m -- | @since 5.3.8 instance (Bind f, Bind g) => Bind (f :*: g) where m :*: n >>- f = (m >>- fstP . f) :*: (n >>- sndP . f) where fstP (a :*: _) = a sndP (_ :*: b) = b infixl 4 <<.>>, <<., .>> class Bifunctor p => Biapply p where (<<.>>) :: p (a -> b) (c -> d) -> p a c -> p b d -- | -- @ -- a '.>' b ≡ 'const' 'id' '<$>' a '<.>' b -- @ (.>>) :: p a b -> p c d -> p c d a .>> b = bimap (const id) (const id) <<$>> a <<.>> b {-# INLINE (.>>) #-} -- | -- @ -- a '<.' b ≡ 'const' '<$>' a '<.>' b -- @ (<<.) :: p a b -> p c d -> p a b a <<. b = bimap const const <<$>> a <<.>> b {-# INLINE (<<.) #-} instance Biapply (,) where (f, g) <<.>> (a, b) = (f a, g b) {-# INLINE (<<.>>) #-} instance Biapply Arg where Arg f g <<.>> Arg a b = Arg (f a) (g b) {-# INLINE (<<.>>) #-} instance Semigroup x => Biapply ((,,) x) where (x, f, g) <<.>> (x', a, b) = (x <> x', f a, g b) {-# INLINE (<<.>>) #-} instance (Semigroup x, Semigroup y) => Biapply ((,,,) x y) where (x, y, f, g) <<.>> (x', y', a, b) = (x <> x', y <> y', f a, g b) {-# INLINE (<<.>>) #-} instance (Semigroup x, Semigroup y, Semigroup z) => Biapply ((,,,,) x y z) where (x, y, z, f, g) <<.>> (x', y', z', a, b) = (x <> x', y <> y', z <> z', f a, g b) {-# INLINE (<<.>>) #-} instance Biapply Const where Const f <<.>> Const x = Const (f x) {-# INLINE (<<.>>) #-} #ifdef MIN_VERSION_tagged instance Biapply Tagged where Tagged f <<.>> Tagged x = Tagged (f x) {-# INLINE (<<.>>) #-} #endif instance (Biapply p, Apply f, Apply g) => Biapply (Biff p f g) where Biff fg <<.>> Biff xy = Biff (bimap (<.>) (<.>) fg <<.>> xy) {-# INLINE (<<.>>) #-} instance Apply f => Biapply (Clown f) where Clown fg <<.>> Clown xy = Clown (fg <.> xy) {-# INLINE (<<.>>) #-} instance Biapply p => Biapply (Flip p) where Flip fg <<.>> Flip xy = Flip (fg <<.>> xy) {-# INLINE (<<.>>) #-} instance Apply g => Biapply (Joker g) where Joker fg <<.>> Joker xy = Joker (fg <.> xy) {-# INLINE (<<.>>) #-} -- orphan mess instance Biapply p => Apply (Join p) where Join f <.> Join a = Join (f <<.>> a) {-# INLINE (<.>) #-} Join a .> Join b = Join (a .>> b) {-# INLINE (.>) #-} Join a <. Join b = Join (a <<. b) {-# INLINE (<.) #-} instance (Biapply p, Biapply q) => Biapply (Bifunctor.Product p q) where Bifunctor.Pair w x <<.>> Bifunctor.Pair y z = Bifunctor.Pair (w <<.>> y) (x <<.>> z) {-# INLINE (<<.>>) #-} instance (Apply f, Biapply p) => Biapply (Tannen f p) where Tannen fg <<.>> Tannen xy = Tannen ((<<.>>) <$> fg <.> xy) {-# INLINE (<<.>>) #-} instance Biapply p => Biapply (WrappedBifunctor p) where WrapBifunctor fg <<.>> WrapBifunctor xy = WrapBifunctor (fg <<.>> xy) {-# INLINE (<<.>>) #-} semigroupoids-6.0.1/src/Data/Functor/Bind/Trans.hs0000644000000000000000000000533507346545000020165 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Bind.Trans -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Functor.Bind.Trans ( BindTrans(..) ) where -- import _everything_ import Control.Category import Control.Monad.Trans.Class import Control.Monad.Trans.Cont -- import Control.Monad.Trans.Error import Control.Monad.Trans.Identity -- import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader -- import Control.Monad.Trans.List #if MIN_VERSION_transformers(0,5,6) import qualified Control.Monad.Trans.RWS.CPS as CPS import qualified Control.Monad.Trans.Writer.CPS as CPS #endif import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.State.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Lazy as Lazy import qualified Control.Monad.Trans.RWS.Strict as Strict import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.Writer.Strict as Strict import Data.Functor.Bind import Data.Orphans () #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup hiding (Product) #endif import Prelude hiding (id, (.)) -- | A subset of monad transformers can transform any 'Bind' as well. class MonadTrans t => BindTrans t where liftB :: Bind b => b a -> t b a instance BindTrans IdentityT where liftB = IdentityT instance BindTrans (ReaderT e) where liftB = ReaderT . const instance Monoid w => BindTrans (Lazy.WriterT w) where liftB = Lazy.WriterT . fmap (\a -> (a, mempty)) instance Monoid w => BindTrans (Strict.WriterT w) where liftB = Strict.WriterT . fmap (\a -> (a, mempty)) #if MIN_VERSION_transformers(0,5,6) -- | @since 5.3.6 instance Monoid w => BindTrans (CPS.WriterT w) where liftB = CPS.writerT . fmap (\a -> (a, mempty)) #endif instance BindTrans (Lazy.StateT s) where liftB m = Lazy.StateT $ \s -> fmap (\a -> (a, s)) m instance BindTrans (Strict.StateT s) where liftB m = Strict.StateT $ \s -> fmap (\a -> (a, s)) m instance Monoid w => BindTrans (Lazy.RWST r w s) where liftB m = Lazy.RWST $ \ _r s -> fmap (\a -> (a, s, mempty)) m instance Monoid w => BindTrans (Strict.RWST r w s) where liftB m = Strict.RWST $ \ _r s -> fmap (\a -> (a, s, mempty)) m #if MIN_VERSION_transformers(0,5,6) -- | @since 5.3.6 instance Monoid w => BindTrans (CPS.RWST r w s) where liftB m = CPS.rwsT $ \ _r s -> fmap (\a -> (a, s, mempty)) m #endif instance BindTrans (ContT r) where liftB m = ContT (m >>-) semigroupoids-6.0.1/src/Data/Functor/Contravariant/0000755000000000000000000000000007346545000020473 5ustar0000000000000000semigroupoids-6.0.1/src/Data/Functor/Contravariant/Conclude.hs0000644000000000000000000001627107346545000022572 0ustar0000000000000000{-# 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 semigroupoids-6.0.1/src/Data/Functor/Contravariant/Decide.hs0000644000000000000000000002151107346545000022204 0ustar0000000000000000{-# 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 semigroupoids-6.0.1/src/Data/Functor/Contravariant/Divise.hs0000644000000000000000000002351007346545000022253 0ustar0000000000000000{-# 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 semigroupoids-6.0.1/src/Data/Functor/Extend.hs0000644000000000000000000001612507346545000017450 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Extend -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Functor.Extend ( -- * Extendable Functors -- $definition Extend(..) , gduplicated , gextended ) where import Prelude hiding (id, (.)) import Control.Category import Control.Monad.Trans.Identity import Data.Functor.Identity import Data.Functor.Sum as Functor (Sum(..)) import Data.List (tails) import Data.List.NonEmpty (NonEmpty(..), toList) import Data.Orphans () import qualified Data.Monoid as Monoid import Data.Proxy import Data.Semigroup as Semigroup import GHC.Generics as Generics #ifdef MIN_VERSION_containers import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Tree #endif #ifdef MIN_VERSION_comonad import Control.Comonad.Trans.Env import Control.Comonad.Trans.Store import Control.Comonad.Trans.Traced #endif #ifdef MIN_VERSION_tagged import Data.Tagged #endif class Functor w => Extend w where -- | -- > duplicated = extended id -- > fmap (fmap f) . duplicated = duplicated . fmap f duplicated :: w a -> w (w a) -- | -- > extended f = fmap f . duplicated extended :: (w a -> b) -> w a -> w b extended f = fmap f . duplicated duplicated = extended id {-# MINIMAL duplicated | extended #-} -- | Generic 'duplicated'. Caveats: -- -- 1. Will not compile if @w@ is a product type. -- 2. Will not compile if @w@ contains fields where the type variable appears underneath the composition of type constructors (e.g., @f (g a)@). -- -- @since 5.3.8 gduplicated :: (Extend (Rep1 w), Generic1 w) => w a -> w (w a) gduplicated = to1 . fmap to1 . duplicated . from1 -- | Generic 'extended'. Caveats are the same as for 'gduplicated'. -- -- @since 5.3.8 gextended :: (Extend (Rep1 w), Generic1 w) => (w a -> b) -> w a -> w b gextended f = to1 . extended (f . to1) . from1 -- * Extends for Prelude types: -- -- Instances: While Data.Functor.Extend.Instances would be symmetric -- to the definition of Control.Monad.Instances in base, the reason -- the latter exists is because of Haskell 98 specifying the types -- @'Either' a@, @((,)m)@ and @((->)e)@ and the class Monad without -- having the foresight to require or allow instances between them. -- -- Here Haskell 98 says nothing about Extend, so we can include the -- instances directly avoiding the wart of orphan instances. instance Extend [] where duplicated = init . tails #ifdef MIN_VERSION_tagged instance Extend (Tagged a) where duplicated = Tagged #endif instance Extend Proxy where duplicated _ = Proxy extended _ _ = Proxy instance Extend Maybe where duplicated Nothing = Nothing duplicated j = Just j instance Extend (Either a) where duplicated (Left a) = Left a duplicated r = Right r instance Extend ((,)e) where duplicated p = (fst p, p) instance Semigroup m => Extend ((->)m) where duplicated f m = f . (<>) m #ifdef MIN_VERSION_containers instance Extend Seq where duplicated l = Seq.take (Seq.length l) (Seq.tails l) instance Extend Tree where duplicated w@(Node _ as) = Node w (map duplicated as) #endif #ifdef MIN_VERSION_comonad {- instance (Extend f, Extend g) => Extend (Coproduct f g) where extended f = Coproduct . coproduct (Left . extended (f . Coproduct . Left)) (Right . extended (f . Coproduct . Right)) -} instance Extend w => Extend (EnvT e w) where duplicated (EnvT e wa) = EnvT e (extended (EnvT e) wa) instance Extend w => Extend (StoreT s w) where duplicated (StoreT wf s) = StoreT (extended StoreT wf) s extended f (StoreT wf s) = StoreT (extended (\wf' s' -> f (StoreT wf' s')) wf) s instance (Extend w, Semigroup m) => Extend (TracedT m w) where extended f = TracedT . extended (\wf m -> f (TracedT (fmap (. (<>) m) wf))) . runTracedT #endif -- I can't fix the world -- instance (Monoid m, Extend n) => Extend (ReaderT m n) -- duplicate f m = f . mappend m -- * Extends for types from 'transformers'. -- -- This isn't really a transformer, so i have no compunction about including the instance here. -- -- TODO: Petition to move Data.Functor.Identity into base instance Extend Identity where duplicated = Identity -- Provided to avoid an orphan instance. Not proposed to standardize. -- If Extend moved to base, consider moving instance into transformers? instance Extend w => Extend (IdentityT w) where extended f (IdentityT m) = IdentityT (extended (f . IdentityT) m) instance Extend NonEmpty where extended f w@(~(_ :| aas)) = f w :| case aas of [] -> [] (a:as) -> toList (extended f (a :| as)) instance (Extend f, Extend g) => Extend (Functor.Sum f g) where extended f (InL l) = InL (extended (f . InL) l) extended f (InR r) = InR (extended (f . InR) r) instance (Extend f, Extend g) => Extend (f :+: g) where extended f (L1 l) = L1 (extended (f . L1) l) extended f (R1 r) = R1 (extended (f . R1) r) -- | @since 5.3.8 instance Extend (Generics.K1 i c) where duplicated (K1 c) = K1 c instance Extend Generics.U1 where extended _ U1 = U1 instance Extend Generics.V1 where extended _ e = case e of {} instance Extend f => Extend (Generics.M1 i t f) where extended f = M1 . extended (f . M1) . unM1 instance Extend Par1 where extended f w@Par1{} = Par1 (f w) instance Extend f => Extend (Rec1 f) where extended f = Rec1 . extended (f . Rec1) . unRec1 instance Extend Monoid.Sum where extended f w@Monoid.Sum{} = Monoid.Sum (f w) instance Extend Monoid.Product where extended f w@Monoid.Product{} = Monoid.Product (f w) instance Extend Monoid.Dual where extended f w@Monoid.Dual{} = Monoid.Dual (f w) instance Extend f => Extend (Monoid.Alt f) where extended f = Monoid.Alt . extended (f . Monoid.Alt) . Monoid.getAlt -- in GHC 8.6 we'll have to deal with Apply f => Apply (Ap f) the same way instance Extend Semigroup.First where extended f w@Semigroup.First{} = Semigroup.First (f w) instance Extend Semigroup.Last where extended f w@Semigroup.Last{} = Semigroup.Last (f w) instance Extend Semigroup.Min where extended f w@Semigroup.Min{} = Semigroup.Min (f w) instance Extend Semigroup.Max where extended f w@Semigroup.Max{} = Semigroup.Max (f w) -- $definition -- There are two ways to define an 'Extend' instance: -- -- I. Provide definitions for 'extended' -- satisfying this law: -- -- > extended f . extended g = extended (f . extended g) -- -- II. Alternately, you may choose to provide definitions for 'duplicated' -- satisfying this law: -- -- > duplicated . duplicated = fmap duplicated . duplicated -- -- You may of course, choose to define both 'duplicated' /and/ 'extended'. -- In that case you must also satisfy these laws: -- -- > extended f = fmap f . duplicated -- > duplicated = extended id -- -- These are the default definitions of 'extended' and 'duplicated'. semigroupoids-6.0.1/src/Data/Functor/Plus.hs0000644000000000000000000001342107346545000017140 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Functor.Plus ( Plus(..) , psum , gzero , module Data.Functor.Alt ) where import Control.Applicative hiding (some, many) import Control.Applicative.Backwards import Control.Applicative.Lift import Control.Arrow import Control.Monad import Control.Monad.Trans.Identity import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader #if MIN_VERSION_transformers(0,5,6) import qualified Control.Monad.Trans.RWS.CPS as CPS import qualified Control.Monad.Trans.Writer.CPS as CPS import Semigroupoids.Internal #endif import qualified Control.Monad.Trans.RWS.Strict as Strict import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.Writer.Strict as Strict import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.State.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Lazy as Lazy import Data.Foldable hiding (asum) import Data.Functor.Apply import Data.Functor.Alt import Data.Functor.Compose import Data.Functor.Product import Data.Functor.Reverse import qualified Data.Monoid as Monoid import Data.Proxy import Data.Semigroup hiding (Product) import GHC.Generics import Prelude hiding (id, (.), foldr) #if !(MIN_VERSION_transformers(0,6,0)) import Control.Monad.Trans.Error import Control.Monad.Trans.List #endif #ifdef MIN_VERSION_containers import qualified Data.IntMap as IntMap import Data.IntMap (IntMap) import Data.Sequence (Seq) import qualified Data.Map as Map import Data.Map (Map) #endif #ifdef MIN_VERSION_unordered_containers import Data.Hashable import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap #endif -- | Laws: -- -- > zero m = m -- > m zero = m -- -- If extended to an 'Alternative' then 'zero' should equal 'empty'. class Alt f => Plus f where zero :: f a -- | The sum of a collection of actions, generalizing 'concat'. -- -- >>> psum [Just "Hello", Nothing, Just "World"] -- Just "Hello" -- -- @since 5.3.6 psum :: (Foldable t, Plus f) => t (f a) -> f a psum = foldr () zero -- | Generic 'zero'. Caveats: -- -- 1. Will not compile if @f@ is a sum type. -- 2. Any types where the @a@ does not appear must have a 'Monoid' instance. -- -- @since 5.3.8 gzero :: (Plus (Rep1 f), Generic1 f) => f a gzero = to1 zero instance Plus Proxy where zero = Proxy instance Plus U1 where zero = U1 -- | @since 5.3.8 instance (Monoid c #if !(MIN_VERSION_base(4,11,0)) , Semigroup c #endif ) => Plus (K1 i c) where zero = K1 mempty instance (Plus f, Plus g) => Plus (f :*: g) where zero = zero :*: zero -- | @since 5.3.8 instance (Plus f, Functor g) => Plus (f :.: g) where zero = Comp1 zero instance Plus f => Plus (M1 i c f) where zero = M1 zero instance Plus f => Plus (Rec1 f) where zero = Rec1 zero instance Plus IO where zero = error "zero" instance Plus [] where zero = [] instance Plus Maybe where zero = Nothing #if !(MIN_VERSION_base(4,16,0)) instance Plus Option where zero = empty #endif instance MonadPlus m => Plus (WrappedMonad m) where zero = empty instance ArrowPlus a => Plus (WrappedArrow a b) where zero = empty #ifdef MIN_VERSION_containers instance Ord k => Plus (Map k) where zero = Map.empty instance Plus IntMap where zero = IntMap.empty instance Plus Seq where zero = mempty #endif #ifdef MIN_VERSION_unordered_containers instance (Hashable k, Eq k) => Plus (HashMap k) where zero = HashMap.empty #endif instance Alternative f => Plus (WrappedApplicative f) where zero = empty instance Plus f => Plus (IdentityT f) where zero = IdentityT zero instance Plus f => Plus (ReaderT e f) where zero = ReaderT $ \_ -> zero instance (Functor f, Monad f) => Plus (MaybeT f) where zero = MaybeT $ return zero #if !(MIN_VERSION_transformers(0,6,0)) instance (Functor f, Monad f, Error e) => Plus (ErrorT e f) where zero = ErrorT $ return $ Left noMsg instance (Apply f, Applicative f) => Plus (ListT f) where zero = ListT $ pure [] #endif instance (Functor f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f) where zero = ExceptT $ return $ Left mempty instance Plus f => Plus (Strict.StateT e f) where zero = Strict.StateT $ \_ -> zero instance Plus f => Plus (Lazy.StateT e f) where zero = Lazy.StateT $ \_ -> zero instance Plus f => Plus (Strict.WriterT w f) where zero = Strict.WriterT zero instance Plus f => Plus (Lazy.WriterT w f) where zero = Lazy.WriterT zero #if MIN_VERSION_transformers(0,5,6) -- | @since 5.3.6 instance (Plus f) => Plus (CPS.WriterT w f) where zero = mkWriterT $ const zero #endif instance Plus f => Plus (Strict.RWST r w s f) where zero = Strict.RWST $ \_ _ -> zero instance Plus f => Plus (Lazy.RWST r w s f) where zero = Lazy.RWST $ \_ _ -> zero #if MIN_VERSION_transformers(0,5,6) -- | @since 5.3.6 instance (Plus f) => Plus (CPS.RWST r w s f) where zero = mkRWST $ \_ _ _ -> zero #endif instance Plus f => Plus (Backwards f) where zero = Backwards zero instance (Plus f, Functor g) => Plus (Compose f g) where zero = Compose zero instance Plus f => Plus (Lift f) where zero = Other zero instance (Plus f, Plus g) => Plus (Product f g) where zero = Pair zero zero instance Plus f => Plus (Reverse f) where zero = Reverse zero instance Plus Monoid.First where zero = Monoid.First Nothing instance Plus Monoid.Last where zero = Monoid.Last Nothing semigroupoids-6.0.1/src/Data/0000755000000000000000000000000007346545000014240 5ustar0000000000000000semigroupoids-6.0.1/src/Data/Groupoid.hs0000644000000000000000000000225007346545000016363 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : polykinds -- ---------------------------------------------------------------------------- module Data.Groupoid ( Groupoid(..) ) where import Data.Semigroupoid import Data.Semigroupoid.Dual import qualified Data.Type.Coercion as Co import qualified Data.Type.Equality as Eq -- | semigroupoid with inverses. This technically should be a category with inverses, except we need to use Ob to define the valid objects for the category class Semigroupoid k => Groupoid k where inv :: k a b -> k b a instance Groupoid k => Groupoid (Dual k) where inv (Dual k) = Dual (inv k) instance Groupoid Co.Coercion where inv = Co.sym instance Groupoid (Eq.:~:) where inv = Eq.sym #if MIN_VERSION_base(4,10,0) instance Groupoid (Eq.:~~:) where inv Eq.HRefl = Eq.HRefl #endif semigroupoids-6.0.1/src/Data/Isomorphism.hs0000644000000000000000000000160407346545000017106 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} {-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : polykinds -- ---------------------------------------------------------------------------- module Data.Isomorphism ( Iso(..) ) where import Control.Category import Data.Semigroupoid import Data.Groupoid import Prelude () data Iso k a b = Iso { embed :: k a b, project :: k b a } instance Semigroupoid k => Semigroupoid (Iso k) where Iso f g `o` Iso h i = Iso (f `o` h) (i `o` g) instance Semigroupoid k => Groupoid (Iso k) where inv (Iso f g) = Iso g f instance Category k => Category (Iso k) where Iso f g . Iso h i = Iso (f . h) (i . g) id = Iso id id semigroupoids-6.0.1/src/Data/Semigroup/0000755000000000000000000000000007346545000016212 5ustar0000000000000000semigroupoids-6.0.1/src/Data/Semigroup/Bifoldable.hs0000644000000000000000000000402207346545000020567 0ustar0000000000000000{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- Re-exports a subset of the "Data.Bifoldable1" module along with some -- additional combinators that require 'Bifoldable1' constraints. -- ---------------------------------------------------------------------------- module Data.Semigroup.Bifoldable ( -- @Data.Bifoldable1@ re-exports Bifoldable1(bifold1, bifoldMap1) -- Additional @Bifoldable1@ functionality , bitraverse1_ , bifor1_ , bisequenceA1_ , bifoldMapDefault1 ) where import Control.Applicative import Data.Bifoldable import Data.Bifoldable1 import Data.Functor.Apply import Data.Semigroup import Prelude hiding (foldr) newtype Act f a = Act { getAct :: f a } instance Apply f => Semigroup (Act f a) where Act a <> Act b = Act (a .> b) {-# INLINE (<>) #-} instance Functor f => Functor (Act f) where fmap f (Act a) = Act (f <$> a) {-# INLINE fmap #-} b <$ Act a = Act (b <$ a) {-# INLINE (<$) #-} bitraverse1_ :: (Bifoldable1 t, Apply f) => (a -> f b) -> (c -> f d) -> t a c -> f () bitraverse1_ f g t = getAct (bifoldMap1 (Act . ignore . f) (Act . ignore . g) t) {-# INLINE bitraverse1_ #-} bifor1_ :: (Bifoldable1 t, Apply f) => t a c -> (a -> f b) -> (c -> f d) -> f () bifor1_ t f g = bitraverse1_ f g t {-# INLINE bifor1_ #-} ignore :: Functor f => f a -> f () ignore = (() <$) {-# INLINE ignore #-} bisequenceA1_ :: (Bifoldable1 t, Apply f) => t (f a) (f b) -> f () bisequenceA1_ t = getAct (bifoldMap1 (Act . ignore) (Act . ignore) t) {-# INLINE bisequenceA1_ #-} -- | Usable default for foldMap, but only if you define bifoldMap1 yourself bifoldMapDefault1 :: (Bifoldable1 t, Monoid m) => (a -> m) -> (b -> m) -> t a b -> m bifoldMapDefault1 f g = unwrapMonoid . bifoldMap (WrapMonoid . f) (WrapMonoid . g) {-# INLINE bifoldMapDefault1 #-} semigroupoids-6.0.1/src/Data/Semigroup/Bitraversable.hs0000644000000000000000000000147407346545000021341 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Semigroup.Bitraversable ( Bitraversable1(..) , bifoldMap1Default ) where import Control.Applicative #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif import Data.Semigroup.Traversable.Class bifoldMap1Default :: (Bitraversable1 t, Semigroup m) => (a -> m) -> (b -> m) -> t a b -> m bifoldMap1Default f g = getConst . bitraverse1 (Const . f) (Const . g) {-# INLINE bifoldMap1Default #-} semigroupoids-6.0.1/src/Data/Semigroup/Foldable.hs0000644000000000000000000000733107346545000020262 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- Re-exports a subset of the "Data.Foldable1" module along with some additional -- combinators that require 'Foldable1' constraints. -- ---------------------------------------------------------------------------- module Data.Semigroup.Foldable ( -- @Data.Foldable1@ re-exports Foldable1(fold1, foldMap1, toNonEmpty) , intercalate1 , foldrM1 , foldlM1 -- Additional @Foldable1@ functionality , intercalateMap1 , traverse1_ , for1_ , sequenceA1_ , foldMapDefault1 , asum1 -- Generic defaults , gfold1 , gfoldMap1 , gtoNonEmpty ) where import Data.Foldable import Data.Foldable1 import Data.Functor.Alt (Alt(..)) import Data.Functor.Apply import Data.List.NonEmpty (NonEmpty(..)) import Data.Traversable.Instances () import Data.Semigroup hiding (Product, Sum) import GHC.Generics import Prelude hiding (foldr) -- $setup -- >>> import Data.List.NonEmpty (NonEmpty (..)) -- >>> import Data.Monoid (Monoid (..)) newtype JoinWith a = JoinWith {joinee :: (a -> a)} instance Semigroup a => Semigroup (JoinWith a) where JoinWith a <> JoinWith b = JoinWith $ \j -> a j <> j <> b j -- | Insert @m@ between each pair of @m@ derived from @a@. -- -- >>> intercalateMap1 " " show $ True :| [False, True] -- "True False True" -- -- >>> intercalateMap1 " " show $ True :| [] -- "True" intercalateMap1 :: (Foldable1 t, Semigroup m) => m -> (a -> m) -> t a -> m intercalateMap1 j f = flip joinee j . foldMap1 (JoinWith . const . f) {-# INLINE intercalateMap1 #-} newtype Act f a = Act { getAct :: f a } instance Apply f => Semigroup (Act f a) where Act a <> Act b = Act (a .> b) instance Functor f => Functor (Act f) where fmap f (Act a) = Act (f <$> a) b <$ Act a = Act (b <$ a) traverse1_ :: (Foldable1 t, Apply f) => (a -> f b) -> t a -> f () traverse1_ f t = () <$ getAct (foldMap1 (Act . f) t) {-# INLINE traverse1_ #-} for1_ :: (Foldable1 t, Apply f) => t a -> (a -> f b) -> f () for1_ = flip traverse1_ {-# INLINE for1_ #-} sequenceA1_ :: (Foldable1 t, Apply f) => t (f a) -> f () sequenceA1_ t = () <$ getAct (foldMap1 Act t) {-# INLINE sequenceA1_ #-} -- | Usable default for foldMap, but only if you define foldMap1 yourself foldMapDefault1 :: (Foldable1 t, Monoid m) => (a -> m) -> t a -> m foldMapDefault1 f = unwrapMonoid . foldMap (WrapMonoid . f) {-# INLINE foldMapDefault1 #-} -- toStream :: Foldable1 t => t a -> Stream a -- concat1 :: Foldable1 t => t (Stream a) -> Stream a -- concatMap1 :: Foldable1 t => (a -> Stream b) -> t a -> Stream b newtype Alt_ f a = Alt_ { getAlt_ :: f a } instance Alt f => Semigroup (Alt_ f a) where Alt_ a <> Alt_ b = Alt_ (a b) asum1 :: (Foldable1 t, Alt m) => t (m a) -> m a asum1 = getAlt_ . foldMap1 Alt_ {-# INLINE asum1 #-} -- | Generic 'fold1'. Caveats: -- -- 1. Will not compile if @t@ is an empty constructor. -- 2. Will not compile if @t@ has some fields that don't mention @a@, for exmaple @data Bar a = MkBar a Int@ -- -- @since 5.3.8 gfold1 :: (Foldable1 (Rep1 t), Generic1 t, Semigroup m) => t m -> m gfold1 = fold1 . from1 -- | Generic 'foldMap1'. Caveats are the same as for 'gfold1'. -- -- @since 5.3.8 gfoldMap1 :: (Foldable1 (Rep1 t), Generic1 t, Semigroup m) => (a -> m) -> t a -> m gfoldMap1 f = foldMap1 f . from1 -- | Generic 'toNonEmpty'. Caveats are the same as for 'gfold1'. -- -- @since 5.3.8 gtoNonEmpty :: (Foldable1 (Rep1 t), Generic1 t) => t a -> NonEmpty a gtoNonEmpty = toNonEmpty . from1 semigroupoids-6.0.1/src/Data/Semigroup/Foldable/0000755000000000000000000000000007346545000017722 5ustar0000000000000000semigroupoids-6.0.1/src/Data/Semigroup/Foldable/Class.hs0000644000000000000000000000174707346545000021334 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Semigroup.Foldable.Class {-# DEPRECATED [ "This module re-exports a limited subset of the class methods in the " , "Foldable1 and Bifoldable1 classes, which are now located in the " , "Data.Foldable1 and Data.Bifoldable1 modules in base-4.18. " , "(On older versions of base, these can be found in the " , "foldable1-classes-compat library.) " , "Import from these modules instead." ] #-} ( Foldable1(fold1, foldMap1, toNonEmpty) , Bifoldable1(bifold1, bifoldMap1) ) where import Data.Bifoldable1 import Data.Foldable1 semigroupoids-6.0.1/src/Data/Semigroup/Traversable.hs0000644000000000000000000000420707346545000021023 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Semigroup.Traversable ( Traversable1(..) -- * Defining Traversable1 instances -- $traversable1instances , traverse1Maybe , gtraverse1 , gsequence1 -- * Default superclass instance helpers , foldMap1Default ) where import Control.Applicative #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif import Data.Semigroup.Traversable.Class import Data.Functor.Bind.Class import GHC.Generics -- | Default implementation of 'foldMap1' given an implementation of 'Traversable1'. foldMap1Default :: (Traversable1 f, Semigroup m) => (a -> m) -> f a -> m foldMap1Default f = getConst . traverse1 (Const . f) -- | Generic 'traverse1'. Caveats: -- -- 1. Will not compile if @t@ is an empty constructor. -- 2. Will not compile if @t@ has some fields that don't mention @a@, for exmaple @data Bar a = MkBar a Int@ -- -- @since 5.3.8 gtraverse1 :: (Traversable1 (Rep1 t), Apply f, Generic1 t) => (a -> f b) -> t a -> f (t b) gtraverse1 f x = to1 <$> traverse1 f (from1 x) -- | Generic 'sequence1'. Caveats are the same for 'gtraverse1'. -- -- @since 5.3.8 gsequence1 :: (Traversable1 (Rep1 t), Apply f, Generic1 t) => t (f b) -> f (t b) gsequence1 = fmap to1 . sequence1 . from1 -- $traversable1instances -- Defining 'Traversable1' instances for types with both 'Traversable1' and 'Traversable' -- substructures can be done with 'traverse1Maybe', '(<*.>)', and '(<.*>)'. -- -- > data Foo a = Foo (Maybe a) (Maybe a) a [a] -- > deriving (Functor, Traversable, Foldable) -- > instance Traversable1 Foo where -- > traverse1 f (Foo ma ma' a as) = Foo <$> traverseMaybe ma <*> traverseMaybe ma' <*.> f a <.*> traverseMaybe as -- > instance Foldable1 Foo where -- > foldMap1 = foldMap1Default semigroupoids-6.0.1/src/Data/Semigroup/Traversable/0000755000000000000000000000000007346545000020464 5ustar0000000000000000semigroupoids-6.0.1/src/Data/Semigroup/Traversable/Class.hs0000644000000000000000000001775707346545000022106 0ustar0000000000000000{-# LANGUAGE CPP, TypeOperators #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Semigroup.Traversable.Class ( Bitraversable1(..) , Traversable1(..) ) where import Control.Applicative import Data.Bitraversable import Data.Bifunctor import Data.Bifunctor.Biff import Data.Bifunctor.Clown import Data.Bifunctor.Flip import Data.Bifunctor.Joker import Data.Bifunctor.Join import Data.Bifunctor.Product as Bifunctor import Data.Bifunctor.Tannen import Data.Bifunctor.Wrapped import Data.Functor.Apply import Data.Functor.Compose import Data.Complex import Data.Functor.Identity import Data.Functor.Product as Functor import Data.Functor.Sum as Functor import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Monoid as Monoid import Data.Orphans () import Data.Semigroup as Semigroup import Data.Semigroup.Foldable import Data.Semigroup.Bifoldable #ifdef MIN_VERSION_tagged import Data.Tagged #endif import Data.Traversable.Instances () import GHC.Generics #ifdef MIN_VERSION_containers import Data.Tree #endif import Control.Applicative.Backwards import Control.Applicative.Lift import Control.Monad.Trans.Identity import Data.Functor.Reverse class (Bifoldable1 t, Bitraversable t) => Bitraversable1 t where bitraverse1 :: Apply f => (a -> f b) -> (c -> f d) -> t a c -> f (t b d) bitraverse1 f g = bisequence1 . bimap f g {-# INLINE bitraverse1 #-} bisequence1 :: Apply f => t (f a) (f b) -> f (t a b) bisequence1 = bitraverse1 id id {-# INLINE bisequence1 #-} {-# MINIMAL bitraverse1 | bisequence1 #-} instance Bitraversable1 Arg where bitraverse1 f g (Arg a b) = Arg <$> f a <.> g b instance Bitraversable1 Either where bitraverse1 f _ (Left a) = Left <$> f a bitraverse1 _ g (Right b) = Right <$> g b {-# INLINE bitraverse1 #-} instance Bitraversable1 (,) where bitraverse1 f g (a, b) = (,) <$> f a <.> g b {-# INLINE bitraverse1 #-} instance Bitraversable1 ((,,) x) where bitraverse1 f g (x, a, b) = (,,) x <$> f a <.> g b {-# INLINE bitraverse1 #-} instance Bitraversable1 ((,,,) x y) where bitraverse1 f g (x, y, a, b) = (,,,) x y <$> f a <.> g b {-# INLINE bitraverse1 #-} instance Bitraversable1 ((,,,,) x y z) where bitraverse1 f g (x, y, z, a, b) = (,,,,) x y z <$> f a <.> g b {-# INLINE bitraverse1 #-} instance Bitraversable1 Const where bitraverse1 f _ (Const a) = Const <$> f a {-# INLINE bitraverse1 #-} #ifdef MIN_VERSION_tagged instance Bitraversable1 Tagged where bitraverse1 _ g (Tagged b) = Tagged <$> g b {-# INLINE bitraverse1 #-} #endif instance (Bitraversable1 p, Traversable1 f, Traversable1 g) => Bitraversable1 (Biff p f g) where bitraverse1 f g = fmap Biff . bitraverse1 (traverse1 f) (traverse1 g) . runBiff {-# INLINE bitraverse1 #-} instance Traversable1 f => Bitraversable1 (Clown f) where bitraverse1 f _ = fmap Clown . traverse1 f . runClown {-# INLINE bitraverse1 #-} instance Bitraversable1 p => Bitraversable1 (Flip p) where bitraverse1 f g = fmap Flip . bitraverse1 g f . runFlip {-# INLINE bitraverse1 #-} instance Bitraversable1 p => Traversable1 (Join p) where traverse1 f (Join a) = fmap Join (bitraverse1 f f a) {-# INLINE traverse1 #-} sequence1 (Join a) = fmap Join (bisequence1 a) {-# INLINE sequence1 #-} instance Traversable1 g => Bitraversable1 (Joker g) where bitraverse1 _ g = fmap Joker . traverse1 g . runJoker {-# INLINE bitraverse1 #-} instance (Bitraversable1 f, Bitraversable1 g) => Bitraversable1 (Bifunctor.Product f g) where bitraverse1 f g (Bifunctor.Pair x y) = Bifunctor.Pair <$> bitraverse1 f g x <.> bitraverse1 f g y {-# INLINE bitraverse1 #-} instance (Traversable1 f, Bitraversable1 p) => Bitraversable1 (Tannen f p) where bitraverse1 f g = fmap Tannen . traverse1 (bitraverse1 f g) . runTannen {-# INLINE bitraverse1 #-} instance Bitraversable1 p => Bitraversable1 (WrappedBifunctor p) where bitraverse1 f g = fmap WrapBifunctor . bitraverse1 f g . unwrapBifunctor {-# INLINE bitraverse1 #-} class (Foldable1 t, Traversable t) => Traversable1 t where traverse1 :: Apply f => (a -> f b) -> t a -> f (t b) sequence1 :: Apply f => t (f b) -> f (t b) sequence1 = traverse1 id traverse1 f = sequence1 . fmap f {-# MINIMAL traverse1 | sequence1 #-} instance Traversable1 f => Traversable1 (Rec1 f) where traverse1 f (Rec1 as) = Rec1 <$> traverse1 f as instance Traversable1 f => Traversable1 (M1 i c f) where traverse1 f (M1 as) = M1 <$> traverse1 f as instance Traversable1 Par1 where traverse1 f (Par1 a) = Par1 <$> f a instance Traversable1 V1 where traverse1 _ v = v `seq` undefined instance (Traversable1 f, Traversable1 g) => Traversable1 (f :*: g) where traverse1 f (as :*: bs) = (:*:) <$> traverse1 f as <.> traverse1 f bs instance (Traversable1 f, Traversable1 g) => Traversable1 (f :+: g) where traverse1 f (L1 as) = L1 <$> traverse1 f as traverse1 f (R1 bs) = R1 <$> traverse1 f bs instance (Traversable1 f, Traversable1 g) => Traversable1 (f :.: g) where traverse1 f (Comp1 m) = Comp1 <$> traverse1 (traverse1 f) m instance Traversable1 Identity where traverse1 f = fmap Identity . f . runIdentity instance (Traversable1 f, Traversable1 g) => Traversable1 (Functor.Product f g) where traverse1 f (Functor.Pair a b) = Functor.Pair <$> traverse1 f a <.> traverse1 f b instance (Traversable1 f, Traversable1 g) => Traversable1 (Functor.Sum f g) where traverse1 f (Functor.InL x) = Functor.InL <$> traverse1 f x traverse1 f (Functor.InR y) = Functor.InR <$> traverse1 f y instance (Traversable1 f, Traversable1 g) => Traversable1 (Compose f g) where traverse1 f = fmap Compose . traverse1 (traverse1 f) . getCompose instance Traversable1 f => Traversable1 (IdentityT f) where traverse1 f = fmap IdentityT . traverse1 f . runIdentityT instance Traversable1 f => Traversable1 (Backwards f) where traverse1 f = fmap Backwards . traverse1 f . forwards instance Traversable1 f => Traversable1 (Lift f) where traverse1 f (Pure x) = Pure <$> f x traverse1 f (Other y) = Other <$> traverse1 f y instance Traversable1 f => Traversable1 (Reverse f) where traverse1 f = fmap Reverse . forwards . traverse1 (Backwards . f) . getReverse instance Traversable1 Complex where traverse1 f (a :+ b) = (:+) <$> f a <.> f b {-# INLINE traverse1 #-} #ifdef MIN_VERSION_tagged instance Traversable1 (Tagged a) where traverse1 f (Tagged a) = Tagged <$> f a #endif #ifdef MIN_VERSION_containers instance Traversable1 Tree where traverse1 f (Node a []) = (`Node`[]) <$> f a traverse1 f (Node a (x:xs)) = (\b (y:|ys) -> Node b (y:ys)) <$> f a <.> traverse1 (traverse1 f) (x :| xs) #endif instance Traversable1 NonEmpty where traverse1 f (a :| as) = foldr (\b g x -> (\a' (b':| bs') -> a' :| b': bs') <$> f x <.> g b) (fmap (:|[]) . f) as a instance Traversable1 ((,) a) where traverse1 f (a, b) = (,) a <$> f b instance Traversable1 g => Traversable1 (Joker g a) where traverse1 g = fmap Joker . traverse1 g . runJoker {-# INLINE traverse1 #-} instance Traversable1 Monoid.Sum where traverse1 g (Monoid.Sum a) = Monoid.Sum <$> g a instance Traversable1 Monoid.Product where traverse1 g (Monoid.Product a) = Monoid.Product <$> g a instance Traversable1 Monoid.Dual where traverse1 g (Monoid.Dual a) = Monoid.Dual <$> g a instance Traversable1 f => Traversable1 (Monoid.Alt f) where traverse1 g (Monoid.Alt m) = Monoid.Alt <$> traverse1 g m instance Traversable1 Semigroup.First where traverse1 g (Semigroup.First a) = Semigroup.First <$> g a instance Traversable1 Semigroup.Last where traverse1 g (Semigroup.Last a) = Semigroup.Last <$> g a instance Traversable1 Semigroup.Min where traverse1 g (Semigroup.Min a) = Semigroup.Min <$> g a instance Traversable1 Semigroup.Max where traverse1 g (Semigroup.Max a) = Semigroup.Max <$> g a semigroupoids-6.0.1/src/Data/Semigroupoid.hs0000644000000000000000000000534307346545000017247 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Semigroupoid -- Copyright : (C) 2007-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- A semigroupoid satisfies all of the requirements to be a Category except -- for the existence of identity arrows. ---------------------------------------------------------------------------- module Data.Semigroupoid ( Semigroupoid(..) , WrappedCategory(..) , Semi(..) ) where import Control.Applicative import Control.Arrow import Control.Category import Data.Functor.Bind import Data.Semigroup import qualified Data.Type.Coercion as Co import qualified Data.Type.Equality as Eq import Prelude hiding (id, (.)) #ifdef MIN_VERSION_contravariant import Data.Functor.Contravariant #endif #ifdef MIN_VERSION_comonad import Data.Functor.Extend import Control.Comonad #endif #ifdef MIN_VERSION_tagged import Data.Tagged (Tagged (..)) #endif -- | 'Control.Category.Category' sans 'Control.Category.id' class Semigroupoid c where o :: c j k -> c i j -> c i k instance Semigroupoid (->) where o = (.) -- | instance Semigroupoid (,) where o (_,k) (i,_) = (i,k) instance Bind m => Semigroupoid (Kleisli m) where Kleisli g `o` Kleisli f = Kleisli $ \a -> f a >>- g #ifdef MIN_VERSION_comonad instance Extend w => Semigroupoid (Cokleisli w) where Cokleisli f `o` Cokleisli g = Cokleisli $ f . extended g #endif #ifdef MIN_VERSION_contravariant instance Semigroupoid Op where Op f `o` Op g = Op (g `o` f) #endif newtype WrappedCategory k a b = WrapCategory { unwrapCategory :: k a b } instance Category k => Semigroupoid (WrappedCategory k) where WrapCategory f `o` WrapCategory g = WrapCategory (f . g) instance Category k => Category (WrappedCategory k) where id = WrapCategory id WrapCategory f . WrapCategory g = WrapCategory (f . g) newtype Semi m a b = Semi { getSemi :: m } instance Semigroup m => Semigroupoid (Semi m) where Semi m `o` Semi n = Semi (m <> n) instance Monoid m => Category (Semi m) where id = Semi mempty Semi m . Semi n = Semi (m `mappend` n) instance Semigroupoid Const where _ `o` Const a = Const a #ifdef MIN_VERSION_tagged instance Semigroupoid Tagged where Tagged b `o` _ = Tagged b #endif instance Semigroupoid Co.Coercion where o = flip Co.trans instance Semigroupoid (Eq.:~:) where o = flip Eq.trans #if MIN_VERSION_base(4,10,0) instance Semigroupoid (Eq.:~~:) where o Eq.HRefl Eq.HRefl = Eq.HRefl #endif semigroupoids-6.0.1/src/Data/Semigroupoid/0000755000000000000000000000000007346545000016706 5ustar0000000000000000semigroupoids-6.0.1/src/Data/Semigroupoid/Categorical.hs0000644000000000000000000000257407346545000021467 0ustar0000000000000000{-# 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 semigroupoids-6.0.1/src/Data/Semigroupoid/Dual.hs0000644000000000000000000000156707346545000020140 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} {-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2007-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- A semigroupoid satisfies all of the requirements to be a Category except -- for the existence of identity arrows. ---------------------------------------------------------------------------- module Data.Semigroupoid.Dual (Dual(..)) where import Data.Semigroupoid import Control.Category import Prelude () newtype Dual k a b = Dual { getDual :: k b a } instance Semigroupoid k => Semigroupoid (Dual k) where Dual f `o` Dual g = Dual (g `o` f) instance Category k => Category (Dual k) where id = Dual id Dual f . Dual g = Dual (g . f) semigroupoids-6.0.1/src/Data/Semigroupoid/Ob.hs0000644000000000000000000000204407346545000017602 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable (flexible MPTCs) -- ---------------------------------------------------------------------------- module Data.Semigroupoid.Ob where import Data.Semigroupoid import Data.Functor.Bind import Control.Arrow #ifdef MIN_VERSION_comonad import Data.Functor.Extend import Control.Comonad #endif class Semigroupoid k => Ob k a where semiid :: k a a instance (Bind m, Monad m) => Ob (Kleisli m) a where semiid = Kleisli return #ifdef MIN_VERSION_comonad instance (Extend w, Comonad w) => Ob (Cokleisli w) a where semiid = Cokleisli extract #endif instance Ob (->) a where semiid = id semigroupoids-6.0.1/src/Data/Semigroupoid/Static.hs0000644000000000000000000000512207346545000020471 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : polykinds -- ---------------------------------------------------------------------------- module Data.Semigroupoid.Static ( Static(..) ) where import Control.Arrow import Control.Applicative import Control.Category import Control.Monad (ap) import Data.Functor.Apply import Data.Functor.Plus import Data.Functor.Extend import Data.Orphans () import Data.Semigroup import Data.Semigroupoid import Prelude hiding ((.), id) #ifdef MIN_VERSION_comonad import Control.Comonad #endif newtype Static f a b = Static { runStatic :: f (a -> b) } instance Functor f => Functor (Static f a) where fmap f = Static . fmap (f .) . runStatic instance Apply f => Apply (Static f a) where Static f <.> Static g = Static (ap <$> f <.> g) instance Alt f => Alt (Static f a) where Static f Static g = Static (f g) instance Plus f => Plus (Static f a) where zero = Static zero instance Applicative f => Applicative (Static f a) where pure = Static . pure . const Static f <*> Static g = Static (ap <$> f <*> g) instance (Extend f, Semigroup a) => Extend (Static f a) where extended f = Static . extended (\wf m -> f (Static (fmap (. (<>) m) wf))) . runStatic #ifdef MIN_VERSION_comonad instance (Comonad f, Monoid a) => Comonad (Static f a) where extend f = Static . extend (\wf m -> f (Static (fmap (. mappend m) wf))) . runStatic extract (Static g) = extract g mempty #endif instance Apply f => Semigroupoid (Static f) where Static f `o` Static g = Static ((.) <$> f <.> g) instance Applicative f => Category (Static f) where id = Static (pure id) Static f . Static g = Static ((.) <$> f <*> g) instance Applicative f => Arrow (Static f) where arr = Static . pure first (Static g) = Static (first <$> g) second (Static g) = Static (second <$> g) Static g *** Static h = Static ((***) <$> g <*> h) Static g &&& Static h = Static ((&&&) <$> g <*> h) instance Alternative f => ArrowZero (Static f) where zeroArrow = Static empty instance Alternative f => ArrowPlus (Static f) where Static f <+> Static g = Static (f <|> g) instance Applicative f => ArrowChoice (Static f) where left (Static g) = Static (left <$> g) right (Static g) = Static (right <$> g) Static g +++ Static h = Static ((+++) <$> g <*> h) Static g ||| Static h = Static ((|||) <$> g <*> h) semigroupoids-6.0.1/src/Data/Traversable/0000755000000000000000000000000007346545000016512 5ustar0000000000000000semigroupoids-6.0.1/src/Data/Traversable/Instances.hs0000644000000000000000000000107707346545000021002 0ustar0000000000000000{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015,2018 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : polykinds -- -- Re-exports from the `base-orphans` and `transformers-compat` packages. ---------------------------------------------------------------------------- module Data.Traversable.Instances where import Control.Monad.Trans.Instances () import Data.Orphans () semigroupoids-6.0.1/src/Semigroupoids/0000755000000000000000000000000007346545000016220 5ustar0000000000000000semigroupoids-6.0.1/src/Semigroupoids/Do.hs0000644000000000000000000000315107346545000017116 0ustar0000000000000000{-# 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 semigroupoids-6.0.1/src/Semigroupoids/Internal.hs0000644000000000000000000000146207346545000020333 0ustar0000000000000000{-# 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