```-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2008 Edward Kmett
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable (rank-2 polymorphism)
--
----------------------------------------------------------------------------
( Codensity, liftCodensity, lowerCodensity
, codensityToRan, ranToCodensity
, toCodensity, fromCodensity
, improveFree
) where

import Prelude hiding (abs)
import Control.Functor.Extras
import Control.Functor.Pointed ()
import Control.Functor.KanExtension

newtype Codensity m a = Codensity { runCodensity :: forall b. (a -> m b) -> m b }

codensityToRan :: Codensity m :~> Ran m m
codensityToRan x = Ran (runCodensity x)

ranToCodensity :: Ran m m :~> Codensity m
ranToCodensity x = Codensity (runRan x)

liftCodensity :: Monad m => m :~> Codensity m
liftCodensity m = Codensity (m >>=)

lowerCodensity :: Monad m => Codensity m :~> m
lowerCodensity a = runCodensity a return

toCodensity :: Functor s => (forall a. s (k a) -> k a) -> s :~> Codensity k
toCodensity s t = Codensity (s . flip fmap t)

fromCodensity :: (s :~> Codensity k) -> s (k a) -> k a
fromCodensity s = flip runCodensity id . s

instance Functor (Codensity k) where
fmap f m = Codensity (\k -> runCodensity m (k . f))

instance Pointed (Codensity f) where
point x = Codensity (\k -> k x)

return = point
m >>= k = Codensity (\c -> runCodensity m (\a -> runCodensity (k a) c))

local f m = Codensity (\c -> ask >>= \r -> local f (runCodensity m (local (const r) . c)))

liftIO = liftCodensity . liftIO

get = liftCodensity get
put = liftCodensity . put

inFree t = Codensity (inFree . flip fmap t . flip runCodensity)