profunctors-5.6.2/0000755000000000000000000000000007346545000012301 5ustar0000000000000000profunctors-5.6.2/.ghci0000644000000000000000000000012507346545000013212 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h profunctors-5.6.2/.gitignore0000644000000000000000000000044507346545000014274 0ustar0000000000000000dist/ dist-newstyle/ .hsenv/ docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# :w .stack-work/ cabal-dev *.chi *.chs.h *.dyn_o *.dyn_hi .hpc .hsenv .cabal-sandbox/ cabal.sandbox.config *.prof *.aux *.hp *.eventlog cabal.project.local cabal.project.local~ .HTF/ .ghc.environment.* profunctors-5.6.2/.hlint.yaml0000644000000000000000000000240507346545000014362 0ustar0000000000000000- extensions: - default: false # all extension are banned by default - name: - CPP - DeriveFunctor - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - InstanceSigs - MultiParamTypeClasses - PolyKinds - RankNTypes - Safe - ScopedTypeVariables - Trustworthy - TypeFamilies - TypeOperators - UndecidableInstances - functions: - {name: unsafeCoerce, within: []} # banned - ignore: name: Use const within: - Data.Profunctor.Types - ignore: name: Avoid lambda within: - Data.Profunctor.Choice - Data.Profunctor.Traversing - ignore: name: Use fmap within: - Data.Profunctor.Composition - Data.Profunctor.Strong - Data.Profunctor.Unsafe - ignore: name: Avoid lambda within: Data.Profunctor.Strong - ignore: name: Redundant lambda within: Data.Profunctor.Unsafe - ignore: name: Collapse lambdas within: Data.Profunctor.Unsafe - ignore: name: Eta reduce within: - Data.Profunctor.Mapping - Data.Profunctor.Choice - Data.Profunctor.Strong - ignore: name: "Use tuple-section" - ignore: name: "Avoid lambda using `infix`" - fixity: "infixr 9 #." - fixity: "infixl 8 .#" - fixity: "infixr 0 :->" profunctors-5.6.2/.vim.custom0000644000000000000000000000137707346545000014416 0ustar0000000000000000" Add the following to your .vimrc to automatically load this on startup " if filereadable(".vim.custom") " so .vim.custom " endif function StripTrailingWhitespace() let myline=line(".") let mycolumn = col(".") silent %s/ *$// call cursor(myline, mycolumn) endfunction " enable syntax highlighting syntax on " search for the tags file anywhere between here and / set tags=TAGS;/ " highlight tabs and trailing spaces set listchars=tab:‗‗,trail:‗ set list " f2 runs hasktags map :exec ":!hasktags -x -c --ignore src" " strip trailing whitespace before saving " au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() " rebuild hasktags after saving au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" profunctors-5.6.2/CHANGELOG.markdown0000644000000000000000000001350107346545000015334 0ustar00000000000000005.6.2 [2021.02.17] ------------------ * Add `Semigroup` and `Monoid` instances for `Forget` 5.6.1 [2020.12.31] ------------------ * Add `Functor` instances for `PastroSum`, `CopastroSum`, `Environment`, `FreeMapping`, `Pastro`, `Copastro`, `FreeTraversing`, and `Coyoneda`. * Explicitly mark modules as `Safe`. 5.6 [2020.10.01] ---------------- * Enable the `PolyKinds` extension. The following datatypes now have polymorphic kinds: `(:->)`, `Cayley`, `Procompose`, `Rift`, `ProfunctorFunctor`, `Ran`, `Codensity`, `Prep`, `Coprep`, `Star`, `Costar`, `WrappedArrow`, `Forget`. * Allow building with GHC 9.0. 5.5.2 [2020.02.13] ------------------ * Add `Cochoice`, `Costrong`, `Closed`, `Traversing`, and `Mapping` instances for `Cayley`. * Add `Mapping` and `Traversing` instances for `Tannen`. 5.5.1 [2019.11.26] ------------------ * Add `Choice`, `Cochoice`, `Closed`, `Strong`, and `Costrong` instances for `Data.Bifunctor.Sum`. 5.5 [2019.09.06] ---------------- * Change the type of `roam` to make it actually useful. * Add a `Cochoice` instance for `Forget`. 5.4 [2019.05.10] ---------------- * Add `wander`-like combinator `roam` to `Mapping`. * Remove illegal `instance Choice (Costar w)`. * Add `strong` combinator #62. * Only depend on `semigroups` before GHC 8.0. * Add `Contravariant` instances for `Star` and `Forget`. 5.3 [2018.07.02] ---------------- * Generalize the types of `(#.)` and `(.#)`. Before, they were: ```haskell (#.) :: (Profunctor p, Coercible c b) => (b -> c) -> p a b -> p a c (.#) :: (Profunctor p, Coercible b a) => p b c -> (a -> b) -> p a c ``` Now, they are: ```haskell (#.) :: (Profunctor p, Coercible c b) => q b c -> p a b -> p a c (.#) :: (Profunctor p, Coercible b a) => p b c -> q a b -> p a c ``` * Drop support for GHC < 7.8. * Add a `Profunctor` instance for `Data.Bifunctor.Sum`. 5.2.2 [2018.01.18] ------------------ * Add `Semigroup` instances for `Closure` and `Tambara` 5.2.1 ----- * Allow `base-orphans-0.6`. * Add `Traversing` instance for `Forget` * Add `Traversing` and `Mapping` instances for `Procompose` * Add `Category` instance for `Star` * Add `mapCayley` to `Data.Profunctor.Cayley` * Add `pastro` and `unpastro` to `Data.Profunctor.Strong`. * Add `dimapWandering`, `lmapWandering`, and `rmapWandering` to `Data.Profunctor.Traversing` * Add documentation stating the laws for various profunctors. * Introduce the `Data.Profunctor.Yoneda` module. 5.2 --- * Renamed `Cotambara` to `TambaraChoice` and `Pastro` to `PastroChoice`. * Added a true `Cotambara` and `Copastro` construction for (co)freely generating costrength, along with `CotambaraSum` and `CopastroSum` variants. * Engaged in a fair bit of bikeshedding about the module structure for lesser used modules in this package. 5.1.2 ----- * Added `Prep` and `Coprep` along with witnesses to the adjunctions `Prep -| Star : [Hask,Hask] -> Prof` and `Coprep -| Costar : [Hask,Hask]^op -> Prof`. 5.1.1 ----- * Add proper support for GHC 7.0+. 5.1 --- * `instance Costrong (Cokleisli f)`. * `instance Cochoice (Star f)`. * Changed the instance for `Cochoice (Costar f)`. 5.0.1 ----- * MINIMAL pragma for `Costrong` and `Cochoice`. * More `Costrong` and `Cochoice` instances. 5.0.0.1 ------- * Documentation fix 5 - * `UpStar` and `DownStar` have become `Star` and `Costar`. `Star` is analogous to `Kleisli`, `Costar` is analogous to `Cokleisli`. * Split representability into sieves and representability. * Moved `Data.Profunctor.Collage` to `semigroupoids` 5, and removed the `semigroupoids` dependency. * Rather greatly widened the range of GHC versions we can support. 4.4.1 ------- * Using `SafeHaskell`, GHC 7.8+ `Data.Profunctor.Unsafe` now infers as `Trustworthy` and many more modules now infer as `Safe`. * We now build warning-free on GHC 7.10.0.20150307 4.4 ----- * Added `Coercible` constraint to (#.) and (.#) when building with GHC 7.8 * `Strong` is now a superclass of `Representable` * Updated the URL of the "Arrows are Strong Monads" paper. The old URL is now a dead link. 4.3.2 ----- * Added some missing instances for `UpStar` and `DownStar`. 4.3 --- * Removed the non law-abiding instance for `Closed (Forget r)` * `Forget` is `Representable` * MINIMAL pragmas 4.2.0.1 ------- * Avoided using 'type' in the export list, as that doesn't work on 7.4. 4.2 --- * Renamed `-|` to `ProfunctorAdjunction` because GHC 7.4 still exists in the wild. * Renamed `-/->` to `:->` for the same reason. Also the former was confusing as they conflated profunctor homomorphisms and profunctors themselves. 4.1 --- * Flipped the order of 'Procompose' * Added the notion of Monads and Comonads on the category of profunctors. * Added 'Cayley' which takes normal Haskell Monads and Comonads to a 'ProfunctorMonad' and 'ProfunctorComonad' respectively. Cayley is also known as the 'static arrow' construction * Added 'Closed' which is adjoint to 'Strong'. * Added 'Closure' which freely adjoins 'Closed' to any 'Profunctor'. * Added 'Tambara' which freely adjoins 'Strong' to any 'Profunctor'. * Added 'Cotambara' which freely adjoins 'Choice' to any 'Profunctor'. * Under the new 'Procompose' the old 'Rift' is now 'Ran', and the old 'Lift' was misnamed. It is now 'Rift' 4.0.3 ----- * Added `Data.Profunctor.Lift` containing the left Kan lift of a profunctor. 4.0.2 ----- * Added `assoc` to `Data.Profunctor.Composition` so that we have all 3 associators. 4.0 --- * Merged the contents of `profunctor-extras` into `profunctors`. 3.3 --- * Added `instance Choice (Upstar f)` and introduced `Forget`. 3.2 --- * Renamed `Lenticular` and `Prismatic` to `Strong` and `Choice`, and restructured them. 3.1.3 ----- * Removed upper bounds on my own intra-package dependencies 3.1.1 ----- * Added Documentation! * Added `Lenticular` and `Prismatic` Profunctors 3.1 --- * instance Profunctor Tagged 3.0 --- * Updated version number to match the rest of my libraries profunctors-5.6.2/LICENSE0000644000000000000000000000266007346545000013312 0ustar0000000000000000Copyright 2011-2015 Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 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 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. profunctors-5.6.2/README.markdown0000644000000000000000000000101507346545000014777 0ustar0000000000000000Profunctors =========== [![Hackage](https://img.shields.io/hackage/v/profunctors.svg)](https://hackage.haskell.org/package/profunctors) [![Build Status](https://github.com/ekmett/profunctors/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/profunctors/actions?query=workflow%3AHaskell-CI) Profunctors for Haskell. Contact Information ------------------- Contributions and bug reports are welcome! Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. -Edward Kmett profunctors-5.6.2/Setup.lhs0000644000000000000000000000016507346545000014113 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain profunctors-5.6.2/profunctors.cabal0000644000000000000000000000451107346545000015652 0ustar0000000000000000name: profunctors category: Control, Categories version: 5.6.2 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: experimental homepage: http://github.com/ekmett/profunctors/ bug-reports: http://github.com/ekmett/profunctors/issues copyright: Copyright (C) 2011-2015 Edward A. Kmett synopsis: Profunctors description: Profunctors. tested-with: GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.3 , GHC == 8.10.1 build-type: Simple extra-source-files: .ghci .gitignore .hlint.yaml .vim.custom README.markdown CHANGELOG.markdown source-repository head type: git location: git://github.com/ekmett/profunctors.git library build-depends: base >= 4.7 && < 5, base-orphans >= 0.8.4 && < 0.9, bifunctors >= 5.5.9 && < 6, comonad >= 5.0.8 && < 6, contravariant >= 1.5.3 && < 2, distributive >= 0.5.2 && < 1, tagged >= 0.8.6.1 && < 1, transformers >= 0.3 && < 0.6 if !impl(ghc >= 8.0) build-depends: semigroups >= 0.18.5 && < 0.20 exposed-modules: Data.Profunctor Data.Profunctor.Adjunction Data.Profunctor.Cayley Data.Profunctor.Choice Data.Profunctor.Closed Data.Profunctor.Composition Data.Profunctor.Mapping Data.Profunctor.Monad Data.Profunctor.Ran Data.Profunctor.Rep Data.Profunctor.Sieve Data.Profunctor.Strong Data.Profunctor.Traversing Data.Profunctor.Types Data.Profunctor.Unsafe Data.Profunctor.Yoneda ghc-options: -Wall -O2 if impl(ghc>=8.0) ghc-options: -Wno-trustworthy-safe if impl(ghc >= 8.6) ghc-options: -Wno-star-is-type 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 hs-source-dirs: src default-language: Haskell2010 other-extensions: CPP GADTs FlexibleContexts FlexibleInstances InstanceSigs UndecidableInstances TypeFamilies profunctors-5.6.2/src/Data/0000755000000000000000000000000007346545000013741 5ustar0000000000000000profunctors-5.6.2/src/Data/Profunctor.hs0000644000000000000000000000226707346545000016445 0ustar0000000000000000{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett, -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- For a good explanation of profunctors in Haskell see Dan Piponi's article: -- -- -- -- For more information on strength and costrength, see: -- -- ---------------------------------------------------------------------------- module Data.Profunctor ( -- * Profunctors Profunctor(dimap,lmap,rmap) -- ** Profunctorial Strength , Strong(..) , uncurry' , Choice(..) -- ** Closed , Closed(..) , curry' , Mapping(..) -- ** Profunctorial Costrength , Costrong(..) , Cochoice(..) -- ** Common Profunctors , Star(..) , Costar(..) , WrappedArrow(..) , Forget(..) , (:->) ) where import Data.Profunctor.Choice import Data.Profunctor.Closed import Data.Profunctor.Mapping import Data.Profunctor.Strong import Data.Profunctor.Types profunctors-5.6.2/src/Data/Profunctor/0000755000000000000000000000000007346545000016102 5ustar0000000000000000profunctors-5.6.2/src/Data/Profunctor/Adjunction.hs0000644000000000000000000000200107346545000020525 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable, MPTCs, fundeps -- ---------------------------------------------------------------------------- module Data.Profunctor.Adjunction where import Data.Profunctor.Types import Data.Profunctor.Monad -- | Laws: -- -- @ -- 'unit' '.' 'counit' ≡ 'id' -- 'counit' '.' 'unit' ≡ 'id' -- @ -- ProfunctorAdjunction :: ((Type -> Type -> Type) -> (Type -> Type -> Type)) -> ((Type -> Type -> Type) -> (Type -> Type -> Type)) -> Constraint class (ProfunctorFunctor f, ProfunctorFunctor u) => ProfunctorAdjunction f u | f -> u, u -> f where unit :: Profunctor p => p :-> u (f p) counit :: Profunctor p => f (u p) :-> p profunctors-5.6.2/src/Data/Profunctor/Cayley.hs0000644000000000000000000001235407346545000017671 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2014-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Profunctor.Cayley where import Control.Applicative import Control.Arrow import Control.Category import Control.Comonad import Data.Profunctor import Data.Profunctor.Monad import Data.Profunctor.Traversing import Data.Profunctor.Unsafe import Prelude hiding ((.), id) -- | Static arrows. Lifted by 'Applicative'. -- -- 'Cayley' has a polymorphic kind since @5.6@. -- Cayley :: (k3 -> Type) -> (k1 -> k2 -> k3) -> (k1 -> k2 -> Type) newtype Cayley f p a b = Cayley { runCayley :: f (p a b) } instance Functor f => ProfunctorFunctor (Cayley f) where promap f (Cayley p) = Cayley (fmap f p) -- | Cayley transforms Monads in @Hask@ into monads on @Prof@ instance (Functor f, Monad f) => ProfunctorMonad (Cayley f) where proreturn = Cayley . return projoin (Cayley m) = Cayley $ m >>= runCayley -- | Cayley transforms Comonads in @Hask@ into comonads on @Prof@ instance Comonad f => ProfunctorComonad (Cayley f) where proextract = extract . runCayley produplicate (Cayley w) = Cayley $ extend Cayley w instance (Functor f, Profunctor p) => Profunctor (Cayley f p) where dimap f g = Cayley . fmap (dimap f g) . runCayley lmap f = Cayley . fmap (lmap f) . runCayley rmap g = Cayley . fmap (rmap g) . runCayley w #. Cayley fp = Cayley $ fmap (w #.) fp Cayley fp .# w = Cayley $ fmap (.# w) fp instance (Functor f, Strong p) => Strong (Cayley f p) where first' = Cayley . fmap first' . runCayley second' = Cayley . fmap second' . runCayley instance (Functor f, Costrong p) => Costrong (Cayley f p) where unfirst (Cayley fp) = Cayley (fmap unfirst fp) unsecond (Cayley fp) = Cayley (fmap unsecond fp) instance (Functor f, Choice p) => Choice (Cayley f p) where left' = Cayley . fmap left' . runCayley right' = Cayley . fmap right' . runCayley instance (Functor f, Cochoice p) => Cochoice (Cayley f p) where unleft (Cayley fp) = Cayley (fmap unleft fp) {-# INLINE unleft #-} unright (Cayley fp) = Cayley (fmap unright fp) {-# INLINE unright #-} instance (Functor f, Closed p) => Closed (Cayley f p) where closed = Cayley . fmap closed . runCayley instance (Functor f, Traversing p) => Traversing (Cayley f p) where traverse' = Cayley . fmap traverse' . runCayley instance (Functor f, Mapping p) => Mapping (Cayley f p) where map' = Cayley . fmap map' . runCayley instance (Applicative f, Category p) => Category (Cayley f p) where id = Cayley $ pure id Cayley fpbc . Cayley fpab = Cayley $ liftA2 (.) fpbc fpab instance (Applicative f, Arrow p) => Arrow (Cayley f p) where arr f = Cayley $ pure $ arr f first = Cayley . fmap first . runCayley second = Cayley . fmap second . runCayley Cayley ab *** Cayley cd = Cayley $ liftA2 (***) ab cd Cayley ab &&& Cayley ac = Cayley $ liftA2 (&&&) ab ac instance (Applicative f, ArrowChoice p) => ArrowChoice (Cayley f p) where left = Cayley . fmap left . runCayley right = Cayley . fmap right . runCayley Cayley ab +++ Cayley cd = Cayley $ liftA2 (+++) ab cd Cayley ac ||| Cayley bc = Cayley $ liftA2 (|||) ac bc instance (Applicative f, ArrowLoop p) => ArrowLoop (Cayley f p) where loop = Cayley . fmap loop . runCayley instance (Applicative f, ArrowZero p) => ArrowZero (Cayley f p) where zeroArrow = Cayley $ pure zeroArrow instance (Applicative f, ArrowPlus p) => ArrowPlus (Cayley f p) where Cayley f <+> Cayley g = Cayley (liftA2 (<+>) f g) mapCayley :: (forall a. f a -> g a) -> Cayley f p x y -> Cayley g p x y mapCayley f (Cayley g) = Cayley (f g) -- instance Adjunction f g => ProfunctorAdjunction (Cayley f) (Cayley g) where {- newtype Uncayley p a = Uncayley (p () a) instance Profunctor p => Functor (Uncayley p) where fmap f (Uncayley p) = Uncayley (rmap f p) smash :: Strong p => Cayley (Uncayley p) (->) a b -> p a b smash (Cayley (Uncayley pab)) = dimap ((,)()) (uncurry id) (first' pab) unsmash :: Closed p => p a b -> Cayley (Uncayley p) (->) a b unsmash = Cayley . Uncayley . curry' . lmap snd type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) -- pastro and street's strong tambara module class (Strong p, Closed p) => Stronger p -- only a true iso for Stronger p and q, no? _Smash :: (Strong p, Closed q) => Iso (Cayley (Uncayley p) (->) a b) (Cayley (Uncayley q) (->) c d) (p a b) (q c d) _Smash = dimap hither (fmap yon) where hither (Cayley (Uncayley pab)) = dimap ((,)()) (uncurry id) (first' pab) yon = Cayley . Uncayley . curry' . lmap snd fsmash :: (forall x y. p x y -> q x y) -> Cayley (Uncayley p) (->) a b -> Cayley (Uncayley q) (->) a b fsmash f (Cayley (Uncayley puab)) = Cayley (Uncayley (f puab)) -- | proposition 4.3 from pastro and street is that fsmash and funsmash form an equivalence of categories funsmash :: (Closed p, Strong q) => (forall x y. Cayley (Uncayley p) (->) x y -> Cayley (Uncayley q) (->) x y) -> p a b -> q a b funsmash k = smash . k . unsmash -} profunctors-5.6.2/src/Data/Profunctor/Choice.hs0000644000000000000000000003777507346545000017653 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2014-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- ---------------------------------------------------------------------------- module Data.Profunctor.Choice ( -- * Strength Choice(..) , TambaraSum(..) , tambaraSum, untambaraSum , PastroSum(..) -- * Costrength , Cochoice(..) , CotambaraSum(..) , cotambaraSum, uncotambaraSum , CopastroSum(..) ) where import Control.Applicative hiding (WrappedArrow(..)) import Control.Arrow import Control.Category import Control.Comonad import Data.Bifunctor.Joker (Joker(..)) import Data.Bifunctor.Product (Product(..)) import Data.Bifunctor.Sum (Sum(..)) import Data.Bifunctor.Tannen (Tannen(..)) import Data.Monoid hiding (Product, Sum) import Data.Profunctor.Adjunction import Data.Profunctor.Monad import Data.Profunctor.Strong import Data.Profunctor.Types import Data.Profunctor.Unsafe import Data.Tagged #if __GLASGOW_HASKELL__ < 710 import Data.Traversable import Prelude hiding (id,(.),sequence) #else import Prelude hiding (id,(.)) #endif ------------------------------------------------------------------------------ -- Choice ------------------------------------------------------------------------------ -- | The generalization of 'Costar' of 'Functor' that is strong with respect -- to 'Either'. -- -- Note: This is also a notion of strength, except with regards to another monoidal -- structure that we can choose to equip Hask with: the cocartesian coproduct. class Profunctor p => Choice p where -- | Laws: -- -- @ -- 'left'' ≡ 'dimap' swapE swapE '.' 'right'' where -- swapE :: 'Either' a b -> 'Either' b a -- swapE = 'either' 'Right' 'Left' -- 'rmap' 'Left' ≡ 'lmap' 'Left' '.' 'left'' -- 'lmap' ('right' f) '.' 'left'' ≡ 'rmap' ('right' f) '.' 'left'' -- 'left'' '.' 'left'' ≡ 'dimap' assocE unassocE '.' 'left'' where -- assocE :: 'Either' ('Either' a b) c -> 'Either' a ('Either' b c) -- assocE ('Left' ('Left' a)) = 'Left' a -- assocE ('Left' ('Right' b)) = 'Right' ('Left' b) -- assocE ('Right' c) = 'Right' ('Right' c) -- unassocE :: 'Either' a ('Either' b c) -> 'Either' ('Either' a b) c -- unassocE ('Left' a) = 'Left' ('Left' a) -- unassocE ('Right' ('Left' b)) = 'Left' ('Right' b) -- unassocE ('Right' ('Right' c)) = 'Right' c -- @ left' :: p a b -> p (Either a c) (Either b c) left' = dimap (either Right Left) (either Right Left) . right' -- | Laws: -- -- @ -- 'right'' ≡ 'dimap' swapE swapE '.' 'left'' where -- swapE :: 'Either' a b -> 'Either' b a -- swapE = 'either' 'Right' 'Left' -- 'rmap' 'Right' ≡ 'lmap' 'Right' '.' 'right'' -- 'lmap' ('left' f) '.' 'right'' ≡ 'rmap' ('left' f) '.' 'right'' -- 'right'' '.' 'right'' ≡ 'dimap' unassocE assocE '.' 'right'' where -- assocE :: 'Either' ('Either' a b) c -> 'Either' a ('Either' b c) -- assocE ('Left' ('Left' a)) = 'Left' a -- assocE ('Left' ('Right' b)) = 'Right' ('Left' b) -- assocE ('Right' c) = 'Right' ('Right' c) -- unassocE :: 'Either' a ('Either' b c) -> 'Either' ('Either' a b) c -- unassocE ('Left' a) = 'Left' ('Left' a) -- unassocE ('Right' ('Left' b)) = 'Left' ('Right' b) -- unassocE ('Right' ('Right' c)) = 'Right' c -- @ right' :: p a b -> p (Either c a) (Either c b) right' = dimap (either Right Left) (either Right Left) . left' {-# MINIMAL left' | right' #-} instance Choice (->) where left' ab (Left a) = Left (ab a) left' _ (Right c) = Right c {-# INLINE left' #-} right' = fmap {-# INLINE right' #-} instance Monad m => Choice (Kleisli m) where left' = left {-# INLINE left' #-} right' = right {-# INLINE right' #-} instance Applicative f => Choice (Star f) where left' (Star f) = Star $ either (fmap Left . f) (pure . Right) {-# INLINE left' #-} right' (Star f) = Star $ either (pure . Left) (fmap Right . f) {-# INLINE right' #-} -- | 'extract' approximates 'costrength' instance Comonad w => Choice (Cokleisli w) where left' = left {-# INLINE left' #-} right' = right {-# INLINE right' #-} instance Choice Tagged where left' (Tagged b) = Tagged (Left b) {-# INLINE left' #-} right' (Tagged b) = Tagged (Right b) {-# INLINE right' #-} instance ArrowChoice p => Choice (WrappedArrow p) where left' (WrapArrow k) = WrapArrow (left k) {-# INLINE left' #-} right' (WrapArrow k) = WrapArrow (right k) {-# INLINE right' #-} instance Monoid r => Choice (Forget r) where left' (Forget k) = Forget (either k (const mempty)) {-# INLINE left' #-} right' (Forget k) = Forget (either (const mempty) k) {-# INLINE right' #-} instance Functor f => Choice (Joker f) where left' (Joker fb) = Joker (fmap Left fb) {-# INLINE left' #-} right' (Joker fb) = Joker (fmap Right fb) {-# INLINE right' #-} instance (Choice p, Choice q) => Choice (Product p q) where left' (Pair p q) = Pair (left' p) (left' q) {-# INLINE left' #-} right' (Pair p q) = Pair (right' p) (right' q) {-# INLINE right' #-} instance (Choice p, Choice q) => Choice (Sum p q) where left' (L2 p) = L2 (left' p) left' (R2 q) = R2 (left' q) {-# INLINE left' #-} right' (L2 p) = L2 (right' p) right' (R2 q) = R2 (right' q) {-# INLINE right' #-} instance (Functor f, Choice p) => Choice (Tannen f p) where left' (Tannen fp) = Tannen (fmap left' fp) {-# INLINE left' #-} right' (Tannen fp) = Tannen (fmap right' fp) {-# INLINE right' #-} instance Choice p => Choice (Tambara p) where left' (Tambara f) = Tambara $ dimap hither yon $ left' f where hither :: (Either a b, c) -> Either (a, c) (b, c) hither (Left y, s) = Left (y, s) hither (Right z, s) = Right (z, s) yon :: Either (a, c) (b, c) -> (Either a b, c) yon (Left (y, s)) = (Left y, s) yon (Right (z, s)) = (Right z, s) ---------------------------------------------------------------------------- -- * TambaraSum ---------------------------------------------------------------------------- -- | TambaraSum is cofreely adjoins strength with respect to Either. -- -- Note: this is not dual to 'Data.Profunctor.Tambara.Tambara'. It is 'Data.Profunctor.Tambara.Tambara' with respect to a different tensor. newtype TambaraSum p a b = TambaraSum { runTambaraSum :: forall c. p (Either a c) (Either b c) } instance ProfunctorFunctor TambaraSum where promap f (TambaraSum p) = TambaraSum (f p) instance ProfunctorComonad TambaraSum where proextract (TambaraSum p) = dimap Left fromEither p produplicate (TambaraSum p) = TambaraSum (TambaraSum $ dimap hither yon p) where hither :: Either (Either a b) c -> Either a (Either b c) hither (Left (Left x)) = Left x hither (Left (Right y)) = Right (Left y) hither (Right z) = Right (Right z) yon :: Either a (Either b c) -> Either (Either a b) c yon (Left x) = Left (Left x) yon (Right (Left y)) = Left (Right y) yon (Right (Right z)) = Right z instance Profunctor p => Profunctor (TambaraSum p) where dimap f g (TambaraSum p) = TambaraSum $ dimap (left f) (left g) p {-# INLINE dimap #-} instance Profunctor p => Choice (TambaraSum p) where left' p = runTambaraSum $ produplicate p {-# INLINE left' #-} instance Category p => Category (TambaraSum p) where id = TambaraSum id TambaraSum p . TambaraSum q = TambaraSum (p . q) instance Profunctor p => Functor (TambaraSum p a) where fmap = rmap -- | -- @ -- 'tambaraSum' '.' 'untambaraSum' ≡ 'id' -- 'untambaraSum' '.' 'tambaraSum' ≡ 'id' -- @ tambaraSum :: Choice p => (p :-> q) -> p :-> TambaraSum q tambaraSum f p = TambaraSum $ f $ left' p -- | -- @ -- 'tambaraSum' '.' 'untambaraSum' ≡ 'id' -- 'untambaraSum' '.' 'tambaraSum' ≡ 'id' -- @ untambaraSum :: Profunctor q => (p :-> TambaraSum q) -> p :-> q untambaraSum f p = dimap Left fromEither $ runTambaraSum $ f p fromEither :: Either a a -> a fromEither = either id id ---------------------------------------------------------------------------- -- * PastroSum ---------------------------------------------------------------------------- -- | PastroSum -| TambaraSum -- -- PastroSum freely constructs strength with respect to Either. data PastroSum p a b where PastroSum :: (Either y z -> b) -> p x y -> (a -> Either x z) -> PastroSum p a b instance Functor (PastroSum p a) where fmap f (PastroSum l m r) = PastroSum (f . l) m r instance Profunctor (PastroSum p) where dimap f g (PastroSum l m r) = PastroSum (g . l) m (r . f) lmap f (PastroSum l m r) = PastroSum l m (r . f) rmap g (PastroSum l m r) = PastroSum (g . l) m r w #. PastroSum l m r = PastroSum (w #. l) m r PastroSum l m r .# w = PastroSum l m (r .# w) instance ProfunctorAdjunction PastroSum TambaraSum where counit (PastroSum f (TambaraSum g) h) = dimap h f g unit p = TambaraSum $ PastroSum id p id instance ProfunctorFunctor PastroSum where promap f (PastroSum l m r) = PastroSum l (f m) r instance ProfunctorMonad PastroSum where proreturn p = PastroSum fromEither p Left projoin (PastroSum l (PastroSum m n o) q) = PastroSum lm n oq where oq a = case q a of Left b -> Left <$> o b Right z -> Right (Right z) lm (Left x) = l $ Left $ m $ Left x lm (Right (Left y)) = l $ Left $ m $ Right y lm (Right (Right z)) = l $ Right z instance Choice (PastroSum p) where left' (PastroSum l m r) = PastroSum l' m r' where r' = either (fmap Left . r) (Right . Right) l' (Left y) = Left (l (Left y)) l' (Right (Left z)) = Left (l (Right z)) l' (Right (Right c)) = Right c right' (PastroSum l m r) = PastroSum l' m r' where r' = either (Right . Left) (fmap Right . r) l' (Right (Left c)) = Left c l' (Right (Right z)) = Right (l (Right z)) l' (Left y) = Right (l (Left y)) -------------------------------------------------------------------------------- -- * Costrength for Either -------------------------------------------------------------------------------- class Profunctor p => Cochoice p where -- | Laws: -- -- @ -- 'unleft' ≡ 'unright' '.' 'dimap' swapE swapE where -- swapE :: 'Either' a b -> 'Either' b a -- swapE = 'either' 'Right' 'Left' -- 'rmap' ('either' 'id' 'absurd') ≡ 'unleft' '.' 'lmap' ('either' 'id' 'absurd') -- 'unfirst' '.' 'rmap' ('second' f) ≡ 'unfirst' '.' 'lmap' ('second' f) -- 'unleft' '.' 'unleft' ≡ 'unleft' '.' 'dimap' assocE unassocE where -- assocE :: 'Either' ('Either' a b) c -> 'Either' a ('Either' b c) -- assocE ('Left' ('Left' a)) = 'Left' a -- assocE ('Left' ('Right' b)) = 'Right' ('Left' b) -- assocE ('Right' c) = 'Right' ('Right' c) -- unassocE :: 'Either' a ('Either' b c) -> 'Either' ('Either' a b) c -- unassocE ('Left' a) = 'Left' ('Left' a) -- unassocE ('Right' ('Left' b)) = 'Left' ('Right' b) -- unassocE ('Right' ('Right' c)) = 'Right' c -- @ unleft :: p (Either a d) (Either b d) -> p a b unleft = unright . dimap (either Right Left) (either Right Left) -- | Laws: -- -- @ -- 'unright' ≡ 'unleft' '.' 'dimap' swapE swapE where -- swapE :: 'Either' a b -> 'Either' b a -- swapE = 'either' 'Right' 'Left' -- 'rmap' ('either' 'absurd' 'id') ≡ 'unright' '.' 'lmap' ('either' 'absurd' 'id') -- 'unsecond' '.' 'rmap' ('first' f) ≡ 'unsecond' '.' 'lmap' ('first' f) -- 'unright' '.' 'unright' ≡ 'unright' '.' 'dimap' unassocE assocE where -- assocE :: 'Either' ('Either' a b) c -> 'Either' a ('Either' b c) -- assocE ('Left' ('Left' a)) = 'Left' a -- assocE ('Left' ('Right' b)) = 'Right' ('Left' b) -- assocE ('Right' c) = 'Right' ('Right' c) -- unassocE :: 'Either' a ('Either' b c) -> 'Either' ('Either' a b) c -- unassocE ('Left' a) = 'Left' ('Left' a) -- unassocE ('Right' ('Left' b)) = 'Left' ('Right' b) -- unassocE ('Right' ('Right' c)) = 'Right' c -- @ unright :: p (Either d a) (Either d b) -> p a b unright = unleft . dimap (either Right Left) (either Right Left) {-# MINIMAL unleft | unright #-} instance Cochoice (->) where unleft f = go . Left where go = either id (go . Right) . f unright f = go . Right where go = either (go . Left) id . f instance Applicative f => Cochoice (Costar f) where unleft (Costar f) = Costar (go . fmap Left) where go = either id (go . pure . Right) . f -- NB: Another instance that's highly questionable instance Traversable f => Cochoice (Star f) where unright (Star f) = Star (go . Right) where go = either (go . Left) id . sequence . f instance (Functor f, Cochoice p) => Cochoice (Tannen f p) where unleft (Tannen fp) = Tannen (fmap unleft fp) {-# INLINE unleft #-} unright (Tannen fp) = Tannen (fmap unright fp) {-# INLINE unright #-} instance (Cochoice p, Cochoice q) => Cochoice (Product p q) where unleft (Pair p q) = Pair (unleft p) (unleft q) unright (Pair p q) = Pair (unright p) (unright q) instance (Cochoice p, Cochoice q) => Cochoice (Sum p q) where unleft (L2 p) = L2 (unleft p) unleft (R2 q) = R2 (unleft q) unright (L2 p) = L2 (unright p) unright (R2 q) = R2 (unright q) instance Cochoice (Forget r) where unleft (Forget f) = Forget (f . Left) unright (Forget f) = Forget (f . Right) ---------------------------------------------------------------------------- -- * CotambaraSum ---------------------------------------------------------------------------- -- | 'CotambaraSum' cofreely constructs costrength with respect to 'Either' (aka 'Choice') data CotambaraSum q a b where CotambaraSum :: Cochoice r => (r :-> q) -> r a b -> CotambaraSum q a b instance Profunctor (CotambaraSum p) where lmap f (CotambaraSum n p) = CotambaraSum n (lmap f p) rmap g (CotambaraSum n p) = CotambaraSum n (rmap g p) dimap f g (CotambaraSum n p) = CotambaraSum n (dimap f g p) instance ProfunctorFunctor CotambaraSum where promap f (CotambaraSum n p) = CotambaraSum (f . n) p instance ProfunctorComonad CotambaraSum where proextract (CotambaraSum n p) = n p produplicate (CotambaraSum n p) = CotambaraSum id (CotambaraSum n p) instance Cochoice (CotambaraSum p) where unleft (CotambaraSum n p) = CotambaraSum n (unleft p) unright (CotambaraSum n p) = CotambaraSum n (unright p) instance Functor (CotambaraSum p a) where fmap = rmap -- | -- @ -- 'cotambaraSum' '.' 'uncotambaraSum' ≡ 'id' -- 'uncotambaraSum' '.' 'cotambaraSum' ≡ 'id' -- @ cotambaraSum :: Cochoice p => (p :-> q) -> p :-> CotambaraSum q cotambaraSum f = CotambaraSum f -- | -- @ -- 'cotambaraSum' '.' 'uncotambaraSum' ≡ 'id' -- 'uncotambaraSum' '.' 'cotambaraSum' ≡ 'id' -- @ uncotambaraSum :: Profunctor q => (p :-> CotambaraSum q) -> p :-> q uncotambaraSum f p = proextract (f p) ---------------------------------------------------------------------------- -- * Copastro ---------------------------------------------------------------------------- -- | CopastroSum -| CotambaraSum -- -- 'CopastroSum' freely constructs costrength with respect to 'Either' (aka 'Choice') newtype CopastroSum p a b = CopastroSum { runCopastroSum :: forall r. Cochoice r => (forall x y. p x y -> r x y) -> r a b } instance Functor (CopastroSum p a) where fmap f (CopastroSum h) = CopastroSum $ \ n -> rmap f (h n) instance Profunctor (CopastroSum p) where dimap f g (CopastroSum h) = CopastroSum $ \ n -> dimap f g (h n) lmap f (CopastroSum h) = CopastroSum $ \ n -> lmap f (h n) rmap g (CopastroSum h) = CopastroSum $ \ n -> rmap g (h n) instance ProfunctorAdjunction CopastroSum CotambaraSum where unit p = CotambaraSum id (proreturn p) counit (CopastroSum h) = proextract (h id) instance ProfunctorFunctor CopastroSum where promap f (CopastroSum h) = CopastroSum $ \n -> h (n . f) instance ProfunctorMonad CopastroSum where proreturn p = CopastroSum $ \n -> n p projoin p = CopastroSum $ \c -> runCopastroSum p (\x -> runCopastroSum x c) instance Cochoice (CopastroSum p) where unleft (CopastroSum p) = CopastroSum $ \n -> unleft (p n) unright (CopastroSum p) = CopastroSum $ \n -> unright (p n) profunctors-5.6.2/src/Data/Profunctor/Closed.hs0000644000000000000000000001625307346545000017656 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2014-2018 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Profunctor.Closed ( Closed(..) , Closure(..) , close , unclose , Environment(..) , curry' ) where import Control.Applicative import Control.Arrow import Control.Category import Control.Comonad import Data.Bifunctor.Product (Product(..)) import Data.Bifunctor.Sum (Sum(..)) import Data.Bifunctor.Tannen (Tannen(..)) import Data.Coerce (Coercible, coerce) import Data.Distributive import Data.Profunctor.Adjunction import Data.Profunctor.Monad import Data.Profunctor.Strong import Data.Profunctor.Types import Data.Profunctor.Unsafe import Data.Semigroup hiding (Product, Sum) import Data.Tagged import Data.Tuple import Prelude hiding ((.),id) -------------------------------------------------------------------------------- -- * Closed -------------------------------------------------------------------------------- -- | A strong profunctor allows the monoidal structure to pass through. -- -- A closed profunctor allows the closed structure to pass through. class Profunctor p => Closed p where -- | Laws: -- -- @ -- 'lmap' ('.' f) '.' 'closed' ≡ 'rmap' ('.' f) '.' 'closed' -- 'closed' '.' 'closed' ≡ 'dimap' 'uncurry' 'curry' '.' 'closed' -- 'dimap' 'const' ('$'()) '.' 'closed' ≡ 'id' -- @ closed :: p a b -> p (x -> a) (x -> b) instance Closed Tagged where closed (Tagged b) = Tagged (const b) instance Closed (->) where closed = (.) instance Functor f => Closed (Costar f) where closed (Costar fab) = Costar $ \fxa x -> fab (fmap ($ x) fxa) instance Functor f => Closed (Cokleisli f) where closed (Cokleisli fab) = Cokleisli $ \fxa x -> fab (fmap ($ x) fxa) instance Distributive f => Closed (Star f) where closed (Star afb) = Star $ \xa -> distribute $ \x -> afb (xa x) instance (Distributive f, Monad f) => Closed (Kleisli f) where closed (Kleisli afb) = Kleisli $ \xa -> distribute $ \x -> afb (xa x) instance (Closed p, Closed q) => Closed (Product p q) where closed (Pair p q) = Pair (closed p) (closed q) instance (Closed p, Closed q) => Closed (Sum p q) where closed (L2 p) = L2 (closed p) closed (R2 q) = R2 (closed q) instance (Functor f, Closed p) => Closed (Tannen f p) where closed (Tannen fp) = Tannen (fmap closed fp) -- instance Monoid r => Closed (Forget r) where -- closed _ = Forget $ \_ -> mempty curry' :: Closed p => p (a, b) c -> p a (b -> c) curry' = lmap (,) . closed -------------------------------------------------------------------------------- -- * Closure -------------------------------------------------------------------------------- -- | 'Closure' adjoins a 'Closed' structure to any 'Profunctor'. -- -- Analogous to 'Data.Profunctor.Tambara.Tambara' for 'Strong'. newtype Closure p a b = Closure { runClosure :: forall x. p (x -> a) (x -> b) } instance Profunctor p => Profunctor (Closure p) where dimap f g (Closure p) = Closure $ dimap (fmap f) (fmap g) p lmap f (Closure p) = Closure $ lmap (fmap f) p rmap f (Closure p) = Closure $ rmap (fmap f) p (#.) :: forall a b c q. Coercible c b => q b c -> Closure p a b -> Closure p a c _ #. Closure p = Closure $ fmap (coerce (id :: c -> c) :: b -> c) #. p (.#) :: forall a b c q. Coercible b a => Closure p b c -> q a b -> Closure p a c Closure p .# _ = Closure $ p .# fmap (coerce (id :: b -> b) :: a -> b) instance ProfunctorFunctor Closure where promap f (Closure p) = Closure (f p) instance ProfunctorComonad Closure where proextract p = dimap const ($ ()) $ runClosure p produplicate (Closure p) = Closure $ Closure $ dimap uncurry curry p instance Profunctor p => Closed (Closure p) where closed p = runClosure $ produplicate p instance Strong p => Strong (Closure p) where first' (Closure p) = Closure $ dimap hither yon $ first' p instance Category p => Category (Closure p) where id = Closure id Closure p . Closure q = Closure (p . q) hither :: (s -> (a,b)) -> (s -> a, s -> b) hither h = (fst . h, snd . h) yon :: (s -> a, s -> b) -> s -> (a,b) yon h s = (fst h s, snd h s) instance Arrow p => Arrow (Closure p) where arr f = Closure (arr (f .)) first (Closure f) = Closure $ arr yon . first f . arr hither instance ArrowLoop p => ArrowLoop (Closure p) where loop (Closure f) = Closure $ loop (arr hither . f . arr yon) instance ArrowZero p => ArrowZero (Closure p) where zeroArrow = Closure zeroArrow instance ArrowPlus p => ArrowPlus (Closure p) where Closure f <+> Closure g = Closure (f <+> g) instance Profunctor p => Functor (Closure p a) where fmap = rmap instance (Profunctor p, Arrow p) => Applicative (Closure p a) where pure x = arr (const x) f <*> g = arr (uncurry id) . (f &&& g) instance (Profunctor p, ArrowPlus p) => Alternative (Closure p a) where empty = zeroArrow f <|> g = f <+> g instance (Profunctor p, Arrow p, Semigroup b) => Semigroup (Closure p a b) where (<>) = liftA2 (<>) instance (Profunctor p, Arrow p, Semigroup b, Monoid b) => Monoid (Closure p a b) where mempty = pure mempty #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif -- | -- @ -- 'close' '.' 'unclose' ≡ 'id' -- 'unclose' '.' 'close' ≡ 'id' -- @ close :: Closed p => (p :-> q) -> p :-> Closure q close f p = Closure $ f $ closed p -- | -- @ -- 'close' '.' 'unclose' ≡ 'id' -- 'unclose' '.' 'close' ≡ 'id' -- @ unclose :: Profunctor q => (p :-> Closure q) -> p :-> q unclose f p = dimap const ($ ()) $ runClosure $ f p -------------------------------------------------------------------------------- -- * Environment -------------------------------------------------------------------------------- data Environment p a b where Environment :: ((z -> y) -> b) -> p x y -> (a -> z -> x) -> Environment p a b instance Functor (Environment p a) where fmap f (Environment l m r) = Environment (f . l) m r instance Profunctor (Environment p) where dimap f g (Environment l m r) = Environment (g . l) m (r . f) lmap f (Environment l m r) = Environment l m (r . f) rmap g (Environment l m r) = Environment (g . l) m r w #. Environment l m r = Environment (w #. l) m r Environment l m r .# w = Environment l m (r .# w) instance ProfunctorFunctor Environment where promap f (Environment l m r) = Environment l (f m) r instance ProfunctorMonad Environment where proreturn p = Environment ($ ()) p const projoin (Environment l (Environment m n o) p) = Environment (lm . curry) n op where op a (b, c) = o (p a b) c lm zr = l (m.zr) instance ProfunctorAdjunction Environment Closure where counit (Environment g (Closure p) f) = dimap f g p unit p = Closure (Environment id p id) instance Closed (Environment p) where closed (Environment l m r) = Environment l' m r' where r' wa (z,w) = r (wa w) z l' zx2y x = l (\z -> zx2y (z,x)) profunctors-5.6.2/src/Data/Profunctor/Composition.hs0000644000000000000000000002743307346545000020752 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Profunctor.Composition -- Copyright : (C) 2014-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : GADTs, TFs, MPTCs, RankN -- ---------------------------------------------------------------------------- module Data.Profunctor.Composition ( -- * Profunctor Composition Procompose(..) , procomposed -- * Unitors and Associator , idl , idr , assoc -- * Categories as monoid objects , eta , mu -- * Generalized Composition , stars, kleislis , costars, cokleislis -- * Right Kan Lift , Rift(..) , decomposeRift ) where import Control.Arrow import Control.Category import Control.Comonad import Control.Monad (liftM) import Data.Functor.Compose import Data.Profunctor import Data.Profunctor.Adjunction import Data.Profunctor.Monad import Data.Profunctor.Rep import Data.Profunctor.Sieve import Data.Profunctor.Traversing import Data.Profunctor.Unsafe import Prelude hiding ((.),id) type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) -- * Profunctor Composition -- | @'Procompose' p q@ is the 'Profunctor' composition of the -- 'Profunctor's @p@ and @q@. -- -- For a good explanation of 'Profunctor' composition in Haskell -- see Dan Piponi's article: -- -- -- -- 'Procompose' has a polymorphic kind since @5.6@. -- Procompose :: (k1 -> k2 -> Type) -> (k3 -> k1 -> Type) -> (k3 -> k2 -> Type) data Procompose p q d c where Procompose :: p x c -> q d x -> Procompose p q d c instance ProfunctorFunctor (Procompose p) where promap f (Procompose p q) = Procompose p (f q) instance Category p => ProfunctorMonad (Procompose p) where proreturn = Procompose id projoin (Procompose p (Procompose q r)) = Procompose (p . q) r procomposed :: Category p => Procompose p p a b -> p a b procomposed (Procompose pxc pdx) = pxc . pdx {-# INLINE procomposed #-} instance (Profunctor p, Profunctor q) => Profunctor (Procompose p q) where dimap l r (Procompose f g) = Procompose (rmap r f) (lmap l g) {-# INLINE dimap #-} lmap k (Procompose f g) = Procompose f (lmap k g) {-# INLINE rmap #-} rmap k (Procompose f g) = Procompose (rmap k f) g {-# INLINE lmap #-} k #. Procompose f g = Procompose (k #. f) g {-# INLINE (#.) #-} Procompose f g .# k = Procompose f (g .# k) {-# INLINE (.#) #-} instance Profunctor p => Functor (Procompose p q a) where fmap k (Procompose f g) = Procompose (rmap k f) g {-# INLINE fmap #-} instance (Sieve p f, Sieve q g) => Sieve (Procompose p q) (Compose g f) where sieve (Procompose g f) d = Compose $ sieve g <$> sieve f d {-# INLINE sieve #-} -- | The composition of two 'Representable' 'Profunctor's is 'Representable' by -- the composition of their representations. instance (Representable p, Representable q) => Representable (Procompose p q) where type Rep (Procompose p q) = Compose (Rep q) (Rep p) tabulate f = Procompose (tabulate id) (tabulate (getCompose . f)) {-# INLINE tabulate #-} instance (Cosieve p f, Cosieve q g) => Cosieve (Procompose p q) (Compose f g) where cosieve (Procompose g f) (Compose d) = cosieve g $ cosieve f <$> d {-# INLINE cosieve #-} instance (Corepresentable p, Corepresentable q) => Corepresentable (Procompose p q) where type Corep (Procompose p q) = Compose (Corep p) (Corep q) cotabulate f = Procompose (cotabulate (f . Compose)) (cotabulate id) {-# INLINE cotabulate #-} instance (Strong p, Strong q) => Strong (Procompose p q) where first' (Procompose x y) = Procompose (first' x) (first' y) {-# INLINE first' #-} second' (Procompose x y) = Procompose (second' x) (second' y) {-# INLINE second' #-} instance (Choice p, Choice q) => Choice (Procompose p q) where left' (Procompose x y) = Procompose (left' x) (left' y) {-# INLINE left' #-} right' (Procompose x y) = Procompose (right' x) (right' y) {-# INLINE right' #-} instance (Closed p, Closed q) => Closed (Procompose p q) where closed (Procompose x y) = Procompose (closed x) (closed y) {-# INLINE closed #-} instance (Traversing p, Traversing q) => Traversing (Procompose p q) where traverse' (Procompose p q) = Procompose (traverse' p) (traverse' q) {-# INLINE traverse' #-} instance (Mapping p, Mapping q) => Mapping (Procompose p q) where map' (Procompose p q) = Procompose (map' p) (map' q) {-# INLINE map' #-} instance (Corepresentable p, Corepresentable q) => Costrong (Procompose p q) where unfirst = unfirstCorep {-# INLINE unfirst #-} unsecond = unsecondCorep {-# INLINE unsecond #-} -- * Lax identity -- | @(->)@ functions as a lax identity for 'Profunctor' composition. -- -- This provides an 'Iso' for the @lens@ package that witnesses the -- isomorphism between @'Procompose' (->) q d c@ and @q d c@, which -- is the left identity law. -- -- @ -- 'idl' :: 'Profunctor' q => Iso' ('Procompose' (->) q d c) (q d c) -- @ idl :: Profunctor q => Iso (Procompose (->) q d c) (Procompose (->) r d' c') (q d c) (r d' c') idl = dimap (\(Procompose g f) -> rmap g f) (fmap (Procompose id)) -- | @(->)@ functions as a lax identity for 'Profunctor' composition. -- -- This provides an 'Iso' for the @lens@ package that witnesses the -- isomorphism between @'Procompose' q (->) d c@ and @q d c@, which -- is the right identity law. -- -- @ -- 'idr' :: 'Profunctor' q => Iso' ('Procompose' q (->) d c) (q d c) -- @ idr :: Profunctor q => Iso (Procompose q (->) d c) (Procompose r (->) d' c') (q d c) (r d' c') idr = dimap (\(Procompose g f) -> lmap f g) (fmap (`Procompose` id)) -- | The associator for 'Profunctor' composition. -- -- This provides an 'Iso' for the @lens@ package that witnesses the -- isomorphism between @'Procompose' p ('Procompose' q r) a b@ and -- @'Procompose' ('Procompose' p q) r a b@, which arises because -- @Prof@ is only a bicategory, rather than a strict 2-category. assoc :: Iso (Procompose p (Procompose q r) a b) (Procompose x (Procompose y z) a b) (Procompose (Procompose p q) r a b) (Procompose (Procompose x y) z a b) assoc = dimap (\(Procompose f (Procompose g h)) -> Procompose (Procompose f g) h) (fmap (\(Procompose (Procompose f g) h) -> Procompose f (Procompose g h))) -- | 'Profunctor' composition generalizes 'Functor' composition in two ways. -- -- This is the first, which shows that @exists b. (a -> f b, b -> g c)@ is -- isomorphic to @a -> f (g c)@. -- -- @'stars' :: 'Functor' f => Iso' ('Procompose' ('Star' f) ('Star' g) d c) ('Star' ('Compose' f g) d c)@ stars :: Functor g => Iso (Procompose (Star f ) (Star g ) d c ) (Procompose (Star f') (Star g') d' c') (Star (Compose g f ) d c ) (Star (Compose g' f') d' c') stars = dimap hither (fmap yon) where hither (Procompose (Star xgc) (Star dfx)) = Star (Compose . fmap xgc . dfx) yon (Star dfgc) = Procompose (Star id) (Star (getCompose . dfgc)) -- | 'Profunctor' composition generalizes 'Functor' composition in two ways. -- -- This is the second, which shows that @exists b. (f a -> b, g b -> c)@ is -- isomorphic to @g (f a) -> c@. -- -- @'costars' :: 'Functor' f => Iso' ('Procompose' ('Costar' f) ('Costar' g) d c) ('Costar' ('Compose' g f) d c)@ costars :: Functor f => Iso (Procompose (Costar f ) (Costar g ) d c ) (Procompose (Costar f') (Costar g') d' c') (Costar (Compose f g ) d c ) (Costar (Compose f' g') d' c') costars = dimap hither (fmap yon) where hither (Procompose (Costar gxc) (Costar fdx)) = Costar (gxc . fmap fdx . getCompose) yon (Costar dgfc) = Procompose (Costar (dgfc . Compose)) (Costar id) -- | This is a variant on 'stars' that uses 'Kleisli' instead of 'Star'. -- -- @'kleislis' :: 'Monad' f => Iso' ('Procompose' ('Kleisli' f) ('Kleisli' g) d c) ('Kleisli' ('Compose' f g) d c)@ kleislis :: Monad g => Iso (Procompose (Kleisli f ) (Kleisli g ) d c ) (Procompose (Kleisli f') (Kleisli g') d' c') (Kleisli (Compose g f ) d c ) (Kleisli (Compose g' f') d' c') kleislis = dimap hither (fmap yon) where hither (Procompose (Kleisli xgc) (Kleisli dfx)) = Kleisli (Compose . liftM xgc . dfx) yon (Kleisli dfgc) = Procompose (Kleisli id) (Kleisli (getCompose . dfgc)) -- | This is a variant on 'costars' that uses 'Cokleisli' instead -- of 'Costar'. -- -- @'cokleislis' :: 'Functor' f => Iso' ('Procompose' ('Cokleisli' f) ('Cokleisli' g) d c) ('Cokleisli' ('Compose' g f) d c)@ cokleislis :: Functor f => Iso (Procompose (Cokleisli f ) (Cokleisli g ) d c ) (Procompose (Cokleisli f') (Cokleisli g') d' c') (Cokleisli (Compose f g ) d c ) (Cokleisli (Compose f' g') d' c') cokleislis = dimap hither (fmap yon) where hither (Procompose (Cokleisli gxc) (Cokleisli fdx)) = Cokleisli (gxc . fmap fdx . getCompose) yon (Cokleisli dgfc) = Procompose (Cokleisli (dgfc . Compose)) (Cokleisli id) ---------------------------------------------------------------------------- -- * Rift ---------------------------------------------------------------------------- -- | This represents the right Kan lift of a 'Profunctor' @q@ along a -- 'Profunctor' @p@ in a limited version of the 2-category of Profunctors where -- the only object is the category Hask, 1-morphisms are profunctors composed -- and compose with Profunctor composition, and 2-morphisms are just natural -- transformations. -- -- 'Rift' has a polymorphic kind since @5.6@. -- Rift :: (k3 -> k2 -> Type) -> (k1 -> k2 -> Type) -> (k1 -> k3 -> Type) newtype Rift p q a b = Rift { runRift :: forall x. p b x -> q a x } instance ProfunctorFunctor (Rift p) where promap f (Rift g) = Rift (f . g) instance Category p => ProfunctorComonad (Rift p) where proextract (Rift f) = f id produplicate (Rift f) = Rift $ \p -> Rift $ \q -> f (q . p) instance (Profunctor p, Profunctor q) => Profunctor (Rift p q) where dimap ca bd f = Rift (lmap ca . runRift f . lmap bd) {-# INLINE dimap #-} lmap ca f = Rift (lmap ca . runRift f) {-# INLINE lmap #-} rmap bd f = Rift (runRift f . lmap bd) {-# INLINE rmap #-} bd #. f = Rift (\p -> runRift f (p .# bd)) {-# INLINE (#.) #-} f .# ca = Rift (\p -> runRift f p .# ca) {-# INLINE (.#) #-} instance Profunctor p => Functor (Rift p q a) where fmap bd f = Rift (runRift f . lmap bd) {-# INLINE fmap #-} -- | @'Rift' p p@ forms a 'Monad' in the 'Profunctor' 2-category, which is isomorphic to a Haskell 'Category' instance. instance p ~ q => Category (Rift p q) where id = Rift id {-# INLINE id #-} Rift f . Rift g = Rift (g . f) {-# INLINE (.) #-} -- | The 2-morphism that defines a left Kan lift. -- -- Note: When @p@ is right adjoint to @'Rift' p (->)@ then 'decomposeRift' is the 'counit' of the adjunction. decomposeRift :: Procompose p (Rift p q) :-> q decomposeRift (Procompose p (Rift pq)) = pq p {-# INLINE decomposeRift #-} instance ProfunctorAdjunction (Procompose p) (Rift p) where counit (Procompose p (Rift pq)) = pq p unit q = Rift $ \p -> Procompose p q --instance (ProfunctorAdjunction f g, ProfunctorAdjunction f' g') => ProfunctorAdjunction (ProfunctorCompose f' f) (ProfunctorCompose g g') where ---------------------------------------------------------------------------- -- * Monoids ---------------------------------------------------------------------------- -- | a 'Category' that is also a 'Profunctor' is a 'Monoid' in @Prof@ eta :: (Profunctor p, Category p) => (->) :-> p eta f = rmap f id mu :: Category p => Procompose p p :-> p mu (Procompose f g) = f . g profunctors-5.6.2/src/Data/Profunctor/Mapping.hs0000644000000000000000000001370307346545000020035 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2015-2018 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Profunctor.Mapping ( Mapping(..) , CofreeMapping(..) , FreeMapping(..) -- * Traversing in terms of Mapping , wanderMapping -- * Closed in terms of Mapping , traverseMapping , closedMapping ) where import Control.Arrow (Kleisli(..)) import Data.Bifunctor.Tannen import Data.Distributive import Data.Functor.Compose import Data.Functor.Identity import Data.Profunctor.Choice import Data.Profunctor.Closed import Data.Profunctor.Monad import Data.Profunctor.Strong import Data.Profunctor.Traversing import Data.Profunctor.Types import Data.Profunctor.Unsafe #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif class (Traversing p, Closed p) => Mapping p where -- | Laws: -- -- @ -- 'map'' '.' 'rmap' f ≡ 'rmap' ('fmap' f) '.' 'map'' -- 'map'' '.' 'map'' ≡ 'dimap' 'Data.Functor.Compose.Compose' 'Data.Functor.Compose.getCompose' '.' 'map'' -- 'dimap' 'Data.Functor.Identity.Identity' 'Data.Functor.Identity.runIdentity' '.' 'map'' ≡ 'id' -- @ map' :: Functor f => p a b -> p (f a) (f b) map' = roam fmap roam :: ((a -> b) -> s -> t) -> p a b -> p s t roam f = dimap (\s -> Bar $ \ab -> f ab s) lent . map' newtype Bar t b a = Bar { runBar :: (a -> b) -> t } deriving Functor lent :: Bar t a a -> t lent m = runBar m id instance Mapping (->) where map' = fmap roam f = f instance (Monad m, Distributive m) => Mapping (Kleisli m) where map' (Kleisli f) = Kleisli (collect f) #if __GLASGOW_HASKELL__ >= 710 roam f = Kleisli #. genMap f .# runKleisli #else -- We could actually use this implementation everywhere, but it's kind of a -- warty mess, and there have been rumblings of WrappedMonad deprecation. -- If/when GHC 7.8 moves out of the support window, this will vanish in a -- puff of cleanup. roam f = (Kleisli . (unwrapMonad .)) #. genMapW f .# ((WrapMonad .) . runKleisli) where genMapW :: (Monad m, Distributive m) => ((a -> b) -> s -> t) -> (a -> WrappedMonad m b) -> s -> WrappedMonad m t genMapW abst amb s = WrapMonad $ (\ab -> abst ab s) <$> distribute (unwrapMonad #. amb) #endif genMap :: Distributive f => ((a -> b) -> s -> t) -> (a -> f b) -> s -> f t genMap abst afb s = fmap (\ab -> abst ab s) (distribute afb) -- see instance (Applicative m, Distributive m) => Mapping (Star m) where map' (Star f) = Star (collect f) roam f = Star #. genMap f .# runStar instance (Functor f, Mapping p) => Mapping (Tannen f p) where map' = Tannen . fmap map' . runTannen wanderMapping :: Mapping p => (forall f. Applicative f => (a -> f b) -> s -> f t) -> p a b -> p s t wanderMapping f = roam ((runIdentity .) #. f .# (Identity .)) traverseMapping :: (Mapping p, Functor f) => p a b -> p (f a) (f b) traverseMapping = map' closedMapping :: Mapping p => p a b -> p (x -> a) (x -> b) closedMapping = map' newtype CofreeMapping p a b = CofreeMapping { runCofreeMapping :: forall f. Functor f => p (f a) (f b) } instance Profunctor p => Profunctor (CofreeMapping p) where lmap f (CofreeMapping p) = CofreeMapping (lmap (fmap f) p) rmap g (CofreeMapping p) = CofreeMapping (rmap (fmap g) p) dimap f g (CofreeMapping p) = CofreeMapping (dimap (fmap f) (fmap g) p) instance Profunctor p => Strong (CofreeMapping p) where second' = map' instance Profunctor p => Choice (CofreeMapping p) where right' = map' instance Profunctor p => Closed (CofreeMapping p) where closed = map' instance Profunctor p => Traversing (CofreeMapping p) where traverse' = map' wander f = roam $ (runIdentity .) #. f .# (Identity .) instance Profunctor p => Mapping (CofreeMapping p) where -- !@(#*&() Compose isn't representational in its second arg or we could use #. and .# map' (CofreeMapping p) = CofreeMapping (dimap Compose getCompose p) roam f (CofreeMapping p) = CofreeMapping $ dimap (Compose #. fmap (\s -> Bar $ \ab -> f ab s)) (fmap lent .# getCompose) p instance ProfunctorFunctor CofreeMapping where promap f (CofreeMapping p) = CofreeMapping (f p) instance ProfunctorComonad CofreeMapping where proextract (CofreeMapping p) = runIdentity #. p .# Identity produplicate (CofreeMapping p) = CofreeMapping (CofreeMapping (dimap Compose getCompose p)) -- | @FreeMapping -| CofreeMapping@ data FreeMapping p a b where FreeMapping :: Functor f => (f y -> b) -> p x y -> (a -> f x) -> FreeMapping p a b instance Functor (FreeMapping p a) where fmap f (FreeMapping l m r) = FreeMapping (f . l) m r instance Profunctor (FreeMapping p) where lmap f (FreeMapping l m r) = FreeMapping l m (r . f) rmap g (FreeMapping l m r) = FreeMapping (g . l) m r dimap f g (FreeMapping l m r) = FreeMapping (g . l) m (r . f) g #. FreeMapping l m r = FreeMapping (g #. l) m r FreeMapping l m r .# f = FreeMapping l m (r .# f) instance Strong (FreeMapping p) where second' = map' instance Choice (FreeMapping p) where right' = map' instance Closed (FreeMapping p) where closed = map' instance Traversing (FreeMapping p) where traverse' = map' wander f = roam ((runIdentity .) #. f .# (Identity .)) instance Mapping (FreeMapping p) where map' (FreeMapping l m r) = FreeMapping (fmap l .# getCompose) m (Compose #. fmap r) instance ProfunctorFunctor FreeMapping where promap f (FreeMapping l m r) = FreeMapping l (f m) r instance ProfunctorMonad FreeMapping where proreturn p = FreeMapping runIdentity p Identity projoin (FreeMapping l (FreeMapping l' m r') r) = FreeMapping ((l . fmap l') .# getCompose) m (Compose #. (fmap r' . r)) profunctors-5.6.2/src/Data/Profunctor/Monad.hs0000644000000000000000000000544607346545000017505 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2014-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Profunctor.Monad where import Control.Comonad import Data.Bifunctor.Tannen import Data.Bifunctor.Product import Data.Bifunctor.Sum import Data.Profunctor.Types -- | 'ProfunctorFunctor' has a polymorphic kind since @5.6@. -- ProfunctorFunctor :: ((Type -> Type -> Type) -> (k1 -> k2 -> Type)) -> Constraint class ProfunctorFunctor t where -- | Laws: -- -- @ -- 'promap' f '.' 'promap' g ≡ 'promap' (f '.' g) -- 'promap' 'id' ≡ 'id' -- @ promap :: Profunctor p => (p :-> q) -> t p :-> t q instance Functor f => ProfunctorFunctor (Tannen f) where promap f (Tannen g) = Tannen (fmap f g) instance ProfunctorFunctor (Product p) where promap f (Pair p q) = Pair p (f q) instance ProfunctorFunctor (Sum p) where promap _ (L2 p) = L2 p promap f (R2 q) = R2 (f q) -- | Laws: -- -- @ -- 'promap' f '.' 'proreturn' ≡ 'proreturn' '.' f -- 'projoin' '.' 'proreturn' ≡ 'id' -- 'projoin' '.' 'promap' 'proreturn' ≡ 'id' -- 'projoin' '.' 'projoin' ≡ 'projoin' '.' 'promap' 'projoin' -- @ -- ProfunctorMonad :: ((Type -> Type -> Type) -> (Type -> Type -> Type)) -> Constraint class ProfunctorFunctor t => ProfunctorMonad t where proreturn :: Profunctor p => p :-> t p projoin :: Profunctor p => t (t p) :-> t p #if __GLASGOW_HASKELL__ < 710 instance (Functor f, Monad f) => ProfunctorMonad (Tannen f) where #else instance Monad f => ProfunctorMonad (Tannen f) where #endif proreturn = Tannen . return projoin (Tannen m) = Tannen $ m >>= runTannen instance ProfunctorMonad (Sum p) where proreturn = R2 projoin (L2 p) = L2 p projoin (R2 m) = m -- | Laws: -- -- @ -- 'proextract' '.' 'promap' f ≡ f '.' 'proextract' -- 'proextract' '.' 'produplicate' ≡ 'id' -- 'promap' 'proextract' '.' 'produplicate' ≡ 'id' -- 'produplicate' '.' 'produplicate' ≡ 'promap' 'produplicate' '.' 'produplicate' -- @ -- ProfunctorComonad :: ((Type -> Type -> Type) -> (Type -> Type -> Type)) -> Constraint class ProfunctorFunctor t => ProfunctorComonad t where proextract :: Profunctor p => t p :-> p produplicate :: Profunctor p => t p :-> t (t p) instance Comonad f => ProfunctorComonad (Tannen f) where proextract = extract . runTannen produplicate (Tannen w) = Tannen $ extend Tannen w instance ProfunctorComonad (Product p) where proextract (Pair _ q) = q produplicate pq@(Pair p _) = Pair p pq profunctors-5.6.2/src/Data/Profunctor/Ran.hs0000644000000000000000000001103507346545000017156 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2013-2015 Edward Kmett and Dan Doel -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types, TFs -- ---------------------------------------------------------------------------- module Data.Profunctor.Ran ( Ran(..) , decomposeRan , precomposeRan , curryRan , uncurryRan , Codensity(..) , decomposeCodensity ) where import Control.Category import Data.Profunctor import Data.Profunctor.Composition import Data.Profunctor.Monad import Data.Profunctor.Unsafe import Prelude hiding (id,(.)) -------------------------------------------------------------------------------- -- * Ran -------------------------------------------------------------------------------- -- | This represents the right Kan extension of a 'Profunctor' @q@ along a -- 'Profunctor' @p@ in a limited version of the 2-category of Profunctors where -- the only object is the category Hask, 1-morphisms are profunctors composed -- and compose with Profunctor composition, and 2-morphisms are just natural -- transformations. -- -- 'Ran' has a polymorphic kind since @5.6@. -- Ran :: (k1 -> k2 -> Type) -> (k1 -> k3 -> Type) -> (k2 -> k3 -> Type) newtype Ran p q a b = Ran { runRan :: forall x. p x a -> q x b } instance ProfunctorFunctor (Ran p) where promap f (Ran g) = Ran (f . g) instance Category p => ProfunctorComonad (Ran p) where proextract (Ran f) = f id produplicate (Ran f) = Ran $ \ p -> Ran $ \q -> f (p . q) instance (Profunctor p, Profunctor q) => Profunctor (Ran p q) where dimap ca bd f = Ran (rmap bd . runRan f . rmap ca) {-# INLINE dimap #-} lmap ca f = Ran (runRan f . rmap ca) {-# INLINE lmap #-} rmap bd f = Ran (rmap bd . runRan f) {-# INLINE rmap #-} bd #. f = Ran (\p -> bd #. runRan f p) {-# INLINE (#.) #-} f .# ca = Ran (\p -> runRan f (ca #. p)) {-# INLINE (.#) #-} instance Profunctor q => Functor (Ran p q a) where fmap bd f = Ran (rmap bd . runRan f) {-# INLINE fmap #-} -- | @'Ran' p p@ forms a 'Monad' in the 'Profunctor' 2-category, which is isomorphic to a Haskell 'Category' instance. instance p ~ q => Category (Ran p q) where id = Ran id {-# INLINE id #-} Ran f . Ran g = Ran (f . g) {-# INLINE (.) #-} -- | The 2-morphism that defines a right Kan extension. -- -- Note: When @q@ is left adjoint to @'Ran' q (->)@ then 'decomposeRan' is the 'counit' of the adjunction. decomposeRan :: Procompose (Ran q p) q :-> p decomposeRan (Procompose (Ran qp) q) = qp q {-# INLINE decomposeRan #-} precomposeRan :: Profunctor q => Procompose q (Ran p (->)) :-> Ran p q precomposeRan (Procompose p pf) = Ran (\pxa -> runRan pf pxa `lmap` p) {-# INLINE precomposeRan #-} curryRan :: (Procompose p q :-> r) -> p :-> Ran q r curryRan f p = Ran $ \q -> f (Procompose p q) {-# INLINE curryRan #-} uncurryRan :: (p :-> Ran q r) -> Procompose p q :-> r uncurryRan f (Procompose p q) = runRan (f p) q {-# INLINE uncurryRan #-} -------------------------------------------------------------------------------- -- * Codensity -------------------------------------------------------------------------------- -- | This represents the right Kan extension of a 'Profunctor' @p@ along -- itself. This provides a generalization of the \"difference list\" trick to -- profunctors. -- -- 'Codensity' has a polymorphic kind since @5.6@. -- Codensity :: (k1 -> k2 -> Type) -> (k2 -> k2 -> Type) newtype Codensity p a b = Codensity { runCodensity :: forall x. p x a -> p x b } instance Profunctor p => Profunctor (Codensity p) where dimap ca bd f = Codensity (rmap bd . runCodensity f . rmap ca) {-# INLINE dimap #-} lmap ca f = Codensity (runCodensity f . rmap ca) {-# INLINE lmap #-} rmap bd f = Codensity (rmap bd . runCodensity f) {-# INLINE rmap #-} bd #. f = Codensity (\p -> bd #. runCodensity f p) {-# INLINE (#.) #-} f .# ca = Codensity (\p -> runCodensity f (ca #. p)) {-# INLINE (.#) #-} instance Profunctor p => Functor (Codensity p a) where fmap bd f = Codensity (rmap bd . runCodensity f) {-# INLINE fmap #-} instance Category (Codensity p) where id = Codensity id {-# INLINE id #-} Codensity f . Codensity g = Codensity (f . g) {-# INLINE (.) #-} decomposeCodensity :: Procompose (Codensity p) p a b -> p a b decomposeCodensity (Procompose (Codensity pp) p) = pp p {-# INLINE decomposeCodensity #-} profunctors-5.6.2/src/Data/Profunctor/Rep.hs0000644000000000000000000001733507346545000017175 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Profunctor.Rep -- Copyright : (C) 2011-2015 Edward Kmett, -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Type-Families -- ---------------------------------------------------------------------------- module Data.Profunctor.Rep ( -- * Representable Profunctors Representable(..) , tabulated , firstRep, secondRep -- * Corepresentable Profunctors , Corepresentable(..) , cotabulated , unfirstCorep, unsecondCorep , closedCorep -- * Prep -| Star , Prep(..) , prepAdj , unprepAdj , prepUnit , prepCounit -- * Coprep -| Costar , Coprep(..) , coprepAdj , uncoprepAdj , coprepUnit , coprepCounit ) where import Control.Applicative import Control.Arrow import Control.Comonad import Control.Monad ((>=>)) import Data.Functor.Identity import Data.Profunctor import Data.Profunctor.Sieve import Data.Proxy import Data.Tagged -- * Representable Profunctors -- | A 'Profunctor' @p@ is 'Representable' if there exists a 'Functor' @f@ such that -- @p d c@ is isomorphic to @d -> f c@. class (Sieve p (Rep p), Strong p) => Representable p where type Rep p :: * -> * -- | Laws: -- -- @ -- 'tabulate' '.' 'sieve' ≡ 'id' -- 'sieve' '.' 'tabulate' ≡ 'id' -- @ tabulate :: (d -> Rep p c) -> p d c -- | Default definition for 'first'' given that p is 'Representable'. firstRep :: Representable p => p a b -> p (a, c) (b, c) firstRep p = tabulate $ \(a,c) -> (\b -> (b, c)) <$> sieve p a -- | Default definition for 'second'' given that p is 'Representable'. secondRep :: Representable p => p a b -> p (c, a) (c, b) secondRep p = tabulate $ \(c,a) -> (,) c <$> sieve p a instance Representable (->) where type Rep (->) = Identity tabulate f = runIdentity . f {-# INLINE tabulate #-} instance (Monad m, Functor m) => Representable (Kleisli m) where type Rep (Kleisli m) = m tabulate = Kleisli {-# INLINE tabulate #-} instance Functor f => Representable (Star f) where type Rep (Star f) = f tabulate = Star {-# INLINE tabulate #-} instance Representable (Forget r) where type Rep (Forget r) = Const r tabulate = Forget . (getConst .) {-# INLINE tabulate #-} {- TODO: coproducts and products instance (Representable p, Representable q) => Representable (Bifunctor.Product p q) type Rep (Bifunctor.Product p q) = Functor.Product p q instance (Corepresentable p, Corepresentable q) => Corepresentable (Bifunctor.Product p q) where type Rep (Bifunctor.Product p q) = Functor.Sum p q -} type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) -- | 'tabulate' and 'sieve' form two halves of an isomorphism. -- -- This can be used with the combinators from the @lens@ package. -- -- @'tabulated' :: 'Representable' p => 'Iso'' (d -> 'Rep' p c) (p d c)@ tabulated :: (Representable p, Representable q) => Iso (d -> Rep p c) (d' -> Rep q c') (p d c) (q d' c') tabulated = dimap tabulate (fmap sieve) {-# INLINE tabulated #-} -- * Corepresentable Profunctors -- | A 'Profunctor' @p@ is 'Corepresentable' if there exists a 'Functor' @f@ such that -- @p d c@ is isomorphic to @f d -> c@. class (Cosieve p (Corep p), Costrong p) => Corepresentable p where type Corep p :: * -> * -- | Laws: -- -- @ -- 'cotabulate' '.' 'cosieve' ≡ 'id' -- 'cosieve' '.' 'cotabulate' ≡ 'id' -- @ cotabulate :: (Corep p d -> c) -> p d c -- | Default definition for 'unfirst' given that @p@ is 'Corepresentable'. unfirstCorep :: Corepresentable p => p (a, d) (b, d) -> p a b unfirstCorep p = cotabulate f where f fa = b where (b, d) = cosieve p ((\a -> (a, d)) <$> fa) -- | Default definition for 'unsecond' given that @p@ is 'Corepresentable'. unsecondCorep :: Corepresentable p => p (d, a) (d, b) -> p a b unsecondCorep p = cotabulate f where f fa = b where (d, b) = cosieve p ((,) d <$> fa) -- | Default definition for 'closed' given that @p@ is 'Corepresentable' closedCorep :: Corepresentable p => p a b -> p (x -> a) (x -> b) closedCorep p = cotabulate $ \fs x -> cosieve p (fmap ($ x) fs) instance Corepresentable (->) where type Corep (->) = Identity cotabulate f = f . Identity {-# INLINE cotabulate #-} instance Functor w => Corepresentable (Cokleisli w) where type Corep (Cokleisli w) = w cotabulate = Cokleisli {-# INLINE cotabulate #-} instance Corepresentable Tagged where type Corep Tagged = Proxy cotabulate f = Tagged (f Proxy) {-# INLINE cotabulate #-} instance Functor f => Corepresentable (Costar f) where type Corep (Costar f) = f cotabulate = Costar {-# INLINE cotabulate #-} -- | 'cotabulate' and 'cosieve' form two halves of an isomorphism. -- -- This can be used with the combinators from the @lens@ package. -- -- @'cotabulated' :: 'Corep' f p => 'Iso'' (f d -> c) (p d c)@ cotabulated :: (Corepresentable p, Corepresentable q) => Iso (Corep p d -> c) (Corep q d' -> c') (p d c) (q d' c') cotabulated = dimap cotabulate (fmap cosieve) {-# INLINE cotabulated #-} -------------------------------------------------------------------------------- -- * Prep -------------------------------------------------------------------------------- -- | @'Prep' -| 'Star' :: [Hask, Hask] -> Prof@ -- -- This gives rise to a monad in @Prof@, @('Star'.'Prep')@, and -- a comonad in @[Hask,Hask]@ @('Prep'.'Star')@ -- -- 'Prep' has a polymorphic kind since @5.6@. -- Prep :: (Type -> k -> Type) -> (k -> Type) data Prep p a where Prep :: x -> p x a -> Prep p a instance Profunctor p => Functor (Prep p) where fmap f (Prep x p) = Prep x (rmap f p) instance (Applicative (Rep p), Representable p) => Applicative (Prep p) where pure a = Prep () $ tabulate $ const $ pure a Prep xf pf <*> Prep xa pa = Prep (xf,xa) (tabulate go) where go (xf',xa') = sieve pf xf' <*> sieve pa xa' instance (Monad (Rep p), Representable p) => Monad (Prep p) where return a = Prep () $ tabulate $ const $ return a Prep xa pa >>= f = Prep xa $ tabulate $ sieve pa >=> \a -> case f a of Prep xb pb -> sieve pb xb prepAdj :: (forall a. Prep p a -> g a) -> p :-> Star g prepAdj k p = Star $ \x -> k (Prep x p) unprepAdj :: (p :-> Star g) -> Prep p a -> g a unprepAdj k (Prep x p) = runStar (k p) x prepUnit :: p :-> Star (Prep p) prepUnit p = Star $ \x -> Prep x p prepCounit :: Prep (Star f) a -> f a prepCounit (Prep x p) = runStar p x -------------------------------------------------------------------------------- -- * Coprep -------------------------------------------------------------------------------- -- | 'Prep' has a polymorphic kind since @5.6@. -- Coprep :: (k -> Type -> Type) -> (k -> Type) newtype Coprep p a = Coprep { runCoprep :: forall r. p a r -> r } instance Profunctor p => Functor (Coprep p) where fmap f (Coprep g) = Coprep (g . lmap f) -- | @'Coprep' -| 'Costar' :: [Hask, Hask]^op -> Prof@ -- -- Like all adjunctions this gives rise to a monad and a comonad. -- -- This gives rise to a monad on Prof @('Costar'.'Coprep')@ and -- a comonad on @[Hask, Hask]^op@ given by @('Coprep'.'Costar')@ which -- is a monad in @[Hask,Hask]@ coprepAdj :: (forall a. f a -> Coprep p a) -> p :-> Costar f coprepAdj k p = Costar $ \f -> runCoprep (k f) p uncoprepAdj :: (p :-> Costar f) -> f a -> Coprep p a uncoprepAdj k f = Coprep $ \p -> runCostar (k p) f coprepUnit :: p :-> Costar (Coprep p) coprepUnit p = Costar $ \f -> runCoprep f p coprepCounit :: f a -> Coprep (Costar f) a coprepCounit f = Coprep $ \p -> runCostar p f profunctors-5.6.2/src/Data/Profunctor/Sieve.hs0000644000000000000000000000426407346545000017517 0ustar0000000000000000{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : MPTCs, fundeps -- ---------------------------------------------------------------------------- module Data.Profunctor.Sieve ( Sieve(..) , Cosieve(..) ) where import Control.Applicative import Control.Arrow import Control.Comonad import Data.Functor.Identity import Data.Profunctor import Data.Proxy import Data.Tagged -- | A 'Profunctor' @p@ is a 'Sieve' __on__ @f@ if it is a subprofunctor of @'Star' f@. -- -- That is to say it is a subset of @Hom(-,f=)@ closed under 'lmap' and 'rmap'. -- -- Alternately, you can view it as a sieve __in__ the comma category @Hask/f@. class (Profunctor p, Functor f) => Sieve p f | p -> f where sieve :: p a b -> a -> f b instance Sieve (->) Identity where sieve f = Identity . f {-# INLINE sieve #-} instance (Monad m, Functor m) => Sieve (Kleisli m) m where sieve = runKleisli {-# INLINE sieve #-} instance Functor f => Sieve (Star f) f where sieve = runStar {-# INLINE sieve #-} instance Sieve (Forget r) (Const r) where sieve = (Const .) . runForget {-# INLINE sieve #-} -- | A 'Profunctor' @p@ is a 'Cosieve' __on__ @f@ if it is a subprofunctor of @'Costar' f@. -- -- That is to say it is a subset of @Hom(f-,=)@ closed under 'lmap' and 'rmap'. -- -- Alternately, you can view it as a cosieve __in__ the comma category @f/Hask@. class (Profunctor p, Functor f) => Cosieve p f | p -> f where cosieve :: p a b -> f a -> b instance Cosieve (->) Identity where cosieve f (Identity d) = f d {-# INLINE cosieve #-} instance Functor w => Cosieve (Cokleisli w) w where cosieve = runCokleisli {-# INLINE cosieve #-} instance Cosieve Tagged Proxy where cosieve (Tagged a) _ = a {-# INLINE cosieve #-} instance Functor f => Cosieve (Costar f) f where cosieve = runCostar {-# INLINE cosieve #-} profunctors-5.6.2/src/Data/Profunctor/Strong.hs0000644000000000000000000003512207346545000017715 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2014-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- ---------------------------------------------------------------------------- module Data.Profunctor.Strong ( -- * Strength Strong(..) , uncurry' , strong , Tambara(..) , tambara, untambara , Pastro(..) , pastro, unpastro -- * Costrength , Costrong(..) , Cotambara(..) , cotambara, uncotambara , Copastro(..) ) where import Control.Applicative hiding (WrappedArrow(..)) import Control.Arrow import Control.Category import Control.Comonad import Control.Monad (liftM) import Control.Monad.Fix import Data.Bifunctor.Clown (Clown(..)) import Data.Bifunctor.Product (Product(..)) import Data.Bifunctor.Sum (Sum(..)) import Data.Bifunctor.Tannen (Tannen(..)) import Data.Functor.Contravariant (Contravariant(..)) import Data.Profunctor.Adjunction import Data.Profunctor.Monad import Data.Profunctor.Types import Data.Profunctor.Unsafe import Data.Semigroup hiding (Product, Sum) import Data.Tagged import Data.Tuple import Prelude hiding (id,(.)) ------------------------------------------------------------------------------ -- Strong ------------------------------------------------------------------------------ -- | Generalizing 'Star' of a strong 'Functor' -- -- /Note:/ Every 'Functor' in Haskell is strong with respect to @(,)@. -- -- This describes profunctor strength with respect to the product structure -- of Hask. -- -- -- class Profunctor p => Strong p where -- | Laws: -- -- @ -- 'first'' ≡ 'dimap' 'swap' 'swap' '.' 'second'' -- 'lmap' 'fst' ≡ 'rmap' 'fst' '.' 'first'' -- 'lmap' ('second'' f) '.' 'first'' ≡ 'rmap' ('second'' f) '.' 'first'' -- 'first'' '.' 'first'' ≡ 'dimap' assoc unassoc '.' 'first'' where -- assoc ((a,b),c) = (a,(b,c)) -- unassoc (a,(b,c)) = ((a,b),c) -- @ first' :: p a b -> p (a, c) (b, c) first' = dimap swap swap . second' -- | Laws: -- -- @ -- 'second'' ≡ 'dimap' 'swap' 'swap' '.' 'first'' -- 'lmap' 'snd' ≡ 'rmap' 'snd' '.' 'second'' -- 'lmap' ('first'' f) '.' 'second'' ≡ 'rmap' ('first'' f) '.' 'second'' -- 'second'' '.' 'second'' ≡ 'dimap' unassoc assoc '.' 'second'' where -- assoc ((a,b),c) = (a,(b,c)) -- unassoc (a,(b,c)) = ((a,b),c) -- @ second' :: p a b -> p (c, a) (c, b) second' = dimap swap swap . first' {-# MINIMAL first' | second' #-} uncurry' :: Strong p => p a (b -> c) -> p (a, b) c uncurry' = rmap (\(f,x) -> f x) . first' {-# INLINE uncurry' #-} strong :: Strong p => (a -> b -> c) -> p a b -> p a c strong f x = dimap (\a -> (a, a)) (\(b, a) -> f a b) (first' x) instance Strong (->) where first' ab ~(a, c) = (ab a, c) {-# INLINE first' #-} second' ab ~(c, a) = (c, ab a) {-# INLINE second' #-} instance Monad m => Strong (Kleisli m) where first' (Kleisli f) = Kleisli $ \ ~(a, c) -> do b <- f a return (b, c) {-# INLINE first' #-} second' (Kleisli f) = Kleisli $ \ ~(c, a) -> do b <- f a return (c, b) {-# INLINE second' #-} instance Functor m => Strong (Star m) where first' (Star f) = Star $ \ ~(a, c) -> (\b' -> (b', c)) <$> f a {-# INLINE first' #-} second' (Star f) = Star $ \ ~(c, a) -> (,) c <$> f a {-# INLINE second' #-} -- | 'Arrow' is 'Strong' 'Category' instance Arrow p => Strong (WrappedArrow p) where first' (WrapArrow k) = WrapArrow (first k) {-# INLINE first' #-} second' (WrapArrow k) = WrapArrow (second k) {-# INLINE second' #-} instance Strong (Forget r) where first' (Forget k) = Forget (k . fst) {-# INLINE first' #-} second' (Forget k) = Forget (k . snd) {-# INLINE second' #-} instance Contravariant f => Strong (Clown f) where first' (Clown fa) = Clown (contramap fst fa) {-# INLINE first' #-} second' (Clown fa) = Clown (contramap snd fa) {-# INLINE second' #-} instance (Strong p, Strong q) => Strong (Product p q) where first' (Pair p q) = Pair (first' p) (first' q) {-# INLINE first' #-} second' (Pair p q) = Pair (second' p) (second' q) {-# INLINE second' #-} instance (Strong p, Strong q) => Strong (Sum p q) where first' (L2 p) = L2 (first' p) first' (R2 q) = R2 (first' q) {-# INLINE first' #-} second' (L2 p) = L2 (second' p) second' (R2 q) = R2 (second' q) {-# INLINE second' #-} instance (Functor f, Strong p) => Strong (Tannen f p) where first' (Tannen fp) = Tannen (fmap first' fp) {-# INLINE first' #-} second' (Tannen fp) = Tannen (fmap second' fp) {-# INLINE second' #-} ---------------------------------------------------------------------------- -- * Tambara ---------------------------------------------------------------------------- -- | 'Tambara' cofreely makes any 'Profunctor' 'Strong'. newtype Tambara p a b = Tambara { runTambara :: forall c. p (a, c) (b, c) } instance Profunctor p => Profunctor (Tambara p) where dimap f g (Tambara p) = Tambara $ dimap (first f) (first g) p {-# INLINE dimap #-} instance ProfunctorFunctor Tambara where promap f (Tambara p) = Tambara (f p) instance ProfunctorComonad Tambara where proextract (Tambara p) = dimap (\a -> (a,())) fst p produplicate (Tambara p) = Tambara (Tambara $ dimap hither yon p) where hither :: ((a, b), c) -> (a, (b, c)) hither ~(~(x,y),z) = (x,(y,z)) yon :: (a, (b, c)) -> ((a, b), c) yon ~(x,~(y,z)) = ((x,y),z) instance Profunctor p => Strong (Tambara p) where first' p = runTambara $ produplicate p {-# INLINE first' #-} instance Category p => Category (Tambara p) where id = Tambara id Tambara p . Tambara q = Tambara (p . q) instance Arrow p => Arrow (Tambara p) where arr f = Tambara $ arr $ first f first (Tambara f) = Tambara (arr go . first f . arr go) where go :: ((a, b), c) -> ((a, c), b) go ~(~(x,y),z) = ((x,z),y) instance ArrowChoice p => ArrowChoice (Tambara p) where left (Tambara f) = Tambara (arr yon . left f . arr hither) where hither :: (Either a b, c) -> Either (a, c) (b, c) hither (Left y, s) = Left (y, s) hither (Right z, s) = Right (z, s) yon :: Either (a, c) (b, c) -> (Either a b, c) yon (Left (y, s)) = (Left y, s) yon (Right (z, s)) = (Right z, s) instance ArrowApply p => ArrowApply (Tambara p) where app = Tambara $ app . arr (\((Tambara f, x), s) -> (f, (x, s))) instance ArrowLoop p => ArrowLoop (Tambara p) where loop (Tambara f) = Tambara (loop (arr go . f . arr go)) where go :: ((a, b), c) -> ((a, c), b) go ~(~(x,y),z) = ((x,z),y) instance ArrowZero p => ArrowZero (Tambara p) where zeroArrow = Tambara zeroArrow instance ArrowPlus p => ArrowPlus (Tambara p) where Tambara f <+> Tambara g = Tambara (f <+> g) instance Profunctor p => Functor (Tambara p a) where fmap = rmap instance (Profunctor p, Arrow p) => Applicative (Tambara p a) where pure x = arr (const x) f <*> g = arr (uncurry id) . (f &&& g) instance (Profunctor p, ArrowPlus p) => Alternative (Tambara p a) where empty = zeroArrow f <|> g = f <+> g instance ArrowPlus p => Semigroup (Tambara p a b) where f <> g = f <+> g instance ArrowPlus p => Monoid (Tambara p a b) where mempty = zeroArrow #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif -- | -- @ -- 'tambara' ('untambara' f) ≡ f -- 'untambara' ('tambara' f) ≡ f -- @ tambara :: Strong p => (p :-> q) -> p :-> Tambara q tambara f p = Tambara $ f $ first' p -- | -- @ -- 'tambara' ('untambara' f) ≡ f -- 'untambara' ('tambara' f) ≡ f -- @ untambara :: Profunctor q => (p :-> Tambara q) -> p :-> q untambara f p = dimap (\a -> (a,())) fst $ runTambara $ f p ---------------------------------------------------------------------------- -- * Pastro ---------------------------------------------------------------------------- -- | Pastro -| Tambara -- -- @ -- Pastro p ~ exists z. Costar ((,)z) `Procompose` p `Procompose` Star ((,)z) -- @ -- -- 'Pastro' freely makes any 'Profunctor' 'Strong'. data Pastro p a b where Pastro :: ((y, z) -> b) -> p x y -> (a -> (x, z)) -> Pastro p a b instance Functor (Pastro p a) where fmap f (Pastro l m r) = Pastro (f . l) m r instance Profunctor (Pastro p) where dimap f g (Pastro l m r) = Pastro (g . l) m (r . f) lmap f (Pastro l m r) = Pastro l m (r . f) rmap g (Pastro l m r) = Pastro (g . l) m r w #. Pastro l m r = Pastro (w #. l) m r Pastro l m r .# w = Pastro l m (r .# w) instance ProfunctorFunctor Pastro where promap f (Pastro l m r) = Pastro l (f m) r instance ProfunctorMonad Pastro where proreturn p = Pastro fst p $ \a -> (a,()) projoin (Pastro l (Pastro m n o) p) = Pastro lm n op where op a = case p a of (b, f) -> case o b of (c, g) -> (c, (f, g)) lm (d, (f, g)) = l (m (d, g), f) instance ProfunctorAdjunction Pastro Tambara where counit (Pastro g (Tambara p) f) = dimap f g p unit p = Tambara (Pastro id p id) instance Strong (Pastro p) where first' (Pastro l m r) = Pastro l' m r' where r' (a,c) = case r a of (x,z) -> (x,(z,c)) l' (y,(z,c)) = (l (y,z), c) second' (Pastro l m r) = Pastro l' m r' where r' (c,a) = case r a of (x,z) -> (x,(c,z)) l' (y,(c,z)) = (c,l (y,z)) -- | -- @ -- 'pastro' ('unpastro' f) ≡ f -- 'unpastro' ('pastro' f) ≡ f -- @ pastro :: Strong q => (p :-> q) -> Pastro p :-> q pastro f (Pastro r g l) = dimap l r (first' (f g)) -- | -- @ -- 'pastro' ('unpastro' f) ≡ f -- 'unpastro' ('pastro' f) ≡ f -- @ unpastro :: (Pastro p :-> q) -> p :-> q unpastro f p = f (Pastro fst p (\a -> (a, ()))) -------------------------------------------------------------------------------- -- * Costrength for (,) -------------------------------------------------------------------------------- -- | Analogous to 'ArrowLoop', 'loop' = 'unfirst' class Profunctor p => Costrong p where -- | Laws: -- -- @ -- 'unfirst' ≡ 'unsecond' '.' 'dimap' 'swap' 'swap' -- 'lmap' (,()) ≡ 'unfirst' '.' 'rmap' (,()) -- 'unfirst' '.' 'lmap' ('second' f) ≡ 'unfirst' '.' 'rmap' ('second' f) -- 'unfirst' '.' 'unfirst' = 'unfirst' '.' 'dimap' assoc unassoc where -- assoc ((a,b),c) = (a,(b,c)) -- unassoc (a,(b,c)) = ((a,b),c) -- @ unfirst :: p (a, d) (b, d) -> p a b unfirst = unsecond . dimap swap swap -- | Laws: -- -- @ -- 'unsecond' ≡ 'unfirst' '.' 'dimap' 'swap' 'swap' -- 'lmap' ((),) ≡ 'unsecond' '.' 'rmap' ((),) -- 'unsecond' '.' 'lmap' ('first' f) ≡ 'unsecond' '.' 'rmap' ('first' f) -- 'unsecond' '.' 'unsecond' = 'unsecond' '.' 'dimap' unassoc assoc where -- assoc ((a,b),c) = (a,(b,c)) -- unassoc (a,(b,c)) = ((a,b),c) -- @ unsecond :: p (d, a) (d, b) -> p a b unsecond = unfirst . dimap swap swap {-# MINIMAL unfirst | unsecond #-} instance Costrong (->) where unfirst f a = b where (b, d) = f (a, d) unsecond f a = b where (d, b) = f (d, a) instance Functor f => Costrong (Costar f) where unfirst (Costar f) = Costar f' where f' fa = b where (b, d) = f ((\a -> (a, d)) <$> fa) unsecond (Costar f) = Costar f' where f' fa = b where (d, b) = f ((,) d <$> fa) instance Costrong Tagged where unfirst (Tagged bd) = Tagged (fst bd) unsecond (Tagged db) = Tagged (snd db) instance ArrowLoop p => Costrong (WrappedArrow p) where unfirst (WrapArrow k) = WrapArrow (loop k) instance MonadFix m => Costrong (Kleisli m) where unfirst (Kleisli f) = Kleisli (liftM fst . mfix . f') where f' x y = f (x, snd y) instance Functor f => Costrong (Cokleisli f) where unfirst (Cokleisli f) = Cokleisli f' where f' fa = b where (b, d) = f ((\a -> (a, d)) <$> fa) instance (Functor f, Costrong p) => Costrong (Tannen f p) where unfirst (Tannen fp) = Tannen (fmap unfirst fp) unsecond (Tannen fp) = Tannen (fmap unsecond fp) instance (Costrong p, Costrong q) => Costrong (Product p q) where unfirst (Pair p q) = Pair (unfirst p) (unfirst q) unsecond (Pair p q) = Pair (unsecond p) (unsecond q) instance (Costrong p, Costrong q) => Costrong (Sum p q) where unfirst (L2 p) = L2 (unfirst p) unfirst (R2 q) = R2 (unfirst q) unsecond (L2 p) = L2 (unsecond p) unsecond (R2 q) = R2 (unsecond q) ---------------------------------------------------------------------------- -- * Cotambara ---------------------------------------------------------------------------- -- | Cotambara cofreely constructs costrength data Cotambara q a b where Cotambara :: Costrong r => (r :-> q) -> r a b -> Cotambara q a b instance Profunctor (Cotambara p) where lmap f (Cotambara n p) = Cotambara n (lmap f p) rmap g (Cotambara n p) = Cotambara n (rmap g p) dimap f g (Cotambara n p) = Cotambara n (dimap f g p) instance ProfunctorFunctor Cotambara where promap f (Cotambara n p) = Cotambara (f . n) p instance ProfunctorComonad Cotambara where proextract (Cotambara n p) = n p produplicate (Cotambara n p) = Cotambara id (Cotambara n p) instance Costrong (Cotambara p) where unfirst (Cotambara n p) = Cotambara n (unfirst p) instance Functor (Cotambara p a) where fmap = rmap -- | -- @ -- 'cotambara' '.' 'uncotambara' ≡ 'id' -- 'uncotambara' '.' 'cotambara' ≡ 'id' -- @ cotambara :: Costrong p => (p :-> q) -> p :-> Cotambara q cotambara f = Cotambara f -- | -- @ -- 'cotambara' '.' 'uncotambara' ≡ 'id' -- 'uncotambara' '.' 'cotambara' ≡ 'id' -- @ uncotambara :: Profunctor q => (p :-> Cotambara q) -> p :-> q uncotambara f p = proextract (f p) ---------------------------------------------------------------------------- -- * Copastro ---------------------------------------------------------------------------- -- | Copastro -| Cotambara -- -- Copastro freely constructs costrength newtype Copastro p a b = Copastro { runCopastro :: forall r. Costrong r => (forall x y. p x y -> r x y) -> r a b } instance Functor (Copastro p a) where fmap f (Copastro h) = Copastro $ \ n -> rmap f (h n) instance Profunctor (Copastro p) where dimap f g (Copastro h) = Copastro $ \ n -> dimap f g (h n) lmap f (Copastro h) = Copastro $ \ n -> lmap f (h n) rmap g (Copastro h) = Copastro $ \ n -> rmap g (h n) instance ProfunctorAdjunction Copastro Cotambara where unit p = Cotambara id (proreturn p) counit (Copastro h) = proextract (h id) instance ProfunctorFunctor Copastro where promap f (Copastro h) = Copastro $ \n -> h (n . f) instance ProfunctorMonad Copastro where proreturn p = Copastro $ \n -> n p projoin p = Copastro $ \c -> runCopastro p (\x -> runCopastro x c) instance Costrong (Copastro p) where unfirst (Copastro p) = Copastro $ \n -> unfirst (p n) unsecond (Copastro p) = Copastro $ \n -> unsecond (p n) profunctors-5.6.2/src/Data/Profunctor/Traversing.hs0000644000000000000000000001533707346545000020573 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE Safe #-} module Data.Profunctor.Traversing ( Traversing(..) , CofreeTraversing(..) , FreeTraversing(..) -- * Profunctor in terms of Traversing , dimapWandering , lmapWandering , rmapWandering -- * Strong in terms of Traversing , firstTraversing , secondTraversing -- * Choice in terms of Traversing , leftTraversing , rightTraversing ) where import Control.Applicative import Control.Arrow (Kleisli(..)) import Data.Bifunctor.Tannen import Data.Functor.Compose import Data.Functor.Identity import Data.Orphans () import Data.Profunctor.Choice import Data.Profunctor.Monad import Data.Profunctor.Strong import Data.Profunctor.Types import Data.Profunctor.Unsafe import Data.Traversable import Data.Tuple (swap) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid) import Data.Foldable import Prelude hiding (mapM) #endif firstTraversing :: Traversing p => p a b -> p (a, c) (b, c) firstTraversing = dimap swap swap . traverse' secondTraversing :: Traversing p => p a b -> p (c, a) (c, b) secondTraversing = traverse' swapE :: Either a b -> Either b a swapE = either Right Left -- | A definition of 'dimap' for 'Traversing' instances that define -- an explicit 'wander'. dimapWandering :: Traversing p => (a' -> a) -> (b -> b') -> p a b -> p a' b' dimapWandering f g = wander (\afb a' -> g <$> afb (f a')) -- | 'lmapWandering' may be a more efficient implementation -- of 'lmap' than the default produced from 'dimapWandering'. lmapWandering :: Traversing p => (a -> b) -> p b c -> p a c lmapWandering f = wander (\afb a' -> afb (f a')) -- | 'rmapWandering' is the same as the default produced from -- 'dimapWandering'. rmapWandering :: Traversing p => (b -> c) -> p a b -> p a c rmapWandering g = wander (\afb a' -> g <$> afb a') leftTraversing :: Traversing p => p a b -> p (Either a c) (Either b c) leftTraversing = dimap swapE swapE . traverse' rightTraversing :: Traversing p => p a b -> p (Either c a) (Either c b) rightTraversing = traverse' newtype Bazaar a b t = Bazaar { runBazaar :: forall f. Applicative f => (a -> f b) -> f t } deriving Functor instance Applicative (Bazaar a b) where pure a = Bazaar $ \_ -> pure a mf <*> ma = Bazaar $ \k -> runBazaar mf k <*> runBazaar ma k instance Profunctor (Bazaar a) where dimap f g m = Bazaar $ \k -> g <$> runBazaar m (fmap f . k) sell :: a -> Bazaar a b b sell a = Bazaar $ \k -> k a newtype Baz t b a = Baz { runBaz :: forall f. Applicative f => (a -> f b) -> f t } deriving Functor -- bsell :: a -> Baz b b a -- bsell a = Baz $ \k -> k a -- aar :: Bazaar a b t -> Baz t b a -- aar (Bazaar f) = Baz f sold :: Baz t a a -> t sold m = runIdentity (runBaz m Identity) instance Foldable (Baz t b) where foldMap = foldMapDefault instance Traversable (Baz t b) where traverse f bz = fmap (\m -> Baz (runBazaar m)) . getCompose . runBaz bz $ \x -> Compose $ sell <$> f x instance Profunctor (Baz t) where dimap f g m = Baz $ \k -> runBaz m (fmap f . k . g) -- | Note: Definitions in terms of 'wander' are much more efficient! class (Choice p, Strong p) => Traversing p where -- | Laws: -- -- @ -- 'traverse'' ≡ 'wander' 'traverse' -- 'traverse'' '.' 'rmap' f ≡ 'rmap' ('fmap' f) '.' 'traverse'' -- 'traverse'' '.' 'traverse'' ≡ 'dimap' 'Compose' 'getCompose' '.' 'traverse'' -- 'dimap' 'Identity' 'runIdentity' '.' 'traverse'' ≡ 'id' -- @ traverse' :: Traversable f => p a b -> p (f a) (f b) traverse' = wander traverse -- | This combinator is mutually defined in terms of 'traverse'' wander :: (forall f. Applicative f => (a -> f b) -> s -> f t) -> p a b -> p s t wander f pab = dimap (\s -> Baz $ \afb -> f afb s) sold (traverse' pab) {-# MINIMAL wander | traverse' #-} instance Traversing (->) where traverse' = fmap wander f ab = runIdentity #. f (Identity #. ab) instance Monoid m => Traversing (Forget m) where traverse' (Forget h) = Forget (foldMap h) wander f (Forget h) = Forget (getConst . f (Const . h)) instance Monad m => Traversing (Kleisli m) where traverse' (Kleisli m) = Kleisli (mapM m) wander f (Kleisli amb) = Kleisli $ unwrapMonad #. f (WrapMonad #. amb) instance Applicative m => Traversing (Star m) where traverse' (Star m) = Star (traverse m) wander f (Star amb) = Star (f amb) instance (Functor f, Traversing p) => Traversing (Tannen f p) where traverse' = Tannen . fmap traverse' . runTannen newtype CofreeTraversing p a b = CofreeTraversing { runCofreeTraversing :: forall f. Traversable f => p (f a) (f b) } instance Profunctor p => Profunctor (CofreeTraversing p) where lmap f (CofreeTraversing p) = CofreeTraversing (lmap (fmap f) p) rmap g (CofreeTraversing p) = CofreeTraversing (rmap (fmap g) p) dimap f g (CofreeTraversing p) = CofreeTraversing (dimap (fmap f) (fmap g) p) instance Profunctor p => Strong (CofreeTraversing p) where second' = traverse' instance Profunctor p => Choice (CofreeTraversing p) where right' = traverse' instance Profunctor p => Traversing (CofreeTraversing p) where -- !@(#*&() Compose isn't representational in its second arg or we could use #. and .# traverse' (CofreeTraversing p) = CofreeTraversing (dimap Compose getCompose p) instance ProfunctorFunctor CofreeTraversing where promap f (CofreeTraversing p) = CofreeTraversing (f p) instance ProfunctorComonad CofreeTraversing where proextract (CofreeTraversing p) = runIdentity #. p .# Identity produplicate (CofreeTraversing p) = CofreeTraversing (CofreeTraversing (dimap Compose getCompose p)) -- | @FreeTraversing -| CofreeTraversing@ data FreeTraversing p a b where FreeTraversing :: Traversable f => (f y -> b) -> p x y -> (a -> f x) -> FreeTraversing p a b instance Functor (FreeTraversing p a) where fmap f (FreeTraversing l m r) = FreeTraversing (f . l) m r instance Profunctor (FreeTraversing p) where lmap f (FreeTraversing l m r) = FreeTraversing l m (r . f) rmap g (FreeTraversing l m r) = FreeTraversing (g . l) m r dimap f g (FreeTraversing l m r) = FreeTraversing (g . l) m (r . f) g #. FreeTraversing l m r = FreeTraversing (g #. l) m r FreeTraversing l m r .# f = FreeTraversing l m (r .# f) instance Strong (FreeTraversing p) where second' = traverse' instance Choice (FreeTraversing p) where right' = traverse' instance Traversing (FreeTraversing p) where traverse' (FreeTraversing l m r) = FreeTraversing (fmap l .# getCompose) m (Compose #. fmap r) instance ProfunctorFunctor FreeTraversing where promap f (FreeTraversing l m r) = FreeTraversing l (f m) r instance ProfunctorMonad FreeTraversing where proreturn p = FreeTraversing runIdentity p Identity projoin (FreeTraversing l (FreeTraversing l' m r') r) = FreeTraversing ((l . fmap l') .# getCompose) m (Compose #. (fmap r' . r)) profunctors-5.6.2/src/Data/Profunctor/Types.hs0000644000000000000000000001757507346545000017561 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett, -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- For a good explanation of profunctors in Haskell see Dan Piponi's article: -- -- -- -- For more information on strength and costrength, see: -- -- ---------------------------------------------------------------------------- module Data.Profunctor.Types ( Profunctor(dimap, lmap, rmap) , Star(..) , Costar(..) , WrappedArrow(..) , Forget(..) , (:->) ) where import Control.Applicative hiding (WrappedArrow(..)) import Control.Arrow import Control.Category import Control.Comonad import Control.Monad (MonadPlus(..), (>=>)) import Data.Coerce (Coercible, coerce) import Data.Distributive import Data.Foldable import Data.Functor.Contravariant import Data.Profunctor.Unsafe import Data.Traversable import Prelude hiding (id,(.)) #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid (Monoid(..)) #endif #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) #endif infixr 0 :-> -- | (':->') has a polymorphic kind since @5.6@. -- (:->) :: forall k1 k2. (k1 -> k2 -> Type) -> (k1 -> k2 -> Type) -> Type type p :-> q = forall a b. p a b -> q a b ------------------------------------------------------------------------------ -- Star ------------------------------------------------------------------------------ -- | Lift a 'Functor' into a 'Profunctor' (forwards). -- -- 'Star' has a polymorphic kind since @5.6@. -- Star :: (k -> Type) -> (Type -> k -> Type) newtype Star f d c = Star { runStar :: d -> f c } instance Functor f => Profunctor (Star f) where dimap ab cd (Star bfc) = Star (fmap cd . bfc . ab) {-# INLINE dimap #-} lmap k (Star f) = Star (f . k) {-# INLINE lmap #-} rmap k (Star f) = Star (fmap k . f) {-# INLINE rmap #-} -- We cannot safely overload (#.) because we didn't write the 'Functor'. p .# _ = coerce p {-# INLINE (.#) #-} instance Functor f => Functor (Star f a) where fmap = rmap {-# INLINE fmap #-} instance Applicative f => Applicative (Star f a) where pure a = Star $ \_ -> pure a Star ff <*> Star fx = Star $ \a -> ff a <*> fx a Star ff *> Star fx = Star $ \a -> ff a *> fx a Star ff <* Star fx = Star $ \a -> ff a <* fx a instance Alternative f => Alternative (Star f a) where empty = Star $ \_ -> empty Star f <|> Star g = Star $ \a -> f a <|> g a instance Monad f => Monad (Star f a) where #if __GLASGOW_HASKELL__ < 710 return a = Star $ \_ -> return a #endif Star m >>= f = Star $ \ e -> do a <- m e runStar (f a) e instance MonadPlus f => MonadPlus (Star f a) where mzero = Star $ \_ -> mzero Star f `mplus` Star g = Star $ \a -> f a `mplus` g a instance Distributive f => Distributive (Star f a) where distribute fs = Star $ \a -> collect (($ a) .# runStar) fs instance Monad f => Category (Star f) where id = Star return Star f . Star g = Star $ g >=> f instance Contravariant f => Contravariant (Star f a) where contramap f (Star g) = Star (contramap f . g) {-# INLINE contramap #-} ------------------------------------------------------------------------------ -- Costar ------------------------------------------------------------------------------ -- | Lift a 'Functor' into a 'Profunctor' (backwards). -- -- 'Costar' has a polymorphic kind since @5.6@. -- Costar :: (k -> Type) -> k -> Type -> Type newtype Costar f d c = Costar { runCostar :: f d -> c } instance Functor f => Profunctor (Costar f) where dimap ab cd (Costar fbc) = Costar (cd . fbc . fmap ab) {-# INLINE dimap #-} lmap k (Costar f) = Costar (f . fmap k) {-# INLINE lmap #-} rmap k (Costar f) = Costar (k . f) {-# INLINE rmap #-} (#.) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b {-# INLINE (#.) #-} -- We cannot overload (.#) because we didn't write the 'Functor'. instance Distributive (Costar f d) where distribute fs = Costar $ \gd -> fmap (($ gd) .# runCostar) fs instance Functor (Costar f a) where fmap k (Costar f) = Costar (k . f) {-# INLINE fmap #-} a <$ _ = Costar $ \_ -> a {-# INLINE (<$) #-} instance Applicative (Costar f a) where pure a = Costar $ \_ -> a Costar ff <*> Costar fx = Costar $ \a -> ff a (fx a) _ *> m = m m <* _ = m instance Monad (Costar f a) where return = pure Costar m >>= f = Costar $ \ x -> runCostar (f (m x)) x ------------------------------------------------------------------------------ -- Wrapped Profunctors ------------------------------------------------------------------------------ -- | Wrap an arrow for use as a 'Profunctor'. -- -- 'WrappedArrow' has a polymorphic kind since @5.6@. -- WrappedArrow :: (k1 -> k2 -> Type) -> (k1 -> k2 -> Type) newtype WrappedArrow p a b = WrapArrow { unwrapArrow :: p a b } instance Category p => Category (WrappedArrow p) where WrapArrow f . WrapArrow g = WrapArrow (f . g) {-# INLINE (.) #-} id = WrapArrow id {-# INLINE id #-} instance Arrow p => Arrow (WrappedArrow p) where arr = WrapArrow . arr {-# INLINE arr #-} first = WrapArrow . first . unwrapArrow {-# INLINE first #-} second = WrapArrow . second . unwrapArrow {-# INLINE second #-} WrapArrow a *** WrapArrow b = WrapArrow (a *** b) {-# INLINE (***) #-} WrapArrow a &&& WrapArrow b = WrapArrow (a &&& b) {-# INLINE (&&&) #-} instance ArrowZero p => ArrowZero (WrappedArrow p) where zeroArrow = WrapArrow zeroArrow {-# INLINE zeroArrow #-} instance ArrowChoice p => ArrowChoice (WrappedArrow p) where left = WrapArrow . left . unwrapArrow {-# INLINE left #-} right = WrapArrow . right . unwrapArrow {-# INLINE right #-} WrapArrow a +++ WrapArrow b = WrapArrow (a +++ b) {-# INLINE (+++) #-} WrapArrow a ||| WrapArrow b = WrapArrow (a ||| b) {-# INLINE (|||) #-} instance ArrowApply p => ArrowApply (WrappedArrow p) where app = WrapArrow $ app . arr (first unwrapArrow) {-# INLINE app #-} instance ArrowLoop p => ArrowLoop (WrappedArrow p) where loop = WrapArrow . loop . unwrapArrow {-# INLINE loop #-} instance Arrow p => Profunctor (WrappedArrow p) where lmap = (^>>) {-# INLINE lmap #-} rmap = (^<<) {-# INLINE rmap #-} -- We cannot safely overload (#.) or (.#) because we didn't write the 'Arrow'. ------------------------------------------------------------------------------ -- Forget ------------------------------------------------------------------------------ -- | 'Forget' has a polymorphic kind since @5.6@. -- Forget :: Type -> Type -> k -> Type newtype Forget r a b = Forget { runForget :: a -> r } instance Profunctor (Forget r) where dimap f _ (Forget k) = Forget (k . f) {-# INLINE dimap #-} lmap f (Forget k) = Forget (k . f) {-# INLINE lmap #-} rmap _ (Forget k) = Forget k {-# INLINE rmap #-} instance Functor (Forget r a) where fmap _ (Forget k) = Forget k {-# INLINE fmap #-} instance Foldable (Forget r a) where foldMap _ _ = mempty {-# INLINE foldMap #-} instance Traversable (Forget r a) where traverse _ (Forget k) = pure (Forget k) {-# INLINE traverse #-} instance Contravariant (Forget r a) where contramap _ (Forget k) = Forget k {-# INLINE contramap #-} -- | Via @Semigroup r => (a -> r)@ -- -- @since 5.6.2 instance Semigroup r => Semigroup (Forget r a b) where Forget f <> Forget g = Forget (f <> g) {-# INLINE (<>) #-} -- | Via @Monoid r => (a -> r)@ -- -- @since 5.6.2 instance Monoid r => Monoid (Forget r a b) where mempty = Forget mempty {-# INLINE mempty #-} #if !(MIN_VERSION_base(4,11,0)) mappend (Forget f) (Forget g) = Forget (mappend f g) {-# INLINE mappend #-} #endif profunctors-5.6.2/src/Data/Profunctor/Unsafe.hs0000644000000000000000000002127207346545000017663 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2018 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- For a good explanation of profunctors in Haskell see Dan Piponi's article: -- -- -- -- This module includes /unsafe/ composition operators that are useful in -- practice when it comes to generating optimal core in GHC. -- -- If you import this module you are taking upon yourself the obligation -- that you will only call the operators with @#@ in their names with functions -- that are operationally identity such as @newtype@ constructors or the field -- accessor of a @newtype@. -- -- If you are ever in doubt, use 'rmap' or 'lmap'. ---------------------------------------------------------------------------- module Data.Profunctor.Unsafe ( -- * Profunctors Profunctor(..) ) where import Control.Arrow import Control.Category import Control.Comonad (Cokleisli(..)) import Control.Monad (liftM) import Data.Bifunctor.Biff (Biff(..)) import Data.Bifunctor.Clown (Clown(..)) import Data.Bifunctor.Joker (Joker(..)) import Data.Bifunctor.Product (Product(..)) import Data.Bifunctor.Sum (Sum(..)) import Data.Bifunctor.Tannen (Tannen(..)) import Data.Coerce (Coercible, coerce) #if __GLASGOW_HASKELL__ < 710 import Data.Functor #endif import Data.Functor.Contravariant (Contravariant(..)) import Data.Tagged import Prelude hiding (id,(.)) infixr 9 #. infixl 8 .# ---------------------------------------------------------------------------- -- Profunctors ---------------------------------------------------------------------------- -- | Formally, the class 'Profunctor' represents a profunctor -- from @Hask@ -> @Hask@. -- -- Intuitively it is a bifunctor where the first argument is contravariant -- and the second argument is covariant. -- -- You can define a 'Profunctor' by either defining 'dimap' or by defining both -- 'lmap' and 'rmap'. -- -- If you supply 'dimap', you should ensure that: -- -- @'dimap' 'id' 'id' ≡ 'id'@ -- -- If you supply 'lmap' and 'rmap', ensure: -- -- @ -- 'lmap' 'id' ≡ 'id' -- 'rmap' 'id' ≡ 'id' -- @ -- -- If you supply both, you should also ensure: -- -- @'dimap' f g ≡ 'lmap' f '.' 'rmap' g@ -- -- These ensure by parametricity: -- -- @ -- 'dimap' (f '.' g) (h '.' i) ≡ 'dimap' g h '.' 'dimap' f i -- 'lmap' (f '.' g) ≡ 'lmap' g '.' 'lmap' f -- 'rmap' (f '.' g) ≡ 'rmap' f '.' 'rmap' g -- @ class Profunctor p where -- | Map over both arguments at the same time. -- -- @'dimap' f g ≡ 'lmap' f '.' 'rmap' g@ dimap :: (a -> b) -> (c -> d) -> p b c -> p a d dimap f g = lmap f . rmap g {-# INLINE dimap #-} -- | Map the first argument contravariantly. -- -- @'lmap' f ≡ 'dimap' f 'id'@ lmap :: (a -> b) -> p b c -> p a c lmap f = dimap f id {-# INLINE lmap #-} -- | Map the second argument covariantly. -- -- @'rmap' ≡ 'dimap' 'id'@ rmap :: (b -> c) -> p a b -> p a c rmap = dimap id {-# INLINE rmap #-} -- | Strictly map the second argument argument -- covariantly with a function that is assumed -- operationally to be a cast, such as a newtype -- constructor. -- -- /Note:/ This operation is explicitly /unsafe/ -- since an implementation may choose to use -- 'unsafeCoerce' to implement this combinator -- and it has no way to validate that your function -- meets the requirements. -- -- If you implement this combinator with -- 'unsafeCoerce', then you are taking upon yourself -- the obligation that you don't use GADT-like -- tricks to distinguish values. -- -- If you import "Data.Profunctor.Unsafe" you are -- taking upon yourself the obligation that you -- will only call this with a first argument that is -- operationally identity. -- -- The semantics of this function with respect to bottoms -- should match the default definition: -- -- @('Profuctor.Unsafe.#.') ≡ \\_ -> \\p -> p \`seq\` 'rmap' 'coerce' p@ (#.) :: forall a b c q. Coercible c b => q b c -> p a b -> p a c (#.) = \_ -> \p -> p `seq` rmap (coerce (id :: c -> c) :: b -> c) p {-# INLINE (#.) #-} -- | Strictly map the first argument argument -- contravariantly with a function that is assumed -- operationally to be a cast, such as a newtype -- constructor. -- -- /Note:/ This operation is explicitly /unsafe/ -- since an implementation may choose to use -- 'unsafeCoerce' to implement this combinator -- and it has no way to validate that your function -- meets the requirements. -- -- If you implement this combinator with -- 'unsafeCoerce', then you are taking upon yourself -- the obligation that you don't use GADT-like -- tricks to distinguish values. -- -- If you import "Data.Profunctor.Unsafe" you are -- taking upon yourself the obligation that you -- will only call this with a second argument that is -- operationally identity. -- -- @('.#') ≡ \\p -> p \`seq\` \\f -> 'lmap' 'coerce' p@ (.#) :: forall a b c q. Coercible b a => p b c -> q a b -> p a c (.#) = \p -> p `seq` \_ -> lmap (coerce (id :: b -> b) :: a -> b) p {-# INLINE (.#) #-} {-# MINIMAL dimap | (lmap, rmap) #-} instance Profunctor (->) where dimap ab cd bc = cd . bc . ab {-# INLINE dimap #-} lmap = flip (.) {-# INLINE lmap #-} rmap = (.) {-# INLINE rmap #-} (#.) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b (.#) pbc _ = coerce pbc {-# INLINE (#.) #-} {-# INLINE (.#) #-} instance Profunctor Tagged where dimap _ f (Tagged s) = Tagged (f s) {-# INLINE dimap #-} lmap _ = retag {-# INLINE lmap #-} rmap = fmap {-# INLINE rmap #-} (#.) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b {-# INLINE (#.) #-} Tagged s .# _ = Tagged s {-# INLINE (.#) #-} instance Monad m => Profunctor (Kleisli m) where dimap f g (Kleisli h) = Kleisli (liftM g . h . f) {-# INLINE dimap #-} lmap k (Kleisli f) = Kleisli (f . k) {-# INLINE lmap #-} rmap k (Kleisli f) = Kleisli (liftM k . f) {-# INLINE rmap #-} -- We cannot safely overload (#.) because we didn't provide the 'Monad'. (.#) pbc _ = coerce pbc {-# INLINE (.#) #-} instance Functor w => Profunctor (Cokleisli w) where dimap f g (Cokleisli h) = Cokleisli (g . h . fmap f) {-# INLINE dimap #-} lmap k (Cokleisli f) = Cokleisli (f . fmap k) {-# INLINE lmap #-} rmap k (Cokleisli f) = Cokleisli (k . f) {-# INLINE rmap #-} -- We cannot safely overload (.#) because we didn't provide the 'Functor'. (#.) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b {-# INLINE (#.) #-} instance Contravariant f => Profunctor (Clown f) where lmap f (Clown fa) = Clown (contramap f fa) {-# INLINE lmap #-} rmap _ (Clown fa) = Clown fa {-# INLINE rmap #-} dimap f _ (Clown fa) = Clown (contramap f fa) {-# INLINE dimap #-} instance Functor f => Profunctor (Joker f) where lmap _ (Joker fb) = Joker fb {-# INLINE lmap #-} rmap g (Joker fb) = Joker (fmap g fb) {-# INLINE rmap #-} dimap _ g (Joker fb) = Joker (fmap g fb) {-# INLINE dimap #-} instance (Profunctor p, Functor f, Functor g) => Profunctor (Biff p f g) where lmap f (Biff p) = Biff (lmap (fmap f) p) rmap g (Biff p) = Biff (rmap (fmap g) p) dimap f g (Biff p) = Biff (dimap (fmap f) (fmap g) p) instance (Profunctor p, Profunctor q) => Profunctor (Product p q) where lmap f (Pair p q) = Pair (lmap f p) (lmap f q) {-# INLINE lmap #-} rmap g (Pair p q) = Pair (rmap g p) (rmap g q) {-# INLINE rmap #-} dimap f g (Pair p q) = Pair (dimap f g p) (dimap f g q) {-# INLINE dimap #-} (#.) f (Pair p q) = Pair (f #. p) (f #. q) {-# INLINE (#.) #-} (.#) (Pair p q) f = Pair (p .# f) (q .# f) {-# INLINE (.#) #-} instance (Profunctor p, Profunctor q) => Profunctor (Sum p q) where lmap f (L2 x) = L2 (lmap f x) lmap f (R2 y) = R2 (lmap f y) {-# INLINE lmap #-} rmap g (L2 x) = L2 (rmap g x) rmap g (R2 y) = R2 (rmap g y) {-# INLINE rmap #-} dimap f g (L2 x) = L2 (dimap f g x) dimap f g (R2 y) = R2 (dimap f g y) {-# INLINE dimap #-} f #. L2 x = L2 (f #. x) f #. R2 y = R2 (f #. y) {-# INLINE (#.) #-} L2 x .# f = L2 (x .# f) R2 y .# f = R2 (y .# f) {-# INLINE (.#) #-} instance (Functor f, Profunctor p) => Profunctor (Tannen f p) where lmap f (Tannen h) = Tannen (lmap f <$> h) {-# INLINE lmap #-} rmap g (Tannen h) = Tannen (rmap g <$> h) {-# INLINE rmap #-} dimap f g (Tannen h) = Tannen (dimap f g <$> h) {-# INLINE dimap #-} (#.) f (Tannen h) = Tannen ((f #.) <$> h) {-# INLINE (#.) #-} (.#) (Tannen h) f = Tannen ((.# f) <$> h) {-# INLINE (.#) #-} profunctors-5.6.2/src/Data/Profunctor/Yoneda.hs0000644000000000000000000001635507346545000017667 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2017 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types, TFs -- ---------------------------------------------------------------------------- module Data.Profunctor.Yoneda ( Yoneda(..), extractYoneda, duplicateYoneda , Coyoneda(..), returnCoyoneda, joinCoyoneda ) where import Control.Category import Data.Coerce (Coercible, coerce) import Data.Profunctor import Data.Profunctor.Monad import Data.Profunctor.Traversing import Data.Profunctor.Unsafe import Prelude hiding (id,(.)) -------------------------------------------------------------------------------- -- * Yoneda -------------------------------------------------------------------------------- -- | This is the cofree profunctor given a data constructor of kind @* -> * -> *@ newtype Yoneda p a b = Yoneda { runYoneda :: forall x y. (x -> a) -> (b -> y) -> p x y } -- Yoneda is a comonad on |*| -> Nat(|*|,*), we don't need the profunctor constraint to extract or duplicate -- | -- @ -- 'projoin' '.' 'extractYoneda' ≡ 'id' -- 'extractYoneda' '.' 'projoin' ≡ 'id' -- 'projoin' ≡ 'extractYoneda' -- @ extractYoneda :: Yoneda p a b -> p a b extractYoneda p = runYoneda p id id -- | -- @ -- 'projoin' '.' 'duplicateYoneda' ≡ 'id' -- 'duplicateYoneda' '.' 'projoin' ≡ 'id' -- 'duplicateYoneda' = 'proreturn' -- @ duplicateYoneda :: Yoneda p a b -> Yoneda (Yoneda p) a b duplicateYoneda p = Yoneda $ \l r -> dimap l r p instance Profunctor (Yoneda p) where dimap l r p = Yoneda $ \l' r' -> runYoneda p (l . l') (r' . r) {-# INLINE dimap #-} lmap l p = Yoneda $ \l' r -> runYoneda p (l . l') r {-# INLINE lmap #-} rmap r p = Yoneda $ \l r' -> runYoneda p l (r' . r) {-# INLINE rmap #-} (.#) p _ = coerce p {-# INLINE (.#) #-} (#.) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b {-# INLINE (#.) #-} instance Functor (Yoneda p a) where fmap f p = Yoneda $ \l r -> runYoneda p l (r . f) {-# INLINE fmap #-} instance ProfunctorFunctor Yoneda where promap f p = Yoneda $ \l r -> f (runYoneda p l r) {-# INLINE promap #-} instance ProfunctorComonad Yoneda where proextract p = runYoneda p id id {-# INLINE proextract #-} produplicate p = Yoneda $ \l r -> dimap l r p {-# INLINE produplicate #-} instance ProfunctorMonad Yoneda where proreturn p = Yoneda $ \l r -> dimap l r p {-# INLINE proreturn #-} projoin p = runYoneda p id id {-# INLINE projoin #-} instance (Category p, Profunctor p) => Category (Yoneda p) where id = Yoneda $ \l r -> dimap l r id {-# INLINE id #-} p . q = Yoneda $ \ l r -> runYoneda p id r . runYoneda q l id {-# INLINE (.) #-} instance Strong p => Strong (Yoneda p) where first' = proreturn . first' . extractYoneda {-# INLINE first' #-} second' = proreturn . second' . extractYoneda {-# INLINE second' #-} instance Choice p => Choice (Yoneda p) where left' = proreturn . left' . extractYoneda {-# INLINE left' #-} right' = proreturn . right' . extractYoneda {-# INLINE right' #-} instance Costrong p => Costrong (Yoneda p) where unfirst = proreturn . unfirst . extractYoneda {-# INLINE unfirst #-} unsecond = proreturn . unsecond . extractYoneda {-# INLINE unsecond #-} instance Cochoice p => Cochoice (Yoneda p) where unleft = proreturn . unleft . extractYoneda {-# INLINE unleft #-} unright = proreturn . unright . extractYoneda {-# INLINE unright #-} instance Closed p => Closed (Yoneda p) where closed = proreturn . closed . extractYoneda {-# INLINE closed #-} instance Mapping p => Mapping (Yoneda p) where map' = proreturn . map' . extractYoneda {-# INLINE map' #-} instance Traversing p => Traversing (Yoneda p) where traverse' = proreturn . traverse' . extractYoneda {-# INLINE traverse' #-} wander f = proreturn . wander f . extractYoneda {-# INLINE wander #-} -------------------------------------------------------------------------------- -- * Coyoneda -------------------------------------------------------------------------------- data Coyoneda p a b where Coyoneda :: (a -> x) -> (y -> b) -> p x y -> Coyoneda p a b -- Coyoneda is a Monad on |*| -> Nat(|*|,*), we don't need the profunctor constraint to extract or duplicate -- | -- @ -- 'returnCoyoneda' '.' 'proextract' ≡ 'id' -- 'proextract' '.' 'returnCoyoneda' ≡ 'id' -- 'produplicate' ≡ 'returnCoyoneda' -- @ returnCoyoneda :: p a b -> Coyoneda p a b returnCoyoneda = Coyoneda id id -- | -- @ -- 'joinCoyoneda' '.' 'produplicate' ≡ 'id' -- 'produplicate' '.' 'joinCoyoneda' ≡ 'id' -- 'joinCoyoneda' ≡ 'proextract' -- @ joinCoyoneda :: Coyoneda (Coyoneda p) a b -> Coyoneda p a b joinCoyoneda (Coyoneda l r p) = dimap l r p instance Functor (Coyoneda p a) where fmap f (Coyoneda l r' p) = Coyoneda l (f . r') p instance Profunctor (Coyoneda p) where dimap l r (Coyoneda l' r' p) = Coyoneda (l' . l) (r . r') p {-# INLINE dimap #-} lmap l (Coyoneda l' r p) = Coyoneda (l' . l) r p {-# INLINE lmap #-} rmap r (Coyoneda l r' p) = Coyoneda l (r . r') p {-# INLINE rmap #-} (.#) p _ = coerce p {-# INLINE (.#) #-} (#.) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b {-# INLINE (#.) #-} instance ProfunctorFunctor Coyoneda where promap f (Coyoneda l r p) = Coyoneda l r (f p) {-# INLINE promap #-} instance ProfunctorComonad Coyoneda where proextract (Coyoneda l r p) = dimap l r p {-# INLINE proextract #-} produplicate = Coyoneda id id {-# INLINE produplicate #-} instance ProfunctorMonad Coyoneda where proreturn = returnCoyoneda {-# INLINE proreturn #-} projoin = joinCoyoneda {-# INLINE projoin #-} instance (Category p, Profunctor p) => Category (Coyoneda p) where id = Coyoneda id id id {-# INLINE id #-} Coyoneda lp rp p . Coyoneda lq rq q = Coyoneda lq rp (p . rmap (lp . rq) q) {-# INLINE (.) #-} instance Strong p => Strong (Coyoneda p) where first' = returnCoyoneda . first' . proextract {-# INLINE first' #-} second' = returnCoyoneda . second' . proextract {-# INLINE second' #-} instance Choice p => Choice (Coyoneda p) where left' = returnCoyoneda . left' . proextract {-# INLINE left' #-} right' = returnCoyoneda . right' . proextract {-# INLINE right' #-} instance Costrong p => Costrong (Coyoneda p) where unfirst = returnCoyoneda . unfirst . proextract {-# INLINE unfirst #-} unsecond = returnCoyoneda . unsecond . proextract {-# INLINE unsecond #-} instance Cochoice p => Cochoice (Coyoneda p) where unleft = returnCoyoneda . unleft . proextract {-# INLINE unleft #-} unright = returnCoyoneda . unright . proextract {-# INLINE unright #-} instance Closed p => Closed (Coyoneda p) where closed = returnCoyoneda . closed . proextract {-# INLINE closed #-} instance Mapping p => Mapping (Coyoneda p) where map' = returnCoyoneda . map' . proextract {-# INLINE map' #-} instance Traversing p => Traversing (Coyoneda p) where traverse' = returnCoyoneda . traverse' . proextract {-# INLINE traverse' #-} wander f = returnCoyoneda . wander f . proextract {-# INLINE wander #-}