Monads from adjunctions

adjunctions.hs

{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FunctionalDependencies #-}

-- Composition of functors
newtype Compose g f a = Compose { getCompose :: g (f a) }
                      deriving Functor

-- Definition of adjoint functors
class (Functor f, Functor g) => Adjoint f g | f -> g, g -> f where
     counit :: f (g a) -> a
     unit   :: a -> g (f a)

-- phiLeft and phiRight witness the isomorphism between the Hom-sets
phiLeft :: Adjoint f g => (f a -> b) -> (a -> g b)
phiLeft f = fmap f . unit

phiRight :: Adjoint f g => (a -> g b) -> (f a -> b)
phiRight f = counit . fmap f

-- Curry/uncurry adjunction
instance Adjoint ((,) a) ((->) a) where
    -- counit :: (a,a -> b) -> b
    counit (x, f) = f x
    -- unit :: b -> (a -> (a,b))
    unit x = \y -> (y, x)

-- If composition of two functors g and f form a monad, it also forms
-- a strong lax monoidial functor (needed for this file to compile).
instance (Functor g, Functor f, Monad (Compose g f))
      => Applicative (Compose g f) where
  pure = return
  f <*> x = do f' <- f
               x' <- x
               pure (f' x')

-- Every adjunction induces a monad
instance Adjoint f g => Monad (Compose g f) where
    return   = Compose . unit
    x >>= f  = Compose . fmap counit . getCompose $ fmap (getCompose . f) x

-- Deriving the state monad
newtype State s a = State (Compose ((->) s) ((,) s) a)
                  deriving (Functor, Applicative, Monad)

runState :: State s a -> s -> (s,a)
runState (State (Compose f)) = f

execState :: State s a -> s -> a
execState f s = snd (runState f s)

put :: s -> State s ()
put s = State (Compose (\_ -> (s,())))

get :: State s s
get = State (Compose (\s -> (s,s)))

gets :: (s -> a) -> State s a
gets f = get >>= (pure . f)

modify :: (s -> s) -> State s ()
modify f = get >>= (put . f)

-- Factorial with state monad
runFact :: State (Int, Int) Int
runFact = do
  acc <- gets fst
  curr <- gets snd
  if curr == 1 
    then return acc
    else do
      put (curr * acc, curr - 1)
      runFact

fact :: Int -> Int
fact n = execState runFact (1,n)