{-# LANGUAGE MultiParamTypeClasses, GADTs #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Comonad.Density
-- Copyright   :  (C) 2008-2011 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable (GADTs, MPTCs)
--
-- The density comonad for a functor. aka the comonad generated by a functor
-- The ''density'' term dates back to Dubuc''s 1974 thesis. The term
-- ''monad genererated by a functor'' dates back to 1972 in Street''s
-- ''Formal Theory of Monads''.
----------------------------------------------------------------------------
module Control.Comonad.Density
  ( Density(..)
  , liftDensity
  , densityToAdjunction, adjunctionToDensity
  ) where

import Control.Applicative
import Control.Comonad
import Control.Comonad.Trans.Class
import Data.Functor.Apply
import Data.Functor.Adjunction
import Data.Functor.Extend

data Density k a where
  Density :: (k b -> a) -> k b -> Density k a

instance Functor (Density f) where
  fmap f (Density g h) = Density (f . g) h

instance Extend (Density f) where
  duplicated (Density f ws) = Density (Density f) ws

instance Comonad (Density f) where
  duplicate (Density f ws) = Density (Density f) ws
  extract (Density f a) = f a

instance ComonadTrans Density where
  lower (Density f c) = extend f c

instance Apply f => Apply (Density f) where
  Density kxf x <.> Density kya y =
    Density (\k -> kxf (fmap fst k) (kya (fmap snd k))) ((,) <$> x <.> y)

instance Applicative f => Applicative (Density f) where
  pure a = Density (const a) (pure ())
  Density kxf x <*> Density kya y =
    Density (\k -> kxf (fmap fst k) (kya (fmap snd k))) (liftA2 (,) x y)

-- | The natural isomorphism between a comonad w and the comonad generated by w (forwards).
liftDensity :: Comonad w => w a -> Density w a
liftDensity = Density extract

densityToAdjunction :: Adjunction f g => Density f a -> f (g a)
densityToAdjunction (Density f v) = fmap (leftAdjunct f) v

adjunctionToDensity :: Adjunction f g => f (g a) -> Density f a
adjunctionToDensity = Density counit