Yoneda.hs

{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Trustworthy #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Functor.Yoneda
-- Copyright   :  (C) 2011-2016 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  MPTCs, fundeps
--
-- The covariant form of the Yoneda lemma states that @f@ is naturally
-- isomorphic to @Yoneda f@.
--
-- This is described in a rather intuitive fashion by Dan Piponi in
--
-- <http://blog.sigfpe.com/2006/11/yoneda-lemma.html>
----------------------------------------------------------------------------

module Data.Functor.Yoneda
  ( Yoneda(..)
  , liftYoneda, lowerYoneda
  , maxF, minF, maxM, minM
  -- * as a right Kan extension
  , yonedaToRan, ranToYoneda
  ) where

import Control.Applicative
import Control.Monad (MonadPlus(..), liftM)
import Control.Monad.Fix
import Control.Monad.Free.Class
import Control.Monad.Trans.Class
import Control.Comonad
import Control.Comonad.Trans.Class
import Data.Distributive
import Data.Foldable
import Data.Functor.Adjunction
import Data.Functor.Bind
import Data.Functor.Classes
import Data.Functor.Extend
import Data.Functor.Identity
import Data.Functor.Kan.Ran
import Data.Functor.Plus
import Data.Functor.Rep
import Data.Semigroup.Foldable
import Data.Semigroup.Traversable
import Data.Traversable
import Text.Read hiding (lift)
import Prelude hiding (sequence, lookup, zipWith)

-- | @Yoneda f a@ can be viewed as the partial application of 'fmap' to its second argument.
newtype Yoneda f a = Yoneda { runYoneda :: forall b. (a -> b) -> f b }

-- | The natural isomorphism between @f@ and @'Yoneda' f@ given by the Yoneda lemma
-- is witnessed by 'liftYoneda' and 'lowerYoneda'
--
-- @
-- 'liftYoneda' . 'lowerYoneda' ≡ 'id'
-- 'lowerYoneda' . 'liftYoneda' ≡ 'id'
-- @
--
-- @
-- lowerYoneda (liftYoneda fa) =         -- definition
-- lowerYoneda (Yoneda (\f -> fmap f a)) -- definition
-- (\f -> fmap f fa) id                  -- beta reduction
-- fmap id fa                            -- functor law
-- fa
-- @
--
-- @
-- 'lift' = 'liftYoneda'
-- @
liftYoneda :: Functor f => f a -> Yoneda f a
liftYoneda a = Yoneda (\f -> fmap f a)
{-# INLINE liftYoneda #-}

lowerYoneda :: Yoneda f a -> f a
lowerYoneda (Yoneda f) = f id
{-# INLINE lowerYoneda #-}

-- TODO: coerce
-- {-# RULES "lower/lift=id" liftYoneda . lowerYoneda = id #-}
-- {-# RULES "lift/lower=id" lowerYoneda . liftYoneda = id #-}

-- | @Yoneda f@ can be viewed as the right Kan extension of @f@ along the 'Identity' functor.
--
-- @
-- 'yonedaToRan' . 'ranToYoneda' ≡ 'id'
-- 'ranToYoneda' . 'yonedaToRan' ≡ 'id'
-- @
yonedaToRan :: Yoneda f a -> Ran Identity f a
yonedaToRan (Yoneda m) = Ran (m . fmap runIdentity)
{-# INLINE yonedaToRan #-}

ranToYoneda :: Ran Identity f a -> Yoneda f a
ranToYoneda (Ran m) = Yoneda (m . fmap Identity)
{-# INLINE ranToYoneda #-}

-- {-# RULES "yonedaToRan/ranToYoneda=id" yonedaToRan . ranToYoneda = id #-}
-- {-# RULES "ranToYoneda/yonedaToRan=id" ranToYoneda . yonedaToRan = id #-}

instance Functor (Yoneda f) where
  fmap f m = Yoneda (\k -> runYoneda m (k . f))
  {-# INLINE fmap #-}

instance Apply f => Apply (Yoneda f) where
  Yoneda m <.> Yoneda n = Yoneda (\f -> m (f .) <.> n id)
  {-# INLINE (<.>) #-}
  Yoneda m .> Yoneda n = Yoneda (\f -> m id .> n f)
  {-# INLINE (.>) #-}

instance Applicative f => Applicative (Yoneda f) where
  pure a = Yoneda (\f -> pure (f a))
  {-# INLINE pure #-}
  Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id)
  {-# INLINE (<*>) #-}
  Yoneda m *> Yoneda n = Yoneda (\f -> m id *> n f)
  {-# INLINE (*>) #-}

instance Foldable f => Foldable (Yoneda f) where
  foldMap f = foldMap f . lowerYoneda
  {-# INLINE foldMap #-}

instance Foldable1 f => Foldable1 (Yoneda f) where
  foldMap1 f = foldMap1 f . lowerYoneda
  {-# INLINE foldMap1 #-}

instance Traversable f => Traversable (Yoneda f) where
  traverse f = fmap liftYoneda . traverse f . lowerYoneda
  {-# INLINE traverse #-}

instance Traversable1 f => Traversable1 (Yoneda f) where
  traverse1 f = fmap liftYoneda . traverse1 f . lowerYoneda
  {-# INLINE traverse1 #-}

instance Distributive f => Distributive (Yoneda f) where
  collect f = liftYoneda . collect (lowerYoneda . f)
  {-# INLINE collect #-}

instance Representable g => Representable (Yoneda g) where
  type Rep (Yoneda g) = Rep g
  tabulate = liftYoneda . tabulate
  {-# INLINE tabulate #-}
  index = index . lowerYoneda
  {-# INLINE index #-}

instance Adjunction f g => Adjunction (Yoneda f) (Yoneda g) where
  unit = liftYoneda . fmap liftYoneda . unit
  {-# INLINE unit #-}
  counit (Yoneda m) = counit (m lowerYoneda)
  {-# INLINE counit #-}

instance Show1 f => Show1 (Yoneda f) where
  liftShowsPrec sp sl d (Yoneda f) =
    showsUnaryWith (liftShowsPrec sp sl) "liftYoneda" d (f id)

instance (Read1 f, Functor f) => Read1 (Yoneda f) where
  liftReadsPrec rp rl = readsData $
    readsUnaryWith (liftReadsPrec rp rl) "liftYoneda" liftYoneda

instance Show (f a) => Show (Yoneda f a) where
  showsPrec d (Yoneda f) = showParen (d > 10) $
    showString "liftYoneda " . showsPrec 11 (f id)

instance (Functor f, Read (f a)) => Read (Yoneda f a) where
  readPrec = parens $ prec 10 $ do
     Ident "liftYoneda" <- lexP
     liftYoneda <$> step readPrec

infixl 0 `on1`
on1 :: (g a -> g b -> c) -> (forall x. f x -> g x) -> f a -> f b -> c
(.*.) `on1` f = \x y -> f x .*. f y

instance Eq1 f => Eq1 (Yoneda f) where
  liftEq eq = liftEq eq `on1` lowerYoneda
  {-# INLINE liftEq #-}

instance Ord1 f => Ord1 (Yoneda f) where
  liftCompare cmp = liftCompare cmp `on1` lowerYoneda
  {-# INLINE liftCompare #-}

instance (Eq1 f, Eq a) => Eq (Yoneda f a) where
  (==) = eq1
  {-# INLINE (==) #-}

instance (Ord1 f, Ord a) => Ord (Yoneda f a) where
  compare = compare1
  {-# INLINE compare #-}

maxF :: (Functor f, Ord (f a)) => Yoneda f a -> Yoneda f a -> Yoneda f a
Yoneda f `maxF` Yoneda g = liftYoneda $ f id `max` g id
-- {-# RULES "max/maxF" max = maxF #-}
{-# INLINE maxF #-}

minF :: (Functor f, Ord (f a)) => Yoneda f a -> Yoneda f a -> Yoneda f a
Yoneda f `minF` Yoneda g = liftYoneda $ f id `max` g id
-- {-# RULES "min/minF" min = minF #-}
{-# INLINE minF #-}

maxM :: (Monad m, Ord (m a)) => Yoneda m a -> Yoneda m a -> Yoneda m a
Yoneda f `maxM` Yoneda g = lift $ f id `max` g id
-- {-# RULES "max/maxM" max = maxM #-}
{-# INLINE maxM #-}

minM :: (Monad m, Ord (m a)) => Yoneda m a -> Yoneda m a -> Yoneda m a
Yoneda f `minM` Yoneda g = lift $ f id `min` g id
-- {-# RULES "min/minM" min = minM #-}
{-# INLINE minM #-}

instance Alt f => Alt (Yoneda f) where
  Yoneda f <!> Yoneda g = Yoneda (\k -> f k <!> g k)
  {-# INLINE (<!>) #-}

instance Plus f => Plus (Yoneda f) where
  zero = Yoneda $ const zero
  {-# INLINE zero #-}

instance Alternative f => Alternative (Yoneda f) where
  empty = Yoneda $ const empty
  {-# INLINE empty #-}
  Yoneda f <|> Yoneda g = Yoneda (\k -> f k <|> g k)
  {-# INLINE (<|>) #-}

instance Bind m => Bind (Yoneda m) where
  Yoneda m >>- k = Yoneda (\f -> m id >>- \a -> runYoneda (k a) f)
  {-# INLINE (>>-) #-}

instance Monad m => Monad (Yoneda m) where
  Yoneda m >>= k = Yoneda (\f -> m id >>= \a -> runYoneda (k a) f)
  {-# INLINE (>>=) #-}

instance MonadFix m => MonadFix (Yoneda m) where
  mfix f = lift $ mfix (lowerYoneda . f)
  {-# INLINE mfix #-}

instance MonadPlus m => MonadPlus (Yoneda m) where
  mzero = Yoneda (const mzero)
  {-# INLINE mzero #-}
  Yoneda f `mplus` Yoneda g = Yoneda (\k -> f k `mplus` g k)
  {-# INLINE mplus #-}

instance MonadTrans Yoneda where
  lift a = Yoneda (\f -> liftM f a)
  {-# INLINE lift #-}

instance (Functor f, MonadFree f m) => MonadFree f (Yoneda m) where
  wrap = lift . wrap . fmap lowerYoneda
  {-# INLINE wrap #-}

instance Extend w => Extend (Yoneda w) where
  extended k (Yoneda m) = Yoneda (\f -> extended (f . k . liftYoneda) (m id))
  {-# INLINE extended #-}

instance Comonad w => Comonad (Yoneda w) where
  extend k (Yoneda m) = Yoneda (\f -> extend (f . k . liftYoneda) (m id))
  {-# INLINE extend #-}
  extract = extract . lowerYoneda
  {-# INLINE extract #-}

instance ComonadTrans Yoneda where
  lower = lowerYoneda
  {-# INLINE lower #-}