{-# LANGUAGE Rank2Types, GADTs #-}
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
-------------------------------------------------------------------------------------------
-- |
-- Copyright 	: 2008-2016 Edward Kmett
-- License	: BSD
--
-- Maintainer	: Edward Kmett <[email protected]>
-- Stability	: experimental
-- Portability	: rank 2 types
--
-- * Right Kan Extensions
-------------------------------------------------------------------------------------------
module Data.Functor.Kan.Ran
  (
    Ran(..)
  , toRan, fromRan
  , gran
  , composeRan, decomposeRan
  , adjointToRan, ranToAdjoint
  , composedAdjointToRan, ranToComposedAdjoint
  , repToRan, ranToRep
  , composedRepToRan, ranToComposedRep
  ) where

import Data.Functor.Adjunction
import Data.Functor.Composition
import Data.Functor.Identity
import Data.Functor.Rep

-- | The right Kan extension of a 'Functor' h along a 'Functor' g.
--
-- We can define a right Kan extension in several ways. The definition here is obtained by reading off
-- the definition in of a right Kan extension in terms of an End, but we can derive an equivalent definition
-- from the universal property.
--
-- Given a 'Functor' @h : C -> D@ and a 'Functor' @g : C -> C'@, we want to extend @h@ /back/ along @g@
-- to give @Ran g h : C' -> D@, such that the natural transformation @'gran' :: Ran g h (g a) -> h a@ exists.
--
-- In some sense this is trying to approximate the inverse of @g@ by using one of
-- its adjoints, because if the adjoint and the inverse both exist, they match!
--
-- > Hask -h-> Hask
-- >   |       +
-- >   g      /
-- >   |    Ran g h
-- >   v    /
-- > Hask -'
--
-- The Right Kan extension is unique (up to isomorphism) by taking this as its universal property.
--
-- That is to say given any @K : C' -> D@ such that we have a natural transformation from @k.g@ to @h@
-- @(forall x. k (g x) -> h x)@ there exists a canonical natural transformation from @k@ to @Ran g h@.
-- @(forall x. k x -> Ran g h x)@.
--
-- We could literally read this off as a valid Rank-3 definition for 'Ran':
--
-- @
-- data Ran' g h a = forall z. 'Functor' z => Ran' (forall x. z (g x) -> h x) (z a)
-- @
--
-- This definition is isomorphic the simpler Rank-2 definition we use below as witnessed by the
--
-- @
-- ranIso1 :: Ran g f x -> Ran' g f x
-- ranIso1 (Ran e) = Ran' e id
-- @
--
-- @
-- ranIso2 :: Ran' g f x -> Ran g f x
-- ranIso2 (Ran' h z) = Ran $ \\k -> h (k \<$\> z)
-- @
--
-- @
-- ranIso2 (ranIso1 (Ran e)) ≡ -- by definition
-- ranIso2 (Ran' e id) ≡       -- by definition
-- Ran $ \\k -> e (k \<$\> id)    -- by definition
-- Ran $ \\k -> e (k . id)      -- f . id = f
-- Ran $ \\k -> e k             -- eta reduction
-- Ran e
-- @
--
-- The other direction is left as an exercise for the reader.
newtype Ran g h a = Ran { forall {k} (g :: k -> *) (h :: k -> *) a.
Ran g h a -> forall (b :: k). (a -> g b) -> h b
runRan :: forall b. (a -> g b) -> h b }

instance Functor (Ran g h) where
  fmap :: forall a b. (a -> b) -> Ran g h a -> Ran g h b
fmap a -> b
f Ran g h a
m = forall {k} (g :: k -> *) (h :: k -> *) a.
(forall (b :: k). (a -> g b) -> h b) -> Ran g h a
Ran (\b -> g b
k -> forall {k} (g :: k -> *) (h :: k -> *) a.
Ran g h a -> forall (b :: k). (a -> g b) -> h b
runRan Ran g h a
m (b -> g b
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))
  {-# INLINE fmap #-}

-- | The universal property of a right Kan extension.
toRan :: Functor k => (forall a. k (g a) -> h a) -> k b -> Ran g h b
toRan :: forall {k} (k :: * -> *) (g :: k -> *) (h :: k -> *) b.
Functor k =>
(forall (a :: k). k (g a) -> h a) -> k b -> Ran g h b
toRan forall (a :: k). k (g a) -> h a
s k b
t = forall {k} (g :: k -> *) (h :: k -> *) a.
(forall (b :: k). (a -> g b) -> h b) -> Ran g h a
Ran (forall (a :: k). k (g a) -> h a
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap k b
t)
{-# INLINE toRan #-}

-- | 'toRan' and 'fromRan' witness a higher kinded adjunction. from @(`'Compose'` g)@ to @'Ran' g@
--
-- @
-- 'toRan' . 'fromRan' ≡ 'id'
-- 'fromRan' . 'toRan' ≡ 'id'
-- @
fromRan :: (forall a. k a -> Ran g h a) -> k (g b) -> h b
fromRan :: forall {k} (k :: * -> *) (g :: k -> *) (h :: k -> *) (b :: k).
(forall a. k a -> Ran g h a) -> k (g b) -> h b
fromRan forall a. k a -> Ran g h a
s k (g b)
kgb = forall {k} (g :: k -> *) (h :: k -> *) a.
Ran g h a -> forall (b :: k). (a -> g b) -> h b
runRan (forall a. k a -> Ran g h a
s k (g b)
kgb) forall a. a -> a
id
{-# INLINE fromRan #-}

-- |
-- @
-- 'composeRan' . 'decomposeRan' ≡ 'id'
-- 'decomposeRan' . 'composeRan' ≡ 'id'
-- @
composeRan :: Composition compose => Ran f (Ran g h) a -> Ran (compose f g) h a
composeRan :: forall (compose :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *)
       (g :: * -> *) (h :: * -> *) a.
Composition compose =>
Ran f (Ran g h) a -> Ran (compose f g) h a
composeRan Ran f (Ran g h) a
r = forall {k} (g :: k -> *) (h :: k -> *) a.
(forall (b :: k). (a -> g b) -> h b) -> Ran g h a
Ran (\a -> compose f g b
f -> forall {k} (g :: k -> *) (h :: k -> *) a.
Ran g h a -> forall (b :: k). (a -> g b) -> h b
runRan (forall {k} (g :: k -> *) (h :: k -> *) a.
Ran g h a -> forall (b :: k). (a -> g b) -> h b
runRan Ran f (Ran g h) a
r (forall (o :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *)
       (g :: * -> *) x.
Composition o =>
o f g x -> f (g x)
decompose forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> compose f g b
f)) forall a. a -> a
id)
{-# INLINE composeRan #-}

decomposeRan :: (Composition compose, Functor f) => Ran (compose f g) h a -> Ran f (Ran g h) a
decomposeRan :: forall (compose :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *)
       (g :: * -> *) (h :: * -> *) a.
(Composition compose, Functor f) =>
Ran (compose f g) h a -> Ran f (Ran g h) a
decomposeRan Ran (compose f g) h a
r = forall {k} (g :: k -> *) (h :: k -> *) a.
(forall (b :: k). (a -> g b) -> h b) -> Ran g h a
Ran (\a -> f b
f -> forall {k} (g :: k -> *) (h :: k -> *) a.
(forall (b :: k). (a -> g b) -> h b) -> Ran g h a
Ran (\b -> g b
g -> forall {k} (g :: k -> *) (h :: k -> *) a.
Ran g h a -> forall (b :: k). (a -> g b) -> h b
runRan Ran (compose f g) h a
r (forall (o :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *)
       (g :: * -> *) x.
Composition o =>
f (g x) -> o f g x
compose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> g b
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f)))
{-# INLINE decomposeRan #-}

-- |
--
-- @
-- 'adjointToRan' . 'ranToAdjoint' ≡ 'id'
-- 'ranToAdjoint' . 'adjointToRan' ≡ 'id'
-- @
adjointToRan :: Adjunction f g => f a -> Ran g Identity a
adjointToRan :: forall (f :: * -> *) (g :: * -> *) a.
Adjunction f g =>
f a -> Ran g Identity a
adjointToRan f a
f = forall {k} (g :: k -> *) (h :: k -> *) a.
(forall (b :: k). (a -> g b) -> h b) -> Ran g h a
Ran (\a -> g b
a -> forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (u :: * -> *) a b.
Adjunction f u =>
(a -> u b) -> f a -> b
rightAdjunct a -> g b
a f a
f)
{-# INLINE adjointToRan #-}

ranToAdjoint :: Adjunction f g => Ran g Identity a -> f a
ranToAdjoint :: forall (f :: * -> *) (g :: * -> *) a.
Adjunction f g =>
Ran g Identity a -> f a
ranToAdjoint Ran g Identity a
r = forall a. Identity a -> a
runIdentity (forall {k} (g :: k -> *) (h :: k -> *) a.
Ran g h a -> forall (b :: k). (a -> g b) -> h b
runRan Ran g Identity a
r forall (f :: * -> *) (u :: * -> *) a.
Adjunction f u =>
a -> u (f a)
unit)
{-# INLINE ranToAdjoint #-}

-- |
--
-- @
-- 'composedAdjointToRan' . 'ranToComposedAdjoint' ≡ 'id'
-- 'ranToComposedAdjoint' . 'composedAdjointToRan' ≡ 'id'
-- @
ranToComposedAdjoint :: Adjunction f g => Ran g h a -> h (f a)
ranToComposedAdjoint :: forall (f :: * -> *) (g :: * -> *) (h :: * -> *) a.
Adjunction f g =>
Ran g h a -> h (f a)
ranToComposedAdjoint Ran g h a
r = forall {k} (g :: k -> *) (h :: k -> *) a.
Ran g h a -> forall (b :: k). (a -> g b) -> h b
runRan Ran g h a
r forall (f :: * -> *) (u :: * -> *) a.
Adjunction f u =>
a -> u (f a)
unit
{-# INLINE ranToComposedAdjoint #-}

composedAdjointToRan :: (Adjunction f g, Functor h) => h (f a) -> Ran g h a
composedAdjointToRan :: forall (f :: * -> *) (g :: * -> *) (h :: * -> *) a.
(Adjunction f g, Functor h) =>
h (f a) -> Ran g h a
composedAdjointToRan h (f a)
f = forall {k} (g :: k -> *) (h :: k -> *) a.
(forall (b :: k). (a -> g b) -> h b) -> Ran g h a
Ran (\a -> g b
a -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) (u :: * -> *) a b.
Adjunction f u =>
(a -> u b) -> f a -> b
rightAdjunct a -> g b
a) h (f a)
f)
{-# INLINE composedAdjointToRan #-}

-- | This is the natural transformation that defines a Right Kan extension.
gran :: Ran g h (g a) -> h a
gran :: forall {k} (g :: k -> *) (h :: k -> *) (a :: k).
Ran g h (g a) -> h a
gran (Ran forall (b :: k). (g a -> g b) -> h b
f) = forall (b :: k). (g a -> g b) -> h b
f forall a. a -> a
id
{-# INLINE gran #-}

repToRan :: Representable u => Rep u -> a -> Ran u Identity a
repToRan :: forall (u :: * -> *) a.
Representable u =>
Rep u -> a -> Ran u Identity a
repToRan Rep u
e a
a = forall {k} (g :: k -> *) (h :: k -> *) a.
(forall (b :: k). (a -> g b) -> h b) -> Ran g h a
Ran forall a b. (a -> b) -> a -> b
$ \a -> u b
k -> forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index (a -> u b
k a
a) Rep u
e
{-# INLINE repToRan #-}

ranToRep :: Representable u => Ran u Identity a -> (Rep u, a)
ranToRep :: forall (u :: * -> *) a.
Representable u =>
Ran u Identity a -> (Rep u, a)
ranToRep (Ran forall b. (a -> u b) -> Identity b
f) = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall b. (a -> u b) -> Identity b
f (\a
a -> forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate forall a b. (a -> b) -> a -> b
$ \Rep u
e -> (Rep u
e, a
a))
{-# INLINE ranToRep #-}

ranToComposedRep :: Representable u => Ran u h a -> h (Rep u, a)
ranToComposedRep :: forall (u :: * -> *) (h :: * -> *) a.
Representable u =>
Ran u h a -> h (Rep u, a)
ranToComposedRep (Ran forall b. (a -> u b) -> h b
f) = forall b. (a -> u b) -> h b
f (\a
a -> forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate forall a b. (a -> b) -> a -> b
$ \Rep u
e -> (Rep u
e, a
a))
{-# INLINE ranToComposedRep #-}

composedRepToRan :: (Representable u, Functor h) => h (Rep u, a) -> Ran u h a
composedRepToRan :: forall (u :: * -> *) (h :: * -> *) a.
(Representable u, Functor h) =>
h (Rep u, a) -> Ran u h a
composedRepToRan h (Rep u, a)
hfa = forall {k} (g :: k -> *) (h :: k -> *) a.
(forall (b :: k). (a -> g b) -> h b) -> Ran g h a
Ran forall a b. (a -> b) -> a -> b
$ \a -> u b
k -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Rep u
e, a
a) -> forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index (a -> u b
k a
a) Rep u
e) h (Rep u, a)
hfa
{-# INLINE composedRepToRan #-}