{-# 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
( Codensity(..)
, lowerCodensity
, codensityToAdjunction, adjunctionToCodensity
, codensityToRan, ranToCodensity
, codensityToComposedRep, composedRepToCodensity
, wrapCodensity
, improve
, reset
, shift
) 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
#if __GLASGOW_HASKELL__ >= 802
newtype Codensity (m :: k -> TYPE rep) a = Codensity
#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 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
#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 #-}
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 #-}
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 :: 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 #-}
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 #-}
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 #-}
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 ()))
reset :: Monad m => Codensity m a -> Codensity m a
reset :: Codensity m a -> Codensity m a
reset = m a -> Codensity m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> Codensity m a)
-> (Codensity m a -> m a) -> Codensity m a -> Codensity m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Codensity m a -> m a
forall (f :: * -> *) a. Applicative f => Codensity f a -> f a
lowerCodensity
shift ::
#if __GLASGOW_HASKELL__ >= 710
Applicative m
#else
Monad m
#endif
=> (forall b. (a -> m b) -> Codensity m b) -> Codensity m a
shift :: (forall b. (a -> m b) -> Codensity m b) -> Codensity m a
shift forall b. (a -> m b) -> Codensity m b
f = (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
$ Codensity m b -> m b
forall (f :: * -> *) a. Applicative f => Codensity f a -> f a
lowerCodensity (Codensity m b -> m b)
-> ((a -> m b) -> Codensity m b) -> (a -> m b) -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m b) -> Codensity m b
forall b. (a -> m b) -> Codensity m b
f