{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
#if (__GLASGOW_HASKELL__ >= 708) && (__GLASGOW_HASKELL__ < 802)
{-# LANGUAGE DeriveDataTypeable #-}
#endif
#if __GLASGOW_HASKELL__ >= 802
{-# LANGUAGE TypeInType #-}
#endif

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Codensity
-- Copyright   :  (C) 2008-2016 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  non-portable (rank-2 polymorphism)
--
----------------------------------------------------------------------------
module Control.Monad.Codensity
  ( Codensity(..)
  , lowerCodensity
  , codensityToAdjunction, adjunctionToCodensity
  , codensityToRan, ranToCodensity
  , codensityToComposedRep, composedRepToCodensity
  , wrapCodensity
  , improve
  ) where

import Control.Applicative
import Control.Monad (MonadPlus(..))
import qualified Control.Monad.Fail as Fail
import Control.Monad.Free
import Control.Monad.IO.Class
import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Control.Monad.Trans.Class
import Data.Functor.Adjunction
import Data.Functor.Apply
import Data.Functor.Kan.Ran
import Data.Functor.Plus
import Data.Functor.Rep
#if (__GLASGOW_HASKELL__ >= 708) && (__GLASGOW_HASKELL__ < 800)
import Data.Typeable
#endif
#if __GLASGOW_HASKELL__ >= 802
import GHC.Exts (TYPE)
#endif

-- |
-- @'Codensity' f@ is the Monad generated by taking the right Kan extension
-- of any 'Functor' @f@ along itself (@Ran f f@).
--
-- This can often be more \"efficient\" to construct than @f@ itself using
-- repeated applications of @(>>=)@.
--
-- See \"Asymptotic Improvement of Computations over Free Monads\" by Janis
-- Voigtländer for more information about this type.
--
-- <https://www.janis-voigtlaender.eu/papers/AsymptoticImprovementOfComputationsOverFreeMonads.pdf>
#if __GLASGOW_HASKELL__ >= 802
newtype Codensity (m :: k -> TYPE rep) a = Codensity
-- Note: we *could* generalize @a@ to @TYPE repa@, but the 'Functor'
-- instance wouldn't carry that, so it doesn't really seem worth
-- the complication.
#else
newtype Codensity m a = Codensity
#endif
  { Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity :: forall b. (a -> m b) -> m b
  }
#if (__GLASGOW_HASKELL__ >= 708) && (__GLASGOW_HASKELL__ < 800)
    deriving Typeable
#endif

#if __GLASGOW_HASKELL__ >= 802
instance Functor (Codensity (k :: j -> TYPE rep)) where
#else
instance Functor (Codensity k) where
#endif
  fmap :: (a -> b) -> Codensity k a -> Codensity k b
fmap a -> b
f (Codensity forall (b :: j). (a -> k b) -> k b
m) = (forall (b :: j). (b -> k b) -> k b) -> Codensity k b
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity (\b -> k b
k -> (a -> k b) -> k b
forall (b :: j). (a -> k b) -> k b
m (\a
x -> b -> k b
k (a -> b
f a
x)))
  {-# INLINE fmap #-}

#if __GLASGOW_HASKELL__ >= 802
instance Apply (Codensity (f :: k -> TYPE rep)) where
#else
instance Apply (Codensity f) where
#endif
  <.> :: Codensity f (a -> b) -> Codensity f a -> Codensity f b
(<.>) = Codensity f (a -> b) -> Codensity f a -> Codensity f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
  {-# INLINE (<.>) #-}

#if __GLASGOW_HASKELL__ >= 802
instance Applicative (Codensity (f :: k -> TYPE rep)) where
#else
instance Applicative (Codensity f) where
#endif
  pure :: a -> Codensity f a
pure a
x = (forall (b :: k). (a -> f b) -> f b) -> Codensity f a
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity (\a -> f b
k -> a -> f b
k a
x)
  {-# INLINE pure #-}
  Codensity forall (b :: k). ((a -> b) -> f b) -> f b
f <*> :: Codensity f (a -> b) -> Codensity f a -> Codensity f b
<*> Codensity forall (b :: k). (a -> f b) -> f b
g = (forall (b :: k). (b -> f b) -> f b) -> Codensity f b
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity (\b -> f b
bfr -> ((a -> b) -> f b) -> f b
forall (b :: k). ((a -> b) -> f b) -> f b
f (\a -> b
ab -> (a -> f b) -> f b
forall (b :: k). (a -> f b) -> f b
g (\a
x -> b -> f b
bfr (a -> b
ab a
x))))
  {-# INLINE (<*>) #-}

#if __GLASGOW_HASKELL__ >= 802
instance Monad (Codensity (f :: k -> TYPE rep)) where
#else
instance Monad (Codensity f) where
#endif
  return :: a -> Codensity f a
return = a -> Codensity f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE return #-}
  Codensity f a
m >>= :: Codensity f a -> (a -> Codensity f b) -> Codensity f b
>>= a -> Codensity f b
k = (forall (b :: k). (b -> f b) -> f b) -> Codensity f b
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity (\b -> f b
c -> Codensity f a -> (a -> f b) -> f b
forall k (m :: k -> *) a.
Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity Codensity f a
m (\a
a -> Codensity f b -> (b -> f b) -> f b
forall k (m :: k -> *) a.
Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity (a -> Codensity f b
k a
a) b -> f b
c))
  {-# INLINE (>>=) #-}

instance Fail.MonadFail f => Fail.MonadFail (Codensity f) where
  fail :: String -> Codensity f a
fail String
msg = (forall b. (a -> f b) -> f b) -> Codensity f a
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((forall b. (a -> f b) -> f b) -> Codensity f a)
-> (forall b. (a -> f b) -> f b) -> Codensity f a
forall a b. (a -> b) -> a -> b
$ \ a -> f b
_ -> String -> f b
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
msg
  {-# INLINE fail #-}

instance MonadIO m => MonadIO (Codensity m) where
  liftIO :: IO a -> Codensity m a
liftIO = m a -> Codensity m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> Codensity m a) -> (IO a -> m a) -> IO a -> Codensity m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
  {-# INLINE liftIO #-}

instance MonadTrans Codensity where
  lift :: m a -> Codensity m a
lift m a
m = (forall b. (a -> m b) -> m b) -> Codensity m a
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity (m a
m m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)
  {-# INLINE lift #-}

instance Alt v => Alt (Codensity v) where
  Codensity forall b. (a -> v b) -> v b
m <!> :: Codensity v a -> Codensity v a -> Codensity v a
<!> Codensity forall b. (a -> v b) -> v b
n = (forall b. (a -> v b) -> v b) -> Codensity v a
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity (\a -> v b
k -> (a -> v b) -> v b
forall b. (a -> v b) -> v b
m a -> v b
k v b -> v b -> v b
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> (a -> v b) -> v b
forall b. (a -> v b) -> v b
n a -> v b
k)
  {-# INLINE (<!>) #-}

instance Plus v => Plus (Codensity v) where
  zero :: Codensity v a
zero = (forall b. (a -> v b) -> v b) -> Codensity v a
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity (v b -> (a -> v b) -> v b
forall a b. a -> b -> a
const v b
forall (f :: * -> *) a. Plus f => f a
zero)
  {-# INLINE zero #-}

{-
instance Plus v => Alternative (Codensity v) where
  empty = zero
  (<|>) = (<!>)

instance Plus v => MonadPlus (Codensity v) where
  mzero = zero
  mplus = (<!>)
-}

instance Alternative v => Alternative (Codensity v) where
  empty :: Codensity v a
empty = (forall b. (a -> v b) -> v b) -> Codensity v a
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity (\a -> v b
_ -> v b
forall (f :: * -> *) a. Alternative f => f a
empty)
  {-# INLINE empty #-}
  Codensity forall b. (a -> v b) -> v b
m <|> :: Codensity v a -> Codensity v a -> Codensity v a
<|> Codensity forall b. (a -> v b) -> v b
n = (forall b. (a -> v b) -> v b) -> Codensity v a
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity (\a -> v b
k -> (a -> v b) -> v b
forall b. (a -> v b) -> v b
m a -> v b
k v b -> v b -> v b
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (a -> v b) -> v b
forall b. (a -> v b) -> v b
n a -> v b
k)
  {-# INLINE (<|>) #-}

#if __GLASGOW_HASKELL__ >= 710
instance Alternative v => MonadPlus (Codensity v)
#else
instance MonadPlus v => MonadPlus (Codensity v) where
  mzero = Codensity (\_ -> mzero)
  {-# INLINE mzero #-}
  Codensity m `mplus` Codensity n = Codensity (\k -> m k `mplus` n k)
  {-# INLINE mplus #-}
#endif

-- |
-- This serves as the *left*-inverse (retraction) of 'lift'.
--
--
-- @
-- 'lowerCodensity' . 'lift' ≡ 'id'
-- @
--
-- In general this is not a full 2-sided inverse, merely a retraction, as
-- @'Codensity' m@ is often considerably "larger" than @m@.
--
-- e.g. @'Codensity' ((->) s)) a ~ forall r. (a -> s -> r) -> s -> r@
-- could support a full complement of @'MonadState' s@ actions, while @(->) s@
-- is limited to @'MonadReader' s@ actions.
#if __GLASGOW_HASKELL__ >= 710
lowerCodensity :: Applicative f => Codensity f a -> f a
lowerCodensity :: Codensity f a -> f a
lowerCodensity Codensity f a
a = Codensity f a -> (a -> f a) -> f a
forall k (m :: k -> *) a.
Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity Codensity f a
a a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
#else
lowerCodensity :: Monad m => Codensity m a -> m a
lowerCodensity a = runCodensity a return
#endif
{-# INLINE lowerCodensity #-}

-- | The 'Codensity' monad of a right adjoint is isomorphic to the
-- monad obtained from the 'Adjunction'.
--
-- @
-- 'codensityToAdjunction' . 'adjunctionToCodensity' ≡ 'id'
-- 'adjunctionToCodensity' . 'codensityToAdjunction' ≡ 'id'
-- @
codensityToAdjunction :: Adjunction f g => Codensity g a -> g (f a)
codensityToAdjunction :: Codensity g a -> g (f a)
codensityToAdjunction Codensity g a
r = Codensity g a -> (a -> g (f a)) -> g (f a)
forall k (m :: k -> *) a.
Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity Codensity g a
r a -> g (f a)
forall (f :: * -> *) (u :: * -> *) a.
Adjunction f u =>
a -> u (f a)
unit
{-# INLINE codensityToAdjunction #-}

adjunctionToCodensity :: Adjunction f g => g (f a) -> Codensity g a
adjunctionToCodensity :: g (f a) -> Codensity g a
adjunctionToCodensity g (f a)
f = (forall b. (a -> g b) -> g b) -> Codensity g a
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity (\a -> g b
a -> (f a -> b) -> g (f a) -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> g b) -> f a -> b
forall (f :: * -> *) (u :: * -> *) a b.
Adjunction f u =>
(a -> u b) -> f a -> b
rightAdjunct a -> g b
a) g (f a)
f)
{-# INLINE adjunctionToCodensity #-}

-- | The 'Codensity' monad of a representable 'Functor' is isomorphic to the
-- monad obtained from the 'Adjunction' for which that 'Functor' is the right
-- adjoint.
--
-- @
-- 'codensityToComposedRep' . 'composedRepToCodensity' ≡ 'id'
-- 'composedRepToCodensity' . 'codensityToComposedRep' ≡ 'id'
-- @
--
-- @
-- codensityToComposedRep = 'ranToComposedRep' . 'codensityToRan'
-- @

codensityToComposedRep :: Representable u => Codensity u a -> u (Rep u, a)
codensityToComposedRep :: Codensity u a -> u (Rep u, a)
codensityToComposedRep (Codensity forall b. (a -> u b) -> u b
f) = (a -> u (Rep u, a)) -> u (Rep u, a)
forall b. (a -> u b) -> u b
f (\a
a -> (Rep u -> (Rep u, a)) -> u (Rep u, a)
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate ((Rep u -> (Rep u, a)) -> u (Rep u, a))
-> (Rep u -> (Rep u, a)) -> u (Rep u, a)
forall a b. (a -> b) -> a -> b
$ \Rep u
e -> (Rep u
e, a
a))
{-# INLINE codensityToComposedRep #-}

-- |
--
-- @
-- 'composedRepToCodensity' = 'ranToCodensity' . 'composedRepToRan'
-- @
composedRepToCodensity :: Representable u => u (Rep u, a) -> Codensity u a
composedRepToCodensity :: u (Rep u, a) -> Codensity u a
composedRepToCodensity u (Rep u, a)
hfa = (forall b. (a -> u b) -> u b) -> Codensity u a
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((forall b. (a -> u b) -> u b) -> Codensity u a)
-> (forall b. (a -> u b) -> u b) -> Codensity u a
forall a b. (a -> b) -> a -> b
$ \a -> u b
k -> ((Rep u, a) -> b) -> u (Rep u, a) -> u b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Rep u
e, a
a) -> u b -> Rep u -> b
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index (a -> u b
k a
a) Rep u
e) u (Rep u, a)
hfa
{-# INLINE composedRepToCodensity #-}

-- | The 'Codensity' 'Monad' of a 'Functor' @g@ is the right Kan extension ('Ran')
-- of @g@ along itself.
--
-- @
-- 'codensityToRan' . 'ranToCodensity' ≡ 'id'
-- 'ranToCodensity' . 'codensityToRan' ≡ 'id'
-- @
codensityToRan :: Codensity g a -> Ran g g a
codensityToRan :: Codensity g a -> Ran g g a
codensityToRan (Codensity forall (b :: k). (a -> g b) -> g b
m) = (forall (b :: k). (a -> g b) -> g b) -> Ran g g a
forall k (g :: k -> *) (h :: k -> *) a.
(forall (b :: k). (a -> g b) -> h b) -> Ran g h a
Ran forall (b :: k). (a -> g b) -> g b
m
{-# INLINE codensityToRan #-}

ranToCodensity :: Ran g g a -> Codensity g a
ranToCodensity :: Ran g g a -> Codensity g a
ranToCodensity (Ran forall (b :: k). (a -> g b) -> g b
m) = (forall (b :: k). (a -> g b) -> g b) -> Codensity g a
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity forall (b :: k). (a -> g b) -> g b
m
{-# INLINE ranToCodensity #-}

instance (Functor f, MonadFree f m) => MonadFree f (Codensity m) where
  wrap :: f (Codensity m a) -> Codensity m a
wrap f (Codensity m a)
t = (forall b. (a -> m b) -> m b) -> Codensity m a
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity (\a -> m b
h -> f (m b) -> m b
forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
wrap ((Codensity m a -> m b) -> f (Codensity m a) -> f (m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Codensity m a
p -> Codensity m a -> (a -> m b) -> m b
forall k (m :: k -> *) a.
Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity Codensity m a
p a -> m b
h) f (Codensity m a)
t))
  {-# INLINE wrap #-}

instance MonadReader r m => MonadState r (Codensity m) where
  get :: Codensity m r
get = (forall b. (r -> m b) -> m b) -> Codensity m r
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity (m r
forall r (m :: * -> *). MonadReader r m => m r
ask m r -> (r -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)
  {-# INLINE get #-}
  put :: r -> Codensity m ()
put r
s = (forall b. (() -> m b) -> m b) -> Codensity m ()
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity (\() -> m b
k -> (r -> r) -> m b -> m b
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (r -> r -> r
forall a b. a -> b -> a
const r
s) (() -> m b
k ()))
  {-# INLINE put #-}

instance MonadReader r m => MonadReader r (Codensity m) where
  ask :: Codensity m r
ask = (forall b. (r -> m b) -> m b) -> Codensity m r
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity (m r
forall r (m :: * -> *). MonadReader r m => m r
ask m r -> (r -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)
  {-# INLINE ask #-}
  local :: (r -> r) -> Codensity m a -> Codensity m a
local r -> r
f Codensity m a
m = (forall b. (a -> m b) -> m b) -> Codensity m a
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((forall b. (a -> m b) -> m b) -> Codensity m a)
-> (forall b. (a -> m b) -> m b) -> Codensity m a
forall a b. (a -> b) -> a -> b
$ \a -> m b
c -> m r
forall r (m :: * -> *). MonadReader r m => m r
ask m r -> (r -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \r
r -> (r -> r) -> m b -> m b
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
f (m b -> m b) -> ((a -> m b) -> m b) -> (a -> m b) -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Codensity m a -> forall b. (a -> m b) -> m b
forall k (m :: k -> *) a.
Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity Codensity m a
m ((a -> m b) -> m b) -> (a -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ (r -> r) -> m b -> m b
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (r -> r -> r
forall a b. a -> b -> a
const r
r) (m b -> m b) -> (a -> m b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
c
  {-# INLINE local #-}

-- | Right associate all binds in a computation that generates a free monad
--
-- This can improve the asymptotic efficiency of the result, while preserving
-- semantics.
--
-- See \"Asymptotic Improvement of Computations over Free Monads\" by Janis
-- Voightländer for more information about this combinator.
--
-- <http://www.iai.uni-bonn.de/~jv/mpc08.pdf>
improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a
improve :: (forall (m :: * -> *). MonadFree f m => m a) -> Free f a
improve forall (m :: * -> *). MonadFree f m => m a
m = Codensity (Free f) a -> Free f a
forall (f :: * -> *) a. Applicative f => Codensity f a -> f a
lowerCodensity Codensity (Free f) a
forall (m :: * -> *). MonadFree f m => m a
m
{-# INLINE improve #-}


-- | Wrap the remainder of the 'Codensity' action using the given
-- function.
--
-- This function can be used to register cleanup actions that will be
-- executed at the end.  Example:
--
-- > wrapCodensity (`finally` putStrLn "Done.")
wrapCodensity :: (forall a. m a -> m a) -> Codensity m ()
wrapCodensity :: (forall (a :: k). m a -> m a) -> Codensity m ()
wrapCodensity forall (a :: k). m a -> m a
f = (forall (b :: k). (() -> m b) -> m b) -> Codensity m ()
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity (\() -> m b
k -> m b -> m b
forall (a :: k). m a -> m a
f (() -> m b
k ()))