semigroupoids-5.3.7/0000755000000000000000000000000007346545000012610 5ustar0000000000000000semigroupoids-5.3.7/.gitignore0000644000000000000000000000036607346545000014605 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-5.3.7/.vim.custom0000644000000000000000000000137707346545000014725 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-5.3.7/CHANGELOG.markdown0000644000000000000000000001557707346545000015662 0ustar00000000000000005.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-5.3.7/LICENSE0000644000000000000000000000236407346545000013622 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-5.3.7/README.markdown0000644000000000000000000000503207346545000015311 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-5.3.7/Setup.lhs0000644000000000000000000000016507346545000014422 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain semigroupoids-5.3.7/img/0000755000000000000000000000000007346545000013364 5ustar0000000000000000semigroupoids-5.3.7/img/classes.dot0000644000000000000000000000313707346545000015535 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-5.3.7/img/classes.svg0000644000000000000000000003555707346545000015561 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-5.3.7/semigroupoids.cabal0000644000000000000000000001650007346545000016467 0ustar0000000000000000name: semigroupoids category: Control, Comonads version: 5.3.7 license: BSD2 cabal-version: 1.18 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 == 7.0.4 , GHC == 7.2.2 , GHC == 7.4.2 , GHC == 7.6.3 , GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.4 , GHC == 9.0.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.3 && < 5, base-orphans >= 0.8.4 && < 1, bifunctors >= 5.5.9 && < 6, template-haskell >= 0.2.5.0, transformers >= 0.3 && < 0.7, transformers-compat >= 0.5 && < 0.8 if impl(ghc >= 7.0 && < 7.2) build-depends: generic-deriving >= 1.14 && < 1.15 if impl(ghc >= 7.2 && < 7.6) build-depends: ghc-prim if !impl(ghc >= 7.10) build-depends: void >= 0.4 && < 1 if !impl(ghc >= 8.0) build-depends: semigroups >= 0.18.5 && < 1 if flag(containers) build-depends: containers >= 0.3 && < 0.7 if flag(contravariant) build-depends: contravariant >= 1.5.3 && < 2 if flag(distributive) build-depends: distributive >= 0.5.2 && < 1 if flag(comonad) build-depends: comonad >= 5.0.8 && < 6 if flag(tagged) build-depends: tagged >= 0.8.6.1 && < 1 if flag(unordered-containers) if impl(ghc >= 7.4) build-depends: hashable >= 1.2.7.0 && < 1.5, unordered-containers >= 0.2.8.0 && < 0.3 else build-depends: hashable >= 1.2.5.0 && < 1.5, unordered-containers >= 0.2.8.0 && < 0.3 hs-source-dirs: src exposed-modules: Data.Bifunctor.Apply Data.Functor.Alt Data.Functor.Apply Data.Functor.Bind Data.Functor.Bind.Class Data.Functor.Bind.Trans Data.Functor.Contravariant.Conclude Data.Functor.Contravariant.Decide Data.Functor.Contravariant.Divise Data.Functor.Extend Data.Functor.Plus Data.Groupoid Data.Isomorphism Data.Semigroup.Bifoldable Data.Semigroup.Bitraversable Data.Semigroup.Foldable Data.Semigroup.Foldable.Class Data.Semigroup.Traversable Data.Semigroup.Traversable.Class Data.Semigroupoid Data.Semigroupoid.Categorical Data.Semigroupoid.Dual Data.Semigroupoid.Ob Data.Semigroupoid.Static Data.Traversable.Instances Semigroupoids.Do other-modules: Semigroupoids.Internal ghc-options: -Wall -fno-warn-warnings-deprecations if impl(ghc >= 7.10) ghc-options: -fno-warn-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-5.3.7/src/Data/Bifunctor/0000755000000000000000000000000007346545000016203 5ustar0000000000000000semigroupoids-5.3.7/src/Data/Bifunctor/Apply.hs0000644000000000000000000000234307346545000017626 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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-5.3.7/src/Data/Functor/0000755000000000000000000000000007346545000015670 5ustar0000000000000000semigroupoids-5.3.7/src/Data/Functor/Alt.hs0000644000000000000000000002263007346545000016747 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 711 {-# LANGUAGE ConstrainedClassMethods #-} #endif {-# options_ghc -fno-warn-deprecations #-} ----------------------------------------------------------------------------- -- | -- 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 , 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.Semigroup (Semigroup(..)) import qualified Data.Semigroup as Semigroup import Prelude (($),Either(..),Maybe(..),const,IO,(++),(.),either,seq,undefined,repeat) 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,8,0) import Prelude (mappend) #else import Data.Monoid (mappend) #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 #if defined(MIN_VERSION_tagged) || (MIN_VERSION_base(4,7,0)) import Data.Proxy #endif #ifdef MIN_VERSION_unordered_containers import Data.Hashable import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap import Prelude (Eq) #endif #ifdef MIN_VERSION_generic_deriving import Generics.Deriving.Base #else import GHC.Generics #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 instance (Alt f, Alt g) => Alt (f :*: g) where (as :*: bs) (cs :*: ds) = (as cs) :*: (bs ds) 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)) 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 #if defined(MIN_VERSION_tagged) || (MIN_VERSION_base(4,7,0)) instance Alt Proxy where _ _ = Proxy some _ = Proxy many _ = Proxy #endif instance Alt (Either a) where Left _ b = b a _ = a -- | This instance does not actually satisfy the ('<.>') right distributive law -- It instead satisfies the \"left catch\" law 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-5.3.7/src/Data/Functor/Apply.hs0000644000000000000000000000273607346545000017321 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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 -- * Wrappers , WrappedApplicative(..) , MaybeApply(..) , (<.*>) , (<*.>) ) where import Data.Functor import Data.Functor.Bind.Class 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 #-} #if !(MIN_VERSION_base(4,7,0)) infixl 4 $> -- | Replace the contents of a functor uniformly with a constant value. ($>) :: Functor f => f a -> b -> f b ($>) = flip (<$) #endif semigroupoids-5.3.7/src/Data/Functor/Bind.hs0000644000000000000000000000254407346545000017105 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 {-# OPTIONS_GHC -fno-warn-amp #-} #endif ----------------------------------------------------------------------------- -- | -- 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(..) , (-<<) , (-<-) , (->-) , apDefault , returning ) where import Data.Functor.Apply import Data.Functor.Bind.Class 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-5.3.7/src/Data/Functor/Bind/0000755000000000000000000000000007346545000016544 5ustar0000000000000000semigroupoids-5.3.7/src/Data/Functor/Bind/Class.hs0000644000000000000000000006470107346545000020155 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE EmptyCase #-} #endif #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif {-# OPTIONS_HADDOCK not-home #-} #if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 {-# OPTIONS_GHC -fno-warn-amp #-} #endif {-# OPTIONS_GHC -fno-warn-deprecations #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-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.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.Semigroup as Semigroup import qualified Data.Monoid as Monoid import Data.Orphans () 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 #if MIN_VERSION_base(4,6,0) import Data.Ord (Down (..)) #else import GHC.Exts (Down (..)) #endif #if MIN_VERSION_base(4,4,0) import Data.Complex #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 #if defined(MIN_VERSION_tagged) || MIN_VERSION_base(4,7,0) import Data.Proxy #endif #ifdef MIN_VERSION_unordered_containers import Data.Hashable import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap #endif #ifdef MIN_VERSION_generic_deriving import Generics.Deriving.Base as Generics #else import GHC.Generics as Generics #endif #if __GLASGOW_HASKELL__ < 710 import Data.Traversable #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 #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 {-# MINIMAL (<.>) | liftF2 #-} #endif #ifdef MIN_VERSION_tagged instance Apply (Tagged a) where (<.>) = (<*>) (<.) = (<*) (.>) = (*>) #endif #if defined(MIN_VERSION_tagged) || MIN_VERSION_base(4,7,0) instance Apply Proxy where (<.>) = (<*>) (<.) = (<*) (.>) = (*>) #endif instance Apply f => Apply (Backwards f) where Backwards f <.> Backwards a = Backwards (flip id <$> a <.> f) 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 (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) #if MIN_VERSION_base(4,4,0) instance Apply Complex where (a :+ b) <.> (c :+ d) = a c :+ b d #endif -- Applicative Q was only added in template-haskell 2.7 (GHC 7.4), so -- define in terms of Monad instead. 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 (<.>)=(<*>);(.>)=(*>);(<.)=(<*) #if MIN_VERSION_base(4,8,0) deriving instance Apply f => Apply (Monoid.Alt f) #endif -- 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 #if __GLASGOW_HASKELL__ >= 708 e <.> _ = case e of {} #else e <.> _ = e `seq` undefined #endif -- | 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) #if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL (>>-) | join #-} #endif 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 #if defined(MIN_VERSION_tagged) || MIN_VERSION_base(4,7,0) instance Bind Proxy where _ >>- _ = Proxy join _ = Proxy #endif instance Bind (Either a) where Left a >>- _ = Left a 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 #if MIN_VERSION_base(4,4,0) instance Bind Complex where (a :+ b) >>- f = a' :+ b' where a' :+ _ = f a _ :+ b' = f b {-# INLINE (>>-) #-} #endif #ifdef MIN_VERSION_containers -- | A 'Map 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 (>>-) = (>>=) #if MIN_VERSION_base(4,8,0) instance Bind f => Bind (Monoid.Alt f) where Monoid.Alt m >>- k = Monoid.Alt (m >>- Monoid.getAlt . k) #endif -- 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 #if __GLASGOW_HASKELL__ >= 708 m >>- _ = case m of {} #else m >>- _ = m `seq` undefined #endif 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-5.3.7/src/Data/Functor/Bind/Trans.hs0000644000000000000000000000550107346545000020170 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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-5.3.7/src/Data/Functor/Contravariant/0000755000000000000000000000000007346545000020503 5ustar0000000000000000semigroupoids-5.3.7/src/Data/Functor/Contravariant/Conclude.hs0000644000000000000000000001470507346545000022602 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif {-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2021 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Functor.Contravariant.Conclude ( Conclude(..) , concluded ) where import Control.Applicative.Backwards import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.RWS.Strict as Strict import Control.Monad.Trans.Reader import qualified Control.Monad.Trans.State.Lazy as Lazy import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.Writer.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Strict as Strict import Data.Functor.Apply import Data.Functor.Compose import Data.Functor.Contravariant import Data.Functor.Contravariant.Decide import Data.Functor.Contravariant.Divise import Data.Functor.Contravariant.Divisible import Data.Functor.Product import Data.Functor.Reverse import Data.Void #if !(MIN_VERSION_transformers(0,6,0)) import Control.Monad.Trans.List #endif #if MIN_VERSION_base(4,8,0) import Data.Monoid (Alt(..)) #else import Control.Applicative #endif #if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) import Data.Proxy #endif #ifdef MIN_VERSION_StateVar import Data.StateVar #endif #if __GLASGOW_HASKELL__ >= 702 #define GHC_GENERICS import GHC.Generics #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 -- | 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 -- | @since 5.3.6 instance Decidable f => Conclude (WrappedDivisible f) where conclude f = WrapDivisible (lose f) -- | @since 5.3.6 instance Conclude Comparison where conclude = lose -- | @since 5.3.6 instance Conclude Equivalence where conclude = lose -- | @since 5.3.6 instance Conclude Predicate where conclude = lose -- | @since 5.3.6 instance Conclude (Op r) where conclude f = Op $ absurd . f #if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) -- | @since 5.3.6 instance Conclude Proxy where conclude = lose #endif #ifdef MIN_VERSION_StateVar -- | @since 5.3.6 instance Conclude SettableStateVar where conclude = lose #endif #if MIN_VERSION_base(4,8,0) -- | @since 5.3.6 instance Conclude f => Conclude (Alt f) where conclude = Alt . conclude #endif #ifdef GHC_GENERICS -- | @since 5.3.6 instance Conclude U1 where conclude = lose -- | @since 5.3.6 instance Conclude f => Conclude (Rec1 f) where conclude = Rec1 . conclude -- | @since 5.3.6 instance Conclude f => Conclude (M1 i c f) where conclude = M1 . conclude -- | @since 5.3.6 instance (Conclude f, Conclude g) => Conclude (f :*: g) where conclude f = conclude f :*: conclude f -- | @since 5.3.6 instance (Apply f, Applicative f, Conclude g) => Conclude (f :.: g) where conclude = Comp1 . pure . conclude #endif -- | @since 5.3.6 instance Conclude f => Conclude (Backwards f) where conclude = Backwards . conclude -- | @since 5.3.6 instance Conclude f => Conclude (IdentityT f) where conclude = IdentityT . conclude -- | @since 5.3.6 instance Conclude m => Conclude (ReaderT r m) where conclude f = ReaderT $ \_ -> conclude f -- | @since 5.3.6 instance Conclude m => Conclude (Lazy.RWST r w s m) where conclude f = Lazy.RWST $ \_ _ -> contramap (\ ~(a, _, _) -> a) (conclude f) -- | @since 5.3.6 instance Conclude m => Conclude (Strict.RWST r w s m) where conclude f = Strict.RWST $ \_ _ -> contramap (\(a, _, _) -> a) (conclude f) #if !(MIN_VERSION_transformers(0,6,0)) -- | @since 5.3.6 instance (Divisible m, Divise m) => Conclude (ListT m) where conclude _ = ListT conquer #endif -- | @since 5.3.6 instance (Divisible m, Divise m) => Conclude (MaybeT m) where conclude _ = MaybeT conquer -- | @since 5.3.6 instance Conclude m => Conclude (Lazy.StateT s m) where conclude f = Lazy.StateT $ \_ -> contramap lazyFst (conclude f) -- | @since 5.3.6 instance Conclude m => Conclude (Strict.StateT s m) where conclude f = Strict.StateT $ \_ -> contramap fst (conclude f) -- | @since 5.3.6 instance Conclude m => Conclude (Lazy.WriterT w m) where conclude f = Lazy.WriterT $ contramap lazyFst (conclude f) -- | @since 5.3.6 instance Conclude m => Conclude (Strict.WriterT w m) where conclude f = Strict.WriterT $ contramap fst (conclude f) -- | @since 5.3.6 instance (Apply f, Applicative f, Conclude g) => Conclude (Compose f g) where conclude = Compose . pure . conclude -- | @since 5.3.6 instance (Conclude f, Conclude g) => Conclude (Product f g) where conclude f = Pair (conclude f) (conclude f) -- | @since 5.3.6 instance Conclude f => Conclude (Reverse f) where conclude = Reverse . conclude -- Helpers lazyFst :: (a, b) -> a lazyFst ~(a, _) = a semigroupoids-5.3.7/src/Data/Functor/Contravariant/Decide.hs0000644000000000000000000001763207346545000022225 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #if MIN_VERSION_base(4,7,0) {-# LANGUAGE EmptyCase #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2021 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Functor.Contravariant.Decide ( Decide(..) , decided ) where import Control.Applicative.Backwards import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.RWS.Strict as Strict import Control.Monad.Trans.Reader import qualified Control.Monad.Trans.State.Lazy as Lazy import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.Writer.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Strict as Strict import Data.Functor.Apply import Data.Functor.Compose import Data.Functor.Contravariant import Data.Functor.Contravariant.Divise import Data.Functor.Contravariant.Divisible import Data.Functor.Product import Data.Functor.Reverse #if !(MIN_VERSION_transformers(0,6,0)) import Control.Arrow import Control.Monad.Trans.List import Data.Either #endif #if MIN_VERSION_base(4,8,0) import Data.Monoid (Alt(..)) #endif #if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) import Data.Proxy #endif #ifdef MIN_VERSION_StateVar import Data.StateVar #endif #if __GLASGOW_HASKELL__ >= 702 #define GHC_GENERICS import GHC.Generics #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 -- | 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 -- | @since 5.3.6 instance Decidable f => Decide (WrappedDivisible f) where decide f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (choose f x y) -- | @since 5.3.6 instance Decide Comparison where decide = choose -- | @since 5.3.6 instance Decide Equivalence where decide = choose -- | @since 5.3.6 instance Decide Predicate where decide = choose -- | Unlike 'Decidable', requires no constraint on @r@. -- -- @since 5.3.6 instance Decide (Op r) where decide f (Op g) (Op h) = Op $ either g h . f #if MIN_VERSION_base(4,8,0) -- | @since 5.3.6 instance Decide f => Decide (Alt f) where decide f (Alt l) (Alt r) = Alt $ decide f l r #endif #ifdef GHC_GENERICS -- | @since 5.3.6 instance Decide U1 where decide = choose -- | Has no 'Decidable' or 'Conclude' instance. -- -- @since 5.3.6 #if MIN_VERSION_base(4,7,0) instance Decide V1 where decide _ x = case x of {} #else instance Decide V1 where decide _ x = case x of !_ -> error "V1" #endif -- | @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) #endif -- | @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) #if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) -- | @since 5.3.6 instance Decide Proxy where decide _ Proxy Proxy = Proxy #endif #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-5.3.7/src/Data/Functor/Contravariant/Divise.hs0000644000000000000000000002235507346545000022271 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #if MIN_VERSION_base(4,7,0) {-# LANGUAGE EmptyCase #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2021 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Functor.Contravariant.Divise ( Divise(..) , divised , WrappedDivisible(..) ) where import Control.Applicative import Control.Applicative.Backwards import Control.Arrow import Control.Monad.Trans.Except import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.RWS.Strict as Strict import Control.Monad.Trans.Reader import qualified Control.Monad.Trans.State.Lazy as Lazy import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.Writer.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Strict as Strict import Data.Functor.Apply import Data.Functor.Compose import Data.Functor.Constant import Data.Functor.Contravariant import Data.Functor.Contravariant.Divisible import Data.Functor.Product import Data.Functor.Reverse #if !(MIN_VERSION_transformers(0,6,0)) import Control.Monad.Trans.Error import Control.Monad.Trans.List #endif #if MIN_VERSION_base(4,8,0) import Data.Monoid (Alt(..)) #else import Data.Monoid (Monoid(..)) #endif #if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,12,0) import Data.Semigroup (Semigroup(..)) #endif #if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) import Data.Proxy #endif #ifdef MIN_VERSION_StateVar import Data.StateVar #endif #if __GLASGOW_HASKELL__ >= 702 #define GHC_GENERICS import GHC.Generics #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 -- | 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 -- | Wrap a 'Divisible' to be used as a member of 'Divise' -- -- @since 5.3.6 newtype WrappedDivisible f a = WrapDivisible { unwrapDivisible :: f a } -- | @since 5.3.6 instance Contravariant f => Contravariant (WrappedDivisible f) where contramap f (WrapDivisible a) = WrapDivisible (contramap f a) -- | @since 5.3.6 instance Divisible f => Divise (WrappedDivisible f) where divise f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (divide f x y) #if MIN_VERSION_base(4,9,0) -- | 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) #else -- | @since 5.3.6 instance Monoid r => Divise (Op r) where divise = divide -- | @since 5.3.6 instance Monoid m => Divise (Const m) where divise = divide -- | @since 5.3.6 instance Monoid m => Divise (Constant m) where divise = divide #endif -- | @since 5.3.6 instance Divise Comparison where divise = divide -- | @since 5.3.6 instance Divise Equivalence where divise = divide -- | @since 5.3.6 instance Divise Predicate where divise = divide #if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) -- | @since 5.3.6 instance Divise Proxy where divise = divide #endif #ifdef MIN_VERSION_StateVar -- | @since 5.3.6 instance Divise SettableStateVar where divise = divide #endif #if MIN_VERSION_base(4,8,0) -- | @since 5.3.6 instance Divise f => Divise (Alt f) where divise f (Alt l) (Alt r) = Alt $ divise f l r #endif #ifdef GHC_GENERICS -- | @since 5.3.6 instance Divise U1 where divise = divide -- | Has no 'Divisible' instance. -- -- @since 5.3.6 #if MIN_VERSION_base(4,7,0) instance Divise V1 where divise _ x = case x of {} #else instance Divise V1 where divise _ !_ = error "V1" #endif -- | @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) #endif -- | @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-5.3.7/src/Data/Functor/Extend.hs0000644000000000000000000001550507346545000017461 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE EmptyCase #-} #endif ----------------------------------------------------------------------------- -- | -- 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(..) ) 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) #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 #if defined(MIN_VERSION_tagged) || MIN_VERSION_base(4,7,0) import Data.Proxy #endif #ifdef MIN_VERSION_generic_deriving import Generics.Deriving.Base as Generics #else import GHC.Generics as Generics #endif import Data.Orphans () import qualified Data.Monoid as Monoid import Data.Semigroup as Semigroup 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 #if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL duplicated | extended #-} #endif -- * 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 #if defined(MIN_VERSION_tagged) || MIN_VERSION_base(4,7,0) instance Extend Proxy where duplicated _ = Proxy extended _ _ = Proxy #endif instance Extend Maybe where duplicated Nothing = Nothing 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) instance Extend Generics.U1 where extended _ U1 = U1 instance Extend Generics.V1 where #if __GLASGOW_HASKELL__ >= 708 extended _ e = case e of {} #else extended _ e = seq e undefined #endif 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) #if MIN_VERSION_base(4,8,0) instance Extend f => Extend (Monoid.Alt f) where extended f = Monoid.Alt . extended (f . Monoid.Alt) . Monoid.getAlt #endif -- 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-5.3.7/src/Data/Functor/Plus.hs0000644000000000000000000001270407346545000017153 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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 , 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.Semigroup hiding (Product) 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 #if defined(MIN_VERSION_tagged) || (MIN_VERSION_base(4,7,0)) import Data.Proxy #endif #ifdef MIN_VERSION_unordered_containers import Data.Hashable import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap #endif #ifdef MIN_VERSION_generic_deriving import Generics.Deriving.Base #else import GHC.Generics #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 instance Plus Proxy where zero = Proxy instance Plus U1 where zero = U1 instance (Plus f, Plus g) => Plus (f :*: g) where zero = zero :*: 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-5.3.7/src/Data/0000755000000000000000000000000007346545000014250 5ustar0000000000000000semigroupoids-5.3.7/src/Data/Groupoid.hs0000644000000000000000000000247307346545000016402 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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 #if MIN_VERSION_base(4,7,0) import qualified Data.Type.Coercion as Co import qualified Data.Type.Equality as Eq #endif -- | semigroupoid with inverses. This technically should be a category with inverses, except we need to use Ob to define the valid objects for the category class Semigroupoid k => Groupoid k where inv :: k a b -> k b a instance Groupoid k => Groupoid (Dual k) where inv (Dual k) = Dual (inv k) #if MIN_VERSION_base(4,7,0) instance Groupoid Co.Coercion where inv = Co.sym instance Groupoid (Eq.:~:) where inv = Eq.sym #endif #if MIN_VERSION_base(4,10,0) instance Groupoid (Eq.:~~:) where inv Eq.HRefl = Eq.HRefl #endif semigroupoids-5.3.7/src/Data/Isomorphism.hs0000644000000000000000000000204307346545000017114 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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-5.3.7/src/Data/Semigroup/0000755000000000000000000000000007346545000016222 5ustar0000000000000000semigroupoids-5.3.7/src/Data/Semigroup/Bifoldable.hs0000644000000000000000000000364607346545000020612 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Semigroup.Bifoldable ( Bifoldable1(..) , bitraverse1_ , bifor1_ , bisequenceA1_ , bifoldMapDefault1 ) where import Control.Applicative import Data.Bifoldable import Data.Functor.Apply import Data.Semigroup import Data.Semigroup.Foldable.Class 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-5.3.7/src/Data/Semigroup/Bitraversable.hs0000644000000000000000000000164007346545000021344 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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-5.3.7/src/Data/Semigroup/Foldable.hs0000644000000000000000000001004007346545000020261 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Semigroup.Foldable ( Foldable1(..) , intercalate1 , intercalateMap1 , traverse1_ , for1_ , sequenceA1_ , foldMapDefault1 , asum1 , foldrM1 , foldlM1 ) where import Data.Foldable import Data.Functor.Alt (Alt(..)) import Data.Functor.Apply import Data.List.NonEmpty (NonEmpty(..)) import Data.Traversable.Instances () import Data.Semigroup hiding (Product, Sum) import Data.Semigroup.Foldable.Class import 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 an @m@ between each pair of @t m@. Equivalent to -- 'intercalateMap1' with 'id' as the second argument. -- -- >>> intercalate1 ", " $ "hello" :| ["how", "are", "you"] -- "hello, how, are, you" -- -- >>> intercalate1 ", " $ "hello" :| [] -- "hello" -- -- >>> intercalate1 mempty $ "I" :| ["Am", "Fine", "You?"] -- "IAmFineYou?" intercalate1 :: (Foldable1 t, Semigroup m) => m -> t m -> m intercalate1 = flip intercalateMap1 id {-# INLINE intercalate1 #-} -- | Insert @m@ between each pair of @m@ derived from @a@. -- -- >>> 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 #-} -- | Monadic fold over the elements of a non-empty structure, -- associating to the right, i.e. from right to left. -- -- > let g = (=<<) . f -- > in foldrM1 f (x1 :| [x2, ..., xn]) == x1 `g` (x2 `g` ... (xn-1 `f` xn)...) -- foldrM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a foldrM1 f = go . toNonEmpty where g = (=<<) . f go (e:|es) = case es of [] -> return e x:xs -> e `g` (go (x:|xs)) -- | Monadic fold over the elements of a non-empty structure, -- associating to the left, i.e. from left to right. -- -- > let g = flip $ (=<<) . f -- > in foldlM1 f (x1 :| [x2, ..., xn]) == (...((x1 `f` x2) `g` x2) `g`...) `g` xn -- foldlM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a foldlM1 f t = foldlM f x xs where x:|xs = toNonEmpty t semigroupoids-5.3.7/src/Data/Semigroup/Foldable/0000755000000000000000000000000007346545000017732 5ustar0000000000000000semigroupoids-5.3.7/src/Data/Semigroup/Foldable/Class.hs0000644000000000000000000002030407346545000021332 0ustar0000000000000000{-# LANGUAGE CPP, TypeOperators #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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 ( Foldable1(..) , Bifoldable1(..) ) where import Control.Applicative import Control.Applicative.Backwards import Control.Applicative.Lift import Control.Monad.Trans.Identity import Data.Bifoldable import Data.Bifunctor.Biff import Data.Bifunctor.Clown import Data.Bifunctor.Flip import Data.Bifunctor.Join import Data.Bifunctor.Product as Bifunctor import Data.Bifunctor.Joker import Data.Bifunctor.Tannen import Data.Bifunctor.Wrapped import Data.Foldable import Data.Functor.Identity import Data.Functor.Product as Functor import Data.Functor.Reverse import Data.Functor.Sum as Functor import Data.Functor.Compose import Data.List.NonEmpty (NonEmpty(..)) #if MIN_VERSION_base(4,4,0) import Data.Complex #endif #ifdef MIN_VERSION_tagged import Data.Tagged #endif import Data.Traversable.Instances () #ifdef MIN_VERSION_containers import Data.Tree #endif import qualified Data.Monoid as Monoid import Data.Semigroup as Semigroup hiding (Product, Sum) import Data.Orphans () -- import Data.Ord -- missing Foldable, https://ghc.haskell.org/trac/ghc/ticket/15098#ticket #ifdef MIN_VERSION_generic_deriving import Generics.Deriving.Base #else import GHC.Generics #endif import Prelude hiding (foldr) class Foldable t => Foldable1 t where fold1 :: Semigroup m => t m -> m foldMap1 :: Semigroup m => (a -> m) -> t a -> m toNonEmpty :: t a -> NonEmpty a foldMap1 f = maybe (error "foldMap1") id . getOptionCompat . foldMap (optionCompat . Just . f) fold1 = foldMap1 id toNonEmpty = foldMap1 (:|[]) instance Foldable1 Monoid.Sum where foldMap1 f (Monoid.Sum a) = f a instance Foldable1 Monoid.Product where foldMap1 f (Monoid.Product a) = f a instance Foldable1 Monoid.Dual where foldMap1 f (Monoid.Dual a) = f a #if MIN_VERSION_base(4,8,0) instance Foldable1 f => Foldable1 (Monoid.Alt f) where foldMap1 g (Monoid.Alt m) = foldMap1 g m #endif instance Foldable1 Semigroup.First where foldMap1 f (Semigroup.First a) = f a instance Foldable1 Semigroup.Last where foldMap1 f (Semigroup.Last a) = f a instance Foldable1 Semigroup.Min where foldMap1 f (Semigroup.Min a) = f a instance Foldable1 Semigroup.Max where foldMap1 f (Semigroup.Max a) = f a instance Foldable1 f => Foldable1 (Rec1 f) where foldMap1 f (Rec1 as) = foldMap1 f as instance Foldable1 f => Foldable1 (M1 i c f) where foldMap1 f (M1 as) = foldMap1 f as instance Foldable1 Par1 where foldMap1 f (Par1 a) = f a instance (Foldable1 f, Foldable1 g) => Foldable1 (f :*: g) where foldMap1 f (as :*: bs) = foldMap1 f as <> foldMap1 f bs instance (Foldable1 f, Foldable1 g) => Foldable1 (f :+: g) where foldMap1 f (L1 as) = foldMap1 f as foldMap1 f (R1 bs) = foldMap1 f bs instance Foldable1 V1 where foldMap1 _ v = v `seq` undefined instance (Foldable1 f, Foldable1 g) => Foldable1 (f :.: g) where foldMap1 f (Comp1 m) = foldMap1 (foldMap1 f) m class Bifoldable t => Bifoldable1 t where bifold1 :: Semigroup m => t m m -> m bifold1 = bifoldMap1 id id {-# INLINE bifold1 #-} bifoldMap1 :: Semigroup m => (a -> m) -> (b -> m) -> t a b -> m bifoldMap1 f g = maybe (error "bifoldMap1") id . getOptionCompat . bifoldMap (optionCompat . Just . f) (optionCompat . Just . g) {-# INLINE bifoldMap1 #-} instance Bifoldable1 Arg where bifoldMap1 f g (Arg a b) = f a <> g b instance Bifoldable1 Either where bifoldMap1 f _ (Left a) = f a bifoldMap1 _ g (Right b) = g b {-# INLINE bifoldMap1 #-} instance Bifoldable1 (,) where bifoldMap1 f g (a, b) = f a <> g b {-# INLINE bifoldMap1 #-} instance Bifoldable1 ((,,) x) where bifoldMap1 f g (_,a,b) = f a <> g b {-# INLINE bifoldMap1 #-} instance Bifoldable1 ((,,,) x y) where bifoldMap1 f g (_,_,a,b) = f a <> g b {-# INLINE bifoldMap1 #-} instance Bifoldable1 ((,,,,) x y z) where bifoldMap1 f g (_,_,_,a,b) = f a <> g b {-# INLINE bifoldMap1 #-} instance Bifoldable1 Const where bifoldMap1 f _ (Const a) = f a {-# INLINE bifoldMap1 #-} #ifdef MIN_VERSION_tagged instance Bifoldable1 Tagged where bifoldMap1 _ g (Tagged b) = g b {-# INLINE bifoldMap1 #-} #endif instance (Bifoldable1 p, Foldable1 f, Foldable1 g) => Bifoldable1 (Biff p f g) where bifoldMap1 f g = bifoldMap1 (foldMap1 f) (foldMap1 g) . runBiff {-# INLINE bifoldMap1 #-} instance Foldable1 f => Bifoldable1 (Clown f) where bifoldMap1 f _ = foldMap1 f . runClown {-# INLINE bifoldMap1 #-} instance Bifoldable1 p => Bifoldable1 (Flip p) where bifoldMap1 f g = bifoldMap1 g f . runFlip {-# INLINE bifoldMap1 #-} instance Bifoldable1 p => Foldable1 (Join p) where foldMap1 f (Join a) = bifoldMap1 f f a {-# INLINE foldMap1 #-} instance Foldable1 g => Bifoldable1 (Joker g) where bifoldMap1 _ g = foldMap1 g . runJoker {-# INLINE bifoldMap1 #-} instance (Bifoldable1 f, Bifoldable1 g) => Bifoldable1 (Bifunctor.Product f g) where bifoldMap1 f g (Bifunctor.Pair x y) = bifoldMap1 f g x <> bifoldMap1 f g y {-# INLINE bifoldMap1 #-} instance (Foldable1 f, Bifoldable1 p) => Bifoldable1 (Tannen f p) where bifoldMap1 f g = foldMap1 (bifoldMap1 f g) . runTannen {-# INLINE bifoldMap1 #-} instance Bifoldable1 p => Bifoldable1 (WrappedBifunctor p) where bifoldMap1 f g = bifoldMap1 f g . unwrapBifunctor {-# INLINE bifoldMap1 #-} #if MIN_VERSION_base(4,4,0) instance Foldable1 Complex where foldMap1 f (a :+ b) = f a <> f b {-# INLINE foldMap1 #-} #endif #ifdef MIN_VERSION_containers instance Foldable1 Tree where foldMap1 f (Node a []) = f a foldMap1 f (Node a (x:xs)) = f a <> foldMap1 (foldMap1 f) (x :| xs) #endif instance Foldable1 Identity where foldMap1 f = f . runIdentity #ifdef MIN_VERSION_tagged instance Foldable1 (Tagged a) where foldMap1 f (Tagged a) = f a #endif instance Foldable1 m => Foldable1 (IdentityT m) where foldMap1 f = foldMap1 f . runIdentityT instance Foldable1 f => Foldable1 (Backwards f) where foldMap1 f = foldMap1 f . forwards instance (Foldable1 f, Foldable1 g) => Foldable1 (Compose f g) where foldMap1 f = foldMap1 (foldMap1 f) . getCompose instance Foldable1 f => Foldable1 (Lift f) where foldMap1 f (Pure x) = f x foldMap1 f (Other y) = foldMap1 f y instance (Foldable1 f, Foldable1 g) => Foldable1 (Functor.Product f g) where foldMap1 f (Functor.Pair a b) = foldMap1 f a <> foldMap1 f b instance Foldable1 f => Foldable1 (Reverse f) where foldMap1 f = getDual . foldMap1 (Dual . f) . getReverse instance (Foldable1 f, Foldable1 g) => Foldable1 (Functor.Sum f g) where foldMap1 f (Functor.InL x) = foldMap1 f x foldMap1 f (Functor.InR y) = foldMap1 f y instance Foldable1 NonEmpty where foldMap1 f (a :| as) = foldr (\b g x -> f x <> g b) f as a toNonEmpty = id instance Foldable1 ((,) a) where foldMap1 f (_, x) = f x instance Foldable1 g => Foldable1 (Joker g a) where foldMap1 g = foldMap1 g . runJoker {-# INLINE foldMap1 #-} -- The default implementations of foldMap1 and bifoldMap1 above require the use -- of a Maybe type with the following Monoid instance: -- -- instance Semigroup a => Monoid (Maybe a) where ... -- -- Unfortunately, Maybe has only had such an instance since base-4.11. Prior -- to that, its Monoid instance had an instance context of Monoid a, which is -- too strong. To compensate, we use CPP to define an OptionCompat type -- synonym, which is an alias for Maybe on recent versions of base and an alias -- for Data.Semigroup.Option on older versions of base. We don't want to use -- Option on recent versions of base, as it has been removed. #if MIN_VERSION_base(4,11,0) type OptionCompat = Maybe optionCompat :: Maybe a -> OptionCompat a optionCompat = id getOptionCompat :: OptionCompat a -> Maybe a getOptionCompat = id #else type OptionCompat = Option optionCompat :: Maybe a -> OptionCompat a optionCompat = Option getOptionCompat :: OptionCompat a -> Maybe a getOptionCompat = getOption #endif semigroupoids-5.3.7/src/Data/Semigroup/Traversable.hs0000644000000000000000000000311607346545000021031 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Semigroup.Traversable ( Traversable1(..) -- * Defining Traversable1 instances -- $traversable1instances , traverse1Maybe -- * 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 -- | 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) -- $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-5.3.7/src/Data/Semigroup/Traversable/0000755000000000000000000000000007346545000020474 5ustar0000000000000000semigroupoids-5.3.7/src/Data/Semigroup/Traversable/Class.hs0000644000000000000000000002056607346545000022106 0ustar0000000000000000{-# LANGUAGE CPP, TypeOperators #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Semigroup.Traversable.Class ( Bitraversable1(..) , Traversable1(..) ) where import Control.Applicative import Control.Applicative.Backwards import Control.Applicative.Lift import Control.Monad.Trans.Identity 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.Functor.Identity import Data.Functor.Product as Functor import Data.Functor.Reverse 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 #if __GLASGOW_HASKELL__ < 710 import Data.Traversable #endif import Data.Traversable.Instances () #if MIN_VERSION_base(4,4,0) import Data.Complex #endif #ifdef MIN_VERSION_containers import Data.Tree #endif #ifdef MIN_VERSION_generic_deriving import Generics.Deriving.Base #else import GHC.Generics #endif class (Bifoldable1 t, Bitraversable t) => Bitraversable1 t where bitraverse1 :: Apply f => (a -> f b) -> (c -> f d) -> t a c -> f (t b d) bitraverse1 f g = bisequence1 . bimap f g {-# INLINE bitraverse1 #-} bisequence1 :: Apply f => t (f a) (f b) -> f (t a b) bisequence1 = bitraverse1 id id {-# INLINE bisequence1 #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 {-# MINIMAL bitraverse1 | bisequence1 #-} #endif 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 #if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL traverse1 | sequence1 #-} #endif 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 (IdentityT f) where traverse1 f = fmap IdentityT . traverse1 f . runIdentityT instance Traversable1 f => Traversable1 (Backwards f) where traverse1 f = fmap Backwards . traverse1 f . forwards instance (Traversable1 f, Traversable1 g) => Traversable1 (Compose f g) where traverse1 f = fmap Compose . traverse1 (traverse1 f) . getCompose instance Traversable1 f => Traversable1 (Lift f) where traverse1 f (Pure x) = Pure <$> f x traverse1 f (Other y) = Other <$> traverse1 f y instance (Traversable1 f, Traversable1 g) => Traversable1 (Functor.Product f g) where traverse1 f (Functor.Pair a b) = Functor.Pair <$> traverse1 f a <.> traverse1 f b instance Traversable1 f => Traversable1 (Reverse f) where traverse1 f = fmap Reverse . forwards . traverse1 (Backwards . f) . getReverse instance (Traversable1 f, Traversable1 g) => Traversable1 (Functor.Sum f g) where traverse1 f (Functor.InL x) = Functor.InL <$> traverse1 f x traverse1 f (Functor.InR y) = Functor.InR <$> traverse1 f y #if MIN_VERSION_base(4,4,0) instance Traversable1 Complex where traverse1 f (a :+ b) = (:+) <$> f a <.> f b {-# INLINE traverse1 #-} #endif #ifdef MIN_VERSION_tagged instance Traversable1 (Tagged a) where 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 #if MIN_VERSION_base(4,8,0) instance Traversable1 f => Traversable1 (Monoid.Alt f) where traverse1 g (Monoid.Alt m) = Monoid.Alt <$> traverse1 g m #endif 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-5.3.7/src/Data/Semigroupoid.hs0000644000000000000000000000557007346545000017261 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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 Data.Functor.Bind import Data.Semigroup import Control.Category 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 #if MIN_VERSION_base(4,7,0) import qualified Data.Type.Coercion as Co import qualified Data.Type.Equality as Eq #endif -- | 'Control.Category.Category' sans 'Control.Category.id' class Semigroupoid c where o :: c j k -> c i j -> c i k 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 #if MIN_VERSION_base(4,7,0) instance Semigroupoid Co.Coercion where o = flip Co.trans instance Semigroupoid (Eq.:~:) where o = flip Eq.trans #endif #if MIN_VERSION_base(4,10,0) instance Semigroupoid (Eq.:~~:) where o Eq.HRefl Eq.HRefl = Eq.HRefl #endif semigroupoids-5.3.7/src/Data/Semigroupoid/0000755000000000000000000000000007346545000016716 5ustar0000000000000000semigroupoids-5.3.7/src/Data/Semigroupoid/Categorical.hs0000644000000000000000000000247007346545000021472 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2021 Koz Ross -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Koz Ross -- Stability : Experimental -- Portability : GHC only -- -- Provides a way to attach an identity to any semigroupoid. ---------------------------------------------------------------------------- module Data.Semigroupoid.Categorical ( Categorical(..), runCategorical ) where import Control.Category (Category (id, (.))) import Data.Semigroupoid (Semigroupoid (o)) import Prelude () -- | Attaches an identity. -- -- @since 5.3.6 data Categorical s a b where Id :: Categorical s a a Embed :: s a b -> Categorical s a b -- | @since 5.3.6 instance (Semigroupoid s) => Semigroupoid (Categorical s) where Id `o` y = y x `o` Id = x Embed x `o` Embed y = Embed (x `o` y) -- | @since 5.3.6 instance (Semigroupoid s) => Category (Categorical s) where id = Id (.) = o -- | @since 5.3.6 runCategorical :: (a ~ b => r) -> (s a b -> r) -> Categorical s a b -> r runCategorical r _ Id = r runCategorical _ f (Embed x) = f x semigroupoids-5.3.7/src/Data/Semigroupoid/Dual.hs0000644000000000000000000000202607346545000020137 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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-5.3.7/src/Data/Semigroupoid/Ob.hs0000644000000000000000000000225607346545000017617 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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-5.3.7/src/Data/Semigroupoid/Static.hs0000644000000000000000000000537107346545000020507 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : polykinds -- ---------------------------------------------------------------------------- module Data.Semigroupoid.Static ( Static(..) ) where 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 LANGUAGE_DeriveDataTypeable import Data.Typeable #endif #ifdef MIN_VERSION_comonad import Control.Comonad #endif newtype Static f a b = Static { runStatic :: f (a -> b) } #ifdef LANGUAGE_DeriveDataTypeable deriving (Typeable) #endif instance Functor f => Functor (Static f a) where fmap f = Static . fmap (f .) . runStatic 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-5.3.7/src/Data/Traversable/0000755000000000000000000000000007346545000016522 5ustar0000000000000000semigroupoids-5.3.7/src/Data/Traversable/Instances.hs0000644000000000000000000000127007346545000021005 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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-5.3.7/src/Semigroupoids/0000755000000000000000000000000007346545000016230 5ustar0000000000000000semigroupoids-5.3.7/src/Semigroupoids/Do.hs0000644000000000000000000000363707346545000017137 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ == 708 {-# OPTIONS_GHC -fno-warn-amp #-} #endif {-| 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 #if !MIN_VERSION_base(4,8,0) import Control.Applicative (pure) import Prelude (String, fmap, return) #else import Prelude (String, fmap, pure, return) #endif 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-5.3.7/src/Semigroupoids/Internal.hs0000644000000000000000000000153107346545000020340 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif 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