```{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}
-------------------------------------------------------------------------------------------
-- |
-- Copyright 	: 2008 Edward Kmett
--
-- Maintainer	: Edward Kmett <ekmett@gmail.com>
-- Stability	: experimental
-- Portability	: non-portable (functional-dependencies)
--
-------------------------------------------------------------------------------------------

, ACompF(ACompF)
) where

import Control.Functor.Composition
import Control.Functor.Exponential
import Control.Functor.Full
import Control.Functor.HigherOrder
import Control.Applicative

-- | An 'Adjunction' formed by the 'Functor' f and 'Functor' g.

-- Minimal definition:

-- 2. @unit@ and @counit@

class (Functor f, Functor g) => Adjunction f g | f -> g, g -> f where
unit   :: a -> g (f a)
counit :: f (g a) -> a
leftAdjunct  :: (f a -> b) -> a -> g b
rightAdjunct :: (a -> g b) -> f a -> b

leftAdjunct f = fmap f . unit
rightAdjunct f = counit . fmap f

counit = counit . fmap (counit . fmap decompose) . decompose
unit = compose . fmap (fmap compose . unit) . unit

newtype ACompF f g a = ACompF (CompF f g a) deriving (Functor, ExpFunctor, Full, Composition, HFunctor)

instance Adjunction f g => Pointed (ACompF g f) where
point = compose . unit

instance Adjunction f g => Copointed (ACompF f g) where
extract = counit . decompose

instance Adjunction f g => Applicative (ACompF g f) where
pure = point
(<*>) = ap

return = point
m >>= f = compose . fmap (rightAdjunct (decompose . f)) \$ decompose m

extend f = compose . fmap (leftAdjunct (f . compose)) . decompose

leftAdjunct f a e  = f (e,a)
rightAdjunct f ~(e,a) = f a e
unit a e = (e,a)
counit (x,f) = f x

unit = Identity . Identity
counit = runIdentity . runIdentity