{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2013 Edward Kmett and Dan Doel -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional -- Portability : Rank2Types, TFs -- ---------------------------------------------------------------------------- module Data.Profunctor.Rift ( Rift(..) , decomposeRift , precomposeRift ) where import Control.Category import Data.Profunctor.Unsafe import Data.Profunctor.Composition import Prelude hiding (id,(.)) -- | 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. newtype Rift p q a b = Rift { runRift :: forall x. p x a -> q x b } -- Ran f g a = forall b. (a -> f b) -> g b instance (Profunctor p, Profunctor q) => Profunctor (Rift p q) where dimap ca bd f = Rift (rmap bd . runRift f . rmap ca) {-# INLINE dimap #-} lmap ca f = Rift (runRift f . rmap ca) {-# INLINE lmap #-} rmap bd f = Rift (rmap bd . runRift f) {-# INLINE rmap #-} bd #. f = Rift (\p -> bd #. runRift f p) {-# INLINE ( #. ) #-} f .# ca = Rift (\p -> runRift f (ca #. p)) {-# INLINE (.#) #-} instance Profunctor q => Functor (Rift p q a) where fmap bd f = Rift (rmap bd . runRift f) {-# 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 (f . g) {-# INLINE (.) #-} -- | The 2-morphism that defines a right Kan lift. -- -- Note: When @q@ is left adjoint to @'Rift' q (->)@ then 'decomposeRift' is the 'counit' of the adjunction. decomposeRift :: Procompose q (Rift q p) a b -> p a b decomposeRift (Procompose q (Rift qp)) = qp q {-# INLINE decomposeRift #-} precomposeRift :: Profunctor q => Procompose (Rift p (->)) q a b -> Rift p q a b precomposeRift (Procompose pf p) = Rift (\pxa -> runRift pf pxa `lmap` p) {-# INLINE precomposeRift #-}