Skip to content

Instantly share code, notes, and snippets.

@kl0tl
Last active July 30, 2017 15:29
Show Gist options
  • Save kl0tl/b2a63d4cec8cbd74190da12a5744d985 to your computer and use it in GitHub Desktop.
Save kl0tl/b2a63d4cec8cbd74190da12a5744d985 to your computer and use it in GitHub Desktop.
(Co)Monads from adjunctions
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment