semigroupoids 3.0 → 6.0.2
raw patch · 48 files changed
Files
- .gitignore +30/−0
- .travis.yml +0/−1
- .vim.custom +31/−0
- CHANGELOG.markdown +292/−0
- Data/Functor/Alt.hs +0/−169
- Data/Functor/Apply.hs +0/−30
- Data/Functor/Bind.hs +0/−460
- Data/Functor/Bind/Trans.hs +0/−65
- Data/Functor/Extend.hs +0/−122
- Data/Functor/Plus.hs +0/−115
- Data/Semigroup/Foldable.hs +0/−87
- Data/Semigroup/Traversable.hs +0/−58
- Data/Semigroupoid.hs +0/−61
- Data/Semigroupoid/Dual.hs +0/−27
- Data/Semigroupoid/Static.hs +0/−76
- Data/Traversable/Instances.hs +0/−16
- LICENSE +1/−5
- README.markdown +63/−0
- img/classes.dot +52/−0
- img/classes.svg +306/−0
- semigroupoids.cabal +149/−28
- src/Data/Bifunctor/Apply.hs +39/−0
- src/Data/Functor/Alt.hs +335/−0
- src/Data/Functor/Apply.hs +64/−0
- src/Data/Functor/Bind.hs +59/−0
- src/Data/Functor/Bind/Class.hs +856/−0
- src/Data/Functor/Bind/Trans.hs +85/−0
- src/Data/Functor/Contravariant/Conclude.hs +245/−0
- src/Data/Functor/Contravariant/Decide.hs +271/−0
- src/Data/Functor/Contravariant/Divise.hs +311/−0
- src/Data/Functor/Extend.hs +242/−0
- src/Data/Functor/Plus.hs +235/−0
- src/Data/Groupoid.hs +42/−0
- src/Data/Isomorphism.hs +33/−0
- src/Data/Semigroup/Bifoldable.hs +64/−0
- src/Data/Semigroup/Bitraversable.hs +26/−0
- src/Data/Semigroup/Foldable.hs +126/−0
- src/Data/Semigroup/Foldable/Class.hs +28/−0
- src/Data/Semigroup/Traversable.hs +68/−0
- src/Data/Semigroup/Traversable/Class.hs +243/−0
- src/Data/Semigroupoid.hs +106/−0
- src/Data/Semigroupoid/Categorical.hs +52/−0
- src/Data/Semigroupoid/Dual.hs +28/−0
- src/Data/Semigroupoid/Ob.hs +41/−0
- src/Data/Semigroupoid/Static.hs +87/−0
- src/Data/Traversable/Instances.hs +16/−0
- src/Semigroupoids/Do.hs +81/−0
- src/Semigroupoids/Internal.hs +28/−0
+ .gitignore view
@@ -0,0 +1,30 @@+.ghc.environment.*+dist+docs+wiki+TAGS+tags+wip+.DS_Store+.*.swp+.*.swo+*.o+*.hi+*~+*#+dist-*+cabal-dev+*.chi+*.chs.h+*.dyn_o+*.dyn_hi+.hpc+.hsenv+.cabal-sandbox/+cabal.sandbox.config+*.prof+*.aux+*.hp+*.eventlog+.stack-work/+cabal.project.local
− .travis.yml
@@ -1,1 +0,0 @@-language: haskell
+ .vim.custom view
@@ -0,0 +1,31 @@+" 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 <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR>++" 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"
+ CHANGELOG.markdown view
@@ -0,0 +1,292 @@+6.0.2 [2026.01.10]+------------------+* Add `Apply` and `Bind` instances for strict and lazy `ST`.+* Remove unused `distributive` dependency.++6.0.1 [2024.05.04]+------------------+* Fix a build error when compiling with `-f-contravariant`.++6.0.0.1 [2023.03.16]+--------------------+* When building with GHC 9.6, require `transformers >= 0.6.1` and+ `containers >= 0.6.7`. This ensures that `semigroupoids` always provides+ `Traversable1` instances for data types from `transformers` and `containers`+ unconditionally.++6 [2023.03.12]+--------------+* Drop support for GHC 7.10 and earlier.+* The `Foldable1` and `Bifoldable1` classes have been migrated:+ * When building with `base-4.18` or later, `semigroupoids` re-exports+ `Foldable1` and `Bifoldable1` from `base`. (These classes were added to+ `base-4.18` as a result of+ [this Core Libraries proposal](haskell/core-libraries-committee#9).)+ * When building with older versions of `base`, `semigroupoids` re-exports+ `Foldable1` and `Bifoldable1` from the+ [`foldable1-classes-compat`](https://github.com/haskell-compat/foldable1-classes-compat)+ compatibility package.++ Note that the version of `Foldable1` that `semigroupoids` defined in previous+ releases only had three class methods: `fold1`, `foldMap1`, and `toNonEmpty`.+ Moreover, `foldMap1` had a default implementation in terms of a `Foldable`+ constraint. `base`'s version of `Foldable1`, however, has some notable+ differences:++ 1. It has many more methods than the three listed above, such as the+ `foldrMap1` method.+ 2. `foldMap1` now has a default implementation in terms of `foldrMap1` instead+ of in terms of a `Foldable` constraint.++ To avoid (1) causing issues when upgrading to `semigroupoids-6`,+ `Data.Semigroup.Foldable` only re-exports the `fold1`, `foldMap1`, and+ `toNonEmpty` methods, which reflects the API in previous `semigroupoids`+ releases. If you want to use the other, new class methods of `Foldable1`,+ consider importing it from `Data.Foldable1` (its home in `base`) instead.++ Difference (2) is trickier, because it is possible that existing code that+ defines valid `Foldable1` instances will need to be migrated. If you have an+ instance like this:++ ```hs+ import Data.Semigroup.Foldable++ data T a = MkT a++ instance Foldable T where+ foldMap f (MkT x) = f x++ instance Foldable1 T -- Relying on Foldable-based defaults+ ```++ Then calling `foldMap1` on `T` will throw an error with `semigroupoids-6`, as+ `foldMap1`'s default implementation no longer uses `Foldable`. To migrate this+ code, change the instance to explicitly define `foldMap1`:++ ```hs+ instance Foldable1 T where+ foldMap1 f (MkT x) = f x+ ```++ This approach should be backwards-compatible with previous `semigroupoids`+ releases.++ Some other side effects of this migration include:++ * The `Data.Semigroup.Foldable.Class` module has been deprecated. It no+ longer serves a useful role, as it simply re-exports a limited subset of+ the `Data.Foldable1` and `Data.Bifoldable1` API.+ * All of the `Foldable1` and `Bifoldable1` instances that were previously+ defined in `semigroupoids` have now been migrated to downstream libraries+ (`base`, `bifunctors`, `containers`, `tagged`, and `transformers`), so it+ is no longer strictly necessary to depend on `semigroupoids` to make use of+ these instances.+* Add `Generic1`-based functions for many classes, useful for writing instances:+ - `Data.Functor.Alt.(<!>)` -> `Data.Functor.Alt.galt`+ - `Data.Functor.Apply.{liftF2,liftF3}` -> `Data.Functor.Apply.{gliftF2,gliftF3}`+ - `Data.Functor.Bind.(>>-)` -> `Data.Functor.Bind.gbind`+ - `Data.Functor.Contravariant.Conclude.{conclude,concluded}` -> `Data.Functor.Contravariant.Conclude.{gconclude,gconcluded}`+ - `Data.Functor.Contravariant.Decide.{decide,decided}` -> `Data.Functor.Contravariant.Decide.{gdecide,gdecided}`+ - `Data.Functor.Contravariant.Divise.{divise,divised}` -> `Data.Functor.Contravariant.Divise.{gdivise,gdivised}`+ - `Data.Functor.Extend.{duplicated,extended}` -> `Data.Functor.Extend.{gduplicated,gextended}`+ - `Data.Functor.Plus.zero` -> `Data.Functor.Plus.gzero`+ - `Data.Semigroup.Foldable.{fold1,foldMap1,toNonEmpty}` -> `Data.Semigroup.Foldable.{gfold1,gfoldMap1,gtoNonEmpty}`+ - `Data.Semigroup.Traversable.{traverse1,sequence1}` -> `Data.Semigroup.Traversable.{gtraverse1,gsequence1}`++5.3.7 [2022.01.09]+------------------+* Relax the `Bind` constraints in the following instances to `Functor`:++ ```diff+ -instance (Bind f, Monad f) => Alt (MaybeT f)+ -instance (Bind f, Monad f) => Plus (MaybeT f)+ +instance (Functor f, Monad f) => Alt (MaybeT f)+ +instance (Functor f, Monad f) => Plus (MaybeT f)++ -instance (Bind f, Monad f, Semigroup e) => Alt (ExceptT e f)+ -instance (Bind f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f)+ +instance (Functor f, Monad f, Semigroup e) => Alt (ExceptT e f)+ +instance (Functor f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f)++ -- If building with transformers-0.5.* or older+ -instance (Bind f, Monad f) => Alt (ErrorT e f)+ -instance (Bind f, Monad f, Error e) => Plus (ErrorT e f+ +instance (Functor f, Monad f) => Alt (ErrorT e f)+ +instance (Functor f, Monad f, Error e) => Plus (ErrorT e f)+ ```++5.3.6 [2021.10.07]+------------------+* Allow building with GHC 9.2.+* Allow building with `transformers-0.6.*`.+* Add `Alt` instance for `Identity`.+* Add `Conclude`, `Decide` and `Divise` type classes and instances.+* Add `(<.*>)`, `(<*.>)`, and `traverseMaybe` functions, which make it easier+ to defined `Traversable1` instances for data types that have fields with a+ combination of `Traversable` and `Traversable1` instances.+* Add `Semigroupoids.Do` module with overloads for use with `QualifiedDo`.+* Add `Apply`, `Alt`, `Plus`, `Bind` and `BindTrans` instances for the CPS+ versions of `WriterT` and `RWST`.+* Add `psum` function to `Data.Functor.Plus`.+* Add `Categorical` data type.++5.3.5 [2020.12.31]+------------------+* The build-type has been changed from `Custom` to `Simple`.+ To achieve this, the `doctests` test suite has been removed in favor of using+ [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec)+ to run the doctests.+* Explicitly mark modules as `Safe`.++5.3.4 [2019.11.26]+------------------+* Achieve forward compatibility with+ [GHC proposal 229](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst).++5.3.3 [2019.08.27]+------------------+* Add `Alt` and `Plus` instances for `HashMap` from the `unordered-containers`+ package.++5.3.2 [2019.01.04]+------------------+* Bump the lower bound on `semigroups` to 0.16.2, and avoid incurring+ the dependency entirely on recent GHCs.+* Fix the build on GHC 7.0 and 7.2.++5.3.1 [2018.07.02]+------------------+* Fix a regression introduced in `semigroupoids-5.3` in which some modules+ regressed from `Trustworthy` to `Unsafe`.++5.3 [2018.07.02]+----------------+* Allow building with `containers-0.6`.+* Add `Alt` instances for `First` and `Last` from `Data.Semigroup`, and+ `Alt` and `Plus` instances for `First` and `Last` from `Data.Monoid`.+* Add missing `Apply`, `Bind`, `Extend`, `Foldable1` and `Traversable1`+ instances for `Data.Semigroups`, `Data.Monoid` and `GHC.Generics`.++5.2.2 [2018.01.18]+------------------+* Add `optional` to `Data.Functor.Alt` (analogous to the `optional` function+ in `Control.Applicative`)+* `liftF2` is now a class method of `Apply` (mirroring the fact that `liftA2`+ is now a class method of `Applicative`). `liftF2` and `(<.>)` have default+ definitions in terms of the other.+* Allow building with GHC 8.4+* `Apply` and `Bind` instances for `Q`, from the `template-haskell` package.+ (As a consequence, `Data.Semigroup.Foldable` is no longer a `Trustworthy`+ module.)+* Add instances for `(:~:)` and `(:~~:)` from `Data.Type.Equality`, and+ `Coercion` from `Data.Type.Coercion`++5.2.1+-----+* Add the `toNonEmpty` method to `Foldable1`. Add `foldrM1` and `foldlM1`+ functions to `Data.Semigroup.Foldable` that are defined in terms of `toNonEmpty`.+* Add `Apply`, `Bind`, `Foldable1`, and `Traversable1` instances for `Complex`+* Add `Apply` and `Bind` instances for `HashMap` from the `unordered-containers` package+ (on which `semigroupoids` now depends)+* Add `Semigroupoid` instances for `Tagged` and `Const`++5.2+---+* Revamp `Setup.hs` to use `cabal-doctest`. This makes it build+ with `Cabal-1.25`, and makes the `doctest`s work with `cabal new-build` and+ sandboxes.+* Added instances to `Alt`, `Plus`, `Apply`, `Bind` and `Extend` for `GHC.Generics`, `Tagged` and `Proxy` where appropriate.++5.1+---+* The remaining orphan instances in `Data.Traversable.Instances` have been replaced in favor of the orphan instances from `transformers-compat-0.5`.+* The documentation now states laws that instances of `Apply` are expected to uphold.+* `doctest-0.11` support+* Fixed compilation of tests with `stack`++5.0.1+-------+* `transformers-compat` 0.5 support+* Removed some redundant constraints.+* GHC 8 support++5.0.0.4+-------+* `doctest` 0.10 support++5.0.0.2+-------+* Bugfix for GHC 7.4. PolyKinds on 7.4 cause all sorts of haskell interface file errors. One of the #if guards that turned it off on 7.4 was missing and has been fixed.++5.0.0.1+-------+* Added the CHANGELOG to the distribution so that `hackage` can link to it in the haddocks.++5+-+* Absorbed `Data.Bifunctor.Apply`, `Data.Semigroup.Bifoldable` and `Data.Semigroup.Traversable` from `bifunctors`.+* This caused us to pick up a dependency on `tagged`.+* Exiled `Data.Semifunctor.*`, `Data.Semigroupoid.Product` and `Data.Semigroupoid.Coproduct` to `semigroupoid-extras`.+* This let us open up to older versions of GHC again.+* Set an explicit fixity for `-<-` and `->-`.++4.5+---+* Major changes to the API to support PolyKinds and DataKinds. This necessarily shuts off GHC <= 7.4.+* Orphan instances have moved upstream into a common `base-orphans` package.++4.3.1+-----+* Added `asum1` to `Data.Semigroup.Foldable`.++4.3.0.1+-------+* Support for 'ConstrainedClassMethods' is currently required for GHC HEAD.++4.3+-----+* Added missing instances for `ExceptT`. Obtain it via `transformers-compat` if need be for old `transformers` versions.+* Several `Bind` and `Apply` instances now require somewhat more minimal contexts.++4.2+---+* Backported `Foldable`/`Traversable` instances from `lens`++4.1+---+* `Foldable1`/`Traversable1` for tuples++4.0.4+-----+* `contravariant` 1.0 support.++4.0.3+---+* Added flags to provide unsupported cabal sandbox build modes.++4.0.1+-----+* Fixed bitrot in the `Data.Functor.Extend` documentation.+* Fixed warnings on GHC 7.8.1rc2 caused by importing `Control.Monad.Instances`.++4.0+---+* Merged in the contents of the `groupoids` and `semigroupoid-extras` packages.++3.1+---+* Added the [rectangular band](http://en.wikipedia.org/wiki/Band_(mathematics)#Rectangular_bands) `Semigroupoid` for `(,)`. Would that make it a Bandoid?++3.0.3+-----+* Claim to be `Trustworthy` where necessary++3.0.2+-----+* Tightened the upper bounds slightly to enable PVP compliance while retaining a flexible development cycle.+* Raised the upper bound on `contravariant`.++3.0.1+-----+* Removed upper bounds relative to my other packages+* Refactored directory layout
− Data/Functor/Alt.hs
@@ -1,169 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Functor.Alt--- Copyright : (C) 2011 Edward Kmett,--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Functor.Alt- ( Alt(..)- , module Data.Functor.Apply- ) where--import Control.Applicative hiding (some, many)-import Control.Arrow-import Control.Exception (catch, SomeException)-import Control.Monad-import Control.Monad.Trans.Identity-import Control.Monad.Trans.Error-import Control.Monad.Trans.List-import Control.Monad.Trans.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 qualified Data.IntMap as IntMap-import Data.IntMap (IntMap)-import Data.Semigroup-import Data.List.NonEmpty (NonEmpty(..))-import Data.Sequence (Seq)-import qualified Data.Map as Map-import Data.Map (Map)-import Prelude (($),Either(..),Maybe(..),const,IO,Ord,(++))--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 (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- (<!>) = (<|>)--instance Ord k => Alt (Map k) where- (<!>) = Map.union--instance Alt IntMap where- (<!>) = IntMap.union--instance Alt Seq where- (<!>) = mappend--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 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
− Data/Functor/Apply.hs
@@ -1,30 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Functor.Apply--- Copyright : (C) 2011 Edward Kmett,--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- 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 Data.Functor.Bind
− Data/Functor/Bind.hs
@@ -1,460 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--------------------------------------------------------------------------------- |--- Module : Data.Functor.Bind--- Copyright : (C) 2011 Edward Kmett,--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ NB: The definitions exported through "Data.Functor.Apply" need to be--- included here because otherwise the instances for the transformers package--- have orphaned heads.------------------------------------------------------------------------------module Data.Functor.Bind (- -- * Functors- 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 _everything_-import Control.Applicative-import Control.Arrow-import Control.Category-import Control.Comonad-import Control.Monad (ap)-import Control.Monad.Instances-import Control.Monad.Trans.Cont-import Control.Monad.Trans.Error-import Control.Monad.Trans.Identity-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Reader-import Control.Monad.Trans.List-import qualified Control.Monad.Trans.RWS.Lazy as Lazy-import qualified Control.Monad.Trans.State.Lazy as Lazy-import qualified Control.Monad.Trans.Writer.Lazy as Lazy-import qualified Control.Monad.Trans.RWS.Strict as Strict-import qualified Control.Monad.Trans.State.Strict as Strict-import qualified Control.Monad.Trans.Writer.Strict as Strict-import Data.Functor.Compose-import Data.Functor.Identity-import Data.Functor.Product-import Data.Functor.Extend-import qualified Data.IntMap as IntMap-import Data.IntMap (IntMap)-import qualified Data.Map as Map-import Data.Map (Map)-import Data.List.NonEmpty-import Data.Semigroup hiding (Product)-import Data.Sequence (Seq)-import Data.Tree (Tree)-import Prelude hiding (id, (.))--infixl 1 >>--infixr 1 -<<-infixl 4 <.>, <., .>, <..>---- | A strong lax semi-monoidal endofunctor.--- This is equivalent to an 'Applicative' without 'pure'.------ Laws:------ > associative composition: (.) <$> u <.> v <.> w = u <.> (v <.> w)-class Functor f => Apply f where- (<.>) :: f (a -> b) -> f a -> f b-- -- | > a .> b = const id <$> a <.> b- (.>) :: f a -> f b -> f b- a .> b = const id <$> a <.> b-- -- | > a <. b = const <$> a <.> b- (<.) :: f a -> f b -> f a- a <. b = const <$> a <.> b--instance (Apply f, Apply g) => Apply (Compose f g) where- Compose f <.> Compose x = Compose ((<.>) <$> f <.> x)--instance (Apply f, Apply g) => Apply (Product f g) where- Pair f g <.> Pair x y = Pair (f <.> x) (g <.> y)--instance Semigroup m => Apply ((,)m) where- (m, f) <.> (n, a) = (m <> n, f a)- (m, a) <. (n, _) = (m <> n, a)- (m, _) .> (n, b) = (m <> n, b)--instance Apply NonEmpty where- (<.>) = ap--instance Apply (Either a) where- Left a <.> _ = Left a- Right _ <.> Left a = Left a- Right f <.> Right b = Right (f b)-- Left a <. _ = Left a- Right _ <. Left a = Left a- Right a <. Right _ = Right a-- Left a .> _ = Left a- Right _ .> Left a = Left a- Right _ .> Right b = Right b--instance Semigroup m => Apply (Const m) where- Const m <.> Const n = Const (m <> n)- Const m <. Const n = Const (m <> n)- Const m .> Const n = Const (m <> n)--instance Apply ((->)m) where- (<.>) = (<*>)- (<. ) = (<* )- ( .>) = ( *>)--instance Apply ZipList where- (<.>) = (<*>)- (<. ) = (<* )- ( .>) = ( *>)--instance Apply [] where- (<.>) = (<*>)- (<. ) = (<* )- ( .>) = ( *>)--instance Apply IO where- (<.>) = (<*>)- (<. ) = (<* )- ( .>) = ( *>)--instance Apply Maybe where- (<.>) = (<*>)- (<. ) = (<* )- ( .>) = ( *>)--instance Apply Option where- (<.>) = (<*>)- (<. ) = (<* )- ( .>) = ( *>)--instance Apply Identity where- (<.>) = (<*>)- (<. ) = (<* )- ( .>) = ( *>)--instance Apply w => Apply (IdentityT w) where- IdentityT wa <.> IdentityT wb = IdentityT (wa <.> wb)--instance Monad m => Apply (WrappedMonad m) where- (<.>) = (<*>)- (<. ) = (<* )- ( .>) = ( *>)--instance Arrow a => Apply (WrappedArrow a b) where- (<.>) = (<*>)- (<. ) = (<* )- ( .>) = ( *>)---- | A Map is not 'Applicative', but it is an instance of 'Apply'-instance Ord k => Apply (Map k) where- (<.>) = Map.intersectionWith id- (<. ) = Map.intersectionWith const- ( .>) = Map.intersectionWith (const id)---- | An IntMap is not 'Applicative', but it is an instance of 'Apply'-instance Apply IntMap where- (<.>) = IntMap.intersectionWith id- (<. ) = IntMap.intersectionWith const- ( .>) = IntMap.intersectionWith (const id)--instance Apply Seq where- (<.>) = ap--instance Apply Tree where- (<.>) = (<*>)- (<. ) = (<* )- ( .>) = ( *>)---- MaybeT is _not_ the same as Compose f Maybe-instance (Bind m, Monad m) => Apply (MaybeT m) where- (<.>) = apDefault---- ErrorT e is _not_ the same as Compose f (Either e)-instance (Bind m, Monad m) => Apply (ErrorT e m) where- (<.>) = apDefault--instance Apply m => Apply (ReaderT e m) where- ReaderT f <.> ReaderT a = ReaderT $ \e -> f e <.> a e--instance Apply m => Apply (ListT m) where- ListT f <.> ListT a = ListT $ (<.>) <$> f <.> a---- unfortunately, WriterT has its wrapped product in the wrong order to just use (<.>) instead of flap-instance (Apply m, Semigroup w) => Apply (Strict.WriterT w m) where- Strict.WriterT f <.> Strict.WriterT a = Strict.WriterT $ flap <$> f <.> a where- flap (x,m) (y,n) = (x y, m <> n)--instance (Apply m, Semigroup w) => Apply (Lazy.WriterT w m) where- Lazy.WriterT f <.> Lazy.WriterT a = Lazy.WriterT $ flap <$> f <.> a where- flap ~(x,m) ~(y,n) = (x y, m <> n)--instance Bind m => Apply (Strict.StateT s m) where- (<.>) = apDefault--instance Bind m => Apply (Lazy.StateT s m) where- (<.>) = apDefault--instance (Bind m, Semigroup w) => Apply (Strict.RWST r w s m) where- (<.>) = apDefault--instance (Bind m, Semigroup w) => Apply (Lazy.RWST r w s m) where- (<.>) = apDefault--instance Apply (ContT r m) where- ContT f <.> ContT v = ContT $ \k -> f $ \g -> v (k . g)---- | Wrap an 'Applicative' to be used as a member of 'Apply'-newtype WrappedApplicative f a = WrapApplicative { unwrapApplicative :: f a }--instance Functor f => Functor (WrappedApplicative f) where- fmap f (WrapApplicative a) = WrapApplicative (f <$> a)--instance Applicative f => Apply (WrappedApplicative f) where- WrapApplicative f <.> WrapApplicative a = WrapApplicative (f <*> a)- WrapApplicative a <. WrapApplicative b = WrapApplicative (a <* b)- WrapApplicative a .> WrapApplicative b = WrapApplicative (a *> b)--instance Applicative f => Applicative (WrappedApplicative f) where- pure = WrapApplicative . pure- WrapApplicative f <*> WrapApplicative a = WrapApplicative (f <*> a)- WrapApplicative a <* WrapApplicative b = WrapApplicative (a <* b)- WrapApplicative a *> WrapApplicative b = WrapApplicative (a *> b)--instance Alternative f => Alternative (WrappedApplicative f) where- empty = WrapApplicative empty- WrapApplicative a <|> WrapApplicative b = WrapApplicative (a <|> b)---- | Transform a Apply into an Applicative by adding a unit.-newtype MaybeApply f a = MaybeApply { runMaybeApply :: Either (f a) a }--instance Functor f => Functor (MaybeApply f) where- fmap f (MaybeApply (Right a)) = MaybeApply (Right (f a ))- fmap f (MaybeApply (Left fa)) = MaybeApply (Left (f <$> fa))--instance Apply f => Apply (MaybeApply f) where- MaybeApply (Right f) <.> MaybeApply (Right a) = MaybeApply (Right (f a ))- MaybeApply (Right f) <.> MaybeApply (Left fa) = MaybeApply (Left (f <$> fa))- MaybeApply (Left ff) <.> MaybeApply (Right a) = MaybeApply (Left (($a) <$> ff))- MaybeApply (Left ff) <.> MaybeApply (Left fa) = MaybeApply (Left (ff <.> fa))-- MaybeApply a <. MaybeApply (Right _) = MaybeApply a- MaybeApply (Right a) <. MaybeApply (Left fb) = MaybeApply (Left (a <$ fb))- MaybeApply (Left fa) <. MaybeApply (Left fb) = MaybeApply (Left (fa <. fb))-- MaybeApply (Right _) .> MaybeApply b = MaybeApply b- MaybeApply (Left fa) .> MaybeApply (Right b) = MaybeApply (Left (fa $> b ))- MaybeApply (Left fa) .> MaybeApply (Left fb) = MaybeApply (Left (fa .> fb))--instance Apply f => Applicative (MaybeApply f) where- pure a = MaybeApply (Right a)- (<*>) = (<.>)- (<* ) = (<. )- ( *>) = ( .>)---- | A variant of '<.>' with the arguments reversed.-(<..>) :: Apply w => w a -> w (a -> b) -> w b-(<..>) = liftF2 (flip id)-{-# INLINE (<..>) #-}---- | Lift a binary function into a comonad with zipping-liftF2 :: Apply w => (a -> b -> c) -> w a -> w b -> w c-liftF2 f a b = f <$> a <.> b-{-# INLINE liftF2 #-}---- | Lift a ternary function into a comonad with zipping-liftF3 :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d-liftF3 f a b c = f <$> a <.> b <.> c-{-# INLINE liftF3 #-}--instance Extend f => Extend (MaybeApply f) where- duplicated w@(MaybeApply Right{}) = MaybeApply (Right w)- duplicated (MaybeApply (Left fa)) = MaybeApply (Left (extended (MaybeApply . Left) fa))--instance Comonad f => Comonad (MaybeApply f) where- duplicate w@(MaybeApply Right{}) = MaybeApply (Right w)- duplicate (MaybeApply (Left fa)) = MaybeApply (Left (extend (MaybeApply . Left) fa))- extract (MaybeApply (Left fa)) = extract fa- extract (MaybeApply (Right a)) = a--instance Apply (Cokleisli w a) where- Cokleisli f <.> Cokleisli a = Cokleisli (\w -> (f w) (a w))---- | 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)--returning :: Functor f => f a -> (a -> b) -> f b-returning = flip fmap--(-<<) :: 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--apDefault :: Bind f => f (a -> b) -> f a -> f b-apDefault f x = f >>- \f' -> f' <$> x--instance Semigroup m => Bind ((,)m) where- ~(m, a) >>- f = let (n, b) = f a in (m <> n, b)--instance Bind (Either a) where- Left a >>- _ = Left a- Right a >>- f = f a--instance (Bind f, Bind g) => Bind (Product f g) where- Pair m n >>- f = Pair (m >>- fstP . f) (n >>- sndP . f) where- fstP (Pair a _) = a- sndP (Pair _ b) = b--instance Bind ((->)m) where- f >>- g = \e -> g (f e) e--instance Bind [] where- (>>-) = (>>=)--instance Bind NonEmpty where- (>>-) = (>>=)--instance Bind IO where- (>>-) = (>>=)--instance Bind Maybe where- (>>-) = (>>=)--instance Bind Option where- (>>-) = (>>=)--instance Bind Identity where- (>>-) = (>>=)--instance Bind m => Bind (IdentityT m) where- IdentityT m >>- f = IdentityT (m >>- runIdentityT . f)--instance Monad m => Bind (WrappedMonad m) where- WrapMonad m >>- f = WrapMonad $ m >>= unwrapMonad . f--instance (Bind m, Monad m) => Bind (MaybeT m) where- (>>-) = (>>=) -- distributive law requires Monad to inject @Nothing@--instance (Bind m, Monad m) => Bind (ListT m) where- (>>-) = (>>=) -- distributive law requires Monad to inject @[]@--instance (Bind m, Monad m) => Bind (ErrorT e m) where- m >>- k = ErrorT $ do- a <- runErrorT m- case a of- Left l -> return (Left l)- Right r -> runErrorT (k r)--instance Bind m => Bind (ReaderT e m) where- ReaderT m >>- f = ReaderT $ \e -> m e >>- \x -> runReaderT (f x) e--instance (Bind m, Semigroup w) => Bind (Lazy.WriterT w m) where- m >>- k = Lazy.WriterT $- Lazy.runWriterT m >>- \ ~(a, w) ->- Lazy.runWriterT (k a) `returning` \ ~(b, w') ->- (b, w <> w')--instance (Bind m, Semigroup w) => Bind (Strict.WriterT w m) where- m >>- k = Strict.WriterT $- Strict.runWriterT m >>- \ (a, w) ->- Strict.runWriterT (k a) `returning` \ (b, w') ->- (b, w <> w')--instance Bind m => Bind (Lazy.StateT s m) where- m >>- k = Lazy.StateT $ \s ->- Lazy.runStateT m s >>- \ ~(a, s') ->- Lazy.runStateT (k a) s'--instance Bind m => Bind (Strict.StateT s m) where- m >>- k = Strict.StateT $ \s ->- Strict.runStateT m s >>- \ ~(a, s') ->- Strict.runStateT (k a) s'--instance (Bind m, Semigroup w) => Bind (Lazy.RWST r w s m) where- m >>- k = Lazy.RWST $ \r s ->- Lazy.runRWST m r s >>- \ ~(a, s', w) ->- Lazy.runRWST (k a) r s' `returning` \ ~(b, s'', w') ->- (b, s'', w <> w')--instance (Bind m, Semigroup w) => Bind (Strict.RWST r w s m) where- m >>- k = Strict.RWST $ \r s ->- Strict.runRWST m r s >>- \ (a, s', w) ->- Strict.runRWST (k a) r s' `returning` \ (b, s'', w') ->- (b, s'', w <> w')--instance Bind (ContT r m) where- m >>- k = ContT $ \c -> runContT m $ \a -> runContT (k a) c--{--instance ArrowApply a => Bind (WrappedArrow a b) where- (>>-) = (>>=)--}---- | A 'Map' is not a 'Monad', but it is an instance of 'Bind'-instance Ord k => Bind (Map k) where- m >>- f = Map.mapMaybeWithKey (\k -> Map.lookup k . f) m---- | An 'IntMap' is a 'Applicative', 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- (>>-) = (>>=)
− Data/Functor/Bind/Trans.hs
@@ -1,65 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Functor.Bind.Trans--- Copyright : (C) 2011 Edward Kmett,--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Functor.Bind.Trans ( - BindTrans(..)- ) where---- import _everything_-import Control.Category-import Control.Monad.Instances-import Control.Monad.Trans.Class-import Control.Monad.Trans.Cont--- import Control.Monad.Trans.Error-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.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 (Semigroup w, Monoid w) => BindTrans (Lazy.WriterT w) where- liftB = Lazy.WriterT . fmap (\a -> (a, mempty))--instance (Semigroup w, 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 (Semigroup w, Monoid w) => BindTrans (Lazy.RWST r w s) where- liftB m = Lazy.RWST $ \ _r s -> fmap (\a -> (a, s, mempty)) m- -instance (Semigroup w, Monoid w) => BindTrans (Strict.RWST r w s) where- liftB m = Strict.RWST $ \ _r s -> fmap (\a -> (a, s, mempty)) m--instance BindTrans (ContT r) where- liftB m = ContT (m >>-)
− Data/Functor/Extend.hs
@@ -1,122 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Functor.Extend--- Copyright : (C) 2011 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Functor.Extend- ( -- * $definition- Extend(..)- ) where--import Prelude hiding (id, (.))-import Control.Category-import Control.Monad.Trans.Identity-import Data.Functor.Identity-import Data.Semigroup-import Data.List (tails)-import Data.List.NonEmpty (NonEmpty(..), toList)-import Data.Sequence (Seq)-import qualified Data.Sequence as Seq-import Data.Tree--class Functor w => Extend w where- -- |- -- > duplicate = extend id- -- > fmap (fmap f) . duplicate = duplicate . fmap f- duplicated :: w a -> w (w a)- -- |- -- > extend f = fmap f . duplicate- extended :: (w a -> b) -> w a -> w b-- extended f = fmap f . duplicated- duplicated = extended id---- * 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--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--instance Extend Seq where- duplicated = Seq.tails--instance Extend Tree where- duplicated w@(Node _ as) = Node w (map duplicated as)---- 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))--{- $definition--There are two ways to define an 'Extend' instance:--I. Provide definitions for 'extend'-satisfying this law:--> extended f . extended g = extended (f . extended g)--II. Alternately, you may choose to provide definitions for 'duplicate'-satisfying this laws:--> duplicated . duplicated = fmap duplicated . duplicated--These are both equivalent to the statement that (->-) is associative--> (f ->- g) ->- h = f ->- (g ->- h)--You may of course, choose to define both 'duplicate' /and/ 'extend'.-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'.---}
− Data/Functor/Plus.hs
@@ -1,115 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Functor.Plus--- Copyright : (C) 2011 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Functor.Plus- ( Plus(..)- , module Data.Functor.Alt- ) where--import Control.Applicative hiding (some, many)-import Control.Arrow--- import Control.Exception-import Control.Monad-import Control.Monad.Trans.Identity--- import Control.Monad.Trans.Cont-import Control.Monad.Trans.Error-import Control.Monad.Trans.List-import Control.Monad.Trans.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 qualified Data.IntMap as IntMap-import Data.IntMap (IntMap)-import Data.Semigroup-import Data.Sequence (Seq)-import qualified Data.Map as Map-import Data.Map (Map)-import Prelude hiding (id, (.))---- | 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 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--instance Ord k => Plus (Map k) where- zero = Map.empty--instance Plus IntMap where- zero = IntMap.empty--instance Plus Seq where- zero = mempty--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 (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
− Data/Semigroup/Foldable.hs
@@ -1,87 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Semigroup.Foldable--- Copyright : (C) 2011 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Semigroup.Foldable- ( Foldable1(..)- , traverse1_- , for1_- , sequenceA1_- , foldMapDefault1- ) where--import Control.Monad.Trans.Identity-import Data.Foldable-import Data.Functor.Identity-import Data.Functor.Apply-import Data.Functor.Product-import Data.Functor.Compose-import Data.Tree-import Data.List.NonEmpty (NonEmpty(..))-import Data.Traversable.Instances ()-import Data.Semigroup hiding (Product)-import Prelude hiding (foldr)--class Foldable t => Foldable1 t where- fold1 :: Semigroup m => t m -> m- foldMap1 :: Semigroup m => (a -> m) -> t a -> m-- foldMap1 f = maybe (error "foldMap1") id . getOption . foldMap (Option . Just . f) - fold1 = foldMap1 id--instance Foldable1 Tree where- foldMap1 f (Node a []) = f a- foldMap1 f (Node a (x:xs)) = f a <> foldMap1 (foldMap1 f) (x :| xs)--instance Foldable1 Identity where- foldMap1 f = f . runIdentity--instance Foldable1 m => Foldable1 (IdentityT m) where- foldMap1 f = foldMap1 f . runIdentityT--instance (Foldable1 f, Foldable1 g) => Foldable1 (Compose f g) where- foldMap1 f = foldMap1 (foldMap1 f) . getCompose--instance (Foldable1 f, Foldable1 g) => Foldable1 (Product f g) where- foldMap1 f (Pair a b) = foldMap1 f a <> foldMap1 f b--instance Foldable1 NonEmpty where- foldMap1 f (a :| []) = f a- foldMap1 f (a :| b : bs) = f a <> foldMap1 f (b :| bs)--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
− Data/Semigroup/Traversable.hs
@@ -1,58 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Semigroup.Traversable--- Copyright : (C) 2011 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Semigroup.Traversable- ( Traversable1(..)- , foldMap1Default- ) where--import Control.Applicative-import Control.Monad.Trans.Identity-import Data.Functor.Identity-import Data.Functor.Apply-import Data.Functor.Product-import Data.Functor.Compose-import Data.Semigroup.Foldable-import Data.Traversable-import Data.Traversable.Instances ()-import Data.Tree-import Data.List.NonEmpty (NonEmpty(..))-import Data.Semigroup hiding (Product)--class (Foldable1 t, Traversable t) => Traversable1 t where- traverse1 :: Apply f => (a -> f b) -> t a -> f (t b)- sequence1 :: Apply f => t (f b) -> f (t b)-- sequence1 = traverse1 id- traverse1 f = sequence1 . fmap f--foldMap1Default :: (Traversable1 f, Semigroup m) => (a -> m) -> f a -> m-foldMap1Default f = getConst . traverse1 (Const . f)--instance Traversable1 Identity where- traverse1 f = fmap Identity . f . runIdentity--instance Traversable1 f => Traversable1 (IdentityT f) where- traverse1 f = fmap IdentityT . traverse1 f . runIdentityT--instance (Traversable1 f, Traversable1 g) => Traversable1 (Compose f g) where- traverse1 f = fmap Compose . traverse1 (traverse1 f) . getCompose--instance (Traversable1 f, Traversable1 g) => Traversable1 (Product f g) where- traverse1 f (Pair a b) = Pair <$> traverse1 f a <.> traverse1 f b--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)--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)
− Data/Semigroupoid.hs
@@ -1,61 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Semigroupoid--- Copyright : (C) 2007-2011 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- 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.Arrow-import Data.Functor.Bind-import Data.Functor.Extend-import Data.Functor.Contravariant-import Control.Comonad-import Data.Semigroup-import Control.Category-import Prelude hiding (id, (.))---- | '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 Bind m => Semigroupoid (Kleisli m) where- Kleisli g `o` Kleisli f = Kleisli $ \a -> f a >>- g--instance Extend w => Semigroupoid (Cokleisli w) where- Cokleisli f `o` Cokleisli g = Cokleisli $ f . extended g--instance Semigroupoid Op where- Op f `o` Op g = Op (g `o` f)--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)
− Data/Semigroupoid/Dual.hs
@@ -1,27 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Semigroupoid.Dual--- Copyright : (C) 2007-2011 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- 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)
− Data/Semigroupoid/Static.hs
@@ -1,76 +0,0 @@-{-# LANGUAGE CPP #-}-module Data.Semigroupoid.Static- ( Static(..)- ) where--import Control.Arrow-import Control.Applicative-import Control.Category-import Control.Comonad-import Control.Monad.Instances ()-import Control.Monad (ap)-import Data.Functor.Apply-import Data.Functor.Plus-import Data.Functor.Extend-import Data.Semigroup-import Data.Semigroupoid-import Prelude hiding ((.), id)--#ifdef LANGUAGE_DeriveDataTypeable-import Data.Typeable-#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--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--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)-
− Data/Traversable/Instances.hs
@@ -1,16 +0,0 @@-{-# LANGUAGE CPP #-}--- | Placeholders for missing instances of Traversable, until base catches up and adds them-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Data.Traversable.Instances where--#if !(MIN_VERSION_transformers(0,3,0))-import Control.Monad.Trans.Identity-import Data.Foldable-import Data.Traversable--instance Foldable m => Foldable (IdentityT m) where- foldMap f = foldMap f . runIdentityT--instance Traversable m => Traversable (IdentityT m) where- traverse f = fmap IdentityT . traverse f . runIdentityT-#endif
LICENSE view
@@ -1,4 +1,4 @@-Copyright 2011 Edward Kmett+Copyright 2011-2015 Edward Kmett All rights reserved. @@ -12,10 +12,6 @@ 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.--3. Neither the name of the author nor the names of his contributors- may be used to endorse or promote products derived from this software- without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ README.markdown view
@@ -0,0 +1,63 @@+semigroupoids+=============++[](https://hackage.haskell.org/package/semigroupoids) [](https://github.com/ekmett/semigroupoids/actions?query=workflow%3AHaskell-CI)++A semigroupoid is a `Category` without `id`. This package provides a range of +`id`-free versions of type classes, as well as some supporting functions and+data types.++Field Guide+-----------++The diagram below describes the relationships between the type classes defined+in this package, and those from `base` (with some from `contravariant` as well). Thick-bordered+nodes correspond to type classes defined in this package; thin-bordered ones are+from elsewhere. Solid edges represent subclass relationships that actually+exist; dashed edges are those which _should_ exist in theory.++++We also provide the following table. This is structured in superclass order -+thus, for any type class `T`, all superclasses of `T` will be listed before `T`+in the table.++|**Name**|**Location**|**Superclass of**|**Ideally superclass of**|+|--------|------------|-----------------|-------------------------|+|`Functor`|`base`|`Alt`, `Apply`, `Traversable`||+|`Foldable`|`base`|`Traversable`, `Foldable1`||+|`Bifunctor`|`base`|`Biapply`||+|`Contravariant`|`base`|`Divise`, `Decide`||+|`Semigroupoid`|`semigroupoids`||`Category`|+|`Alt`|`semigroupoids`|`Plus`||+|`Apply`|`semigroupoids`|`Bind`|`Applicative`|+|`Traversable`|`base`|`Traversable1`||+|`Foldable1`|`semigroupoids`|`Traversable1`||+|`Biapply`|`semigroupoids`|||+|`Divise`|`semigroupoids`||`Divisible`|+|`Decide`|`semigroupoids`|`Conclude`|`Decidable`|+|`Category`|`base`|`Arrow`||+|`Plus`|`semigroupoids`||`Alternative`|+|`Applicative`|`base`|`Alternative`, `Monad`||+|`Bind`|`semigroupoids`||`Monad`|+|`Traversable1`|`semigroupoids`|||+|`Divisible`|`contravariant`|||+|`Conclude`|`semigroupoids`||`Decidable`|+|`Arrow`|`base`|||+|`Alternative`|`base`|`MonadPlus`||+|`Monad`|`base`|`MonadPlus`||+|`Decidable`|`contravariant`|||+|`MonadPlus`|`base`|||++We omit some type class relationships from this diagram, as they are not+relevant for the purposes of this package.++Contact Information+-------------------++Contributions and bug reports are welcome!++Please feel free to contact me through Github or on the #haskell IRC channel on+LiberaChat.++-Edward Kmett
+ img/classes.dot view
@@ -0,0 +1,52 @@+digraph {+ node[shape=box];+ functor [label="Functor"];+ foldable [label="Foldable"];+ traversable [label="Traversable"];+ apply [label="Apply", penwidth=2.0];+ bind [label="Bind", penwidth=2.0];+ applicative [label="Applicative"];+ alt [label="Alt", penwidth=2.0];+ plus [label="Plus", penwidth=2.0];+ alternative [label="Alternative"];+ monad [label="Monad"];+ monad_plus [label="MonadPlus"];+ foldable1 [label="Foldable1", penwidth=2.0];+ traversable1 [label="Traversable1", penwidth=2.0];+ bifunctor [label="Bifunctor"];+ biapply [label="Biapply", penwidth=2.0];+ contravariant [label="Contravariant"];+ divise [label="Divise", penwidth=2.0];+ decide [label="Decide", penwidth=2.0];+ divisible [label="Divisible"];+ decidable [label="Decidable"];+ conclude [label="Conclude", penwidth=2.0];+ semigroupoid [label="Semigroupoid", penwidth=2.0];+ category [label="Category"];+ arrow [label="Arrow"];+ functor -> apply;+ functor -> alt;+ apply -> bind;+ apply -> applicative [style=dashed];+ alt -> plus;+ plus -> alternative [style=dashed];+ applicative -> alternative;+ applicative -> monad;+ bind -> monad [style=dashed];+ monad -> monad_plus;+ alternative -> monad_plus;+ functor -> traversable;+ foldable -> traversable;+ foldable -> foldable1;+ foldable1 -> traversable1;+ traversable -> traversable1;+ bifunctor -> biapply;+ contravariant -> divise;+ contravariant -> decide;+ divise -> divisible [style=dashed];+ decide -> decidable [style=dashed];+ decide -> conclude;+ conclude -> decidable [style=dashed];+ semigroupoid -> category [style=dashed];+ category -> arrow;+}
+ img/classes.svg view
@@ -0,0 +1,306 @@+<?xml version="1.0" encoding="UTF-8" standalone="no"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+ "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<!-- Generated by graphviz version 2.49.1 (0)+ -->+<!-- Pages: 1 -->+<svg width="712pt" height="332pt"+ viewBox="0.00 0.00 712.00 332.00" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">+<g id="graph0" class="graph" transform="scale(1 1) rotate(0) translate(4 328)">+<polygon fill="white" stroke="transparent" points="-4,4 -4,-328 708,-328 708,4 -4,4"/>+<!-- functor -->+<g id="node1" class="node">+<title>functor</title>+<polygon fill="none" stroke="black" points="141.5,-324 82.5,-324 82.5,-288 141.5,-288 141.5,-324"/>+<text text-anchor="middle" x="112" y="-302.3" font-family="Times,serif" font-size="14.00">Functor</text>+</g>+<!-- traversable -->+<g id="node3" class="node">+<title>traversable</title>+<polygon fill="none" stroke="black" points="237,-252 157,-252 157,-216 237,-216 237,-252"/>+<text text-anchor="middle" x="197" y="-230.3" font-family="Times,serif" font-size="14.00">Traversable</text>+</g>+<!-- functor->traversable -->+<g id="edge12" class="edge">+<title>functor->traversable</title>+<path fill="none" stroke="black" d="M133.01,-287.7C143.72,-278.88 156.89,-268.03 168.5,-258.47"/>+<polygon fill="black" stroke="black" points="170.74,-261.16 176.23,-252.1 166.29,-255.76 170.74,-261.16"/>+</g>+<!-- apply -->+<g id="node4" class="node">+<title>apply</title>+<polygon fill="none" stroke="black" stroke-width="2" points="139,-252 85,-252 85,-216 139,-216 139,-252"/>+<text text-anchor="middle" x="112" y="-230.3" font-family="Times,serif" font-size="14.00">Apply</text>+</g>+<!-- functor->apply -->+<g id="edge1" class="edge">+<title>functor->apply</title>+<path fill="none" stroke="black" d="M112,-287.7C112,-279.98 112,-270.71 112,-262.11"/>+<polygon fill="black" stroke="black" points="115.5,-262.1 112,-252.1 108.5,-262.1 115.5,-262.1"/>+</g>+<!-- alt -->+<g id="node7" class="node">+<title>alt</title>+<polygon fill="none" stroke="black" stroke-width="2" points="61,-252 7,-252 7,-216 61,-216 61,-252"/>+<text text-anchor="middle" x="34" y="-230.3" font-family="Times,serif" font-size="14.00">Alt</text>+</g>+<!-- functor->alt -->+<g id="edge2" class="edge">+<title>functor->alt</title>+<path fill="none" stroke="black" d="M92.72,-287.7C83.08,-279.05 71.27,-268.45 60.77,-259.03"/>+<polygon fill="black" stroke="black" points="62.84,-256.18 53.06,-252.1 58.16,-261.39 62.84,-256.18"/>+</g>+<!-- foldable -->+<g id="node2" class="node">+<title>foldable</title>+<polygon fill="none" stroke="black" points="275,-324 211,-324 211,-288 275,-288 275,-324"/>+<text text-anchor="middle" x="243" y="-302.3" font-family="Times,serif" font-size="14.00">Foldable</text>+</g>+<!-- foldable->traversable -->+<g id="edge13" class="edge">+<title>foldable->traversable</title>+<path fill="none" stroke="black" d="M231.63,-287.7C226.28,-279.56 219.8,-269.69 213.89,-260.7"/>+<polygon fill="black" stroke="black" points="216.66,-258.54 208.24,-252.1 210.81,-262.38 216.66,-258.54"/>+</g>+<!-- foldable1 -->+<g id="node12" class="node">+<title>foldable1</title>+<polygon fill="none" stroke="black" stroke-width="2" points="326.5,-252 255.5,-252 255.5,-216 326.5,-216 326.5,-252"/>+<text text-anchor="middle" x="291" y="-230.3" font-family="Times,serif" font-size="14.00">Foldable1</text>+</g>+<!-- foldable->foldable1 -->+<g id="edge14" class="edge">+<title>foldable->foldable1</title>+<path fill="none" stroke="black" d="M254.87,-287.7C260.5,-279.47 267.35,-269.48 273.57,-260.42"/>+<polygon fill="black" stroke="black" points="276.5,-262.33 279.27,-252.1 270.73,-258.37 276.5,-262.33"/>+</g>+<!-- traversable1 -->+<g id="node13" class="node">+<title>traversable1</title>+<polygon fill="none" stroke="black" stroke-width="2" points="332.5,-180 245.5,-180 245.5,-144 332.5,-144 332.5,-180"/>+<text text-anchor="middle" x="289" y="-158.3" font-family="Times,serif" font-size="14.00">Traversable1</text>+</g>+<!-- traversable->traversable1 -->+<g id="edge16" class="edge">+<title>traversable->traversable1</title>+<path fill="none" stroke="black" d="M219.74,-215.7C231.44,-206.8 245.86,-195.82 258.51,-186.2"/>+<polygon fill="black" stroke="black" points="260.68,-188.94 266.52,-180.1 256.44,-183.37 260.68,-188.94"/>+</g>+<!-- bind -->+<g id="node5" class="node">+<title>bind</title>+<polygon fill="none" stroke="black" stroke-width="2" points="224,-180 170,-180 170,-144 224,-144 224,-180"/>+<text text-anchor="middle" x="197" y="-158.3" font-family="Times,serif" font-size="14.00">Bind</text>+</g>+<!-- apply->bind -->+<g id="edge3" class="edge">+<title>apply->bind</title>+<path fill="none" stroke="black" d="M133.01,-215.7C143.72,-206.88 156.89,-196.03 168.5,-186.47"/>+<polygon fill="black" stroke="black" points="170.74,-189.16 176.23,-180.1 166.29,-183.76 170.74,-189.16"/>+</g>+<!-- applicative -->+<g id="node6" class="node">+<title>applicative</title>+<polygon fill="none" stroke="black" points="152,-180 72,-180 72,-144 152,-144 152,-180"/>+<text text-anchor="middle" x="112" y="-158.3" font-family="Times,serif" font-size="14.00">Applicative</text>+</g>+<!-- apply->applicative -->+<g id="edge4" class="edge">+<title>apply->applicative</title>+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M112,-215.7C112,-207.98 112,-198.71 112,-190.11"/>+<polygon fill="black" stroke="black" points="115.5,-190.1 112,-180.1 108.5,-190.1 115.5,-190.1"/>+</g>+<!-- monad -->+<g id="node10" class="node">+<title>monad</title>+<polygon fill="none" stroke="black" points="183,-108 127,-108 127,-72 183,-72 183,-108"/>+<text text-anchor="middle" x="155" y="-86.3" font-family="Times,serif" font-size="14.00">Monad</text>+</g>+<!-- bind->monad -->+<g id="edge9" class="edge">+<title>bind->monad</title>+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M186.62,-143.7C181.74,-135.56 175.81,-125.69 170.42,-116.7"/>+<polygon fill="black" stroke="black" points="173.41,-114.88 165.26,-108.1 167.41,-118.48 173.41,-114.88"/>+</g>+<!-- alternative -->+<g id="node9" class="node">+<title>alternative</title>+<polygon fill="none" stroke="black" points="108.5,-108 31.5,-108 31.5,-72 108.5,-72 108.5,-108"/>+<text text-anchor="middle" x="70" y="-86.3" font-family="Times,serif" font-size="14.00">Alternative</text>+</g>+<!-- applicative->alternative -->+<g id="edge7" class="edge">+<title>applicative->alternative</title>+<path fill="none" stroke="black" d="M101.62,-143.7C96.74,-135.56 90.81,-125.69 85.42,-116.7"/>+<polygon fill="black" stroke="black" points="88.41,-114.88 80.26,-108.1 82.41,-118.48 88.41,-114.88"/>+</g>+<!-- applicative->monad -->+<g id="edge8" class="edge">+<title>applicative->monad</title>+<path fill="none" stroke="black" d="M122.63,-143.7C127.63,-135.56 133.69,-125.69 139.21,-116.7"/>+<polygon fill="black" stroke="black" points="142.24,-118.46 144.49,-108.1 136.28,-114.79 142.24,-118.46"/>+</g>+<!-- plus -->+<g id="node8" class="node">+<title>plus</title>+<polygon fill="none" stroke="black" stroke-width="2" points="54,-180 0,-180 0,-144 54,-144 54,-180"/>+<text text-anchor="middle" x="27" y="-158.3" font-family="Times,serif" font-size="14.00">Plus</text>+</g>+<!-- alt->plus -->+<g id="edge5" class="edge">+<title>alt->plus</title>+<path fill="none" stroke="black" d="M32.27,-215.7C31.5,-207.98 30.57,-198.71 29.71,-190.11"/>+<polygon fill="black" stroke="black" points="33.19,-189.71 28.71,-180.1 26.22,-190.4 33.19,-189.71"/>+</g>+<!-- plus->alternative -->+<g id="edge6" class="edge">+<title>plus->alternative</title>+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M37.63,-143.7C42.63,-135.56 48.69,-125.69 54.21,-116.7"/>+<polygon fill="black" stroke="black" points="57.24,-118.46 59.49,-108.1 51.28,-114.79 57.24,-118.46"/>+</g>+<!-- monad_plus -->+<g id="node11" class="node">+<title>monad_plus</title>+<polygon fill="none" stroke="black" points="151.5,-36 72.5,-36 72.5,0 151.5,0 151.5,-36"/>+<text text-anchor="middle" x="112" y="-14.3" font-family="Times,serif" font-size="14.00">MonadPlus</text>+</g>+<!-- alternative->monad_plus -->+<g id="edge11" class="edge">+<title>alternative->monad_plus</title>+<path fill="none" stroke="black" d="M80.38,-71.7C85.26,-63.56 91.19,-53.69 96.58,-44.7"/>+<polygon fill="black" stroke="black" points="99.59,-46.48 101.74,-36.1 93.59,-42.88 99.59,-46.48"/>+</g>+<!-- monad->monad_plus -->+<g id="edge10" class="edge">+<title>monad->monad_plus</title>+<path fill="none" stroke="black" d="M144.37,-71.7C139.37,-63.56 133.31,-53.69 127.79,-44.7"/>+<polygon fill="black" stroke="black" points="130.72,-42.79 122.51,-36.1 124.76,-46.46 130.72,-42.79"/>+</g>+<!-- foldable1->traversable1 -->+<g id="edge15" class="edge">+<title>foldable1->traversable1</title>+<path fill="none" stroke="black" d="M290.51,-215.7C290.29,-207.98 290.02,-198.71 289.77,-190.11"/>+<polygon fill="black" stroke="black" points="293.27,-190 289.49,-180.1 286.28,-190.2 293.27,-190"/>+</g>+<!-- bifunctor -->+<g id="node14" class="node">+<title>bifunctor</title>+<polygon fill="none" stroke="black" points="408,-324 340,-324 340,-288 408,-288 408,-324"/>+<text text-anchor="middle" x="374" y="-302.3" font-family="Times,serif" font-size="14.00">Bifunctor</text>+</g>+<!-- biapply -->+<g id="node15" class="node">+<title>biapply</title>+<polygon fill="none" stroke="black" stroke-width="2" points="403.5,-252 344.5,-252 344.5,-216 403.5,-216 403.5,-252"/>+<text text-anchor="middle" x="374" y="-230.3" font-family="Times,serif" font-size="14.00">Biapply</text>+</g>+<!-- bifunctor->biapply -->+<g id="edge17" class="edge">+<title>bifunctor->biapply</title>+<path fill="none" stroke="black" d="M374,-287.7C374,-279.98 374,-270.71 374,-262.11"/>+<polygon fill="black" stroke="black" points="377.5,-262.1 374,-252.1 370.5,-262.1 377.5,-262.1"/>+</g>+<!-- contravariant -->+<g id="node16" class="node">+<title>contravariant</title>+<polygon fill="none" stroke="black" points="542.5,-324 451.5,-324 451.5,-288 542.5,-288 542.5,-324"/>+<text text-anchor="middle" x="497" y="-302.3" font-family="Times,serif" font-size="14.00">Contravariant</text>+</g>+<!-- divise -->+<g id="node17" class="node">+<title>divise</title>+<polygon fill="none" stroke="black" stroke-width="2" points="476,-252 422,-252 422,-216 476,-216 476,-252"/>+<text text-anchor="middle" x="449" y="-230.3" font-family="Times,serif" font-size="14.00">Divise</text>+</g>+<!-- contravariant->divise -->+<g id="edge18" class="edge">+<title>contravariant->divise</title>+<path fill="none" stroke="black" d="M485.13,-287.7C479.5,-279.47 472.65,-269.48 466.43,-260.42"/>+<polygon fill="black" stroke="black" points="469.27,-258.37 460.73,-252.1 463.5,-262.33 469.27,-258.37"/>+</g>+<!-- decide -->+<g id="node18" class="node">+<title>decide</title>+<polygon fill="none" stroke="black" stroke-width="2" points="549.5,-252 494.5,-252 494.5,-216 549.5,-216 549.5,-252"/>+<text text-anchor="middle" x="522" y="-230.3" font-family="Times,serif" font-size="14.00">Decide</text>+</g>+<!-- contravariant->decide -->+<g id="edge19" class="edge">+<title>contravariant->decide</title>+<path fill="none" stroke="black" d="M503.18,-287.7C506,-279.81 509.39,-270.3 512.52,-261.55"/>+<polygon fill="black" stroke="black" points="515.82,-262.7 515.89,-252.1 509.23,-260.34 515.82,-262.7"/>+</g>+<!-- divisible -->+<g id="node19" class="node">+<title>divisible</title>+<polygon fill="none" stroke="black" points="482,-180 416,-180 416,-144 482,-144 482,-180"/>+<text text-anchor="middle" x="449" y="-158.3" font-family="Times,serif" font-size="14.00">Divisible</text>+</g>+<!-- divise->divisible -->+<g id="edge20" class="edge">+<title>divise->divisible</title>+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M449,-215.7C449,-207.98 449,-198.71 449,-190.11"/>+<polygon fill="black" stroke="black" points="452.5,-190.1 449,-180.1 445.5,-190.1 452.5,-190.1"/>+</g>+<!-- decidable -->+<g id="node20" class="node">+<title>decidable</title>+<polygon fill="none" stroke="black" points="582.5,-108 511.5,-108 511.5,-72 582.5,-72 582.5,-108"/>+<text text-anchor="middle" x="547" y="-86.3" font-family="Times,serif" font-size="14.00">Decidable</text>+</g>+<!-- decide->decidable -->+<g id="edge21" class="edge">+<title>decide->decidable</title>+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M524.1,-215.87C526.4,-197.9 530.38,-168.87 535,-144 536.58,-135.52 538.56,-126.34 540.45,-118.04"/>+<polygon fill="black" stroke="black" points="543.9,-118.65 542.77,-108.12 537.09,-117.06 543.9,-118.65"/>+</g>+<!-- conclude -->+<g id="node21" class="node">+<title>conclude</title>+<polygon fill="none" stroke="black" stroke-width="2" points="612,-180 544,-180 544,-144 612,-144 612,-180"/>+<text text-anchor="middle" x="578" y="-158.3" font-family="Times,serif" font-size="14.00">Conclude</text>+</g>+<!-- decide->conclude -->+<g id="edge22" class="edge">+<title>decide->conclude</title>+<path fill="none" stroke="black" d="M535.84,-215.7C542.49,-207.39 550.58,-197.28 557.89,-188.14"/>+<polygon fill="black" stroke="black" points="560.8,-190.1 564.32,-180.1 555.34,-185.73 560.8,-190.1"/>+</g>+<!-- conclude->decidable -->+<g id="edge23" class="edge">+<title>conclude->decidable</title>+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M570.34,-143.7C566.81,-135.73 562.54,-126.1 558.63,-117.26"/>+<polygon fill="black" stroke="black" points="561.82,-115.83 554.57,-108.1 555.42,-118.67 561.82,-115.83"/>+</g>+<!-- semigroupoid -->+<g id="node22" class="node">+<title>semigroupoid</title>+<polygon fill="none" stroke="black" stroke-width="2" points="704,-324 610,-324 610,-288 704,-288 704,-324"/>+<text text-anchor="middle" x="657" y="-302.3" font-family="Times,serif" font-size="14.00">Semigroupoid</text>+</g>+<!-- category -->+<g id="node23" class="node">+<title>category</title>+<polygon fill="none" stroke="black" points="690,-252 624,-252 624,-216 690,-216 690,-252"/>+<text text-anchor="middle" x="657" y="-230.3" font-family="Times,serif" font-size="14.00">Category</text>+</g>+<!-- semigroupoid->category -->+<g id="edge24" class="edge">+<title>semigroupoid->category</title>+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M657,-287.7C657,-279.98 657,-270.71 657,-262.11"/>+<polygon fill="black" stroke="black" points="660.5,-262.1 657,-252.1 653.5,-262.1 660.5,-262.1"/>+</g>+<!-- arrow -->+<g id="node24" class="node">+<title>arrow</title>+<polygon fill="none" stroke="black" points="684,-180 630,-180 630,-144 684,-144 684,-180"/>+<text text-anchor="middle" x="657" y="-158.3" font-family="Times,serif" font-size="14.00">Arrow</text>+</g>+<!-- category->arrow -->+<g id="edge25" class="edge">+<title>category->arrow</title>+<path fill="none" stroke="black" d="M657,-215.7C657,-207.98 657,-198.71 657,-190.11"/>+<polygon fill="black" stroke="black" points="660.5,-190.1 657,-180.1 653.5,-190.1 660.5,-190.1"/>+</g>+</g>+</svg>
semigroupoids.cabal view
@@ -1,42 +1,63 @@+cabal-version: 1.24 name: semigroupoids category: Control, Comonads-version: 3.0-license: BSD3-cabal-version: >= 1.6+version: 6.0.2+license: BSD2 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett <ekmett@gmail.com> stability: provisional homepage: http://github.com/ekmett/semigroupoids bug-reports: http://github.com/ekmett/semigroupoids/issues-copyright: Copyright (C) 2011 Edward A. Kmett+copyright: Copyright (C) 2011-2015 Edward A. Kmett+tested-with: GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.7+ , GHC == 9.8.4+ , GHC == 9.10.3+ , GHC == 9.12.2+ , GHC == 9.14.1 build-type: Simple-synopsis: Haskell 98 semigroupoids: Category sans id-extra-source-files: .travis.yml+synopsis: Semigroupoids: Category sans id+extra-source-files:+ .gitignore+ .vim.custom+ README.markdown+ CHANGELOG.markdown+ img/classes.dot+extra-doc-files:+ img/classes.svg+ description:- Provides a wide array of semigroupoids and operations for working with semigroupds.+ Provides a wide array of (semi)groupoids and operations for working with them. .- A Semigroupoid is a Category without the requirement of identity arrows for every object in the category.+ A 'Semigroupoid' is a 'Category' without the requirement of identity arrows for every object in the category. .+ A 'Category' is any 'Semigroupoid' for which the Yoneda lemma holds.+ . When working with comonads you often have the @\<*\>@ portion of an @Applicative@, but not the @pure@. This was captured in Uustalu and Vene's \"Essence of Dataflow Programming\" in the form of the @ComonadZip@ class in the days before @Applicative@. Apply provides a weaker invariant, but for the comonads used for data flow programming (found in the streams package), this invariant is preserved. Applicative function composition forms a semigroupoid. . Similarly many structures are nearly a comonad, but not quite, for instance lists provide a reasonable 'extend' operation in the form of 'tails', but do not always contain a value. .- .- Ideally the following relationships would hold:+ We describe the relationships between the type classes defined in this package+ and those from `base` (and some from `contravariant`) in the diagram below.+ Thick-bordered nodes correspond to type classes defined in this package;+ thin-bordered ones correspond to type classes from elsewhere. Solid edges+ indicate a subclass relationship that actually exists; dashed edges indicate a+ subclass relationship that /should/ exist, but currently doesn't. .- > Traversable <---- Foldable <--- Functor ------> Alt ---------> Plus Semigroupoid- > | | | | |- > v v v v v- > Traversable1 <--- Foldable1 Apply --------> Applicative -> Alternative Category- > | | | |- > v v v v- > Bind ---------> Monad -------> MonadPlus Arrow- >+ <<https://raw.githubusercontent.com/ekmett/semigroupoids/master/img/classes.svg Relationships among type classes from this package and others>> .- Apply, Bind, and Extract give rise the Static, Kleisli and Cokleisli semigroupoids respectively.+ 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.@@ -47,29 +68,129 @@ source-repository head type: git- location: git://github.com/ekmett/semigroupoids.git+ location: https://github.com/ekmett/semigroupoids.git +flag containers+ description:+ You can disable the use of the `containers` package using `-f-containers`.+ .+ Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.+ default: True+ manual: True++flag contravariant+ description:+ You can disable the use of the `contravariant` package using `-f-contravariant`.+ .+ Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.+ .+ If disabled we will not supply instances of `Contravariant`+ .+ default: True+ manual: True++flag comonad+ description:+ You can disable the use of the `comonad` package using `-f-comonad`.+ .+ Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.+ .+ If disabled we will not supply instances of `Comonad`+ .+ default: True+ manual: True++flag tagged+ description:+ You can disable the use of the `tagged` package using `-f-tagged`.+ .+ Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.+ default: True+ manual: True++flag unordered-containers+ description:+ You can disable the use of the `unordered-containers` package (and also its dependency `hashable`) using `-f-unordered-containers`.+ .+ Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.+ default: True+ manual: True+ library build-depends:- base >= 4 && < 5,- transformers >= 0.2 && < 0.4,- containers >= 0.3 && < 0.6,- contravariant >= 0.2.0.1 && < 0.3,- comonad >= 3.0 && < 3.1,- semigroups >= 0.8.3.1 && < 0.9+ base >= 4.9 && < 5,+ base-orphans >= 0.8.4 && < 1,+ bifunctors >= 5.6 && < 6,+ template-haskell >= 0.2.11,+ transformers >= 0.5 && < 0.7,+ transformers-compat >= 0.6 && < 0.8 + if !impl(ghc >= 9.6)+ build-depends: foldable1-classes-compat >= 0.1 && < 0.2++ -- On GHC-9.6&base-4.18 we require recent enough transformers and containers+ -- with Foldable1 instances.+ if impl(ghc >= 9.6)+ build-depends: transformers >= 0.6.1.0+ if flag(containers)+ build-depends: containers >= 0.6.7++ if flag(containers)+ build-depends: containers >= 0.5.7.1 && < 0.9++ if flag(contravariant)+ build-depends: contravariant >= 1.5.3 && < 2++ if flag(comonad)+ build-depends: comonad >= 5.0.8 && < 6++ if flag(tagged)+ build-depends: tagged >= 0.8.7 && < 1++ if flag(unordered-containers)+ build-depends: hashable >= 1.2.7.0 && < 1.6,+ unordered-containers >= 0.2.8.0 && < 0.3++ hs-source-dirs: src+ exposed-modules:+ Data.Bifunctor.Apply Data.Functor.Alt Data.Functor.Apply Data.Functor.Bind+ Data.Functor.Bind.Class Data.Functor.Bind.Trans- Data.Functor.Plus Data.Functor.Extend+ Data.Functor.Plus+ Data.Groupoid+ Data.Isomorphism+ Data.Semigroup.Bifoldable+ Data.Semigroup.Bitraversable Data.Semigroup.Foldable+ Data.Semigroup.Foldable.Class Data.Semigroup.Traversable+ Data.Semigroup.Traversable.Class Data.Semigroupoid+ Data.Semigroupoid.Categorical Data.Semigroupoid.Dual+ Data.Semigroupoid.Ob Data.Semigroupoid.Static Data.Traversable.Instances+ Semigroupoids.Do+ other-modules:+ Semigroupoids.Internal - ghc-options: -Wall+ if impl(ghc >= 8.6) || flag(contravariant)+ exposed-modules:+ Data.Functor.Contravariant.Conclude+ Data.Functor.Contravariant.Decide+ Data.Functor.Contravariant.Divise++ ghc-options: -Wall -Wno-warnings-deprecations -Wno-trustworthy-safe++ if impl(ghc >= 9.0)+ -- these flags may abort compilation with GHC-8.10+ -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295+ ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode++ default-language: Haskell2010
+ src/Data/Bifunctor/Apply.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE Safe #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2011-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- 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 #-}
+ src/Data/Functor/Alt.hs view
@@ -0,0 +1,335 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# options_ghc -Wno-deprecations #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Functor.Alt+-- Copyright : (C) 2011-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+----------------------------------------------------------------------------+module Data.Functor.Alt+ ( Alt(..)+ , optional+ , galt+ , module Data.Functor.Apply+ ) where++import Control.Applicative hiding (some, many, optional)+import Control.Applicative.Backwards+import Control.Applicative.Lift+import Control.Arrow+import Control.Exception (catch, SomeException)+import Control.Monad+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Except+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+#if MIN_VERSION_transformers(0,5,6)+import qualified Control.Monad.Trans.RWS.CPS as CPS+import qualified Control.Monad.Trans.Writer.CPS as CPS+import Semigroupoids.Internal+#endif+import qualified Control.Monad.Trans.RWS.Strict as Strict+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Strict as Strict+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import Data.Functor.Apply+import Data.Functor.Compose+import Data.Functor.Identity (Identity (Identity))+import Data.Functor.Product+import Data.Functor.Reverse+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.Monoid as Monoid+import Data.Proxy+import Data.Semigroup (Semigroup(..))+import qualified Data.Semigroup as Semigroup+import GHC.Generics+import Prelude (($),Either(..),Maybe(..),const,IO,(++),(.),either,seq,undefined,repeat,mappend)+import Unsafe.Coerce++#if !(MIN_VERSION_transformers(0,6,0))+import Control.Monad.Trans.Error+import Control.Monad.Trans.List+#endif++#if !(MIN_VERSION_base(4,16,0))+import Data.Semigroup (Option(..))+#endif++#ifdef MIN_VERSION_containers+import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap)+import Data.Sequence (Seq)+import qualified Data.Map as Map+import Data.Map (Map)+import Prelude (Ord)+#endif++#ifdef MIN_VERSION_unordered_containers+import Data.Hashable+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap+import Prelude (Eq)+#endif++infixl 3 <!>++-- | Laws:+--+-- > <!> is associative: (a <!> b) <!> c = a <!> (b <!> c)+-- > <$> left-distributes over <!>: f <$> (a <!> b) = (f <$> a) <!> (f <$> b)+--+-- If extended to an 'Alternative' then '<!>' should equal '<|>'.+--+-- Ideally, an instance of 'Alt' also satisfies the \"left distribution\" law of+-- MonadPlus with respect to '<.>':+--+-- > <.> right-distributes over <!>: (a <!> b) <.> c = (a <.> c) <!> (b <.> c)+--+-- 'IO', @'Either' a@, @'ExceptT' e m@ and 'GHC.Conc.STM' instead satisfy the+-- \"left catch\" law:+--+-- > pure a <!> b = pure a+--+-- 'Maybe' and 'Identity' satisfy both \"left distribution\" and \"left catch\".+--+-- These variations cannot be stated purely in terms of the dependencies of 'Alt'.+--+-- When and if MonadPlus is successfully refactored, this class should also+-- be refactored to remove these instances.+--+-- The right distributive law should extend in the cases where the a 'Bind' or 'Monad' is+-- provided to yield variations of the right distributive law:+--+-- > (m <!> n) >>- f = (m >>- f) <!> (m >>- f)+-- > (m <!> n) >>= f = (m >>= f) <!> (m >>= f)++class Functor f => Alt f where+ -- | '<|>' without a required @empty@+ (<!>) :: f a -> f a -> f a++ some :: Applicative f => f a -> f [a]+ some v = some_v+ where many_v = some_v <!> pure []+ some_v = (:) <$> v <*> many_v++ many :: Applicative f => f a -> f [a]+ many v = many_v+ where many_v = some_v <!> pure []+ some_v = (:) <$> v <*> many_v++-- | One or none.+optional :: (Alt f, Applicative f) => f a -> f (Maybe a)+optional v = Just <$> v <!> pure Nothing++-- | Generic ('<!>'). Caveats:+--+-- 1. Will not compile if @f@ is a sum type.+-- 2. Any types where the @a@ does not appear must have a 'Semigroup' instance.+--+-- @since 5.3.8+galt :: (Generic1 f, Alt (Rep1 f)) => f a -> f a -> f a+galt as bs = to1 $ from1 as <!> from1 bs++instance (Alt f, Alt g) => Alt (f :*: g) where+ (as :*: bs) <!> (cs :*: ds) = (as <!> cs) :*: (bs <!> ds)++-- | @since 5.3.8+instance (Alt f, Functor g) => Alt (f :.: g) where+ Comp1 as <!> Comp1 bs = Comp1 (as <!> bs)++newtype Magic f = Magic { runMagic :: forall a. Applicative f => f a -> f [a] }++instance Alt f => Alt (M1 i c f) where+ M1 f <!> M1 g = M1 (f <!> g)+ some = runMagic (unsafeCoerce (Magic some :: Magic f))+ many = runMagic (unsafeCoerce (Magic many :: Magic f))++instance Alt f => Alt (Rec1 f) where+ Rec1 f <!> Rec1 g = Rec1 (f <!> g)+ some = runMagic (unsafeCoerce (Magic some :: Magic f))+ many = runMagic (unsafeCoerce (Magic many :: Magic f))++-- | @since 5.3.8@+instance Semigroup c => Alt (K1 i c) where+ K1 c1 <!> K1 c2 = K1 $ c1 <> c2++instance Alt U1 where+ _ <!> _ = U1+ some _ = U1+ many _ = U1++instance Alt V1 where+ v <!> u = v `seq` u `seq` undefined+ some v = v `seq` undefined+ many v = v `seq` undefined++instance Alt Proxy where+ _ <!> _ = Proxy+ some _ = Proxy+ many _ = Proxy++instance Alt (Either a) where+ Left _ <!> b = b+ a <!> _ = a++-- | This instance does not actually satisfy the ('<.>') right distributive law+-- It instead satisfies the \"left catch\" law+instance Alt IO where+ m <!> n = catch m (go n) where+ go :: x -> SomeException -> x+ go = const++-- | Choose the first option every time. While \'choose the last option\' every+-- time is also valid, this instance satisfies more laws.+--+-- @since 5.3.6+instance Alt Identity where+ {-# INLINEABLE (<!>) #-}+ m <!> _ = m+ some (Identity x) = Identity . repeat $ x+ many (Identity x) = Identity . repeat $ x++instance Alt [] where+ (<!>) = (++)++instance Alt Maybe where+ Nothing <!> b = b+ a <!> _ = a++#if !(MIN_VERSION_base(4,16,0))+instance Alt Option where+ (<!>) = (<|>)+#endif++instance MonadPlus m => Alt (WrappedMonad m) where+ (<!>) = (<|>)++instance ArrowPlus a => Alt (WrappedArrow a b) where+ (<!>) = (<|>)++#ifdef MIN_VERSION_containers+instance Ord k => Alt (Map k) where+ (<!>) = Map.union++instance Alt IntMap where+ (<!>) = IntMap.union++instance Alt Seq where+ (<!>) = mappend+#endif++#ifdef MIN_VERSION_unordered_containers+instance (Hashable k, Eq k) => Alt (HashMap k) where+ (<!>) = HashMap.union+#endif++instance Alt NonEmpty where+ (a :| as) <!> ~(b :| bs) = a :| (as ++ b : bs)++instance Alternative f => Alt (WrappedApplicative f) where+ WrapApplicative a <!> WrapApplicative b = WrapApplicative (a <|> b)++instance Alt f => Alt (IdentityT f) where+ IdentityT a <!> IdentityT b = IdentityT (a <!> b)++instance Alt f => Alt (ReaderT e f) where+ ReaderT a <!> ReaderT b = ReaderT $ \e -> a e <!> b e++instance (Functor f, Monad f) => Alt (MaybeT f) where+ MaybeT a <!> MaybeT b = MaybeT $ do+ v <- a+ case v of+ Nothing -> b+ Just _ -> return v++#if !(MIN_VERSION_transformers(0,6,0))+instance (Functor f, Monad f) => Alt (ErrorT e f) where+ ErrorT m <!> ErrorT n = ErrorT $ do+ a <- m+ case a of+ Left _ -> n+ Right r -> return (Right r)++instance Apply f => Alt (ListT f) where+ ListT a <!> ListT b = ListT $ (<!>) <$> a <.> b+#endif++instance (Functor f, Monad f, Semigroup e) => Alt (ExceptT e f) where+ ExceptT m <!> ExceptT n = ExceptT $ do+ a <- m+ case a of+ Left e -> liftM (either (Left . (<>) e) Right) n+ Right x -> return (Right x)+++instance Alt f => Alt (Strict.StateT e f) where+ Strict.StateT m <!> Strict.StateT n = Strict.StateT $ \s -> m s <!> n s++instance Alt f => Alt (Lazy.StateT e f) where+ Lazy.StateT m <!> Lazy.StateT n = Lazy.StateT $ \s -> m s <!> n s++instance Alt f => Alt (Strict.WriterT w f) where+ Strict.WriterT m <!> Strict.WriterT n = Strict.WriterT $ m <!> n++instance Alt f => Alt (Lazy.WriterT w f) where+ Lazy.WriterT m <!> Lazy.WriterT n = Lazy.WriterT $ m <!> n++#if MIN_VERSION_transformers(0,5,6)+-- | @since 5.3.6+instance (Alt f) => Alt (CPS.WriterT w f) where+ m <!> n = mkWriterT $ \w -> unWriterT m w <!> unWriterT n w+#endif++instance Alt f => Alt (Strict.RWST r w s f) where+ Strict.RWST m <!> Strict.RWST n = Strict.RWST $ \r s -> m r s <!> n r s++instance Alt f => Alt (Lazy.RWST r w s f) where+ Lazy.RWST m <!> Lazy.RWST n = Lazy.RWST $ \r s -> m r s <!> n r s++#if MIN_VERSION_transformers(0,5,6)+-- | @since 5.3.6+instance (Alt f) => Alt (CPS.RWST r w s f) where+ m <!> n = mkRWST $ \r s w -> unRWST m r s w <!> unRWST n r s w+#endif++instance Alt f => Alt (Backwards f) where+ Backwards a <!> Backwards b = Backwards (a <!> b)++instance (Alt f, Functor g) => Alt (Compose f g) where+ Compose a <!> Compose b = Compose (a <!> b)++instance Alt f => Alt (Lift f) where+ Pure a <!> _ = Pure a+ Other _ <!> Pure b = Pure b+ Other a <!> Other b = Other (a <!> b)++instance (Alt f, Alt g) => Alt (Product f g) where+ Pair a1 b1 <!> Pair a2 b2 = Pair (a1 <!> a2) (b1 <!> b2)++instance Alt f => Alt (Reverse f) where+ Reverse a <!> Reverse b = Reverse (a <!> b)++instance Alt Semigroup.First where+ (<!>) = (<>)++instance Alt Semigroup.Last where+ (<!>) = (<>)++instance Alt Monoid.First where+ (<!>) = mappend++instance Alt Monoid.Last where+ (<!>) = mappend
+ src/Data/Functor/Apply.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Trustworthy #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2011-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+----------------------------------------------------------------------------+module Data.Functor.Apply (+ -- * Functors+ Functor(..)+ , (<$>) -- :: Functor f => (a -> b) -> f a -> f b+ , ( $>) -- :: Functor f => f a -> b -> f b++ -- * Apply - a strong lax semimonoidal endofunctor++ , Apply(..)+ , (<..>) -- :: Apply w => w a -> w (a -> b) -> w b+ , liftF3 -- :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d+ , gliftF2+ , gliftF3++ -- * Wrappers+ , WrappedApplicative(..)+ , MaybeApply(..)+ , (<.*>)+ , (<*.>)+ ) where++import Data.Functor+import Data.Functor.Bind.Class+import GHC.Generics++infixl 4 <..>++-- | A variant of '<.>' with the arguments reversed.+(<..>) :: Apply w => w a -> w (a -> b) -> w b+(<..>) = liftF2 (flip id)+{-# INLINE (<..>) #-}+++-- | Lift a ternary function into a comonad with zipping+liftF3 :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d+liftF3 f a b c = f <$> a <.> b <.> c+{-# INLINE liftF3 #-}++-- | Generic 'liftF2'. Caveats:+--+-- 1. Will not compile if @w@ is a sum type.+-- 2. Types in @w@ that do not mention the type variable must be instances of 'Semigroup'.+--+-- @since 5.3.8+gliftF2 :: (Generic1 w, Apply (Rep1 w)) => (a -> b -> c) -> w a -> w b -> w c+gliftF2 f wa wb = to1 $ liftF2 f (from1 wa) (from1 wb)++-- | Generic 'liftF3'. Caveats are the same as for 'gliftF2'.+--+-- @since 5.3.8+gliftF3 :: (Generic1 w, Apply (Rep1 w)) => (a -> b -> c -> d) -> w a -> w b -> w c -> w d+gliftF3 f wa wb wc = to1 $ liftF3 f (from1 wa) (from1 wb) (from1 wc)
+ src/Data/Functor/Bind.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Trustworthy #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2011-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+----------------------------------------------------------------------------+module Data.Functor.Bind (+ -- * Functors+ Functor(..)+ , (<$>) -- :: Functor f => (a -> b) -> f a -> f b+ , ( $>) -- :: Functor f => f a -> b -> f b+ -- * Applyable functors+ , Apply(..)+ , (<..>) -- :: Apply w => w a -> w (a -> b) -> w b+ , liftF3 -- :: Apply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d+ -- * Wrappers+ , WrappedApplicative(..)+ , MaybeApply(..)+ -- * Bindable functors+ , Bind(..)+ , gbind+ , (-<<)+ , (-<-)+ , (->-)+ , apDefault+ , returning+ ) where++import Data.Functor.Apply+import Data.Functor.Bind.Class+import GHC.Generics++-- | Generic '(>>-)'. Caveats:+--+-- 1. Will not compile if @m@ is a sum type.+-- 2. Will not compile if @m@ contains fields that do not mention its type variable.+-- 3. Will not compile if @m@ contains fields where the type variable appears underneath the composition of type constructors (e.g., @f (g a)@).+-- 4. May do redundant work, due to the nature of the 'Bind' instance for (':*:')+--+-- @since 5.3.8+gbind :: (Generic1 m, Bind (Rep1 m)) => m a -> (a -> m b) -> m b+gbind m f = to1 $ from1 m >>- (\a -> from1 $ f a)++infixr 1 -<<, -<-, ->-++(-<<) :: Bind m => (a -> m b) -> m a -> m b+(-<<) = flip (>>-)++(->-) :: Bind m => (a -> m b) -> (b -> m c) -> a -> m c+f ->- g = \a -> f a >>- g++(-<-) :: Bind m => (b -> m c) -> (a -> m b) -> a -> m c+g -<- f = \a -> f a >>- g
+ src/Data/Functor/Bind/Class.hs view
@@ -0,0 +1,856 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wno-deprecations #-}+{-# OPTIONS_HADDOCK not-home #-}++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2011-2018 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- This module is used to resolve the cyclic we get from defining these+-- classes here rather than in a package upstream. Otherwise we'd get+-- orphaned heads for many instances on the types in @transformers@ and @bifunctors@.+----------------------------------------------------------------------------+module Data.Functor.Bind.Class (+ -- * Applyable functors+ Apply(..)+ -- * Wrappers+ , WrappedApplicative(..)+ , MaybeApply(..)+ , (<.*>)+ , (<*.>)+ , traverse1Maybe+ -- * Bindable functors+ , Bind(..)+ , apDefault+ , returning+ -- * Biappliable bifunctors+ , Biapply(..)+ ) where++import Data.Semigroup+import Control.Applicative+import Control.Applicative.Backwards+import Control.Applicative.Lift+import Control.Arrow+import Control.Category+import Control.Monad (ap)+import Control.Monad.ST+import qualified Control.Monad.ST.Lazy as Lazy+import Control.Monad.Trans.Cont+import Control.Monad.Trans.Except+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+#if MIN_VERSION_transformers(0,5,6)+import qualified Control.Monad.Trans.RWS.CPS as CPS+import qualified Control.Monad.Trans.Writer.CPS as CPS+import Semigroupoids.Internal+#endif+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Strict as Strict+import Data.Biapplicative+import Data.Bifunctor.Biff+import Data.Bifunctor.Clown+import Data.Bifunctor.Flip+import Data.Bifunctor.Joker+import Data.Bifunctor.Join+import Data.Bifunctor.Product as Bifunctor+import Data.Bifunctor.Tannen+import Data.Bifunctor.Wrapped+import Data.Complex+import Data.Functor.Compose+import Data.Functor.Constant+import Data.Functor.Identity+import Data.Functor.Product as Functor+import Data.Functor.Reverse+import Data.Functor.Extend+import Data.List.NonEmpty (NonEmpty)+import Data.Ord (Down (..))+import Data.Proxy+import Data.Semigroup as Semigroup+import qualified Data.Monoid as Monoid+import Data.Orphans ()+import GHC.Generics as Generics+import Language.Haskell.TH (Q)+import Prelude hiding (id, (.))++#if !(MIN_VERSION_transformers(0,6,0))+import Control.Monad.Trans.Error+import Control.Monad.Trans.List+#endif++#ifdef MIN_VERSION_containers+import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap)+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Sequence (Seq)+import Data.Tree (Tree)+#endif++#ifdef MIN_VERSION_tagged+import Data.Tagged+#endif++#ifdef MIN_VERSION_unordered_containers+import Data.Hashable+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap+#endif++#ifdef MIN_VERSION_comonad+import Control.Comonad+import Control.Comonad.Trans.Env+import Control.Comonad.Trans.Store+import Control.Comonad.Trans.Traced+#else+($>) :: Functor f => f a -> b -> f b+($>) = flip (<$)+#endif++infixl 1 >>-+infixl 4 <.>, <., .>++-- | A strong lax semi-monoidal endofunctor.+-- This is equivalent to an 'Applicative' without 'pure'.+--+-- Laws:+--+-- @+-- ('.') '<$>' u '<.>' v '<.>' w = u '<.>' (v '<.>' w)+-- x '<.>' (f '<$>' y) = ('.' f) '<$>' x '<.>' y+-- f '<$>' (x '<.>' y) = (f '.') '<$>' x '<.>' y+-- @+--+-- The laws imply that `.>` and `<.` really ignore their+-- left and right results, respectively, and really+-- return their right and left results, respectively.+-- Specifically,+--+-- @+-- (mf '<$>' m) '.>' (nf '<$>' n) = nf '<$>' (m '.>' n)+-- (mf '<$>' m) '<.' (nf '<$>' n) = mf '<$>' (m '<.' n)+-- @+class Functor f => Apply f where+ (<.>) :: f (a -> b) -> f a -> f b+ (<.>) = liftF2 id++ -- | @ a '.>' b = 'const' 'id' '<$>' a '<.>' b @+ (.>) :: f a -> f b -> f b+ a .> b = const id <$> a <.> b++ -- | @ a '<.' b = 'const' '<$>' a '<.>' b @+ (<.) :: f a -> f b -> f a+ a <. b = const <$> a <.> b++ -- | Lift a binary function into a comonad with zipping+ liftF2 :: (a -> b -> c) -> f a -> f b -> f c+ liftF2 f a b = f <$> a <.> b+ {-# INLINE liftF2 #-}++ {-# MINIMAL (<.>) | liftF2 #-}++#ifdef MIN_VERSION_tagged+instance Apply (Tagged a) where+ (<.>) = (<*>)+ (<.) = (<*)+ (.>) = (*>)+#endif++instance Apply Proxy where+ (<.>) = (<*>)+ (<.) = (<*)+ (.>) = (*>)++instance Apply f => Apply (Backwards f) where+ Backwards f <.> Backwards a = Backwards (flip id <$> a <.> f)++instance (Apply f, Apply g) => Apply (Compose f g) where+ Compose f <.> Compose x = Compose ((<.>) <$> f <.> x)++-- | A @'Constant' f@ is not 'Applicative' unless its @f@ is a 'Monoid', but it is an instance of 'Apply'+instance Semigroup f => Apply (Constant f) where+ Constant a <.> Constant b = Constant (a <> b)+ Constant a <. Constant b = Constant (a <> b)+ Constant a .> Constant b = Constant (a <> b)++instance Apply f => Apply (Lift f) where+ Pure f <.> Pure x = Pure (f x)+ Pure f <.> Other y = Other (f <$> y)+ Other f <.> Pure x = Other (($ x) <$> f)+ Other f <.> Other y = Other (f <.> y)++instance (Apply f, Apply g) => Apply (Functor.Product f g) where+ Functor.Pair f g <.> Functor.Pair x y = Functor.Pair (f <.> x) (g <.> y)++instance Apply f => Apply (Reverse f) where+ Reverse a <.> Reverse b = Reverse (a <.> b)++-- | A @'(,)' m@ is not 'Applicative' unless its @m@ is a 'Monoid', but it is an instance of 'Apply'+instance Semigroup m => Apply ((,)m) where+ (m, f) <.> (n, a) = (m <> n, f a)+ (m, a) <. (n, _) = (m <> n, a)+ (m, _) .> (n, b) = (m <> n, b)++instance Apply NonEmpty where+ (<.>) = ap++instance Apply (Either a) where+ Left a <.> _ = Left a+ Right _ <.> Left a = Left a+ Right f <.> Right b = Right (f b)++ Left a <. _ = Left a+ Right _ <. Left a = Left a+ Right a <. Right _ = Right a++ Left a .> _ = Left a+ Right _ .> Left a = Left a+ Right _ .> Right b = Right b++-- | A @'Const' m@ is not 'Applicative' unless its @m@ is a 'Monoid', but it is an instance of 'Apply'+instance Semigroup m => Apply (Const m) where+ Const m <.> Const n = Const (m <> n)+ Const m <. Const n = Const (m <> n)+ Const m .> Const n = Const (m <> n)++instance Apply ((->)m) where+ (<.>) = (<*>)+ (<. ) = (<* )+ ( .>) = ( *>)++instance Apply ZipList where+ (<.>) = (<*>)+ (<. ) = (<* )+ ( .>) = ( *>)++instance Apply [] where+ (<.>) = (<*>)+ (<. ) = (<* )+ ( .>) = ( *>)++instance Apply IO where+ (<.>) = (<*>)+ (<. ) = (<* )+ ( .>) = ( *>)++instance Apply Maybe where+ (<.>) = (<*>)+ (<. ) = (<* )+ ( .>) = ( *>)++#if !(MIN_VERSION_base(4,16,0))+instance Apply Option where+ (<.>) = (<*>)+ (<. ) = (<* )+ ( .>) = ( *>)+#endif++instance Apply Identity where+ (<.>) = (<*>)+ (<. ) = (<* )+ ( .>) = ( *>)++instance Apply w => Apply (IdentityT w) where+ IdentityT wa <.> IdentityT wb = IdentityT (wa <.> wb)++instance Monad m => Apply (WrappedMonad m) where+ (<.>) = (<*>)+ (<. ) = (<* )+ ( .>) = ( *>)++instance Arrow a => Apply (WrappedArrow a b) where+ (<.>) = (<*>)+ (<. ) = (<* )+ ( .>) = ( *>)++instance Apply Complex where+ (a :+ b) <.> (c :+ d) = a c :+ b d++-- Applicative Q was only added in template-haskell 2.7 (GHC 7.4), so+-- define in terms of Monad instead.+instance Apply Q where+ (<.>) = ap++#ifdef MIN_VERSION_containers+-- | A 'Map k' is not 'Applicative', but it is an instance of 'Apply'+instance Ord k => Apply (Map k) where+ (<.>) = Map.intersectionWith id+ (<. ) = Map.intersectionWith const+ ( .>) = Map.intersectionWith (const id)++-- | An 'IntMap' is not 'Applicative', but it is an instance of 'Apply'+instance Apply IntMap where+ (<.>) = IntMap.intersectionWith id+ (<. ) = IntMap.intersectionWith const+ ( .>) = IntMap.intersectionWith (const id)++instance Apply Seq where+ (<.>) = ap++instance Apply Tree where+ (<.>) = (<*>)+ (<. ) = (<* )+ ( .>) = ( *>)+#endif++#ifdef MIN_VERSION_unordered_containers+-- | A 'HashMap k' is not 'Applicative', but it is an instance of 'Apply'+instance (Hashable k, Eq k) => Apply (HashMap k) where+ (<.>) = HashMap.intersectionWith id+#endif++-- MaybeT is _not_ the same as Compose f Maybe+instance (Functor m, Monad m) => Apply (MaybeT m) where+ (<.>) = apDefault++#if !(MIN_VERSION_transformers(0,6,0))+-- ErrorT e is _not_ the same as Compose f (Either e)+instance (Functor m, Monad m) => Apply (ErrorT e m) where+ (<.>) = apDefault++instance Apply m => Apply (ListT m) where+ ListT f <.> ListT a = ListT $ (<.>) <$> f <.> a+#endif++instance (Functor m, Monad m) => Apply (ExceptT e m) where+ (<.>) = apDefault++instance Apply m => Apply (ReaderT e m) where+ ReaderT f <.> ReaderT a = ReaderT $ \e -> f e <.> a e++-- unfortunately, WriterT has its wrapped product in the wrong order to just use (<.>) instead of flap+-- | A @'Strict.WriterT' w m@ is not 'Applicative' unless its @w@ is a 'Monoid', but it is an instance of 'Apply'+instance (Apply m, Semigroup w) => Apply (Strict.WriterT w m) where+ Strict.WriterT f <.> Strict.WriterT a = Strict.WriterT $ flap <$> f <.> a where+ flap (x,m) (y,n) = (x y, m <> n)++-- | A @'Lazy.WriterT' w m@ is not 'Applicative' unless its @w@ is a 'Monoid', but it is an instance of 'Apply'+instance (Apply m, Semigroup w) => Apply (Lazy.WriterT w m) where+ Lazy.WriterT f <.> Lazy.WriterT a = Lazy.WriterT $ flap <$> f <.> a where+ flap ~(x,m) ~(y,n) = (x y, m <> n)++instance Apply (ST s) where+ (<.>) = (<*>)+ (<.) = (<*)+ (.>) = (*>)++instance Apply (Lazy.ST s) where+ (<.>) = (<*>)+ (<.) = (<*)+ (.>) = (*>)+++#if MIN_VERSION_transformers(0,5,6)+-- | @since 5.3.6+instance (Bind m) => Apply (CPS.WriterT w m) where+ mf <.> mx = mkWriterT $ \w ->+ unWriterT mf w >>- \(f, w') -> unWriterT (f <$> mx) w'+#endif++instance Bind m => Apply (Strict.StateT s m) where+ (<.>) = apDefault++instance Bind m => Apply (Lazy.StateT s m) where+ (<.>) = apDefault++-- | An @'Strict.RWST' r w s m@ is not 'Applicative' unless its @w@ is a 'Monoid', but it is an instance of 'Apply'+instance (Bind m, Semigroup w) => Apply (Strict.RWST r w s m) where+ (<.>) = apDefault++-- | An @'Lazy.RWST' r w s m@ is not 'Applicative' unless its @w@ is a 'Monoid', but it is an instance of 'Apply'+instance (Bind m, Semigroup w) => Apply (Lazy.RWST r w s m) where+ (<.>) = apDefault++#if MIN_VERSION_transformers(0,5,6)+-- | @since 5.3.6+instance (Bind m) => Apply (CPS.RWST r w s m) where+ mf <.> mx = mkRWST $ \ r s w ->+ unRWST mf r s w >>- \(f, s', w') -> unRWST (f <$> mx) r s' w'+#endif++instance Apply (ContT r m) where+ ContT f <.> ContT v = ContT $ \k -> f $ \g -> v (k . g)++#ifdef MIN_VERSION_comonad+-- | An @'EnvT' e w@ is not 'Applicative' unless its @e@ is a 'Monoid', but it is an instance of 'Apply'+instance (Semigroup e, Apply w) => Apply (EnvT e w) where+ EnvT ef wf <.> EnvT ea wa = EnvT (ef <> ea) (wf <.> wa)++-- | A @'StoreT' s w@ is not 'Applicative' unless its @s@ is a 'Monoid', but it is an instance of 'Apply'+instance (Apply w, Semigroup s) => Apply (StoreT s w) where+ StoreT ff m <.> StoreT fa n = StoreT ((<*>) <$> ff <.> fa) (m <> n)++instance Apply w => Apply (TracedT m w) where+ TracedT wf <.> TracedT wa = TracedT (ap <$> wf <.> wa)+#endif++-- | Wrap an 'Applicative' to be used as a member of 'Apply'+newtype WrappedApplicative f a = WrapApplicative { unwrapApplicative :: f a }++instance Functor f => Functor (WrappedApplicative f) where+ fmap f (WrapApplicative a) = WrapApplicative (f <$> a)++instance Applicative f => Apply (WrappedApplicative f) where+ WrapApplicative f <.> WrapApplicative a = WrapApplicative (f <*> a)+ WrapApplicative a <. WrapApplicative b = WrapApplicative (a <* b)+ WrapApplicative a .> WrapApplicative b = WrapApplicative (a *> b)++instance Applicative f => Applicative (WrappedApplicative f) where+ pure = WrapApplicative . pure+ WrapApplicative f <*> WrapApplicative a = WrapApplicative (f <*> a)+ WrapApplicative a <* WrapApplicative b = WrapApplicative (a <* b)+ WrapApplicative a *> WrapApplicative b = WrapApplicative (a *> b)++instance Alternative f => Alternative (WrappedApplicative f) where+ empty = WrapApplicative empty+ WrapApplicative a <|> WrapApplicative b = WrapApplicative (a <|> b)++-- | Transform an Apply into an Applicative by adding a unit.+newtype MaybeApply f a = MaybeApply { runMaybeApply :: Either (f a) a }++-- | Apply a non-empty container of functions to a possibly-empty-with-unit container of values.+(<.*>) :: (Apply f) => f (a -> b) -> MaybeApply f a -> f b+ff <.*> MaybeApply (Left fa) = ff <.> fa+ff <.*> MaybeApply (Right a) = ($ a) <$> ff+infixl 4 <.*>++-- | Apply a possibly-empty-with-unit container of functions to a non-empty container of values.+(<*.>) :: (Apply f) => MaybeApply f (a -> b) -> f a -> f b+MaybeApply (Left ff) <*.> fa = ff <.> fa+MaybeApply (Right f) <*.> fa = f <$> fa+infixl 4 <*.>++-- | Traverse a 'Traversable' using 'Apply', getting the results back in a 'MaybeApply'.+traverse1Maybe :: (Traversable t, Apply f) => (a -> f b) -> t a -> MaybeApply f (t b)+traverse1Maybe f = traverse (MaybeApply . Left . f)++instance Functor f => Functor (MaybeApply f) where+ fmap f (MaybeApply (Right a)) = MaybeApply (Right (f a ))+ fmap f (MaybeApply (Left fa)) = MaybeApply (Left (f <$> fa))++instance Apply f => Apply (MaybeApply f) where+ MaybeApply (Right f) <.> MaybeApply (Right a) = MaybeApply (Right (f a ))+ MaybeApply (Right f) <.> MaybeApply (Left fa) = MaybeApply (Left (f <$> fa))+ MaybeApply (Left ff) <.> MaybeApply (Right a) = MaybeApply (Left (($ a) <$> ff))+ MaybeApply (Left ff) <.> MaybeApply (Left fa) = MaybeApply (Left (ff <.> fa))++ MaybeApply a <. MaybeApply (Right _) = MaybeApply a+ MaybeApply (Right a) <. MaybeApply (Left fb) = MaybeApply (Left (a <$ fb))+ MaybeApply (Left fa) <. MaybeApply (Left fb) = MaybeApply (Left (fa <. fb))++ MaybeApply (Right _) .> MaybeApply b = MaybeApply b+ MaybeApply (Left fa) .> MaybeApply (Right b) = MaybeApply (Left (fa $> b ))+ MaybeApply (Left fa) .> MaybeApply (Left fb) = MaybeApply (Left (fa .> fb))++instance Apply f => Applicative (MaybeApply f) where+ pure a = MaybeApply (Right a)+ (<*>) = (<.>)+ (<* ) = (<. )+ ( *>) = ( .>)++instance Extend f => Extend (MaybeApply f) where+ duplicated w@(MaybeApply Right{}) = MaybeApply (Right w)+ duplicated (MaybeApply (Left fa)) = MaybeApply (Left (extended (MaybeApply . Left) fa))++#ifdef MIN_VERSION_comonad+instance Comonad f => Comonad (MaybeApply f) where+ duplicate w@(MaybeApply Right{}) = MaybeApply (Right w)+ duplicate (MaybeApply (Left fa)) = MaybeApply (Left (extend (MaybeApply . Left) fa))+ extract (MaybeApply (Left fa)) = extract fa+ extract (MaybeApply (Right a)) = a++instance Apply (Cokleisli w a) where+ Cokleisli f <.> Cokleisli a = Cokleisli (\w -> (f w) (a w))+#endif++instance Apply Down where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)++instance Apply Monoid.Sum where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)+instance Apply Monoid.Product where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)+instance Apply Monoid.Dual where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)+instance Apply Monoid.First where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)+instance Apply Monoid.Last where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)+deriving instance Apply f => Apply (Monoid.Alt f)+-- in GHC 8.6 we'll have to deal with Apply f => Apply (Ap f) the same way+instance Apply Semigroup.First where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)+instance Apply Semigroup.Last where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)+instance Apply Semigroup.Min where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)+instance Apply Semigroup.Max where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)++instance (Apply f, Apply g) => Apply (f :*: g) where+ (a :*: b) <.> (c :*: d) = (a <.> c) :*: (b <.> d)++deriving instance Apply f => Apply (M1 i t f)+deriving instance Apply f => Apply (Rec1 f)++instance (Apply f, Apply g) => Apply (f :.: g) where+ Comp1 m <.> Comp1 n = Comp1 $ (<.>) <$> m <.> n++instance Apply U1 where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)++-- | A @'K1' i c@ is not 'Applicative' unless its @c@ is a 'Monoid', but it is an instance of 'Apply'+instance Semigroup c => Apply (K1 i c) where+ K1 a <.> K1 b = K1 (a <> b)+ K1 a <. K1 b = K1 (a <> b)+ K1 a .> K1 b = K1 (a <> b)+instance Apply Par1 where (<.>)=(<*>);(.>)=(*>);(<.)=(<*)++-- | A 'V1' is not 'Applicative', but it is an instance of 'Apply'+instance Apply Generics.V1 where+ e <.> _ = case e of {}++-- | A 'Monad' sans 'return'.+--+-- Minimal definition: Either 'join' or '>>-'+--+-- If defining both, then the following laws (the default definitions) must hold:+--+-- > join = (>>- id)+-- > m >>- f = join (fmap f m)+--+-- Laws:+--+-- > induced definition of <.>: f <.> x = f >>- (<$> x)+--+-- Finally, there are two associativity conditions:+--+-- > associativity of (>>-): (m >>- f) >>- g == m >>- (\x -> f x >>- g)+-- > associativity of join: join . join = join . fmap join+--+-- These can both be seen as special cases of the constraint that+--+-- > associativity of (->-): (f ->- g) ->- h = f ->- (g ->- h)+--++class Apply m => Bind m where+ (>>-) :: m a -> (a -> m b) -> m b+ m >>- f = join (fmap f m)++ join :: m (m a) -> m a+ join = (>>- id)++ {-# MINIMAL (>>-) | join #-}++returning :: Functor f => f a -> (a -> b) -> f b+returning = flip fmap++apDefault :: Bind f => f (a -> b) -> f a -> f b+apDefault f x = f >>- \f' -> f' <$> x++-- | A @'(,)' m@ is not a 'Monad' unless its @m@ is a 'Monoid', but it is an instance of 'Bind'+instance Semigroup m => Bind ((,) m) where+ ~(m, a) >>- f = let (n, b) = f a in (m <> n, b)++#ifdef MIN_VERSION_tagged+instance Bind (Tagged a) where+ Tagged a >>- f = f a+ join (Tagged a) = a+#endif++instance Bind Proxy where+ _ >>- _ = Proxy+ join _ = Proxy++instance Bind (Either a) where+ Left a >>- _ = Left a+ Right a >>- f = f a++instance (Bind f, Bind g) => Bind (Functor.Product f g) where+ Functor.Pair m n >>- f = Functor.Pair (m >>- fstP . f) (n >>- sndP . f) where+ fstP (Functor.Pair a _) = a+ sndP (Functor.Pair _ b) = b++instance Bind ((->)m) where+ f >>- g = \e -> g (f e) e++instance Bind [] where+ (>>-) = (>>=)++instance Bind NonEmpty where+ (>>-) = (>>=)++instance Bind IO where+ (>>-) = (>>=)++instance Bind (ST s) where+ (>>-) = (>>=)++instance Bind (Lazy.ST s) where+ (>>-) = (>>=)++instance Bind Maybe where+ (>>-) = (>>=)++#if !(MIN_VERSION_base(4,16,0))+instance Bind Option where+ (>>-) = (>>=)+#endif++instance Bind Identity where+ (>>-) = (>>=)++instance Bind Q where+ (>>-) = (>>=)++instance Bind m => Bind (IdentityT m) where+ IdentityT m >>- f = IdentityT (m >>- runIdentityT . f)++instance Monad m => Bind (WrappedMonad m) where+ WrapMonad m >>- f = WrapMonad $ m >>= unwrapMonad . f++instance (Functor m, Monad m) => Bind (MaybeT m) where+ (>>-) = (>>=) -- distributive law requires Monad to inject @Nothing@++#if !(MIN_VERSION_transformers(0,6,0))+instance (Apply m, Monad m) => Bind (ListT m) where+ (>>-) = (>>=) -- distributive law requires Monad to inject @[]@++instance (Functor m, Monad m) => Bind (ErrorT e m) where+ m >>- k = ErrorT $ do+ a <- runErrorT m+ case a of+ Left l -> return (Left l)+ Right r -> runErrorT (k r)+#endif++instance (Functor m, Monad m) => Bind (ExceptT e m) where+ m >>- k = ExceptT $ do+ a <- runExceptT m+ case a of+ Left l -> return (Left l)+ Right r -> runExceptT (k r)++instance Bind m => Bind (ReaderT e m) where+ ReaderT m >>- f = ReaderT $ \e -> m e >>- \x -> runReaderT (f x) e++-- | A @'Lazy.WriterT' w m@ is not a 'Monad' unless its @w@ is a 'Monoid', but it is an instance of 'Bind'+instance (Bind m, Semigroup w) => Bind (Lazy.WriterT w m) where+ m >>- k = Lazy.WriterT $+ Lazy.runWriterT m >>- \ ~(a, w) ->+ Lazy.runWriterT (k a) `returning` \ ~(b, w') ->+ (b, w <> w')++-- | A @'Strict.WriterT' w m@ is not a 'Monad' unless its @w@ is a 'Monoid', but it is an instance of 'Bind'+instance (Bind m, Semigroup w) => Bind (Strict.WriterT w m) where+ m >>- k = Strict.WriterT $+ Strict.runWriterT m >>- \ (a, w) ->+ Strict.runWriterT (k a) `returning` \ (b, w') ->+ (b, w <> w')++#if MIN_VERSION_transformers(0,5,6)+-- | @since 5.3.6+instance (Bind m) => Bind (CPS.WriterT w m) where+ m >>- k = mkWriterT $ \ w ->+ unWriterT m w >>- \(a, w') -> unWriterT (k a) w'+#endif++instance Bind m => Bind (Lazy.StateT s m) where+ m >>- k = Lazy.StateT $ \s ->+ Lazy.runStateT m s >>- \ ~(a, s') ->+ Lazy.runStateT (k a) s'++instance Bind m => Bind (Strict.StateT s m) where+ m >>- k = Strict.StateT $ \s ->+ Strict.runStateT m s >>- \ ~(a, s') ->+ Strict.runStateT (k a) s'++-- | An @'Lazy.RWST' r w s m@ is not a 'Monad' unless its @w@ is a 'Monoid', but it is an instance of 'Bind'+instance (Bind m, Semigroup w) => Bind (Lazy.RWST r w s m) where+ m >>- k = Lazy.RWST $ \r s ->+ Lazy.runRWST m r s >>- \ ~(a, s', w) ->+ Lazy.runRWST (k a) r s' `returning` \ ~(b, s'', w') ->+ (b, s'', w <> w')++-- | An @'Strict.RWST' r w s m@ is not a 'Monad' unless its @w@ is a 'Monoid', but it is an instance of 'Bind'+instance (Bind m, Semigroup w) => Bind (Strict.RWST r w s m) where+ m >>- k = Strict.RWST $ \r s ->+ Strict.runRWST m r s >>- \ (a, s', w) ->+ Strict.runRWST (k a) r s' `returning` \ (b, s'', w') ->+ (b, s'', w <> w')++#if MIN_VERSION_transformers(0,5,6)+-- | @since 5.3.6+instance (Bind m) => Bind (CPS.RWST r w s m) where+ m >>- k = mkRWST $ \ r s w ->+ unRWST m r s w >>- \(a, s', w') -> unRWST (k a) r s' w'+#endif++instance Bind (ContT r m) where+ m >>- k = ContT $ \c -> runContT m $ \a -> runContT (k a) c++instance Bind Complex where+ (a :+ b) >>- f = a' :+ b' where+ a' :+ _ = f a+ _ :+ b' = f b+ {-# INLINE (>>-) #-}++#ifdef MIN_VERSION_containers+-- | A 'Map k' is not a 'Monad', but it is an instance of 'Bind'+instance Ord k => Bind (Map k) where+ m >>- f = Map.mapMaybeWithKey (\k -> Map.lookup k . f) m++-- | An 'IntMap' is not a 'Monad', but it is an instance of 'Bind'+instance Bind IntMap where+ m >>- f = IntMap.mapMaybeWithKey (\k -> IntMap.lookup k . f) m++instance Bind Seq where+ (>>-) = (>>=)++instance Bind Tree where+ (>>-) = (>>=)+#endif++#ifdef MIN_VERSION_unordered_containers+-- | A 'HashMap k' is not a 'Monad', but it is an instance of 'Bind'+instance (Hashable k, Eq k) => Bind (HashMap k) where+ -- this is needlessly painful+ m >>- f = HashMap.fromList $ do+ (k, a) <- HashMap.toList m+ case HashMap.lookup k (f a) of+ Just b -> [(k,b)]+ Nothing -> []+#endif++instance Bind Down where Down a >>- f = f a++instance Bind Monoid.Sum where (>>-) = (>>=)+instance Bind Monoid.Product where (>>-) = (>>=)+instance Bind Monoid.Dual where (>>-) = (>>=)+instance Bind Monoid.First where (>>-) = (>>=)+instance Bind Monoid.Last where (>>-) = (>>=)+instance Bind f => Bind (Monoid.Alt f) where+ Monoid.Alt m >>- k = Monoid.Alt (m >>- Monoid.getAlt . k)+-- in GHC 8.6 we'll have to deal with Bind f => Bind (Ap f) the same way+instance Bind Semigroup.First where (>>-) = (>>=)+instance Bind Semigroup.Last where (>>-) = (>>=)+instance Bind Semigroup.Min where (>>-) = (>>=)+instance Bind Semigroup.Max where (>>-) = (>>=)+-- | A 'V1' is not a 'Monad', but it is an instance of 'Bind'+instance Bind Generics.V1 where+ m >>- _ = case m of {}++-- | @since 5.3.8+instance Bind Generics.U1 where (>>-)=(>>=)++-- | @since 5.3.8+instance Bind f => Bind (Generics.M1 i c f) where+ M1 m >>- f = M1 $ m >>- \a -> case f a of+ M1 m' -> m'++-- | @since 5.3.8+instance Bind m => Bind (Generics.Rec1 m) where+ Rec1 m >>- f = Rec1 $ m >>- \a -> case f a of+ Rec1 m' -> m'++-- | @since 5.3.8+instance Bind Generics.Par1 where+ Par1 m >>- f = f m++-- | @since 5.3.8+instance (Bind f, Bind g) => Bind (f :*: g) where+ m :*: n >>- f = (m >>- fstP . f) :*: (n >>- sndP . f) where+ fstP (a :*: _) = a+ sndP (_ :*: b) = b++infixl 4 <<.>>, <<., .>>++class Bifunctor p => Biapply p where+ (<<.>>) :: p (a -> b) (c -> d) -> p a c -> p b d++ -- |+ -- @+ -- a '.>' b ≡ 'const' 'id' '<$>' a '<.>' b+ -- @+ (.>>) :: p a b -> p c d -> p c d+ a .>> b = bimap (const id) (const id) <<$>> a <<.>> b+ {-# INLINE (.>>) #-}++ -- |+ -- @+ -- a '<.' b ≡ 'const' '<$>' a '<.>' b+ -- @+ (<<.) :: p a b -> p c d -> p a b+ a <<. b = bimap const const <<$>> a <<.>> b+ {-# INLINE (<<.) #-}++instance Biapply (,) where+ (f, g) <<.>> (a, b) = (f a, g b)+ {-# INLINE (<<.>>) #-}++instance Biapply Arg where+ Arg f g <<.>> Arg a b = Arg (f a) (g b)+ {-# INLINE (<<.>>) #-}++instance Semigroup x => Biapply ((,,) x) where+ (x, f, g) <<.>> (x', a, b) = (x <> x', f a, g b)+ {-# INLINE (<<.>>) #-}++instance (Semigroup x, Semigroup y) => Biapply ((,,,) x y) where+ (x, y, f, g) <<.>> (x', y', a, b) = (x <> x', y <> y', f a, g b)+ {-# INLINE (<<.>>) #-}++instance (Semigroup x, Semigroup y, Semigroup z) => Biapply ((,,,,) x y z) where+ (x, y, z, f, g) <<.>> (x', y', z', a, b) = (x <> x', y <> y', z <> z', f a, g b)+ {-# INLINE (<<.>>) #-}++instance Biapply Const where+ Const f <<.>> Const x = Const (f x)+ {-# INLINE (<<.>>) #-}++#ifdef MIN_VERSION_tagged+instance Biapply Tagged where+ Tagged f <<.>> Tagged x = Tagged (f x)+ {-# INLINE (<<.>>) #-}+#endif++instance (Biapply p, Apply f, Apply g) => Biapply (Biff p f g) where+ Biff fg <<.>> Biff xy = Biff (bimap (<.>) (<.>) fg <<.>> xy)+ {-# INLINE (<<.>>) #-}++instance Apply f => Biapply (Clown f) where+ Clown fg <<.>> Clown xy = Clown (fg <.> xy)+ {-# INLINE (<<.>>) #-}++instance Biapply p => Biapply (Flip p) where+ Flip fg <<.>> Flip xy = Flip (fg <<.>> xy)+ {-# INLINE (<<.>>) #-}++instance Apply g => Biapply (Joker g) where+ Joker fg <<.>> Joker xy = Joker (fg <.> xy)+ {-# INLINE (<<.>>) #-}++-- orphan mess+instance Biapply p => Apply (Join p) where+ Join f <.> Join a = Join (f <<.>> a)+ {-# INLINE (<.>) #-}+ Join a .> Join b = Join (a .>> b)+ {-# INLINE (.>) #-}+ Join a <. Join b = Join (a <<. b)+ {-# INLINE (<.) #-}++instance (Biapply p, Biapply q) => Biapply (Bifunctor.Product p q) where+ Bifunctor.Pair w x <<.>> Bifunctor.Pair y z = Bifunctor.Pair (w <<.>> y) (x <<.>> z)+ {-# INLINE (<<.>>) #-}++instance (Apply f, Biapply p) => Biapply (Tannen f p) where+ Tannen fg <<.>> Tannen xy = Tannen ((<<.>>) <$> fg <.> xy)+ {-# INLINE (<<.>>) #-}++instance Biapply p => Biapply (WrappedBifunctor p) where+ WrapBifunctor fg <<.>> WrapBifunctor xy = WrapBifunctor (fg <<.>> xy)+ {-# INLINE (<<.>>) #-}
+ src/Data/Functor/Bind/Trans.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Safe #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Functor.Bind.Trans+-- Copyright : (C) 2011-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+----------------------------------------------------------------------------+module Data.Functor.Bind.Trans (+ BindTrans(..)+ ) where++-- import _everything_+import Control.Category+import Control.Monad.Trans.Class+import Control.Monad.Trans.Cont+-- import Control.Monad.Trans.Error+import Control.Monad.Trans.Identity+-- import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+-- import Control.Monad.Trans.List+#if MIN_VERSION_transformers(0,5,6)+import qualified Control.Monad.Trans.RWS.CPS as CPS+import qualified Control.Monad.Trans.Writer.CPS as CPS+#endif+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Strict as Strict+import Data.Functor.Bind+import Data.Orphans ()+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup hiding (Product)+#endif+import Prelude hiding (id, (.))++-- | A subset of monad transformers can transform any 'Bind' as well.+class MonadTrans t => BindTrans t where+ liftB :: Bind b => b a -> t b a++instance BindTrans IdentityT where+ liftB = IdentityT++instance BindTrans (ReaderT e) where+ liftB = ReaderT . const++instance Monoid w => BindTrans (Lazy.WriterT w) where+ liftB = Lazy.WriterT . fmap (\a -> (a, mempty))++instance Monoid w => BindTrans (Strict.WriterT w) where+ liftB = Strict.WriterT . fmap (\a -> (a, mempty))++#if MIN_VERSION_transformers(0,5,6)+-- | @since 5.3.6+instance Monoid w => BindTrans (CPS.WriterT w) where+ liftB = CPS.writerT . fmap (\a -> (a, mempty))+#endif++instance BindTrans (Lazy.StateT s) where+ liftB m = Lazy.StateT $ \s -> fmap (\a -> (a, s)) m++instance BindTrans (Strict.StateT s) where+ liftB m = Strict.StateT $ \s -> fmap (\a -> (a, s)) m++instance Monoid w => BindTrans (Lazy.RWST r w s) where+ liftB m = Lazy.RWST $ \ _r s -> fmap (\a -> (a, s, mempty)) m++instance Monoid w => BindTrans (Strict.RWST r w s) where+ liftB m = Strict.RWST $ \ _r s -> fmap (\a -> (a, s, mempty)) m++#if MIN_VERSION_transformers(0,5,6)+-- | @since 5.3.6+instance Monoid w => BindTrans (CPS.RWST r w s) where+ liftB m = CPS.rwsT $ \ _r s -> fmap (\a -> (a, s, mempty)) m+#endif++instance BindTrans (ContT r) where+ liftB m = ContT (m >>-)
+ src/Data/Functor/Contravariant/Conclude.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Safe #-}++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2021 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- This module is only available if building with GHC 8.6 or later, or if the+-- @+contravariant@ @cabal@ build flag is available.+----------------------------------------------------------------------------+module Data.Functor.Contravariant.Conclude (+ Conclude(..)+ , gconclude+ , concluded+ , gconcluded+ ) where++import Control.Applicative.Backwards+import Control.Monad.Trans.Identity+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict++import Data.Functor.Apply+import Data.Functor.Compose+import Data.Functor.Contravariant+import Data.Functor.Contravariant.Decide+import Data.Functor.Product+import Data.Functor.Reverse+import Data.Monoid (Alt(..))+import Data.Proxy+import Data.Void+import GHC.Generics++#if defined(MIN_VERSION_contravariant)+# if !(MIN_VERSION_transformers(0,6,0))+import Control.Monad.Trans.List+# endif+import Control.Monad.Trans.Maybe+import Data.Functor.Contravariant.Divise+import Data.Functor.Contravariant.Divisible+#endif++#ifdef MIN_VERSION_StateVar+import Data.StateVar+#endif++-- | The contravariant analogue of 'Plus'. Adds on to 'Decide' the ability+-- to express a combinator that rejects all input, to act as the dead-end.+-- Essentially 'Decidable' without a superclass constraint on 'Divisible'.+--+-- If one thinks of @f a@ as a consumer of @a@s, then 'conclude' defines+-- a consumer that cannot ever receive /any/ input.+--+-- Conclude acts as an identity with 'decide', because any decision that+-- involves 'conclude' must necessarily /always/ pick the other option.+--+-- That is, for, say,+--+-- @+-- 'decide' f x 'concluded'+-- @+--+-- @f@ is the deciding function that picks which of the inputs of @decide@+-- to direct input to; in the situation above, @f@ must /always/ direct all+-- input to @x@, and never 'concluded'.+--+-- Mathematically, a functor being an instance of 'Decide' means that it is+-- \"monoidal\" with respect to the contravariant "either-based" Day+-- convolution described in the documentation of 'Decide'. On top of+-- 'Decide', it adds a way to construct an \"identity\" @conclude@ where+-- @decide f x (conclude q) == x@, and @decide g (conclude r) y == y@.+--+-- @since 5.3.6+class Decide f => Conclude f where+ -- | The consumer that cannot ever receive /any/ input.+ conclude :: (a -> Void) -> f a++-- | Generic 'conclude'. Caveats:+--+-- 1. Will not compile if @f@ is a sum type.+-- 2. Will not compile if @f@ contains fields that do not mention its type variable.+--+-- @since 5.3.8+gconclude :: (Generic1 f, Conclude (Rep1 f)) => (a -> Void) -> f a+gconclude f = to1 $ conclude f++-- | A potentially more meaningful form of 'conclude', the consumer that cannot+-- ever receive /any/ input. That is because it expects only input of type+-- 'Void', but such a type has no values.+--+-- @+-- 'concluded' = 'conclude' 'id'+-- @+--+-- @since 5.3.6+concluded :: Conclude f => f Void+concluded = conclude id++-- | Generic 'concluded'. Caveats are the same as for 'gconclude'.+--+-- @since 5.3.8+gconcluded :: (Generic1 f, Conclude (Rep1 f)) => f Void+gconcluded = to1 concluded++#if defined(MIN_VERSION_contravariant)+-- | This instance is only available if the @+contravariant@ @cabal@ flag is+-- enabled.+--+-- @since 5.3.6+instance Decidable f => Conclude (WrappedDivisible f) where+ conclude f = WrapDivisible (lose f)+#endif++-- | @since 5.3.6+instance Conclude Comparison where+ conclude f = Comparison $ \a _ -> absurd (f a)++-- | @since 5.3.6+instance Conclude Equivalence where+ conclude f = Equivalence $ absurd . f++-- | @since 5.3.6+instance Conclude Predicate where+ conclude f = Predicate $ absurd . f++-- | @since 5.3.6+instance Conclude (Op r) where+ conclude f = Op $ absurd . f++-- | @since 5.3.6+instance Conclude Proxy where+ conclude _ = Proxy++#ifdef MIN_VERSION_StateVar+-- | @since 5.3.6+instance Conclude SettableStateVar where+ conclude k = SettableStateVar (absurd . k)+#endif++-- | @since 5.3.6+instance Conclude f => Conclude (Alt f) where+ conclude = Alt . conclude++-- | @since 5.3.6+instance Conclude U1 where+ conclude _ = U1++-- | @since 5.3.6+instance Conclude f => Conclude (Rec1 f) where+ conclude = Rec1 . conclude++-- | @since 5.3.6+instance Conclude f => Conclude (M1 i c f) where+ conclude = M1 . conclude++-- | @since 5.3.6+instance (Conclude f, Conclude g) => Conclude (f :*: g) where+ conclude f = conclude f :*: conclude f++-- | @since 5.3.6+instance (Apply f, Applicative f, Conclude g) => Conclude (f :.: g) where+ conclude = Comp1 . pure . conclude++-- | @since 5.3.6+instance Conclude f => Conclude (Backwards f) where+ conclude = Backwards . conclude++-- | @since 5.3.6+instance Conclude f => Conclude (IdentityT f) where+ conclude = IdentityT . conclude++-- | @since 5.3.6+instance Conclude m => Conclude (ReaderT r m) where+ conclude f = ReaderT $ \_ -> conclude f++-- | @since 5.3.6+instance Conclude m => Conclude (Lazy.RWST r w s m) where+ conclude f = Lazy.RWST $ \_ _ -> contramap (\ ~(a, _, _) -> a) (conclude f)++-- | @since 5.3.6+instance Conclude m => Conclude (Strict.RWST r w s m) where+ conclude f = Strict.RWST $ \_ _ -> contramap (\(a, _, _) -> a) (conclude f)++#if defined(MIN_VERSION_contravariant)+# if !(MIN_VERSION_transformers(0,6,0))+-- | This instance is only available if the @+contravariant@ @cabal@ flag is+-- enabled.+--+-- @since 5.3.6+instance (Divisible m, Divise m) => Conclude (ListT m) where+ conclude _ = ListT conquer+# endif++-- | This instance is only available if the @+contravariant@ @cabal@ flag is+-- enabled.+--+-- @since 5.3.6+instance (Divisible m, Divise m) => Conclude (MaybeT m) where+ conclude _ = MaybeT conquer+#endif++-- | @since 5.3.6+instance Conclude m => Conclude (Lazy.StateT s m) where+ conclude f = Lazy.StateT $ \_ -> contramap lazyFst (conclude f)++-- | @since 5.3.6+instance Conclude m => Conclude (Strict.StateT s m) where+ conclude f = Strict.StateT $ \_ -> contramap fst (conclude f)++-- | @since 5.3.6+instance Conclude m => Conclude (Lazy.WriterT w m) where+ conclude f = Lazy.WriterT $ contramap lazyFst (conclude f)++-- | @since 5.3.6+instance Conclude m => Conclude (Strict.WriterT w m) where+ conclude f = Strict.WriterT $ contramap fst (conclude f)++-- | @since 5.3.6+instance (Apply f, Applicative f, Conclude g) => Conclude (Compose f g) where+ conclude = Compose . pure . conclude++-- | @since 5.3.6+instance (Conclude f, Conclude g) => Conclude (Product f g) where+ conclude f = Pair (conclude f) (conclude f)++-- | @since 5.3.6+instance Conclude f => Conclude (Reverse f) where+ conclude = Reverse . conclude++-- Helpers++lazyFst :: (a, b) -> a+lazyFst ~(a, _) = a
+ src/Data/Functor/Contravariant/Decide.hs view
@@ -0,0 +1,271 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE TypeOperators #-}++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2021 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- This module is only available if building with GHC 8.6 or later, or if the+-- @+contravariant@ @cabal@ build flag is available.+----------------------------------------------------------------------------+module Data.Functor.Contravariant.Decide (+ Decide(..)+ , gdecide+ , decided+ , gdecided+ ) where++import Control.Applicative.Backwards+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict++import Data.Functor.Apply+import Data.Functor.Compose+import Data.Functor.Contravariant+import Data.Functor.Contravariant.Divise+import Data.Functor.Product+import Data.Functor.Reverse+import Data.Monoid (Alt(..))+import Data.Proxy+import GHC.Generics++#if !(MIN_VERSION_transformers(0,6,0))+import Control.Arrow+import Control.Monad.Trans.List+import Data.Either+#endif++#if defined(MIN_VERSION_contravariant)+import Data.Functor.Contravariant.Divisible+#endif++#ifdef MIN_VERSION_StateVar+import Data.StateVar+#endif++-- | The contravariant analogue of 'Alt'.+--+-- If one thinks of @f a@ as a consumer of @a@s, then 'decide' allows one+-- to handle the consumption of a value by choosing to handle it via+-- exactly one of two independent consumers. It redirects the input+-- completely into one of two consumers.+--+-- 'decide' takes the \"decision\" method and the two potential consumers,+-- and returns the wrapped/combined consumer.+--+-- Mathematically, a functor being an instance of 'Decide' means that it is+-- \"semigroupoidal\" with respect to the contravariant \"either-based\" Day+-- convolution (@data EitherDay f g a = forall b c. EitherDay (f b) (g c) (a -> Either b c)@).+-- That is, it is possible to define a function @(f `EitherDay` f) a ->+-- f a@ in a way that is associative.+--+-- @since 5.3.6+class Contravariant f => Decide f where+ -- | Takes the \"decision\" method and the two potential consumers, and+ -- returns the wrapped/combined consumer.+ decide :: (a -> Either b c) -> f b -> f c -> f a++-- | Generic 'decide'. Caveats:+--+-- 1. Will not compile if @f@ is a sum type.+-- 2. Will not compile if @f@ contains fields that do not mention its type variable.+-- 3. @-XDeriveGeneric@ is not smart enough to make instances where the type variable appears in negative position.+--+-- @since 5.3.8+gdecide :: (Generic1 f, Decide (Rep1 f)) => (a -> Either b c) -> f b -> f c -> f a+gdecide f fb fc = to1 $ decide f (from1 fb) (from1 fc)++-- | For @'decided' x y@, the resulting @f ('Either' b c)@ will direct+-- 'Left's to be consumed by @x@, and 'Right's to be consumed by y.+--+-- @since 5.3.6+decided :: Decide f => f b -> f c -> f (Either b c)+decided = decide id++-- | Generic 'decided'. Caveats are the same as for 'gdecide'.+--+-- @since 5.3.8+gdecided :: (Generic1 f, Decide (Rep1 f)) => f b -> f c -> f (Either b c)+gdecided fb fc = gdecide id fb fc++#if defined(MIN_VERSION_contravariant)+-- | This instance is only available if the @+contravariant@ @cabal@ flag is+-- enabled.+--+-- @since 5.3.6+instance Decidable f => Decide (WrappedDivisible f) where+ decide f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (choose f x y)+#endif++-- | @since 5.3.6+instance Decide Comparison where+ decide f (Comparison g) (Comparison h) = Comparison $ \a b -> case f a of+ Left c -> case f b of+ Left d -> g c d+ Right{} -> LT+ Right c -> case f b of+ Left{} -> GT+ Right d -> h c d++-- | @since 5.3.6+instance Decide Equivalence where+ decide f (Equivalence g) (Equivalence h) = Equivalence $ \a b -> case f a of+ Left c -> case f b of+ Left d -> g c d+ Right{} -> False+ Right c -> case f b of+ Left{} -> False+ Right d -> h c d++-- | @since 5.3.6+instance Decide Predicate where+ decide f (Predicate g) (Predicate h) = Predicate $ either g h . f++-- | Unlike 'Decidable', requires no constraint on @r@.+--+-- @since 5.3.6+instance Decide (Op r) where+ decide f (Op g) (Op h) = Op $ either g h . f++-- | @since 5.3.6+instance Decide f => Decide (Alt f) where+ decide f (Alt l) (Alt r) = Alt $ decide f l r++-- | @since 5.3.6+instance Decide U1 where+ decide _ U1 U1 = U1++-- | Has no 'Decidable' or 'Conclude' instance.+--+-- @since 5.3.6+instance Decide V1 where decide _ x = case x of {}++-- | @since 5.3.6+instance Decide f => Decide (Rec1 f) where+ decide f (Rec1 l) (Rec1 r) = Rec1 $ decide f l r++-- | @since 5.3.6+instance Decide f => Decide (M1 i c f) where+ decide f (M1 l) (M1 r) = M1 $ decide f l r++-- | @since 5.3.6+instance (Decide f, Decide g) => Decide (f :*: g) where+ decide f (l1 :*: r1) (l2 :*: r2) = decide f l1 l2 :*: decide f r1 r2++-- | Unlike 'Decidable', requires only 'Apply' on @f@.+--+-- @since 5.3.6+instance (Apply f, Decide g) => Decide (f :.: g) where+ decide f (Comp1 l) (Comp1 r) = Comp1 (liftF2 (decide f) l r)++-- | @since 5.3.6+instance Decide f => Decide (Backwards f) where+ decide f (Backwards l) (Backwards r) = Backwards $ decide f l r++-- | @since 5.3.6+instance Decide f => Decide (IdentityT f) where+ decide f (IdentityT l) (IdentityT r) = IdentityT $ decide f l r++-- | @since 5.3.6+instance Decide m => Decide (ReaderT r m) where+ decide abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> decide abc (rmb r) (rmc r)++-- | @since 5.3.6+instance Decide m => Decide (Lazy.RWST r w s m) where+ decide abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s ->+ decide (\ ~(a, s', w) -> either (Left . betuple3 s' w)+ (Right . betuple3 s' w)+ (abc a))+ (rsmb r s) (rsmc r s)++-- | @since 5.3.6+instance Decide m => Decide (Strict.RWST r w s m) where+ decide abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s ->+ decide (\(a, s', w) -> either (Left . betuple3 s' w)+ (Right . betuple3 s' w)+ (abc a))+ (rsmb r s) (rsmc r s)++#if !(MIN_VERSION_transformers(0,6,0))+-- | @since 5.3.6+instance Divise m => Decide (ListT m) where+ decide f (ListT l) (ListT r) = ListT $ divise ((lefts &&& rights) . map f) l r+#endif++-- | @since 5.3.6+instance Divise m => Decide (MaybeT m) where+ decide f (MaybeT l) (MaybeT r) = MaybeT $+ divise ( maybe (Nothing, Nothing)+ (either (\b -> (Just b, Nothing))+ (\c -> (Nothing, Just c)) . f)+ ) l r++-- | @since 5.3.6+instance Decide m => Decide (Lazy.StateT s m) where+ decide f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s ->+ decide (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a))+ (l s) (r s)++-- | @since 5.3.6+instance Decide m => Decide (Strict.StateT s m) where+ decide f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s ->+ decide (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a))+ (l s) (r s)++-- | @since 5.3.6+instance Decide m => Decide (Lazy.WriterT w m) where+ decide f (Lazy.WriterT l) (Lazy.WriterT r) = Lazy.WriterT $+ decide (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r++-- | @since 5.3.6+instance Decide m => Decide (Strict.WriterT w m) where+ decide f (Strict.WriterT l) (Strict.WriterT r) = Strict.WriterT $+ decide (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r++-- | Unlike 'Decidable', requires only 'Apply' on @f@.+--+-- @since 5.3.6+instance (Apply f, Decide g) => Decide (Compose f g) where+ decide f (Compose l) (Compose r) = Compose (liftF2 (decide f) l r)++-- | @since 5.3.6+instance (Decide f, Decide g) => Decide (Product f g) where+ decide f (Pair l1 r1) (Pair l2 r2) = Pair (decide f l1 l2) (decide f r1 r2)++-- | @since 5.3.6+instance Decide f => Decide (Reverse f) where+ decide f (Reverse l) (Reverse r) = Reverse $ decide f l r++betuple :: s -> a -> (a, s)+betuple s a = (a, s)++betuple3 :: s -> w -> a -> (a, s, w)+betuple3 s w a = (a, s, w)++-- | @since 5.3.6+instance Decide Proxy where+ decide _ Proxy Proxy = Proxy++#ifdef MIN_VERSION_StateVar+-- | @since 5.3.6+instance Decide SettableStateVar where+ decide k (SettableStateVar l) (SettableStateVar r) = SettableStateVar $ \ a -> case k a of+ Left b -> l b+ Right c -> r c+#endif
+ src/Data/Functor/Contravariant/Divise.hs view
@@ -0,0 +1,311 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE TypeOperators #-}++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2021 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- This module is only available if building with GHC 8.6 or later, or if the+-- @+contravariant@ @cabal@ build flag is available.+----------------------------------------------------------------------------+module Data.Functor.Contravariant.Divise (+ Divise(..)+ , gdivise+ , divised+ , gdivised+ , WrappedDivisible(..)+ ) where++import Control.Applicative+import Control.Applicative.Backwards+import Control.Arrow+import Control.Monad.Trans.Except+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict++import Data.Functor.Apply+import Data.Functor.Compose+import Data.Functor.Constant+import Data.Functor.Contravariant+import Data.Functor.Product+import Data.Functor.Reverse+import Data.Monoid (Alt(..))+import Data.Proxy+import GHC.Generics++#if !(MIN_VERSION_transformers(0,6,0))+import Control.Monad.Trans.Error+import Control.Monad.Trans.List+#endif++#if !MIN_VERSION_base(4,12,0)+import Data.Semigroup (Semigroup(..))+#endif++#if defined(MIN_VERSION_contravariant)+import Data.Functor.Contravariant.Divisible+#endif++#ifdef MIN_VERSION_StateVar+import Data.StateVar+#endif++-- | The contravariant analogue of 'Apply'; it is+-- 'Divisible' without 'conquer'.+--+-- If one thinks of @f a@ as a consumer of @a@s, then 'divise' allows one+-- to handle the consumption of a value by splitting it between two+-- consumers that consume separate parts of @a@.+--+-- 'divise' takes the \"splitting\" method and the two sub-consumers, and+-- returns the wrapped/combined consumer.+--+-- All instances of 'Divisible' should be instances of 'Divise' with+-- @'divise' = 'divide'@.+--+-- If a function is polymorphic over @'Divise' f@ (as opposed to @'Divisible'+-- f@), we can provide a stronger guarantee: namely, that any input consumed+-- will be passed to at least one sub-consumer. With @'Divisible' f@, said input+-- could potentially disappear into the void, as this is possible with+-- 'conquer'.+--+-- Mathematically, a functor being an instance of 'Divise' means that it is+-- \"semigroupoidal\" with respect to the contravariant (tupling) Day+-- convolution. That is, it is possible to define a function @(f `Day` f)+-- a -> f a@ in a way that is associative.+--+-- @since 5.3.6+class Contravariant f => Divise f where+ -- | Takes a \"splitting\" method and the two sub-consumers, and+ -- returns the wrapped/combined consumer.+ divise :: (a -> (b, c)) -> f b -> f c -> f a++-- | Generic 'divise'. Caveats:+--+-- 1. Will not compile if @f@ is a sum type.+-- 2. Will not compile if @f@ contains fields that do not mention its type variable.+-- 3. @-XDeriveGeneric@ is not smart enough to make instances where the type variable appears in negative position.+--+-- @since 5.3.8+gdivise :: (Divise (Rep1 f), Generic1 f) => (a -> (b, c)) -> f b -> f c -> f a+gdivise f x y = to1 $ divise f (from1 x) (from1 y)++-- | Combine a consumer of @a@ with a consumer of @b@ to get a consumer of+-- @(a, b)@.+--+-- @+-- 'divised' = 'divise' 'id'+-- @+--+-- @since 5.3.6+divised :: Divise f => f a -> f b -> f (a, b)+divised = divise id++-- | Generic 'divised'. Caveats are the same as for 'gdivise'.+--+-- @since 5.3.8+gdivised :: (Generic1 f, Divise (Rep1 f)) => f a -> f b -> f (a, b)+gdivised fa fb = gdivise id fa fb++-- | Wrap a 'Divisible' to be used as a member of 'Divise'+--+-- @since 5.3.6+newtype WrappedDivisible f a = WrapDivisible { unwrapDivisible :: f a }++-- | @since 5.3.6+instance Contravariant f => Contravariant (WrappedDivisible f) where+ contramap f (WrapDivisible a) = WrapDivisible (contramap f a)++#if defined(MIN_VERSION_contravariant)+-- | This instance is only available if the @+contravariant@ @cabal@ flag is+-- enabled.+--+-- @since 5.3.6+instance Divisible f => Divise (WrappedDivisible f) where+ divise f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (divide f x y)+#endif++-- | Unlike 'Divisible', requires only 'Semigroup' on @r@.+--+-- @since 5.3.6+instance Semigroup r => Divise (Op r) where+ divise f (Op g) (Op h) = Op $ \a -> case f a of+ (b, c) -> g b <> h c++-- | Unlike 'Divisible', requires only 'Semigroup' on @m@.+--+-- @since 5.3.6+instance Semigroup m => Divise (Const m) where+ divise _ (Const a) (Const b) = Const (a <> b)++-- | Unlike 'Divisible', requires only 'Semigroup' on @m@.+--+-- @since 5.3.6+instance Semigroup m => Divise (Constant m) where+ divise _ (Constant a) (Constant b) = Constant (a <> b)++-- | @since 5.3.6+instance Divise Comparison where+ divise f (Comparison g) (Comparison h) = Comparison $ \a b -> case f a of+ (a',a'') -> case f b of+ (b',b'') -> g a' b' `mappend` h a'' b''++-- | @since 5.3.6+instance Divise Equivalence where+ divise f (Equivalence g) (Equivalence h) = Equivalence $ \a b -> case f a of+ (a',a'') -> case f b of+ (b',b'') -> g a' b' && h a'' b''++-- | @since 5.3.6+instance Divise Predicate where+ divise f (Predicate g) (Predicate h) = Predicate $ \a -> case f a of+ (b, c) -> g b && h c++-- | @since 5.3.6+instance Divise Proxy where+ divise _ Proxy Proxy = Proxy++#ifdef MIN_VERSION_StateVar+-- | @since 5.3.6+instance Divise SettableStateVar where+ divise k (SettableStateVar l) (SettableStateVar r) = SettableStateVar $ \ a -> case k a of+ (b, c) -> l b >> r c+#endif++-- | @since 5.3.6+instance Divise f => Divise (Alt f) where+ divise f (Alt l) (Alt r) = Alt $ divise f l r++-- | @since 5.3.6+instance Divise U1 where+ divise _ U1 U1 = U1++-- | Has no 'Divisible' instance.+--+-- @since 5.3.6+instance Divise V1 where divise _ x = case x of {}++-- | @since 5.3.6+instance Divise f => Divise (Rec1 f) where+ divise f (Rec1 l) (Rec1 r) = Rec1 $ divise f l r++-- | @since 5.3.6+instance Divise f => Divise (M1 i c f) where+ divise f (M1 l) (M1 r) = M1 $ divise f l r++-- | @since 5.3.6+instance (Divise f, Divise g) => Divise (f :*: g) where+ divise f (l1 :*: r1) (l2 :*: r2) = divise f l1 l2 :*: divise f r1 r2++-- | Unlike 'Divisible', requires only 'Apply' on @f@.+--+-- @since 5.3.6+instance (Apply f, Divise g) => Divise (f :.: g) where+ divise f (Comp1 l) (Comp1 r) = Comp1 (liftF2 (divise f) l r)++-- | @since 5.3.6+instance Divise f => Divise (Backwards f) where+ divise f (Backwards l) (Backwards r) = Backwards $ divise f l r++#if !(MIN_VERSION_transformers(0,6,0))+-- | @since 5.3.6+instance Divise m => Divise (ErrorT e m) where+ divise f (ErrorT l) (ErrorT r) = ErrorT $ divise (funzip . fmap f) l r++-- | @since 5.3.6+instance Divise m => Divise (ListT m) where+ divise f (ListT l) (ListT r) = ListT $ divise (funzip . map f) l r+#endif++-- | @since 5.3.6+instance Divise m => Divise (ExceptT e m) where+ divise f (ExceptT l) (ExceptT r) = ExceptT $ divise (funzip . fmap f) l r++-- | @since 5.3.6+instance Divise f => Divise (IdentityT f) where+ divise f (IdentityT l) (IdentityT r) = IdentityT $ divise f l r++-- | @since 5.3.6+instance Divise m => Divise (MaybeT m) where+ divise f (MaybeT l) (MaybeT r) = MaybeT $ divise (funzip . fmap f) l r++-- | @since 5.3.6+instance Divise m => Divise (ReaderT r m) where+ divise abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> divise abc (rmb r) (rmc r)++-- | @since 5.3.6+instance Divise m => Divise (Lazy.RWST r w s m) where+ divise abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s ->+ divise (\ ~(a, s', w) -> case abc a of+ ~(b, c) -> ((b, s', w), (c, s', w)))+ (rsmb r s) (rsmc r s)++-- | @since 5.3.6+instance Divise m => Divise (Strict.RWST r w s m) where+ divise abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s ->+ divise (\(a, s', w) -> case abc a of+ (b, c) -> ((b, s', w), (c, s', w)))+ (rsmb r s) (rsmc r s)++-- | @since 5.3.6+instance Divise m => Divise (Lazy.StateT s m) where+ divise f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s ->+ divise (lazyFanout f) (l s) (r s)++-- | @since 5.3.6+instance Divise m => Divise (Strict.StateT s m) where+ divise f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s ->+ divise (strictFanout f) (l s) (r s)++-- | @since 5.3.6+instance Divise m => Divise (Lazy.WriterT w m) where+ divise f (Lazy.WriterT l) (Lazy.WriterT r) = Lazy.WriterT $+ divise (lazyFanout f) l r++-- | @since 5.3.6+instance Divise m => Divise (Strict.WriterT w m) where+ divise f (Strict.WriterT l) (Strict.WriterT r) = Strict.WriterT $+ divise (strictFanout f) l r++-- | Unlike 'Divisible', requires only 'Apply' on @f@.+--+-- @since 5.3.6+instance (Apply f, Divise g) => Divise (Compose f g) where+ divise f (Compose l) (Compose r) = Compose (liftF2 (divise f) l r)++-- | @since 5.3.6+instance (Divise f, Divise g) => Divise (Product f g) where+ divise f (Pair l1 r1) (Pair l2 r2) = Pair (divise f l1 l2) (divise f r1 r2)++-- | @since 5.3.6+instance Divise f => Divise (Reverse f) where+ divise f (Reverse l) (Reverse r) = Reverse $ divise f l r++-- Helpers++lazyFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s))+lazyFanout f ~(a, s) = case f a of+ ~(b, c) -> ((b, s), (c, s))++strictFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s))+strictFanout f (a, s) = case f a of+ (b, c) -> ((b, s), (c, s))++funzip :: Functor f => f (a, b) -> (f a, f b)+funzip = fmap fst &&& fmap snd
+ src/Data/Functor/Extend.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeOperators #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Functor.Extend+-- Copyright : (C) 2011-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+----------------------------------------------------------------------------+module Data.Functor.Extend+ ( -- * Extendable Functors+ -- $definition+ Extend(..)+ , gduplicated+ , gextended+ ) where++import Prelude hiding (id, (.))+import Control.Category+import Control.Monad.Trans.Identity+import Data.Functor.Identity+import Data.Functor.Sum as Functor (Sum(..))+import Data.List (tails)+import Data.List.NonEmpty (NonEmpty(..), toList)+import Data.Orphans ()+import qualified Data.Monoid as Monoid+import Data.Proxy+import Data.Semigroup as Semigroup+import GHC.Generics as Generics++#ifdef MIN_VERSION_containers+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Data.Tree+#endif++#ifdef MIN_VERSION_comonad+import Control.Comonad.Trans.Env+import Control.Comonad.Trans.Store+import Control.Comonad.Trans.Traced+#endif++#ifdef MIN_VERSION_tagged+import Data.Tagged+#endif++class Functor w => Extend w where+ -- |+ -- > duplicated = extended id+ -- > fmap (fmap f) . duplicated = duplicated . fmap f+ duplicated :: w a -> w (w a)+ -- |+ -- > extended f = fmap f . duplicated+ extended :: (w a -> b) -> w a -> w b++ extended f = fmap f . duplicated+ duplicated = extended id++ {-# MINIMAL duplicated | extended #-}++-- | Generic 'duplicated'. Caveats:+--+-- 1. Will not compile if @w@ is a product type.+-- 2. Will not compile if @w@ contains fields where the type variable appears underneath the composition of type constructors (e.g., @f (g a)@).+--+-- @since 5.3.8+gduplicated :: (Extend (Rep1 w), Generic1 w) => w a -> w (w a)+gduplicated = to1 . fmap to1 . duplicated . from1++-- | Generic 'extended'. Caveats are the same as for 'gduplicated'.+--+-- @since 5.3.8+gextended :: (Extend (Rep1 w), Generic1 w) => (w a -> b) -> w a -> w b+gextended f = to1 . extended (f . to1) . from1++-- * Extends for Prelude types:+--+-- Instances: While Data.Functor.Extend.Instances would be symmetric+-- to the definition of Control.Monad.Instances in base, the reason+-- the latter exists is because of Haskell 98 specifying the types+-- @'Either' a@, @((,)m)@ and @((->)e)@ and the class Monad without+-- having the foresight to require or allow instances between them.+--+-- Here Haskell 98 says nothing about Extend, so we can include the+-- instances directly avoiding the wart of orphan instances.++instance Extend [] where+ duplicated = init . tails++#ifdef MIN_VERSION_tagged+instance Extend (Tagged a) where+ duplicated = Tagged+#endif++instance Extend Proxy where+ duplicated _ = Proxy+ extended _ _ = Proxy++instance Extend Maybe where+ duplicated Nothing = Nothing+ duplicated j = Just j++instance Extend (Either a) where+ duplicated (Left a) = Left a+ duplicated r = Right r++instance Extend ((,)e) where+ duplicated p = (fst p, p)++instance Semigroup m => Extend ((->)m) where+ duplicated f m = f . (<>) m++#ifdef MIN_VERSION_containers+instance Extend Seq where+ duplicated l = Seq.take (Seq.length l) (Seq.tails l)++instance Extend Tree where+ duplicated w@(Node _ as) = Node w (map duplicated as)+#endif++#ifdef MIN_VERSION_comonad+{-+instance (Extend f, Extend g) => Extend (Coproduct f g) where+ extended f = Coproduct . coproduct+ (Left . extended (f . Coproduct . Left))+ (Right . extended (f . Coproduct . Right))+-}++instance Extend w => Extend (EnvT e w) where+ duplicated (EnvT e wa) = EnvT e (extended (EnvT e) wa)++instance Extend w => Extend (StoreT s w) where+ duplicated (StoreT wf s) = StoreT (extended StoreT wf) s+ extended f (StoreT wf s) = StoreT (extended (\wf' s' -> f (StoreT wf' s')) wf) s++instance (Extend w, Semigroup m) => Extend (TracedT m w) where+ extended f = TracedT . extended (\wf m -> f (TracedT (fmap (. (<>) m) wf))) . runTracedT+#endif++-- I can't fix the world+-- instance (Monoid m, Extend n) => Extend (ReaderT m n)+-- duplicate f m = f . mappend m++-- * Extends for types from 'transformers'.+--+-- This isn't really a transformer, so i have no compunction about including the instance here.+--+-- TODO: Petition to move Data.Functor.Identity into base+instance Extend Identity where+ duplicated = Identity++-- Provided to avoid an orphan instance. Not proposed to standardize.+-- If Extend moved to base, consider moving instance into transformers?+instance Extend w => Extend (IdentityT w) where+ extended f (IdentityT m) = IdentityT (extended (f . IdentityT) m)++instance Extend NonEmpty where+ extended f w@(~(_ :| aas)) =+ f w :| case aas of+ [] -> []+ (a:as) -> toList (extended f (a :| as))++instance (Extend f, Extend g) => Extend (Functor.Sum f g) where+ extended f (InL l) = InL (extended (f . InL) l)+ extended f (InR r) = InR (extended (f . InR) r)++instance (Extend f, Extend g) => Extend (f :+: g) where+ extended f (L1 l) = L1 (extended (f . L1) l)+ extended f (R1 r) = R1 (extended (f . R1) r)++-- | @since 5.3.8+instance Extend (Generics.K1 i c) where+ duplicated (K1 c) = K1 c++instance Extend Generics.U1 where+ extended _ U1 = U1++instance Extend Generics.V1 where+ extended _ e = case e of {}++instance Extend f => Extend (Generics.M1 i t f) where+ extended f = M1 . extended (f . M1) . unM1++instance Extend Par1 where+ extended f w@Par1{} = Par1 (f w)++instance Extend f => Extend (Rec1 f) where+ extended f = Rec1 . extended (f . Rec1) . unRec1++instance Extend Monoid.Sum where+ extended f w@Monoid.Sum{} = Monoid.Sum (f w)++instance Extend Monoid.Product where+ extended f w@Monoid.Product{} = Monoid.Product (f w)++instance Extend Monoid.Dual where+ extended f w@Monoid.Dual{} = Monoid.Dual (f w)++instance Extend f => Extend (Monoid.Alt f) where+ extended f = Monoid.Alt . extended (f . Monoid.Alt) . Monoid.getAlt++-- in GHC 8.6 we'll have to deal with Apply f => Apply (Ap f) the same way+instance Extend Semigroup.First where+ extended f w@Semigroup.First{} = Semigroup.First (f w)++instance Extend Semigroup.Last where+ extended f w@Semigroup.Last{} = Semigroup.Last (f w)++instance Extend Semigroup.Min where+ extended f w@Semigroup.Min{} = Semigroup.Min (f w)++instance Extend Semigroup.Max where+ extended f w@Semigroup.Max{} = Semigroup.Max (f w)++-- $definition+-- There are two ways to define an 'Extend' instance:+--+-- I. Provide definitions for 'extended'+-- satisfying this law:+--+-- > extended f . extended g = extended (f . extended g)+--+-- II. Alternately, you may choose to provide definitions for 'duplicated'+-- satisfying this law:+--+-- > duplicated . duplicated = fmap duplicated . duplicated+--+-- You may of course, choose to define both 'duplicated' /and/ 'extended'.+-- In that case you must also satisfy these laws:+--+-- > extended f = fmap f . duplicated+-- > duplicated = extended id+--+-- These are the default definitions of 'extended' and 'duplicated'.
+ src/Data/Functor/Plus.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeOperators #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2011-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+----------------------------------------------------------------------------+module Data.Functor.Plus+ ( Plus(..)+ , psum+ , gzero+ , module Data.Functor.Alt+ ) where++import Control.Applicative hiding (some, many)+import Control.Applicative.Backwards+import Control.Applicative.Lift+import Control.Arrow+import Control.Monad+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Except+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+#if MIN_VERSION_transformers(0,5,6)+import qualified Control.Monad.Trans.RWS.CPS as CPS+import qualified Control.Monad.Trans.Writer.CPS as CPS+import Semigroupoids.Internal+#endif+import qualified Control.Monad.Trans.RWS.Strict as Strict+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Strict as Strict+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import Data.Foldable hiding (asum)+import Data.Functor.Apply+import Data.Functor.Alt+import Data.Functor.Compose+import Data.Functor.Product+import Data.Functor.Reverse+import qualified Data.Monoid as Monoid+import Data.Proxy+import Data.Semigroup hiding (Product)+import GHC.Generics+import Prelude hiding (id, (.), foldr)++#if !(MIN_VERSION_transformers(0,6,0))+import Control.Monad.Trans.Error+import Control.Monad.Trans.List+#endif++#ifdef MIN_VERSION_containers+import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap)+import Data.Sequence (Seq)+import qualified Data.Map as Map+import Data.Map (Map)+#endif++#ifdef MIN_VERSION_unordered_containers+import Data.Hashable+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap+#endif++-- | Laws:+--+-- > zero <!> m = m+-- > m <!> zero = m+--+-- If extended to an 'Alternative' then 'zero' should equal 'empty'.+class Alt f => Plus f where+ zero :: f a++-- | The sum of a collection of actions, generalizing 'concat'.+--+-- >>> psum [Just "Hello", Nothing, Just "World"]+-- Just "Hello"+--+-- @since 5.3.6+psum :: (Foldable t, Plus f) => t (f a) -> f a+psum = foldr (<!>) zero++-- | Generic 'zero'. Caveats:+--+-- 1. Will not compile if @f@ is a sum type.+-- 2. Any types where the @a@ does not appear must have a 'Monoid' instance.+--+-- @since 5.3.8+gzero :: (Plus (Rep1 f), Generic1 f) => f a+gzero = to1 zero++instance Plus Proxy where+ zero = Proxy++instance Plus U1 where+ zero = U1++-- | @since 5.3.8+instance (Monoid c+#if !(MIN_VERSION_base(4,11,0))+ , Semigroup c+#endif+ ) => Plus (K1 i c) where+ zero = K1 mempty++instance (Plus f, Plus g) => Plus (f :*: g) where+ zero = zero :*: zero++-- | @since 5.3.8+instance (Plus f, Functor g) => Plus (f :.: g) where+ zero = Comp1 zero++instance Plus f => Plus (M1 i c f) where+ zero = M1 zero++instance Plus f => Plus (Rec1 f) where+ zero = Rec1 zero++instance Plus IO where+ zero = error "zero"++instance Plus [] where+ zero = []++instance Plus Maybe where+ zero = Nothing++#if !(MIN_VERSION_base(4,16,0))+instance Plus Option where+ zero = empty+#endif++instance MonadPlus m => Plus (WrappedMonad m) where+ zero = empty++instance ArrowPlus a => Plus (WrappedArrow a b) where+ zero = empty++#ifdef MIN_VERSION_containers+instance Ord k => Plus (Map k) where+ zero = Map.empty++instance Plus IntMap where+ zero = IntMap.empty++instance Plus Seq where+ zero = mempty+#endif++#ifdef MIN_VERSION_unordered_containers+instance (Hashable k, Eq k) => Plus (HashMap k) where+ zero = HashMap.empty+#endif++instance Alternative f => Plus (WrappedApplicative f) where+ zero = empty++instance Plus f => Plus (IdentityT f) where+ zero = IdentityT zero++instance Plus f => Plus (ReaderT e f) where+ zero = ReaderT $ \_ -> zero++instance (Functor f, Monad f) => Plus (MaybeT f) where+ zero = MaybeT $ return zero++#if !(MIN_VERSION_transformers(0,6,0))+instance (Functor f, Monad f, Error e) => Plus (ErrorT e f) where+ zero = ErrorT $ return $ Left noMsg++instance (Apply f, Applicative f) => Plus (ListT f) where+ zero = ListT $ pure []+#endif++instance (Functor f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f) where+ zero = ExceptT $ return $ Left mempty++instance Plus f => Plus (Strict.StateT e f) where+ zero = Strict.StateT $ \_ -> zero++instance Plus f => Plus (Lazy.StateT e f) where+ zero = Lazy.StateT $ \_ -> zero++instance Plus f => Plus (Strict.WriterT w f) where+ zero = Strict.WriterT zero++instance Plus f => Plus (Lazy.WriterT w f) where+ zero = Lazy.WriterT zero++#if MIN_VERSION_transformers(0,5,6)+-- | @since 5.3.6+instance (Plus f) => Plus (CPS.WriterT w f) where+ zero = mkWriterT $ const zero+#endif++instance Plus f => Plus (Strict.RWST r w s f) where+ zero = Strict.RWST $ \_ _ -> zero++instance Plus f => Plus (Lazy.RWST r w s f) where+ zero = Lazy.RWST $ \_ _ -> zero++#if MIN_VERSION_transformers(0,5,6)+-- | @since 5.3.6+instance (Plus f) => Plus (CPS.RWST r w s f) where+ zero = mkRWST $ \_ _ _ -> zero+#endif++instance Plus f => Plus (Backwards f) where+ zero = Backwards zero++instance (Plus f, Functor g) => Plus (Compose f g) where+ zero = Compose zero++instance Plus f => Plus (Lift f) where+ zero = Other zero++instance (Plus f, Plus g) => Plus (Product f g) where+ zero = Pair zero zero++instance Plus f => Plus (Reverse f) where+ zero = Reverse zero++instance Plus Monoid.First where+ zero = Monoid.First Nothing++instance Plus Monoid.Last where+ zero = Monoid.Last Nothing
+ src/Data/Groupoid.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Trustworthy #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2011-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : polykinds+--+----------------------------------------------------------------------------++module Data.Groupoid+ ( Groupoid(..)+ ) where++import Data.Semigroupoid+import Data.Semigroupoid.Dual+import qualified Data.Type.Coercion as Co+import qualified Data.Type.Equality as Eq++-- | semigroupoid with inverses. This technically should be a category with inverses, except we need to use Ob to define the valid objects for the category+class Semigroupoid k => Groupoid k where+ inv :: k a b -> k b a++instance Groupoid k => Groupoid (Dual k) where+ inv (Dual k) = Dual (inv k)++instance Groupoid Co.Coercion where+ inv = Co.sym++instance Groupoid (Eq.:~:) where+ inv = Eq.sym++#if MIN_VERSION_base(4,10,0)+instance Groupoid (Eq.:~~:) where+ inv Eq.HRefl = Eq.HRefl+#endif
+ src/Data/Isomorphism.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Safe #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2011-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- 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
+ src/Data/Semigroup/Bifoldable.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE Safe #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2011-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- Re-exports a subset of the "Data.Bifoldable1" module along with some+-- additional combinators that require 'Bifoldable1' constraints.+--+----------------------------------------------------------------------------+module Data.Semigroup.Bifoldable+ ( -- @Data.Bifoldable1@ re-exports+ Bifoldable1(bifold1, bifoldMap1)++ -- Additional @Bifoldable1@ functionality+ , bitraverse1_+ , bifor1_+ , bisequenceA1_+ , bifoldMapDefault1+ ) where++import Control.Applicative+import Data.Bifoldable+import Data.Bifoldable1+import Data.Functor.Apply+import Data.Semigroup+import Prelude hiding (foldr)++newtype Act f a = Act { getAct :: f a }++instance Apply f => Semigroup (Act f a) where+ Act a <> Act b = Act (a .> b)+ {-# INLINE (<>) #-}++instance Functor f => Functor (Act f) where+ fmap f (Act a) = Act (f <$> a)+ {-# INLINE fmap #-}+ b <$ Act a = Act (b <$ a)+ {-# INLINE (<$) #-}++bitraverse1_ :: (Bifoldable1 t, Apply f) => (a -> f b) -> (c -> f d) -> t a c -> f ()+bitraverse1_ f g t = getAct (bifoldMap1 (Act . ignore . f) (Act . ignore . g) t)+{-# INLINE bitraverse1_ #-}++bifor1_ :: (Bifoldable1 t, Apply f) => t a c -> (a -> f b) -> (c -> f d) -> f ()+bifor1_ t f g = bitraverse1_ f g t+{-# INLINE bifor1_ #-}++ignore :: Functor f => f a -> f ()+ignore = (() <$)+{-# INLINE ignore #-}++bisequenceA1_ :: (Bifoldable1 t, Apply f) => t (f a) (f b) -> f ()+bisequenceA1_ t = getAct (bifoldMap1 (Act . ignore) (Act . ignore) t)+{-# INLINE bisequenceA1_ #-}++-- | Usable default for foldMap, but only if you define bifoldMap1 yourself+bifoldMapDefault1 :: (Bifoldable1 t, Monoid m) => (a -> m) -> (b -> m) -> t a b -> m+bifoldMapDefault1 f g = unwrapMonoid . bifoldMap (WrapMonoid . f) (WrapMonoid . g)+{-# INLINE bifoldMapDefault1 #-}
+ src/Data/Semigroup/Bitraversable.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Safe #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2011-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+----------------------------------------------------------------------------+module Data.Semigroup.Bitraversable+ ( Bitraversable1(..)+ , bifoldMap1Default+ ) where++import Control.Applicative+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif+import Data.Semigroup.Traversable.Class++bifoldMap1Default :: (Bitraversable1 t, Semigroup m) => (a -> m) -> (b -> m) -> t a b -> m+bifoldMap1Default f g = getConst . bitraverse1 (Const . f) (Const . g)+{-# INLINE bifoldMap1Default #-}
+ src/Data/Semigroup/Foldable.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Safe #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2011-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- Re-exports a subset of the "Data.Foldable1" module along with some additional+-- combinators that require 'Foldable1' constraints.+--+----------------------------------------------------------------------------+module Data.Semigroup.Foldable+ ( -- @Data.Foldable1@ re-exports+ Foldable1(fold1, foldMap1, toNonEmpty)+ , intercalate1+ , foldrM1+ , foldlM1++ -- Additional @Foldable1@ functionality+ , intercalateMap1+ , traverse1_+ , for1_+ , sequenceA1_+ , foldMapDefault1+ , asum1++ -- Generic defaults+ , gfold1+ , gfoldMap1+ , gtoNonEmpty+ ) where++import Data.Foldable+import Data.Foldable1+import Data.Functor.Alt (Alt(..))+import Data.Functor.Apply+import Data.List.NonEmpty (NonEmpty(..))+import Data.Traversable.Instances ()+import Data.Semigroup hiding (Product, Sum)+import GHC.Generics+import Prelude hiding (foldr)++-- $setup+-- >>> import Data.List.NonEmpty (NonEmpty (..))+-- >>> import Data.Monoid (Monoid (..))++newtype JoinWith a = JoinWith {joinee :: (a -> a)}++instance Semigroup a => Semigroup (JoinWith a) where+ JoinWith a <> JoinWith b = JoinWith $ \j -> a j <> j <> b j++-- | Insert @m@ between each pair of @m@ derived from @a@.+--+-- >>> intercalateMap1 " " show $ True :| [False, True]+-- "True False True"+--+-- >>> intercalateMap1 " " show $ True :| []+-- "True"+intercalateMap1 :: (Foldable1 t, Semigroup m) => m -> (a -> m) -> t a -> m+intercalateMap1 j f = flip joinee j . foldMap1 (JoinWith . const . f)+{-# INLINE intercalateMap1 #-}++newtype Act f a = Act { getAct :: f a }++instance Apply f => Semigroup (Act f a) where+ Act a <> Act b = Act (a .> b)++instance Functor f => Functor (Act f) where+ fmap f (Act a) = Act (f <$> a)+ b <$ Act a = Act (b <$ a)++traverse1_ :: (Foldable1 t, Apply f) => (a -> f b) -> t a -> f ()+traverse1_ f t = () <$ getAct (foldMap1 (Act . f) t)+{-# INLINE traverse1_ #-}++for1_ :: (Foldable1 t, Apply f) => t a -> (a -> f b) -> f ()+for1_ = flip traverse1_+{-# INLINE for1_ #-}++sequenceA1_ :: (Foldable1 t, Apply f) => t (f a) -> f ()+sequenceA1_ t = () <$ getAct (foldMap1 Act t)+{-# INLINE sequenceA1_ #-}++-- | Usable default for foldMap, but only if you define foldMap1 yourself+foldMapDefault1 :: (Foldable1 t, Monoid m) => (a -> m) -> t a -> m+foldMapDefault1 f = unwrapMonoid . foldMap (WrapMonoid . f)+{-# INLINE foldMapDefault1 #-}++-- toStream :: Foldable1 t => t a -> Stream a+-- concat1 :: Foldable1 t => t (Stream a) -> Stream a+-- concatMap1 :: Foldable1 t => (a -> Stream b) -> t a -> Stream b++newtype Alt_ f a = Alt_ { getAlt_ :: f a }++instance Alt f => Semigroup (Alt_ f a) where+ Alt_ a <> Alt_ b = Alt_ (a <!> b)++asum1 :: (Foldable1 t, Alt m) => t (m a) -> m a+asum1 = getAlt_ . foldMap1 Alt_+{-# INLINE asum1 #-}++-- | Generic 'fold1'. Caveats:+--+-- 1. Will not compile if @t@ is an empty constructor.+-- 2. Will not compile if @t@ has some fields that don't mention @a@, for example @data Bar a = MkBar a Int@+--+-- @since 5.3.8+gfold1 :: (Foldable1 (Rep1 t), Generic1 t, Semigroup m) => t m -> m+gfold1 = fold1 . from1++-- | Generic 'foldMap1'. Caveats are the same as for 'gfold1'.+--+-- @since 5.3.8+gfoldMap1 :: (Foldable1 (Rep1 t), Generic1 t, Semigroup m) => (a -> m) -> t a -> m+gfoldMap1 f = foldMap1 f . from1++-- | Generic 'toNonEmpty'. Caveats are the same as for 'gfold1'.+--+-- @since 5.3.8+gtoNonEmpty :: (Foldable1 (Rep1 t), Generic1 t) => t a -> NonEmpty a+gtoNonEmpty = toNonEmpty . from1
+ src/Data/Semigroup/Foldable/Class.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE Trustworthy #-}++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2011-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+----------------------------------------------------------------------------+module Data.Semigroup.Foldable.Class+ {-# DEPRECATED+ [ "This module re-exports a limited subset of the class methods in the "+ , "Foldable1 and Bifoldable1 classes, which are now located in the "+ , "Data.Foldable1 and Data.Bifoldable1 modules in base-4.18. "+ , "(On older versions of base, these can be found in the "+ , "foldable1-classes-compat library.) "+ , "Import from these modules instead."+ ]+ #-}+ ( Foldable1(fold1, foldMap1, toNonEmpty)+ , Bifoldable1(bifold1, bifoldMap1)+ ) where++import Data.Bifoldable1+import Data.Foldable1
+ src/Data/Semigroup/Traversable.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Safe #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2011-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+----------------------------------------------------------------------------+module Data.Semigroup.Traversable+ ( Traversable1(..)+ -- * Defining Traversable1 instances+ -- $traversable1instances+ , traverse1Maybe+ , gtraverse1+ , gsequence1+ -- * Default superclass instance helpers+ , foldMap1Default+ ) where++import Control.Applicative+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif+import Data.Semigroup.Traversable.Class+import Data.Functor.Bind.Class+import GHC.Generics++-- | Default implementation of 'foldMap1' given an implementation of 'Traversable1'.+foldMap1Default :: (Traversable1 f, Semigroup m) => (a -> m) -> f a -> m+foldMap1Default f = getConst . traverse1 (Const . f)++-- | Generic 'traverse1'. Caveats:+--+-- 1. Will not compile if @t@ is an empty constructor.+-- 2. Will not compile if @t@ has some fields that don't mention @a@, for example @data Bar a = MkBar a Int@+--+-- @since 5.3.8+gtraverse1 ::+ (Traversable1 (Rep1 t), Apply f, Generic1 t) =>+ (a -> f b) ->+ t a ->+ f (t b)+gtraverse1 f x = to1 <$> traverse1 f (from1 x)++-- | Generic 'sequence1'. Caveats are the same for 'gtraverse1'.+--+-- @since 5.3.8+gsequence1 ::+ (Traversable1 (Rep1 t), Apply f, Generic1 t) =>+ t (f b) ->+ f (t b)+gsequence1 = fmap to1 . sequence1 . from1++-- $traversable1instances+-- Defining 'Traversable1' instances for types with both 'Traversable1' and 'Traversable'+-- substructures can be done with 'traverse1Maybe', '(<*.>)', and '(<.*>)'.+--+-- > data Foo a = Foo (Maybe a) (Maybe a) a [a]+-- > deriving (Functor, Traversable, Foldable)+-- > instance Traversable1 Foo where+-- > traverse1 f (Foo ma ma' a as) = Foo <$> traverseMaybe ma <*> traverseMaybe ma' <*.> f a <.*> traverseMaybe as+-- > instance Foldable1 Foo where+-- > foldMap1 = foldMap1Default
+ src/Data/Semigroup/Traversable/Class.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE CPP, TypeOperators #-}+{-# LANGUAGE Trustworthy #-}+++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2011-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+----------------------------------------------------------------------------+module Data.Semigroup.Traversable.Class+ ( Bitraversable1(..)+ , Traversable1(..)+ ) where++import Control.Applicative+import Data.Bitraversable+import Data.Bifunctor+import Data.Bifunctor.Biff+import Data.Bifunctor.Clown+import Data.Bifunctor.Flip+import Data.Bifunctor.Joker+import Data.Bifunctor.Join+import Data.Bifunctor.Product as Bifunctor+import Data.Bifunctor.Tannen+import Data.Bifunctor.Wrapped+import Data.Functor.Apply+import Data.Functor.Compose++import Data.Complex+import Data.Functor.Identity+import Data.Functor.Product as Functor+import Data.Functor.Sum as Functor+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.Monoid as Monoid+import Data.Orphans ()+import Data.Semigroup as Semigroup+import Data.Semigroup.Foldable+import Data.Semigroup.Bifoldable+#ifdef MIN_VERSION_tagged+import Data.Tagged+#endif+import Data.Traversable.Instances ()+import GHC.Generics++#ifdef MIN_VERSION_containers+import Data.Tree+#endif++import Control.Applicative.Backwards+import Control.Applicative.Lift+import Control.Monad.Trans.Identity+import Data.Functor.Reverse++class (Bifoldable1 t, Bitraversable t) => Bitraversable1 t where+ bitraverse1 :: Apply f => (a -> f b) -> (c -> f d) -> t a c -> f (t b d)+ bitraverse1 f g = bisequence1 . bimap f g+ {-# INLINE bitraverse1 #-}++ bisequence1 :: Apply f => t (f a) (f b) -> f (t a b)+ bisequence1 = bitraverse1 id id+ {-# INLINE bisequence1 #-}++ {-# MINIMAL bitraverse1 | bisequence1 #-}++instance Bitraversable1 Arg where+ bitraverse1 f g (Arg a b) = Arg <$> f a <.> g b++instance Bitraversable1 Either where+ bitraverse1 f _ (Left a) = Left <$> f a+ bitraverse1 _ g (Right b) = Right <$> g b+ {-# INLINE bitraverse1 #-}++instance Bitraversable1 (,) where+ bitraverse1 f g (a, b) = (,) <$> f a <.> g b+ {-# INLINE bitraverse1 #-}++instance Bitraversable1 ((,,) x) where+ bitraverse1 f g (x, a, b) = (,,) x <$> f a <.> g b+ {-# INLINE bitraverse1 #-}++instance Bitraversable1 ((,,,) x y) where+ bitraverse1 f g (x, y, a, b) = (,,,) x y <$> f a <.> g b+ {-# INLINE bitraverse1 #-}++instance Bitraversable1 ((,,,,) x y z) where+ bitraverse1 f g (x, y, z, a, b) = (,,,,) x y z <$> f a <.> g b+ {-# INLINE bitraverse1 #-}++instance Bitraversable1 Const where+ bitraverse1 f _ (Const a) = Const <$> f a+ {-# INLINE bitraverse1 #-}++#ifdef MIN_VERSION_tagged+instance Bitraversable1 Tagged where+ bitraverse1 _ g (Tagged b) = Tagged <$> g b+ {-# INLINE bitraverse1 #-}+#endif++instance (Bitraversable1 p, Traversable1 f, Traversable1 g) => Bitraversable1 (Biff p f g) where+ bitraverse1 f g = fmap Biff . bitraverse1 (traverse1 f) (traverse1 g) . runBiff+ {-# INLINE bitraverse1 #-}++instance Traversable1 f => Bitraversable1 (Clown f) where+ bitraverse1 f _ = fmap Clown . traverse1 f . runClown+ {-# INLINE bitraverse1 #-}++instance Bitraversable1 p => Bitraversable1 (Flip p) where+ bitraverse1 f g = fmap Flip . bitraverse1 g f . runFlip+ {-# INLINE bitraverse1 #-}++instance Bitraversable1 p => Traversable1 (Join p) where+ traverse1 f (Join a) = fmap Join (bitraverse1 f f a)+ {-# INLINE traverse1 #-}+ sequence1 (Join a) = fmap Join (bisequence1 a)+ {-# INLINE sequence1 #-}++instance Traversable1 g => Bitraversable1 (Joker g) where+ bitraverse1 _ g = fmap Joker . traverse1 g . runJoker+ {-# INLINE bitraverse1 #-}++instance (Bitraversable1 f, Bitraversable1 g) => Bitraversable1 (Bifunctor.Product f g) where+ bitraverse1 f g (Bifunctor.Pair x y) = Bifunctor.Pair <$> bitraverse1 f g x <.> bitraverse1 f g y+ {-# INLINE bitraverse1 #-}++instance (Traversable1 f, Bitraversable1 p) => Bitraversable1 (Tannen f p) where+ bitraverse1 f g = fmap Tannen . traverse1 (bitraverse1 f g) . runTannen+ {-# INLINE bitraverse1 #-}++instance Bitraversable1 p => Bitraversable1 (WrappedBifunctor p) where+ bitraverse1 f g = fmap WrapBifunctor . bitraverse1 f g . unwrapBifunctor+ {-# INLINE bitraverse1 #-}+++class (Foldable1 t, Traversable t) => Traversable1 t where+ traverse1 :: Apply f => (a -> f b) -> t a -> f (t b)+ sequence1 :: Apply f => t (f b) -> f (t b)++ sequence1 = traverse1 id+ traverse1 f = sequence1 . fmap f++ {-# MINIMAL traverse1 | sequence1 #-}++instance Traversable1 f => Traversable1 (Rec1 f) where+ traverse1 f (Rec1 as) = Rec1 <$> traverse1 f as++instance Traversable1 f => Traversable1 (M1 i c f) where+ traverse1 f (M1 as) = M1 <$> traverse1 f as++instance Traversable1 Par1 where+ traverse1 f (Par1 a) = Par1 <$> f a++instance Traversable1 V1 where+ traverse1 _ v = v `seq` undefined++instance (Traversable1 f, Traversable1 g) => Traversable1 (f :*: g) where+ traverse1 f (as :*: bs) = (:*:) <$> traverse1 f as <.> traverse1 f bs++instance (Traversable1 f, Traversable1 g) => Traversable1 (f :+: g) where+ traverse1 f (L1 as) = L1 <$> traverse1 f as+ traverse1 f (R1 bs) = R1 <$> traverse1 f bs++instance (Traversable1 f, Traversable1 g) => Traversable1 (f :.: g) where+ traverse1 f (Comp1 m) = Comp1 <$> traverse1 (traverse1 f) m++instance Traversable1 Identity where+ traverse1 f = fmap Identity . f . runIdentity++instance (Traversable1 f, Traversable1 g) => Traversable1 (Functor.Product f g) where+ traverse1 f (Functor.Pair a b) = Functor.Pair <$> traverse1 f a <.> traverse1 f b++instance (Traversable1 f, Traversable1 g) => Traversable1 (Functor.Sum f g) where+ traverse1 f (Functor.InL x) = Functor.InL <$> traverse1 f x+ traverse1 f (Functor.InR y) = Functor.InR <$> traverse1 f y++instance (Traversable1 f, Traversable1 g) => Traversable1 (Compose f g) where+ traverse1 f = fmap Compose . traverse1 (traverse1 f) . getCompose++instance Traversable1 f => Traversable1 (IdentityT f) where+ traverse1 f = fmap IdentityT . traverse1 f . runIdentityT++instance Traversable1 f => Traversable1 (Backwards f) where+ traverse1 f = fmap Backwards . traverse1 f . forwards++instance Traversable1 f => Traversable1 (Lift f) where+ traverse1 f (Pure x) = Pure <$> f x+ traverse1 f (Other y) = Other <$> traverse1 f y++instance Traversable1 f => Traversable1 (Reverse f) where+ traverse1 f = fmap Reverse . forwards . traverse1 (Backwards . f) . getReverse++instance Traversable1 Complex where+ traverse1 f (a :+ b) = (:+) <$> f a <.> f b+ {-# INLINE traverse1 #-}++#ifdef MIN_VERSION_tagged+instance Traversable1 (Tagged a) where+ traverse1 f (Tagged a) = Tagged <$> f a+#endif++#ifdef MIN_VERSION_containers+instance Traversable1 Tree where+ traverse1 f (Node a []) = (`Node`[]) <$> f a+ traverse1 f (Node a (x:xs)) = (\b (y:|ys) -> Node b (y:ys)) <$> f a <.> traverse1 (traverse1 f) (x :| xs)+#endif++instance Traversable1 NonEmpty where+ traverse1 f (a :| as) = foldr (\b g x -> (\a' (b':| bs') -> a' :| b': bs') <$> f x <.> g b) (fmap (:|[]) . f) as a++instance Traversable1 ((,) a) where+ traverse1 f (a, b) = (,) a <$> f b++instance Traversable1 g => Traversable1 (Joker g a) where+ traverse1 g = fmap Joker . traverse1 g . runJoker+ {-# INLINE traverse1 #-}++instance Traversable1 Monoid.Sum where+ traverse1 g (Monoid.Sum a) = Monoid.Sum <$> g a++instance Traversable1 Monoid.Product where+ traverse1 g (Monoid.Product a) = Monoid.Product <$> g a++instance Traversable1 Monoid.Dual where+ traverse1 g (Monoid.Dual a) = Monoid.Dual <$> g a++instance Traversable1 f => Traversable1 (Monoid.Alt f) where+ traverse1 g (Monoid.Alt m) = Monoid.Alt <$> traverse1 g m++instance Traversable1 Semigroup.First where+ traverse1 g (Semigroup.First a) = Semigroup.First <$> g a++instance Traversable1 Semigroup.Last where+ traverse1 g (Semigroup.Last a) = Semigroup.Last <$> g a++instance Traversable1 Semigroup.Min where+ traverse1 g (Semigroup.Min a) = Semigroup.Min <$> g a++instance Traversable1 Semigroup.Max where+ traverse1 g (Semigroup.Max a) = Semigroup.Max <$> g a
+ src/Data/Semigroupoid.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Trustworthy #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Semigroupoid+-- Copyright : (C) 2007-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- A semigroupoid satisfies all of the requirements to be a Category except+-- for the existence of identity arrows.+----------------------------------------------------------------------------+module Data.Semigroupoid+ ( Semigroupoid(..)+ , WrappedCategory(..)+ , Semi(..)+ ) where++import Control.Applicative+import Control.Arrow+import Control.Category+import Data.Functor.Bind+import Data.Semigroup+import qualified Data.Type.Coercion as Co+import qualified Data.Type.Equality as Eq+import Prelude hiding (id, (.))++#ifdef MIN_VERSION_contravariant+import Data.Functor.Contravariant+#endif++#ifdef MIN_VERSION_comonad+import Data.Functor.Extend+import Control.Comonad+#endif++#ifdef MIN_VERSION_tagged+import Data.Tagged (Tagged (..))+#endif++-- | 'Control.Category.Category' sans 'Control.Category.id'+class Semigroupoid c where+ o :: c j k -> c i j -> c i k++instance Semigroupoid (->) where+ o = (.)++-- | <http://en.wikipedia.org/wiki/Band_(mathematics)#Rectangular_bands>+instance Semigroupoid (,) where+ o (_,k) (i,_) = (i,k)++instance Bind m => Semigroupoid (Kleisli m) where+ Kleisli g `o` Kleisli f = Kleisli $ \a -> f a >>- g++#ifdef MIN_VERSION_comonad+instance Extend w => Semigroupoid (Cokleisli w) where+ Cokleisli f `o` Cokleisli g = Cokleisli $ f . extended g+#endif++#ifdef MIN_VERSION_contravariant+instance Semigroupoid Op where+ Op f `o` Op g = Op (g `o` f)+#endif++newtype WrappedCategory k a b = WrapCategory { unwrapCategory :: k a b }++instance Category k => Semigroupoid (WrappedCategory k) where+ WrapCategory f `o` WrapCategory g = WrapCategory (f . g)++instance Category k => Category (WrappedCategory k) where+ id = WrapCategory id+ WrapCategory f . WrapCategory g = WrapCategory (f . g)++newtype Semi m a b = Semi { getSemi :: m }++instance Semigroup m => Semigroupoid (Semi m) where+ Semi m `o` Semi n = Semi (m <> n)++instance Monoid m => Category (Semi m) where+ id = Semi mempty+ Semi m . Semi n = Semi (m `mappend` n)++instance Semigroupoid Const where+ _ `o` Const a = Const a++#ifdef MIN_VERSION_tagged+instance Semigroupoid Tagged where+ Tagged b `o` _ = Tagged b+#endif++instance Semigroupoid Co.Coercion where+ o = flip Co.trans++instance Semigroupoid (Eq.:~:) where+ o = flip Eq.trans++#if MIN_VERSION_base(4,10,0)+instance Semigroupoid (Eq.:~~:) where+ o Eq.HRefl Eq.HRefl = Eq.HRefl+#endif
+ src/Data/Semigroupoid/Categorical.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2021 Koz Ross+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Koz Ross <koz.ross@retro-freedom.nz>+-- Stability : Experimental+-- Portability : GHC only+--+-- Provides a way to attach an identity to any semigroupoid.+----------------------------------------------------------------------------+module Data.Semigroupoid.Categorical (+ Categorical(..),+ runCategorical+ ) where++import Control.Category (Category (id, (.)))+import Data.Semigroupoid (Semigroupoid (o))+#if __GLASGOW_HASKELL__ >= 904+import Data.Type.Equality (type (~))+#endif+import Prelude ()++-- | Attaches an identity.+--+-- @since 5.3.6+data Categorical s a b where+ Id :: Categorical s a a+ Embed :: s a b -> Categorical s a b++-- | @since 5.3.6+instance (Semigroupoid s) => Semigroupoid (Categorical s) where+ Id `o` y = y+ x `o` Id = x+ Embed x `o` Embed y = Embed (x `o` y)++-- | @since 5.3.6+instance (Semigroupoid s) => Category (Categorical s) where+ id = Id+ (.) = o++-- | @since 5.3.6+runCategorical :: (a ~ b => r) -> (s a b -> r) -> Categorical s a b -> r+runCategorical r _ Id = r+runCategorical _ f (Embed x) = f x
+ src/Data/Semigroupoid/Dual.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Safe #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2007-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- 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)
+ src/Data/Semigroupoid/Ob.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Safe #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2011-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- 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
+ src/Data/Semigroupoid/Static.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Trustworthy #-}++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2011-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : polykinds+--+----------------------------------------------------------------------------++module Data.Semigroupoid.Static+ ( Static(..)+ ) where++import Control.Arrow+import Control.Applicative+import Control.Category+import Control.Monad (ap)+import Data.Functor.Apply+import Data.Functor.Plus+import Data.Functor.Extend+import Data.Orphans ()+import Data.Semigroup+import Data.Semigroupoid+import Prelude hiding ((.), id)++#ifdef MIN_VERSION_comonad+import Control.Comonad+#endif++newtype Static f a b = Static { runStatic :: f (a -> b) }++instance Functor f => Functor (Static f a) where+ fmap f = Static . fmap (f .) . runStatic++instance Apply f => Apply (Static f a) where+ Static f <.> Static g = Static (ap <$> f <.> g)++instance Alt f => Alt (Static f a) where+ Static f <!> Static g = Static (f <!> g)++instance Plus f => Plus (Static f a) where+ zero = Static zero++instance Applicative f => Applicative (Static f a) where+ pure = Static . pure . const+ Static f <*> Static g = Static (ap <$> f <*> g)++instance (Extend f, Semigroup a) => Extend (Static f a) where+ extended f = Static . extended (\wf m -> f (Static (fmap (. (<>) m) wf))) . runStatic++#ifdef MIN_VERSION_comonad+instance (Comonad f, Monoid a) => Comonad (Static f a) where+ extend f = Static . extend (\wf m -> f (Static (fmap (. mappend m) wf))) . runStatic+ extract (Static g) = extract g mempty+#endif++instance Apply f => Semigroupoid (Static f) where+ Static f `o` Static g = Static ((.) <$> f <.> g)++instance Applicative f => Category (Static f) where+ id = Static (pure id)+ Static f . Static g = Static ((.) <$> f <*> g)++instance Applicative f => Arrow (Static f) where+ arr = Static . pure+ first (Static g) = Static (first <$> g)+ second (Static g) = Static (second <$> g)+ Static g *** Static h = Static ((***) <$> g <*> h)+ Static g &&& Static h = Static ((&&&) <$> g <*> h)++instance Alternative f => ArrowZero (Static f) where+ zeroArrow = Static empty++instance Alternative f => ArrowPlus (Static f) where+ Static f <+> Static g = Static (f <|> g)++instance Applicative f => ArrowChoice (Static f) where+ left (Static g) = Static (left <$> g)+ right (Static g) = Static (right <$> g)+ Static g +++ Static h = Static ((+++) <$> g <*> h)+ Static g ||| Static h = Static ((|||) <$> g <*> h)+
+ src/Data/Traversable/Instances.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE Safe #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2011-2015,2018 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- 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 ()
+ src/Semigroupoids/Do.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE Safe #-}++{-|++This module re-exports operators from "Data.Functor.Apply" and+"Data.Functor.Bind", but under the same+names as their 'Applicative' and 'Monad' counterparts. This makes it convenient+to use do-notation on a type that is a 'Bind' but not a monad (or an 'Apply'+but not an 'Applicative' with @ApplicativeDo@), either using the+@QualifiedDo@ extension or the more traditional @RebindableSyntax@.++@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE QualifiedDo #-}++foo :: Apply f => f a -> f b -> f (a, b)+foo as bs = Semi.do+ a <- as+ b <- bs+ pure (a, b)+++bar :: Bind m => (a -> b -> m c) -> m a -> m b -> m c+bar f as bs = Semi.do+ a <- as+ b <- bs+ f a b+@++-}+module Semigroupoids.Do+ ( fmap+ , (<*)+ , (*>)+ , (<*>)+ , (>>)+ , (>>=)+ , join+ , pure+ , return+ , fail+ )+where++import Prelude (String, fmap, pure, return)+import Data.Functor.Apply (Apply, (<.), (.>), (<.>))+import Data.Functor.Bind (Bind, (>>-), join)+import Data.Functor.Plus (Plus, zero)++-- | @since 5.3.6+(<*) :: Apply f => f a -> f b -> f a+(<*) = (<.)++-- | @since 5.3.6+(*>) :: Apply f => f a -> f b -> f b+(*>) = (.>)++-- | @since 5.3.6+(<*>) :: Apply f => f (a -> b) -> f a -> f b+(<*>) = (<.>)++-- | @since 5.3.6+(>>) :: Bind m => m a -> m b -> m b+(>>) = (.>)++-- | @since 5.3.6+(>>=) :: Bind m => m a -> (a -> m b) -> m b+(>>=) = (>>-)++-- | = Important note+--+-- This /ignores/ whatever 'String' you give it. It is a bad idea to use 'fail'+-- as a form of labelled error; instead, it should only be defaulted to when a+-- pattern match fails.+--+-- @since 5.3.6+fail ::+ (Plus m) =>+ String ->+ m a+fail _ = zero
+ src/Semigroupoids/Internal.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Trustworthy #-}++module Semigroupoids.Internal where++#if MIN_VERSION_transformers(0,5,6)+import qualified Control.Monad.Trans.RWS.CPS as CPS+import qualified Control.Monad.Trans.Writer.CPS as CPS+import Unsafe.Coerce (unsafeCoerce)+#endif++-- This is designed to avoid both https://hub.darcs.net/ross/transformers/issue/67+-- and also the unnecessary Monoid constraints that the CPS versions of WriterT+-- and RWST require.++#if MIN_VERSION_transformers(0,5,6)+mkWriterT :: (w -> m (a, w)) -> CPS.WriterT w m a+mkWriterT = unsafeCoerce++unWriterT :: CPS.WriterT w m a -> w -> m (a, w)+unWriterT = unsafeCoerce++mkRWST :: (r -> s -> w -> m (a, s, w)) -> CPS.RWST r w s m a+mkRWST = unsafeCoerce++unRWST :: CPS.RWST r w s m a -> r -> s -> w -> m (a, s, w)+unRWST = unsafeCoerce+#endif