semigroupoids-5.2.1/0000755000000000000000000000000013136723202012575 5ustar0000000000000000semigroupoids-5.2.1/CHANGELOG.markdown0000644000000000000000000000647213136723202015641 0ustar00000000000000005.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.2.1/README.markdown0000644000000000000000000000100513136723202015272 0ustar0000000000000000semigroupoids ========== [![Hackage](https://img.shields.io/hackage/v/semigroupoids.svg)](https://hackage.haskell.org/package/semigroupoids) [![Build Status](https://secure.travis-ci.org/ekmett/semigroupoids.png?branch=master)](http://travis-ci.org/ekmett/semigroupoids) A semigroupoid is a `Category` without `id`. Contact Information ------------------- Contributions and bug reports are welcome! Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. -Edward Kmett semigroupoids-5.2.1/Setup.lhs0000644000000000000000000000124113136723202014403 0ustar0000000000000000\begin{code} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall #-} module Main (main) where #ifndef MIN_VERSION_cabal_doctest #define MIN_VERSION_cabal_doctest(x,y,z) 0 #endif #if MIN_VERSION_cabal_doctest(1,0,0) import Distribution.Extra.Doctest ( defaultMainWithDoctests ) main :: IO () main = defaultMainWithDoctests "doctests" #else #ifdef MIN_VERSION_Cabal -- If the macro is defined, we have new cabal-install, -- but for some reason we don't have cabal-doctest in package-db -- -- Probably we are running cabal sdist, when otherwise using new-build -- workflow import Warning () #endif import Distribution.Simple main :: IO () main = defaultMain #endif \end{code} semigroupoids-5.2.1/.vim.custom0000644000000000000000000000137713136723202014712 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.2.1/Warning.hs0000644000000000000000000000040013136723202014530 0ustar0000000000000000module Warning {-# WARNING ["You are configuring this package without cabal-doctest installed.", "The doctests test-suite will not work as a result.", "To fix this, install cabal-doctest before configuring."] #-} () where semigroupoids-5.2.1/.travis.yml0000644000000000000000000001036413136723202014712 0ustar0000000000000000# This file has been generated -- see https://github.com/hvr/multi-ghc-travis language: c sudo: false cache: directories: - $HOME/.cabsnap - $HOME/.cabal/packages before_cache: - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar matrix: include: - env: CABALVER=1.24 GHCVER=7.0.4 compiler: ": #GHC 7.0.4" addons: {apt: {packages: [cabal-install-1.24,ghc-7.0.4], sources: [hvr-ghc]}} - env: CABALVER=1.24 GHCVER=7.2.2 compiler: ": #GHC 7.2.2" addons: {apt: {packages: [cabal-install-1.24,ghc-7.2.2], sources: [hvr-ghc]}} - env: CABALVER=1.24 GHCVER=7.4.2 compiler: ": #GHC 7.4.2" addons: {apt: {packages: [cabal-install-1.24,ghc-7.4.2], sources: [hvr-ghc]}} - env: CABALVER=1.24 GHCVER=7.6.3 compiler: ": #GHC 7.6.3" addons: {apt: {packages: [cabal-install-1.24,ghc-7.6.3], sources: [hvr-ghc]}} - env: CABALVER=1.24 GHCVER=7.8.4 compiler: ": #GHC 7.8.4" addons: {apt: {packages: [cabal-install-1.24,ghc-7.8.4], sources: [hvr-ghc]}} - env: CABALVER=1.24 GHCVER=7.10.3 compiler: ": #GHC 7.10.3" addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.3], sources: [hvr-ghc]}} - env: CABALVER=1.24 GHCVER=8.0.2 compiler: ": #GHC 8.0.2" addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2], sources: [hvr-ghc]}} - env: CABALVER=2.0 GHCVER=8.2.1 compiler: ": #GHC 8.2.1" addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.1], sources: [hvr-ghc]}} - env: CABALVER=head GHCVER=head compiler: ": #GHC head" addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}} allow_failures: - env: CABALVER=1.24 GHCVER=7.0.4 - env: CABALVER=1.24 GHCVER=7.2.2 - env: CABALVER=head GHCVER=head before_install: - unset CC - export PATH=$HOME/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH install: - cabal --version - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; then zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; fi - travis_retry cabal update -v - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config - cabal install --only-dependencies --enable-tests --dry -v > installplan.txt - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt # check whether current requested install-plan matches cached package-db snapshot - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; then echo "cabal build-cache HIT"; rm -rfv .ghc; cp -a $HOME/.cabsnap/ghc $HOME/.ghc; cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; else echo "cabal build-cache MISS"; rm -rf $HOME/.cabsnap; mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; cabal install -j --only-dependencies --enable-tests; fi # snapshot package-db on cache miss - if [ ! -d $HOME/.cabsnap ]; then echo "snapshotting package-db to build-cache"; mkdir $HOME/.cabsnap; cp -a $HOME/.ghc $HOME/.cabsnap/ghc; cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; fi # Here starts the actual work to be performed for the package under # test; any command which exits with a non-zero exit code causes the # build to fail. script: # -v2 provides useful information for debugging - cabal configure --enable-tests -v2 # this builds all libraries and executables # (including tests/benchmarks) - cabal build - cabal test # tests that a source-distribution can be generated - cabal sdist # check that the generated source-distribution can be built & installed - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ; cd dist/; if [ -f "$SRC_TGZ" ]; then cabal install --force-reinstalls "$SRC_TGZ"; else echo "expected '$SRC_TGZ' not found"; exit 1; fi notifications: irc: channels: - "irc.freenode.org#haskell-lens" skip_join: true template: - "\x0313semigroupoids\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" semigroupoids-5.2.1/.gitignore0000644000000000000000000000034313136723202014565 0ustar0000000000000000dist 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.2.1/LICENSE0000644000000000000000000000236413136723202013607 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.2.1/semigroupoids.cabal0000644000000000000000000001557313136723202016465 0ustar0000000000000000name: semigroupoids category: Control, Comonads version: 5.2.1 license: BSD3 cabal-version: >= 1.8 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.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1 build-type: Custom synopsis: Semigroupoids: Category sans id extra-source-files: .travis.yml .gitignore .vim.custom README.markdown CHANGELOG.markdown Warning.hs 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. . Ideally the following relationships would hold: . > Foldable ----> Traversable <--- Functor ------> Alt ---------> Plus Semigroupoid > | | | | | > v v v v v > Foldable1 ---> Traversable1 Apply --------> Applicative -> Alternative Category > | | | | > v v v v > Bind ---------> Monad -------> MonadPlus Arrow > . Apply, Bind, and Extend (not shown) give rise the Static, Kleisli and Cokleisli semigroupoids respectively. . 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 custom-setup setup-depends: base >= 4 && < 5, Cabal, cabal-doctest >= 1 && < 1.1 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 doctests description: You can disable testing with doctests using `-f-doctests`. default: True manual: True flag comonad description: You can disable the use of the `comonad` package using `-f-comonad`. . 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.5.4 && < 1, bifunctors >= 5 && < 6, semigroups >= 0.8.3.1 && < 1, transformers >= 0.2 && < 0.6, transformers-compat >= 0.5 && < 0.6 if impl(ghc >= 7.0 && < 7.4) build-depends: generic-deriving >= 1.11 && < 1.12 if impl(ghc >= 7.4 && < 7.6) build-depends: ghc-prim if flag(containers) build-depends: containers >= 0.3 && < 0.6 if flag(contravariant) build-depends: contravariant >= 0.2.0.1 && < 2 if flag(distributive) build-depends: distributive >= 0.2.2 && < 1 if flag(comonad) build-depends: comonad >= 4.2.6 && < 6 if flag(tagged) build-depends: tagged >= 0.7.3 && < 1 if flag(unordered-containers) build-depends: hashable >= 1.1 && < 1.3, unordered-containers >= 0.2 && < 0.3 hs-source-dirs: src exposed-modules: Data.Bifunctor.Apply Data.Functor.Alt Data.Functor.Apply Data.Functor.Bind Data.Functor.Bind.Class Data.Functor.Bind.Trans Data.Functor.Extend Data.Functor.Plus Data.Groupoid Data.Isomorphism Data.Semigroup.Bifoldable Data.Semigroup.Bitraversable Data.Semigroup.Foldable Data.Semigroup.Foldable.Class Data.Semigroup.Traversable Data.Semigroup.Traversable.Class Data.Semigroupoid Data.Semigroupoid.Dual Data.Semigroupoid.Ob Data.Semigroupoid.Static Data.Traversable.Instances ghc-options: -Wall -fno-warn-warnings-deprecations test-suite doctests type: exitcode-stdio-1.0 main-is: doctests.hs hs-source-dirs: test ghc-options: -Wall -fno-warn-warnings-deprecations if !flag(doctests) buildable: False else build-depends: base >= 4 && < 5, doctest >= 0.11.1 && < 0.13, semigroupoids semigroupoids-5.2.1/src/0000755000000000000000000000000013136723202013364 5ustar0000000000000000semigroupoids-5.2.1/src/Data/0000755000000000000000000000000013136723202014235 5ustar0000000000000000semigroupoids-5.2.1/src/Data/Isomorphism.hs0000644000000000000000000000165113136723202017105 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #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.2.1/src/Data/Semigroupoid.hs0000644000000000000000000000510013136723202017233 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL <= 706 && defined(MIN_VERSION_comonad) && !(MIN_VERSION_comonad(3,0,3)) {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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 -- | '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 semigroupoids-5.2.1/src/Data/Groupoid.hs0000644000000000000000000000160113136723202016357 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #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 -- | 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) semigroupoids-5.2.1/src/Data/Semigroupoid/0000755000000000000000000000000013136723202016703 5ustar0000000000000000semigroupoids-5.2.1/src/Data/Semigroupoid/Dual.hs0000644000000000000000000000163413136723202020130 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #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.2.1/src/Data/Semigroupoid/Static.hs0000644000000000000000000000552613136723202020476 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL <= 706 && defined(MIN_VERSION_comonad) && !(MIN_VERSION_comonad(3,0,3)) {-# 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.2.1/src/Data/Semigroupoid/Ob.hs0000644000000000000000000000206413136723202017601 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- 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.2.1/src/Data/Bifunctor/0000755000000000000000000000000013136723202016170 5ustar0000000000000000semigroupoids-5.2.1/src/Data/Bifunctor/Apply.hs0000644000000000000000000000215113136723202017610 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- 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.2.1/src/Data/Functor/0000755000000000000000000000000013136723202015655 5ustar0000000000000000semigroupoids-5.2.1/src/Data/Functor/Bind.hs0000644000000000000000000000300313136723202017061 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL <= 706 && defined(MIN_VERSION_comonad) && !(MIN_VERSION_comonad(3,0,3)) {-# 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 , liftF2 -- :: Apply w => (a -> b -> c) -> w a -> w b -> w c , liftF3 -- :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d -- * Wrappers , WrappedApplicative(..) , MaybeApply(..) -- * Bindable functors , Bind(..) , (-<<) , (-<-) , (->-) , 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.2.1/src/Data/Functor/Apply.hs0000644000000000000000000000313213136723202017275 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL <= 706 && defined(MIN_VERSION_comonad) && !(MIN_VERSION_comonad(3,0,3)) {-# 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 , liftF2 -- :: Apply w => (a -> b -> c) -> w a -> w b -> w c , liftF3 -- :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d -- * Wrappers , WrappedApplicative(..) , MaybeApply(..) ) where import Control.Comonad 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 binary function into a comonad with zipping liftF2 :: Apply w => (a -> b -> c) -> w a -> w b -> w c liftF2 f a b = f <$> a <.> b {-# INLINE liftF2 #-} -- | Lift a ternary function into a comonad with zipping liftF3 :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d liftF3 f a b c = f <$> a <.> b <.> c {-# INLINE liftF3 #-} semigroupoids-5.2.1/src/Data/Functor/Alt.hs0000644000000000000000000001672113136723202016740 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(..) , module Data.Functor.Apply ) where import Control.Applicative hiding (some, many) import Control.Applicative.Backwards import Control.Applicative.Lift import Control.Arrow import Control.Exception (catch, SomeException) import Control.Monad import Control.Monad.Trans.Identity import Control.Monad.Trans.Error import Control.Monad.Trans.Except import Control.Monad.Trans.List import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader 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.Bind import Data.Functor.Compose import Data.Functor.Product import Data.Functor.Reverse import Data.Semigroup hiding (Product) import Data.List.NonEmpty (NonEmpty(..)) import Prelude (($),Either(..),Maybe(..),const,IO,Ord,(++),(.),either,seq,undefined) import Unsafe.Coerce #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_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 distributon\" law of -- MonadPlus with respect to '<.>': -- -- > <.> right-distributes over : (a b) <.> c = (a <.> c) (b <.> c) -- -- But 'Maybe', 'IO', @'Either' a@, @'ErrorT' e m@, and 'STM' satisfy the alternative -- \"left catch\" law instead: -- -- > pure a b = pure a -- -- However, this variation 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 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 instance Alt [] where () = (++) instance Alt Maybe where Nothing b = b a _ = a instance Alt Option where () = (<|>) 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 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 (Bind f, Monad f) => Alt (MaybeT f) where MaybeT a MaybeT b = MaybeT $ do v <- a case v of Nothing -> b Just _ -> return v instance (Bind f, Monad f) => Alt (ErrorT e f) where ErrorT m ErrorT n = ErrorT $ do a <- m case a of Left _ -> n Right r -> return (Right r) instance (Bind f, Monad f, Semigroup e) => Alt (ExceptT e f) where ExceptT m ExceptT n = ExceptT $ do a <- m case a of Left e -> liftM (either (Left . (<>) e) Right) n Right x -> return (Right x) instance Apply f => Alt (ListT f) where ListT a ListT b = ListT $ () <$> a <.> b instance Alt f => Alt (Strict.StateT e f) where Strict.StateT m Strict.StateT n = Strict.StateT $ \s -> m s n s 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 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 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) semigroupoids-5.2.1/src/Data/Functor/Extend.hs0000644000000000000000000001227213136723202017444 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL <= 706 && defined(MIN_VERSION_comonad) && !(MIN_VERSION_comonad(3,0,3)) {-# LANGUAGE Trustworthy #-} #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 (Sum(..)) import Data.Semigroup (Semigroup(..)) 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 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 (Sum f g) where extended f (InL l) = InL (extended (f . InL) l) extended f (InR r) = InR (extended (f . InR) r) -- $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.2.1/src/Data/Functor/Plus.hs0000644000000000000000000001051313136723202017134 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL <= 706 && defined(MIN_VERSION_comonad) && !(MIN_VERSION_comonad(3,0,3)) {-# 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(..) , module Data.Functor.Alt ) where import Control.Applicative hiding (some, many) import Control.Applicative.Backwards import Control.Applicative.Lift import Control.Arrow -- import Control.Exception import Control.Monad import Control.Monad.Trans.Identity -- import Control.Monad.Trans.Cont import Control.Monad.Trans.Error import Control.Monad.Trans.Except import Control.Monad.Trans.List import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader 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.Alt import Data.Functor.Bind import Data.Functor.Compose import Data.Functor.Product import Data.Functor.Reverse import Data.Semigroup hiding (Product) import Prelude hiding (id, (.)) #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_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 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 instance Plus Option where zero = empty 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 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 (Bind f, Monad f) => Plus (MaybeT f) where zero = MaybeT $ return zero instance (Bind f, Monad f, Error e) => Plus (ErrorT e f) where zero = ErrorT $ return $ Left noMsg instance (Bind f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f) where zero = ExceptT $ return $ Left mempty instance (Apply f, Applicative f) => Plus (ListT f) where zero = ListT $ pure [] 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 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 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 semigroupoids-5.2.1/src/Data/Functor/Bind/0000755000000000000000000000000013136723202016531 5ustar0000000000000000semigroupoids-5.2.1/src/Data/Functor/Bind/Class.hs0000644000000000000000000004743013136723202020142 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef MIN_VERSION_semigroups #define MIN_VERSION_semigroups(x,y,z) 1 #endif #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL <= 706 && defined(MIN_VERSION_comonad) && !(MIN_VERSION_comonad(3,0,3)) {-# LANGUAGE 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-2015 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(..) -- * 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.Error import Control.Monad.Trans.Except import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Control.Monad.Trans.List 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 import Data.Orphans () import Prelude hiding (id, (.)) #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_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 -- | @ 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 #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) 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) instance Semigroup m => Apply ((,)m) where (m, f) <.> (n, a) = (m <> n, f a) (m, a) <. (n, _) = (m <> n, a) (m, _) .> (n, b) = (m <> n, b) instance Apply NonEmpty where (<.>) = ap instance Apply (Either a) where Left a <.> _ = Left a Right _ <.> Left a = Left a Right f <.> Right b = Right (f b) Left a <. _ = Left a Right _ <. Left a = Left a Right a <. Right _ = Right a Left a .> _ = Left a Right _ .> Left a = Left a Right _ .> Right b = Right b instance Semigroup m => Apply (Const m) where Const m <.> Const n = Const (m <> n) Const m <. Const n = Const (m <> n) Const m .> Const n = Const (m <> n) instance Apply ((->)m) where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) instance Apply ZipList where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) instance Apply [] where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) instance Apply IO where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) instance Apply Maybe where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) instance Apply Option where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) instance Apply Identity where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) instance Apply w => Apply (IdentityT w) where IdentityT wa <.> IdentityT wb = IdentityT (wa <.> wb) instance Monad m => Apply (WrappedMonad m) where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) instance Arrow a => Apply (WrappedArrow a b) where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) #if MIN_VERSION_base(4,4,0) instance Apply Complex where (a :+ b) <.> (c :+ d) = a c :+ b d #endif #ifdef MIN_VERSION_containers -- | A Map is not 'Applicative', but it is an instance of 'Apply' instance Ord k => Apply (Map k) where (<.>) = Map.intersectionWith id (<. ) = Map.intersectionWith const ( .>) = Map.intersectionWith (const id) -- | An IntMap is not 'Applicative', but it is an instance of 'Apply' instance Apply IntMap where (<.>) = IntMap.intersectionWith id (<. ) = IntMap.intersectionWith const ( .>) = IntMap.intersectionWith (const id) instance Apply Seq where (<.>) = ap instance Apply Tree where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>) #endif #ifdef MIN_VERSION_unordered_containers -- | A 'HashMap' 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 -- ErrorT e is _not_ the same as Compose f (Either e) instance (Functor m, Monad m) => Apply (ErrorT e m) where (<.>) = apDefault instance (Functor m, Monad m) => Apply (ExceptT e m) where (<.>) = apDefault instance Apply m => Apply (ReaderT e m) where ReaderT f <.> ReaderT a = ReaderT $ \e -> f e <.> a e instance Apply m => Apply (ListT m) where ListT f <.> ListT a = ListT $ (<.>) <$> f <.> a -- unfortunately, WriterT has its wrapped product in the wrong order to just use (<.>) instead of flap instance (Apply m, Semigroup w) => Apply (Strict.WriterT w m) where Strict.WriterT f <.> Strict.WriterT a = Strict.WriterT $ flap <$> f <.> a where flap (x,m) (y,n) = (x y, m <> n) instance (Apply m, Semigroup w) => Apply (Lazy.WriterT w m) where Lazy.WriterT f <.> Lazy.WriterT a = Lazy.WriterT $ flap <$> f <.> a where flap ~(x,m) ~(y,n) = (x y, m <> n) instance Bind m => Apply (Strict.StateT s m) where (<.>) = apDefault instance Bind m => Apply (Lazy.StateT s m) where (<.>) = apDefault instance (Bind m, Semigroup w) => Apply (Strict.RWST r w s m) where (<.>) = apDefault instance (Bind m, Semigroup w) => Apply (Lazy.RWST r w s m) where (<.>) = apDefault instance Apply (ContT r m) where ContT f <.> ContT v = ContT $ \k -> f $ \g -> v (k . g) #ifdef MIN_VERSION_comonad instance (Semigroup e, Apply w) => Apply (EnvT e w) where EnvT ef wf <.> EnvT ea wa = EnvT (ef <> ea) (wf <.> wa) 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 a Apply into an Applicative by adding a unit. newtype MaybeApply f a = MaybeApply { runMaybeApply :: Either (f a) a } instance Functor f => Functor (MaybeApply f) where fmap f (MaybeApply (Right a)) = MaybeApply (Right (f a )) fmap f (MaybeApply (Left fa)) = MaybeApply (Left (f <$> fa)) instance Apply f => Apply (MaybeApply f) where MaybeApply (Right f) <.> MaybeApply (Right a) = MaybeApply (Right (f a )) MaybeApply (Right f) <.> MaybeApply (Left fa) = MaybeApply (Left (f <$> fa)) MaybeApply (Left ff) <.> MaybeApply (Right a) = MaybeApply (Left (($a) <$> ff)) MaybeApply (Left ff) <.> MaybeApply (Left fa) = MaybeApply (Left (ff <.> fa)) MaybeApply a <. MaybeApply (Right _) = MaybeApply a MaybeApply (Right a) <. MaybeApply (Left fb) = MaybeApply (Left (a <$ fb)) MaybeApply (Left fa) <. MaybeApply (Left fb) = MaybeApply (Left (fa <. fb)) MaybeApply (Right _) .> MaybeApply b = MaybeApply b MaybeApply (Left fa) .> MaybeApply (Right b) = MaybeApply (Left (fa $> b )) MaybeApply (Left fa) .> MaybeApply (Left fb) = MaybeApply (Left (fa .> fb)) instance Apply f => Applicative (MaybeApply f) where pure a = MaybeApply (Right a) (<*>) = (<.>) (<* ) = (<. ) ( *>) = ( .>) 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 -- | 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 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 (>>-) = (>>=) instance Bind Option where (>>-) = (>>=) instance Bind Identity where (>>-) = (>>=) instance Bind m => Bind (IdentityT m) where IdentityT m >>- f = IdentityT (m >>- runIdentityT . f) instance Monad m => Bind (WrappedMonad m) where WrapMonad m >>- f = WrapMonad $ m >>= unwrapMonad . f instance (Functor m, Monad m) => Bind (MaybeT m) where (>>-) = (>>=) -- distributive law requires Monad to inject @Nothing@ 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) 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 instance (Bind m, Semigroup w) => Bind (Lazy.WriterT w m) where m >>- k = Lazy.WriterT $ Lazy.runWriterT m >>- \ ~(a, w) -> Lazy.runWriterT (k a) `returning` \ ~(b, w') -> (b, w <> w') instance (Bind m, Semigroup w) => Bind (Strict.WriterT w m) where m >>- k = Strict.WriterT $ Strict.runWriterT m >>- \ (a, w) -> Strict.runWriterT (k a) `returning` \ (b, w') -> (b, w <> w') instance Bind m => Bind (Lazy.StateT s m) where m >>- k = Lazy.StateT $ \s -> Lazy.runStateT m s >>- \ ~(a, s') -> Lazy.runStateT (k a) s' instance Bind m => Bind (Strict.StateT s m) where m >>- k = Strict.StateT $ \s -> Strict.runStateT m s >>- \ ~(a, s') -> Strict.runStateT (k a) s' instance (Bind m, Semigroup w) => Bind (Lazy.RWST r w s m) where m >>- k = Lazy.RWST $ \r s -> Lazy.runRWST m r s >>- \ ~(a, s', w) -> Lazy.runRWST (k a) r s' `returning` \ ~(b, s'', w') -> (b, s'', w <> w') instance (Bind m, Semigroup w) => Bind (Strict.RWST r w s m) where m >>- k = Strict.RWST $ \r s -> Strict.runRWST m r s >>- \ (a, s', w) -> Strict.runRWST (k a) r s' `returning` \ (b, s'', w') -> (b, s'', w <> w') instance Bind (ContT r m) where m >>- k = ContT $ \c -> runContT m $ \a -> runContT (k a) c {- instance ArrowApply a => Bind (WrappedArrow a b) where (>>-) = (>>=) -} #if MIN_VERSION_base(4,4,0) instance Bind Complex where (a :+ b) >>- f = a' :+ b' where a' :+ _ = f a _ :+ b' = f b {-# INLINE (>>-) #-} #endif #ifdef MIN_VERSION_containers -- | A 'Map' is not a 'Monad', but it is an instance of 'Bind' 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' 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 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 (<<.>>) #-} #if MIN_VERSION_semigroups(0,16,2) instance Biapply Arg where Arg f g <<.>> Arg a b = Arg (f a) (g b) {-# INLINE (<<.>>) #-} #endif instance Semigroup x => Biapply ((,,) x) where (x, f, g) <<.>> (x', a, b) = (x <> x', f a, g b) {-# 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.2.1/src/Data/Functor/Bind/Trans.hs0000644000000000000000000000426313136723202020161 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- 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 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 () import Data.Semigroup hiding (Product) 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)) 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 instance BindTrans (ContT r) where liftB m = ContT (m >>-) semigroupoids-5.2.1/src/Data/Traversable/0000755000000000000000000000000013136723202016507 5ustar0000000000000000semigroupoids-5.2.1/src/Data/Traversable/Instances.hs0000644000000000000000000000104413136723202020771 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 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.2.1/src/Data/Semigroup/0000755000000000000000000000000013136723202016207 5ustar0000000000000000semigroupoids-5.2.1/src/Data/Semigroup/Bifoldable.hs0000644000000000000000000000345413136723202020574 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- 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.2.1/src/Data/Semigroup/Foldable.hs0000644000000000000000000000753513136723202020265 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 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.2.1/src/Data/Semigroup/Bitraversable.hs0000644000000000000000000000137713136723202021340 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- 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 import Data.Semigroup 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.2.1/src/Data/Semigroup/Traversable.hs0000644000000000000000000000123713136723202021020 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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(..) , foldMap1Default ) where import Control.Applicative import Data.Semigroup import Data.Semigroup.Traversable.Class foldMap1Default :: (Traversable1 f, Semigroup m) => (a -> m) -> f a -> m foldMap1Default f = getConst . traverse1 (Const . f) semigroupoids-5.2.1/src/Data/Semigroup/Traversable/0000755000000000000000000000000013136723202020461 5ustar0000000000000000semigroupoids-5.2.1/src/Data/Semigroup/Traversable/Class.hs0000644000000000000000000001673113136723202022072 0ustar0000000000000000{-# LANGUAGE CPP, TypeOperators #-} ----------------------------------------------------------------------------- -- | -- 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 Data.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 #if MIN_VERSION_semigroups(0,16,2) instance Bitraversable1 Arg where bitraverse1 f g (Arg a b) = Arg <$> f a <.> g b #endif instance Bitraversable1 Either where bitraverse1 f _ (Left a) = Left <$> f a 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 :| []) = (:|[]) <$> f a traverse1 f (a :| (b: bs)) = (\a' (b':| bs') -> a' :| b': bs') <$> f a <.> traverse1 f (b :| bs) 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 #-} semigroupoids-5.2.1/src/Data/Semigroup/Foldable/0000755000000000000000000000000013136723202017717 5ustar0000000000000000semigroupoids-5.2.1/src/Data/Semigroup/Foldable/Class.hs0000644000000000000000000001457213136723202021331 0ustar0000000000000000{-# LANGUAGE CPP, TypeOperators #-} #ifndef MIN_VERSION_semigroups #define MIN_VERSION_semigroups(x,y,z) 0 #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.Compose import Data.Functor.Identity import Data.Functor.Product as Functor import Data.Functor.Reverse import Data.Functor.Sum import Data.List.NonEmpty (NonEmpty(..)) #if MIN_VERSION_base(4,4,0) import Data.Complex #endif #ifdef MIN_VERSION_tagged import Data.Tagged #endif import Data.Traversable.Instances () #ifdef MIN_VERSION_containers import Data.Tree #endif import Data.Semigroup hiding (Product, Sum) #ifdef MIN_VERSION_generic_deriving import Generics.Deriving.Base #else import GHC.Generics #endif import Prelude hiding (foldr) class Foldable t => Foldable1 t where fold1 :: Semigroup m => t m -> m foldMap1 :: Semigroup m => (a -> m) -> t a -> m toNonEmpty :: t a -> NonEmpty a foldMap1 f = maybe (error "foldMap1") id . getOption . foldMap (Option . Just . f) fold1 = foldMap1 id toNonEmpty = foldMap1 (:|[]) instance Foldable1 f => Foldable1 (Rec1 f) where foldMap1 f (Rec1 as) = foldMap1 f as instance Foldable1 f => Foldable1 (M1 i c f) where foldMap1 f (M1 as) = foldMap1 f as instance Foldable1 Par1 where foldMap1 f (Par1 a) = f a instance (Foldable1 f, Foldable1 g) => Foldable1 (f :*: g) where foldMap1 f (as :*: bs) = foldMap1 f as <> foldMap1 f bs instance (Foldable1 f, Foldable1 g) => Foldable1 (f :+: g) where foldMap1 f (L1 as) = foldMap1 f as foldMap1 f (R1 bs) = foldMap1 f bs instance Foldable1 V1 where foldMap1 _ v = v `seq` undefined instance (Foldable1 f, Foldable1 g) => Foldable1 (f :.: g) where foldMap1 f (Comp1 m) = foldMap1 (foldMap1 f) m class Bifoldable t => Bifoldable1 t where bifold1 :: Semigroup m => t m m -> m bifold1 = bifoldMap1 id id {-# INLINE bifold1 #-} bifoldMap1 :: Semigroup m => (a -> m) -> (b -> m) -> t a b -> m bifoldMap1 f g = maybe (error "bifoldMap1") id . getOption . bifoldMap (Option . Just . f) (Option . Just . g) {-# INLINE bifoldMap1 #-} #if MIN_VERSION_semigroups(0,16,2) instance Bifoldable1 Arg where bifoldMap1 f g (Arg a b) = f a <> g b #endif instance Bifoldable1 Either where bifoldMap1 f _ (Left a) = f a bifoldMap1 _ g (Right b) = g b {-# INLINE bifoldMap1 #-} instance Bifoldable1 (,) where bifoldMap1 f g (a, b) = f a <> g b {-# INLINE bifoldMap1 #-} instance Bifoldable1 ((,,) x) where bifoldMap1 f g (_,a,b) = f a <> g b {-# INLINE bifoldMap1 #-} instance Bifoldable1 ((,,,) x y) where bifoldMap1 f g (_,_,a,b) = f a <> g b {-# INLINE bifoldMap1 #-} instance Bifoldable1 ((,,,,) x y z) where bifoldMap1 f g (_,_,_,a,b) = f a <> g b {-# INLINE bifoldMap1 #-} instance Bifoldable1 Const where bifoldMap1 f _ (Const a) = f a {-# INLINE bifoldMap1 #-} #ifdef MIN_VERSION_tagged instance Bifoldable1 Tagged where bifoldMap1 _ g (Tagged b) = g b {-# INLINE bifoldMap1 #-} #endif instance (Bifoldable1 p, Foldable1 f, Foldable1 g) => Bifoldable1 (Biff p f g) where bifoldMap1 f g = bifoldMap1 (foldMap1 f) (foldMap1 g) . runBiff {-# INLINE bifoldMap1 #-} instance Foldable1 f => Bifoldable1 (Clown f) where bifoldMap1 f _ = foldMap1 f . runClown {-# INLINE bifoldMap1 #-} instance Bifoldable1 p => Bifoldable1 (Flip p) where bifoldMap1 f g = bifoldMap1 g f . runFlip {-# INLINE bifoldMap1 #-} instance Bifoldable1 p => Foldable1 (Join p) where foldMap1 f (Join a) = bifoldMap1 f f a {-# INLINE foldMap1 #-} instance Foldable1 g => Bifoldable1 (Joker g) where bifoldMap1 _ g = foldMap1 g . runJoker {-# INLINE bifoldMap1 #-} instance (Bifoldable1 f, Bifoldable1 g) => Bifoldable1 (Bifunctor.Product f g) where bifoldMap1 f g (Bifunctor.Pair x y) = bifoldMap1 f g x <> bifoldMap1 f g y {-# INLINE bifoldMap1 #-} instance (Foldable1 f, Bifoldable1 p) => Bifoldable1 (Tannen f p) where bifoldMap1 f g = foldMap1 (bifoldMap1 f g) . runTannen {-# INLINE bifoldMap1 #-} instance Bifoldable1 p => Bifoldable1 (WrappedBifunctor p) where bifoldMap1 f g = bifoldMap1 f g . unwrapBifunctor {-# INLINE bifoldMap1 #-} #if MIN_VERSION_base(4,4,0) instance Foldable1 Complex where foldMap1 f (a :+ b) = f a <> f b {-# INLINE foldMap1 #-} #endif #ifdef MIN_VERSION_containers instance Foldable1 Tree where foldMap1 f (Node a []) = f a foldMap1 f (Node a (x:xs)) = f a <> foldMap1 (foldMap1 f) (x :| xs) #endif instance Foldable1 Identity where foldMap1 f = f . runIdentity #ifdef MIN_VERSION_tagged instance Foldable1 (Tagged a) where foldMap1 f (Tagged a) = f a #endif instance Foldable1 m => Foldable1 (IdentityT m) where foldMap1 f = foldMap1 f . runIdentityT instance Foldable1 f => Foldable1 (Backwards f) where foldMap1 f = foldMap1 f . forwards instance (Foldable1 f, Foldable1 g) => Foldable1 (Compose f g) where foldMap1 f = foldMap1 (foldMap1 f) . getCompose instance Foldable1 f => Foldable1 (Lift f) where foldMap1 f (Pure x) = f x foldMap1 f (Other y) = foldMap1 f y instance (Foldable1 f, Foldable1 g) => Foldable1 (Functor.Product f g) where foldMap1 f (Functor.Pair a b) = foldMap1 f a <> foldMap1 f b instance Foldable1 f => Foldable1 (Reverse f) where foldMap1 f = getDual . foldMap1 (Dual . f) . getReverse instance (Foldable1 f, Foldable1 g) => Foldable1 (Sum f g) where foldMap1 f (InL x) = foldMap1 f x foldMap1 f (InR y) = foldMap1 f y instance Foldable1 NonEmpty where foldMap1 f (a :| []) = f a foldMap1 f (a :| b : bs) = f a <> foldMap1 f (b :| bs) toNonEmpty = id instance Foldable1 ((,) a) where foldMap1 f (_, x) = f x instance Foldable1 g => Foldable1 (Joker g a) where foldMap1 g = foldMap1 g . runJoker {-# INLINE foldMap1 #-} semigroupoids-5.2.1/test/0000755000000000000000000000000013136723202013554 5ustar0000000000000000semigroupoids-5.2.1/test/doctests.hs0000644000000000000000000000147213136723202015744 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Main (doctests) -- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- This module provides doctests for a project based on the actual versions -- of the packages it was built with. It requires a corresponding Setup.lhs -- to be added to the project ----------------------------------------------------------------------------- module Main where import Build_doctests (flags, pkgs, module_sources) import Data.Foldable (traverse_) import Test.DocTest main :: IO () main = do traverse_ putStrLn args doctest args where args = flags ++ pkgs ++ module_sources