module Control.Functor.Internal.Adjunction
(
Adjunction (unit, counit, leftAdjunct, rightAdjunct)
, ACompF(ACompF)
, repAdjunction, unrepAdjunction
, Representable, rep, unrep
, Corepresentable, corep, uncorep
, Both(..), EitherF(..)
, Zap(..), (>$<)
, Bizap(..), (>>$<<)
) where
import Control.Comonad.Reader
import Control.Comonad.Context
import Control.Functor.Combinators.Biff
import Control.Functor.Contra
import Control.Functor.Composition
import Control.Functor.Exponential
import Control.Functor.Full
import Control.Functor.Strong
import Control.Functor.HigherOrder
import Control.Applicative
import Control.Monad.Either ()
import Control.Monad.Identity
import Control.Monad.Reader
import Control.Monad.State
class (Representable g (f ()), Functor f) => 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
unit = leftAdjunct id
counit = rightAdjunct id
leftAdjunct f = fmap f . unit
rightAdjunct f = counit . fmap f
zapWithGF :: Adjunction g f => (a -> b -> c) -> f a -> g b -> c
zapWithGF f a b = uncurry (flip f) . counit . fmap (uncurry (flip strength)) $ strength a b
repAdjunction :: Adjunction f g => (f () -> a) -> g a
repAdjunction f = leftAdjunct f ()
unrepAdjunction :: Adjunction f g => g a -> (f () -> a)
unrepAdjunction = rightAdjunct . const
instance (Adjunction f1 g1, Adjunction f2 g2) => Representable (CompF g1 g2) (CompF f2 f1 ()) where
rep = repAdjunction
unrep = unrepAdjunction
instance (Adjunction f1 g1, Adjunction f2 g2) => Adjunction (CompF f2 f1) (CompF g1 g2) where
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
instance Adjunction f g => Monad (ACompF g f) where
return = point
m >>= f = compose . fmap (rightAdjunct (decompose . f)) $ decompose m
instance Adjunction f g => Comonad (ACompF f g) where
extend f = compose . fmap (leftAdjunct (f . compose)) . decompose
instance Zap ((->)e) ((,)e) where
zapWith = zapWithGF
instance Representable ((->)e) (e,()) where
rep = repAdjunction
unrep = unrepAdjunction
instance Representable ((->)e) e where
rep = id
unrep = id
instance Adjunction ((,)e) ((->)e) where
leftAdjunct f a e = f (e,a)
rightAdjunct f ~(e,a) = f a e
unit a e = (e,a)
counit (x,f) = f x
instance Representable Identity (Identity ()) where
rep = repAdjunction
unrep = unrepAdjunction
instance Adjunction Identity Identity where
unit = Identity . Identity
counit = runIdentity . runIdentity
instance Zap (Reader e) (Coreader e) where
zapWith = zapWithGF
instance Representable (Reader e) (Coreader e ()) where
rep = repAdjunction
unrep = unrepAdjunction
instance Adjunction (Coreader e) (Reader e) where
unit a = Reader (\e -> Coreader e a)
counit (Coreader x f) = runReader f x
instance ComonadContext e ((,)e `ACompF` (->)e) where
getC = fst . decompose
modifyC f = uncurry (flip id . f) . decompose
instance MonadState e ((->)e `ACompF` (,)e) where
get = compose $ \s -> (s,s)
put s = compose $ const (s,())
class ContraFunctor f => Corepresentable f x where
corep :: (a -> x) -> f a
uncorep :: f a -> (a -> x)
class Functor f => Representable f x where
rep :: (x -> a) -> f a
unrep :: f a -> (x -> a)
data EitherF a b c = EitherF (a -> c) (b -> c)
instance Functor (EitherF a b) where
fmap f (EitherF l r) = EitherF (f . l) (f . r)
instance Representable (EitherF a b) (Either a b) where
rep f = EitherF (f . Left) (f . Right)
unrep (EitherF l r) = either l r
instance Representable Identity () where
rep f = Identity (f ())
unrep (Identity a) = const a
data Both a = Both a a
instance Functor Both where
fmap f (Both a b) = Both (f a) (f b)
instance Representable Both Bool where
rep f = Both (f False) (f True)
unrep (Both x _) False = x
unrep (Both _ y) True = y
class Zap f g | f -> g, g -> f where
zapWith :: (a -> b -> c) -> f a -> g b -> c
zap :: f (a -> b) -> g a -> b
zap = zapWith id
(>$<) :: Zap f g => f (a -> b) -> g a -> b
(>$<) = zap
instance Zap Identity Identity where
zapWith f (Identity a) (Identity b) = f a b
class Bizap p q | p -> q, q -> p where
bizapWith :: (a -> c -> e) -> (b -> d -> e) -> p a b -> q c d -> e
bizap :: p (a -> c) (b -> c) -> q a b -> c
bizap = bizapWith id id
(>>$<<) :: Bizap p q => p (a -> c) (b -> c) -> q a b -> c
(>>$<<) = bizap
instance Bizap (,) Either where
bizapWith l _ (f,_) (Left a) = l f a
bizapWith _ r (_,g) (Right b) = r g b
instance Bizap Either (,) where
bizapWith l _ (Left f) (a,_) = l f a
bizapWith _ r (Right g) (_,b) = r g b
instance (Bizap p q, Zap f g, Zap i j) => Bizap (Biff p f i) (Biff q g j) where
bizapWith l r fs as = bizapWith (zapWith l) (zapWith r) (runBiff fs) (runBiff as)