module Data.Functor.Adjunction
( Adjunction(..)
, tabulateAdjunction
, indexAdjunction
, zipR, unzipR
, unabsurdL, absurdL
, cozipL, uncozipL
, extractL, duplicateL
, splitL, unsplitL
) where
import Control.Applicative
import Control.Arrow ((&&&), (|||))
import Control.Monad.Instances ()
import Control.Monad.Trans.Identity
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Writer
import Control.Comonad.Trans.Env
import Control.Comonad.Trans.Traced
import Data.Functor.Identity
import Data.Functor.Compose
import Data.Functor.Representable
import Data.Void
class (Functor f, Representable u) =>
Adjunction f u | f -> u, u -> f where
unit :: a -> u (f a)
counit :: f (u a) -> a
leftAdjunct :: (f a -> b) -> a -> u b
rightAdjunct :: (a -> u b) -> f a -> b
unit = leftAdjunct id
counit = rightAdjunct id
leftAdjunct f = fmap f . unit
rightAdjunct f = counit . fmap f
tabulateAdjunction :: Adjunction f u => (f () -> b) -> u b
tabulateAdjunction f = leftAdjunct f ()
indexAdjunction :: Adjunction f u => u b -> f a -> b
indexAdjunction = rightAdjunct . const
splitL :: Adjunction f u => f a -> (a, f ())
splitL = rightAdjunct (flip leftAdjunct () . (,))
unsplitL :: Functor f => a -> f () -> f a
unsplitL = (<$)
extractL :: Adjunction f u => f a -> a
extractL = fst . splitL
duplicateL :: Adjunction f u => f a -> f (f a)
duplicateL as = as <$ as
zipR :: Adjunction f u => (u a, u b) -> u (a, b)
zipR = leftAdjunct (rightAdjunct fst &&& rightAdjunct snd)
unzipR :: Functor u => u (a, b) -> (u a, u b)
unzipR = fmap fst &&& fmap snd
absurdL :: Void -> f Void
absurdL = absurd
unabsurdL :: Adjunction f u => f Void -> Void
unabsurdL = rightAdjunct absurd
cozipL :: Adjunction f u => f (Either a b) -> Either (f a) (f b)
cozipL = rightAdjunct (leftAdjunct Left ||| leftAdjunct Right)
uncozipL :: Functor f => Either (f a) (f b) -> f (Either a b)
uncozipL = fmap Left ||| fmap Right
instance Adjunction ((,) e) ((->) e) where
leftAdjunct f a e = f (e, a)
rightAdjunct f ~(e, a) = f a e
instance Adjunction Identity Identity where
leftAdjunct f = Identity . f . Identity
rightAdjunct f = runIdentity . f . runIdentity
instance Adjunction f g =>
Adjunction (IdentityT f) (IdentityT g) where
unit = IdentityT . leftAdjunct IdentityT
counit = rightAdjunct runIdentityT . runIdentityT
instance Adjunction w m =>
Adjunction (EnvT e w) (ReaderT e m) where
unit = ReaderT . flip fmap EnvT . flip leftAdjunct
counit (EnvT e w) = rightAdjunct (flip runReaderT e) w
instance Adjunction m w =>
Adjunction (WriterT s m) (TracedT s w) where
unit = TracedT . leftAdjunct (\ma s -> WriterT (fmap (\a -> (a, s)) ma))
counit = rightAdjunct (\(t, s) -> ($s) <$> runTracedT t) . runWriterT
instance (Adjunction f g, Adjunction f' g') =>
Adjunction (Compose f' f) (Compose g g') where
unit = Compose . leftAdjunct (leftAdjunct Compose)
counit = rightAdjunct (rightAdjunct getCompose) . getCompose