(Co)Monads from adjunctions

Adjunctions.hs

{-# LANGUAGE TypeOperators, MultiParamTypeClasses, DeriveFunctor, NoImplicitPrelude #-}

import Prelude hiding (Monad)

class (Functor l, Functor r) => l ⊣ r where
  unit :: a -> r (l a)
  unit = leftAdjunct id
  counit :: l (r a) -> a
  counit = rightAdjunct id
  leftAdjunct :: (l a -> b) -> a -> r b
  leftAdjunct f = fmap f . unit
  rightAdjunct :: (a -> r b) -> l a -> b
  rightAdjunct f = counit . fmap f
  {-# MINIMAL leftAdjunct, rightAdjunct | unit, counit |
    leftAdjunct, counit | unit, rightAdjunct #-}

newtype Compose f g a = Compose { decompose :: (f (g a)) }
  deriving Functor

class (Functor f) => Monad f where
  return :: a -> f a
  join :: f (f a) -> f a

instance (l ⊣ r) => Monad (Compose r l) where
  return = Compose . unit
  join = Compose . fmap counit . decompose . fmap decompose

class (Functor f) => Comonad f where
  extract :: f a -> a
  duplicate :: f a -> f (f a)

instance (l ⊣ r) => Comonad (Compose l r) where
  extract = counit . decompose
  duplicate = fmap Compose . Compose . fmap unit . decompose