content: {-# LANGUAGE GADTs #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE Trustworthy #-}
  
  -----------------------------------------------------------------------------
  -- |
  -- Copyright   :  (C) 2011-2016 Edward Kmett
  -- License     :  BSD-style (see the file LICENSE)
  --
  -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
  -- Stability   :  provisional
  -- Portability :  GADTs, MPTCs, fundeps
  --
  -- @'Coyoneda' f@ is the "free functor" over @f@.
  -- The co-Yoneda lemma for a covariant 'Functor' @f@ states that @'Coyoneda' f@
  -- is naturally isomorphic to @f@.
  ----------------------------------------------------------------------------
  module Data.Functor.Coyoneda
    ( Coyoneda(..)
    , liftCoyoneda, lowerCoyoneda, lowerM, hoistCoyoneda
    -- * as a Left Kan extension
    , coyonedaToLan, lanToCoyoneda
    ) where
  
  import Control.Applicative as A
  import Control.Monad (MonadPlus(..), liftM)
  import Control.Monad.Fix
  import Control.Monad.Trans.Class
  import Control.Comonad
  import Control.Comonad.Trans.Class
  import Data.Distributive
  import Data.Functor.Adjunction
  import Data.Functor.Bind
  import Data.Functor.Classes
  import Data.Functor.Extend
  import Data.Functor.Identity
  import Data.Functor.Kan.Lan
  import Data.Functor.Plus
  import Data.Functor.Rep
  import Data.Foldable
  import Data.Traversable
  import Data.Semigroup.Foldable
  import Data.Semigroup.Traversable
  import Prelude hiding (sequence, lookup, zipWith)
  import Text.Read hiding (lift)
  
  -- | A covariant 'Functor' suitable for Yoneda reduction
  --
  data Coyoneda f a where
    Coyoneda :: (b -> a) -> f b -> Coyoneda f a
  
  -- | @Coyoneda f@ is the left Kan extension of @f@ along the 'Identity' functor.
  --
  -- @Coyoneda f@ is always a functor, even if @f@ is not. In this case, it
  -- is called the /free functor over @f@/. Note the following categorical fine
  -- print: If @f@ is not a functor, @Coyoneda f@ is actually not the left Kan
  -- extension of @f@ along the 'Identity' functor, but along the inclusion
  -- functor from the discrete subcategory of /Hask/ which contains only identity
  -- functions as morphisms to the full category /Hask/. (This is because @f@,
  -- not being a proper functor, can only be interpreted as a categorical functor
  -- by restricting the source category to only contain identities.)
  --
  -- @
  -- 'coyonedaToLan' . 'lanToCoyoneda' ≡ 'id'
  -- 'lanToCoyoneda' . 'coyonedaToLan' ≡ 'id'
  -- @
  coyonedaToLan :: Coyoneda f a -> Lan Identity f a
  coyonedaToLan (Coyoneda ba fb) = Lan (ba . runIdentity) fb
  {-# INLINE coyonedaToLan #-}
  
  lanToCoyoneda :: Lan Identity f a -> Coyoneda f a
  lanToCoyoneda (Lan iba fb) = Coyoneda (iba . Identity) fb
  {-# INLINE lanToCoyoneda #-}
  
  -- {-# RULES "coyonedaToLan/lanToCoyoneda=id" coyonedaToLan . lanToCoyoneda = id #-}
  -- {-# RULES "lanToCoyoneda/coyonedaToLan=id" lanToCoyoneda . coyonedaToLan = id #-}
  
  instance Functor (Coyoneda f) where
    fmap f (Coyoneda g v) = Coyoneda (f . g) v
    {-# INLINE fmap #-}
  
  instance Apply f => Apply (Coyoneda f) where
    Coyoneda mf m <.> Coyoneda nf n =
      liftCoyoneda $ (\mres nres -> mf mres (nf nres)) <$> m <.> n
    {-# INLINE (<.>) #-}
    Coyoneda _ m .> Coyoneda g n = Coyoneda g (m .> n)
    {-# INLINE (.>) #-}
    Coyoneda f m <. Coyoneda _ n = Coyoneda f (m <. n)
    {-# INLINE (<.) #-}
  
  instance Applicative f => Applicative (Coyoneda f) where
    pure = liftCoyoneda . pure
    {-# INLINE pure #-}
    Coyoneda mf m <*> Coyoneda nf n =
      liftCoyoneda $ (\mres nres -> mf mres (nf nres)) <$> m <*> n
    {-# INLINE (<*>) #-}
    Coyoneda _ m *> Coyoneda g n = Coyoneda g (m *> n)
    {-# INLINE (*>) #-}
    Coyoneda f m <* Coyoneda _ n = Coyoneda f (m <* n)
    {-# INLINE (<*) #-}
  
  instance Alternative f => Alternative (Coyoneda f) where
    empty = liftCoyoneda empty
    {-# INLINE empty #-}
    m <|> n = liftCoyoneda $ lowerCoyoneda m <|> lowerCoyoneda n
    {-# INLINE (<|>) #-}
    some = liftCoyoneda . A.some . lowerCoyoneda
    {-# INLINE some #-}
    many = liftCoyoneda . A.many . lowerCoyoneda
    {-# INLINE many #-}
  
  {-
  -- These are slightly optimized versions of the *default*
  -- `some` and `many` definitions for `Coyoneda`. I don't
  -- know if it's worth the clutter to expose them.
  someDefault (Coyoneda vf vb) = liftCoyoneda some_v
    where
      many_v = some_v <|> pure []
      some_v = (:) . vf <$> vb <*> many_v
  {-# INLINE someDefault #-}
  
  manyDefault (Coyoneda vf vb) = liftCoyoneda many_v
    where
      many_v = some_v <|> pure []
      some_v = (:) . vf <$> vb <*> many_v
  {-# INLINE many #-}
  -}
  
  instance Alt f => Alt (Coyoneda f) where
    m <!> n = liftCoyoneda $ lowerCoyoneda m <!> lowerCoyoneda n
    {-# INLINE (<!>) #-}
  
  instance Plus f => Plus (Coyoneda f) where
    zero = liftCoyoneda zero
    {-# INLINE zero #-}
  
  instance Bind m => Bind (Coyoneda m) where
    Coyoneda f v >>- k = liftCoyoneda (v >>- lowerCoyoneda . k . f)
    {-# INLINE (>>-) #-}
  
  instance Monad m => Monad (Coyoneda m) where
    (>>) = (*>)
    {-# INLINE (>>) #-}
  
    Coyoneda f v >>= k = lift (v >>= lowerM . k . f)
    {-# INLINE (>>=) #-}
  
  instance MonadTrans Coyoneda where
    lift = Coyoneda id
    {-# INLINE lift #-}
  
  instance MonadFix f => MonadFix (Coyoneda f) where
    mfix f = lift $ mfix (lowerM . f)
    {-# INLINE mfix #-}
  
  instance MonadPlus f => MonadPlus (Coyoneda f) where
    mzero = lift mzero
    {-# INLINE mzero #-}
    m `mplus` n = lift $ lowerM m `mplus` lowerM n
    {-# INLINE mplus #-}
  
  instance Representable f => Representable (Coyoneda f) where
    type Rep (Coyoneda f) = Rep f
    tabulate = liftCoyoneda . tabulate
    {-# INLINE tabulate #-}
    index = index . lowerCoyoneda
    {-# INLINE index #-}
  
  instance Extend w => Extend (Coyoneda w) where
    extended k (Coyoneda f v) = Coyoneda id $ extended (k . Coyoneda f) v
    {-# INLINE extended #-}
  
  instance Comonad w => Comonad (Coyoneda w) where
    extend k (Coyoneda f v) = Coyoneda id $ extend (k . Coyoneda f) v
    {-# INLINE extend #-}
    extract (Coyoneda f v) = f (extract v)
    {-# INLINE extract #-}
  
  instance ComonadTrans Coyoneda where
    lower (Coyoneda f a) = fmap f a
    {-# INLINE lower #-}
  
  instance Foldable f => Foldable (Coyoneda f) where
    foldMap f (Coyoneda k a) = foldMap (f . k) a
    {-# INLINE foldMap #-}
  
  instance Foldable1 f => Foldable1 (Coyoneda f) where
    foldMap1 f (Coyoneda k a) = foldMap1 (f . k) a
    {-# INLINE foldMap1 #-}
  
  instance Traversable f => Traversable (Coyoneda f) where
    traverse f (Coyoneda k a) = Coyoneda id <$> traverse (f . k) a
    {-# INLINE traverse #-}
  
  instance Traversable1 f => Traversable1 (Coyoneda f) where
    traverse1 f (Coyoneda k a) = Coyoneda id <$> traverse1 (f . k) a
    {-# INLINE traverse1 #-}
  
  instance Distributive f => Distributive (Coyoneda f) where
    collect f = liftCoyoneda . collect (lowerCoyoneda . f)
    {-# INLINE collect #-}
  
  instance (Functor f, Show1 f) => Show1 (Coyoneda f) where
    liftShowsPrec sp sl d (Coyoneda f a) =
      showsUnaryWith (liftShowsPrec sp sl) "liftCoyoneda" d (fmap f a)
    {-# INLINE liftShowsPrec #-}
  
  instance (Read1 f) => Read1 (Coyoneda f) where
    liftReadsPrec rp rl = readsData $
      readsUnaryWith (liftReadsPrec rp rl) "liftCoyoneda" liftCoyoneda
    {-# INLINE liftReadsPrec #-}
  
  instance (Functor f, Show1 f, Show a) => Show (Coyoneda f a) where
    showsPrec = showsPrec1
    {-# INLINE showsPrec #-}
  
  instance Read (f a) => Read (Coyoneda f a) where
    readPrec = parens $ prec 10 $ do
      Ident "liftCoyoneda" <- lexP
      liftCoyoneda <$> step readPrec
    {-# INLINE readPrec #-}
  
  instance Eq1 f => Eq1 (Coyoneda f) where
    liftEq eq (Coyoneda f xs) (Coyoneda g ys) =
      liftEq (\x y -> eq (f x) (g y)) xs ys
    {-# INLINE liftEq #-}
  
  instance Ord1 f => Ord1 (Coyoneda f) where
    liftCompare cmp (Coyoneda f xs) (Coyoneda g ys) =
      liftCompare (\x y -> cmp (f x) (g y)) xs ys
    {-# INLINE liftCompare #-}
  
  instance (Eq1 f, Eq a) => Eq (Coyoneda f a) where
    (==) = eq1
    {-# INLINE (==) #-}
  
  instance (Ord1 f, Ord a) => Ord (Coyoneda f a) where
    compare = compare1
    {-# INLINE compare #-}
  
  instance Adjunction f g => Adjunction (Coyoneda f) (Coyoneda g) where
    unit = liftCoyoneda . leftAdjunct liftCoyoneda
    {-# INLINE unit #-}
    counit = rightAdjunct lowerCoyoneda . lowerCoyoneda
    {-# INLINE counit #-}
  
  -- | Yoneda \"expansion\"
  --
  -- @
  -- 'liftCoyoneda' . 'lowerCoyoneda' ≡ 'id'
  -- 'lowerCoyoneda' . 'liftCoyoneda' ≡ 'id'
  -- @
  --
  -- @
  -- lowerCoyoneda (liftCoyoneda fa) = -- by definition
  -- lowerCoyoneda (Coyoneda id fa)  = -- by definition
  -- fmap id fa                      = -- functor law
  -- fa
  -- @
  --
  -- @
  -- 'lift' = 'liftCoyoneda'
  -- @
  liftCoyoneda :: f a -> Coyoneda f a
  liftCoyoneda = Coyoneda id
  {-# INLINE liftCoyoneda #-}
  
  -- | Yoneda reduction lets us walk under the existential and apply 'fmap'.
  --
  -- Mnemonically, \"Yoneda reduction\" sounds like and works a bit like β-reduction.
  --
  -- <http://ncatlab.org/nlab/show/Yoneda+reduction>
  --
  -- You can view 'Coyoneda' as just the arguments to 'fmap' tupled up.
  --
  -- @
  -- 'lower' = 'lowerM' = 'lowerCoyoneda'
  -- @
  lowerCoyoneda :: Functor f => Coyoneda f a -> f a
  lowerCoyoneda (Coyoneda f m) = fmap f m
  {-# INLINE lowerCoyoneda #-}
  
  -- | Yoneda reduction given a 'Monad' lets us walk under the existential and apply 'liftM'.
  --
  -- You can view 'Coyoneda' as just the arguments to 'liftM' tupled up.
  --
  -- @
  -- 'lower' = 'lowerM' = 'lowerCoyoneda'
  -- @
  lowerM :: Monad f => Coyoneda f a -> f a
  lowerM (Coyoneda f m) = liftM f m
  {-# INLINE lowerM #-}
  
  -- | Lift a natural transformation from @f@ to @g@ to a natural transformation
  -- from @Coyoneda f@ to @Coyoneda g@.
  hoistCoyoneda :: (forall a. f a -> g a) -> (Coyoneda f b -> Coyoneda g b)
  hoistCoyoneda f (Coyoneda g x) = Coyoneda g (f x)
  {-# INLINE hoistCoyoneda #-}
  