Lift.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2014 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  Rank2Types, TFs
--
----------------------------------------------------------------------------
module Data.Profunctor.Lift
  ( Lift(..)
  , decomposeLift
  ) where

import Control.Category
import Data.Profunctor.Unsafe
import Data.Profunctor.Composition
import Prelude hiding (id,(.))

-- | This represents the left 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 Lift p q a b = Lift { runLift :: forall x. p b x -> q a x }


instance (Profunctor p, Profunctor q) => Profunctor (Lift p q) where
  dimap ca bd f = Lift (lmap ca . runLift f . lmap bd)
  {-# INLINE dimap #-}
  lmap ca f = Lift (lmap ca . runLift f)
  {-# INLINE lmap #-}
  rmap bd f = Lift (runLift f . lmap bd)
  {-# INLINE rmap #-}
  bd #. f = Lift (\p -> runLift f (p .# bd))
  {-# INLINE ( #. ) #-}
  f .# ca = Lift (\p -> runLift f p .# ca)
  {-# INLINE (.#) #-}

instance Profunctor p => Functor (Lift p q a) where
  fmap bd f = Lift (runLift f . lmap bd)
  {-# INLINE fmap #-}

-- | @'Lift' p p@ forms a 'Monad' in the 'Profunctor' 2-category, which is isomorphic to a Haskell 'Category' instance.
instance p ~ q => Category (Lift p q) where
  id = Lift id
  {-# INLINE id #-}
  Lift f . Lift g = Lift (g . f)
  {-# INLINE (.) #-}

-- | The 2-morphism that defines a left Kan lift.
--
-- Note: When @p@ is right adjoint to @'Lift' p (->)@ then 'decomposeLift' is the 'counit' of the adjunction.
decomposeLift :: Procompose (Lift p q) p a b -> q a b
decomposeLift (Procompose (Lift pq) p) = pq p
{-# INLINE decomposeLift #-}