{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif
#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710
{-# LANGUAGE Trustworthy #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2011-2016 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <[email protected]>
-- Stability   :  provisional
-- Portability :  non-portable (rank-2 polymorphism)
--
-- Monads from Comonads
--
-- <http://comonad.com/reader/2011/monads-from-comonads/>
--
-- 'Co' can be viewed as a right Kan lift along a 'Comonad'.
--
-- In general you can \"sandwich\" a monad in between two halves of an adjunction.
-- That is to say, if you have an adjunction @F -| G : C -> D @ then not only does @GF@
-- form a monad, but @GMF@ forms a monad for @M@ a monad in @D@. Therefore if we
-- have an adjunction @F -| G : Hask -> Hask^op@ then we can lift a 'Comonad' in @Hask@
-- which is a 'Monad' in @Hask^op@ to a 'Monad' in 'Hask'.
--
-- For any @r@, the 'Contravariant' functor / presheaf @(-> r)@ :: Hask^op -> Hask is adjoint to the \"same\"
-- 'Contravariant' functor @(-> r) :: Hask -> Hask^op@. So we can sandwich a
-- Monad in Hask^op in the middle to obtain @w (a -> r-) -> r+@, and then take a coend over
-- @r@ to obtain @forall r. w (a -> r) -> r@. This gives rise to 'Co'. If we observe that
-- we didn't care what the choices we made for @r@ were to finish this construction, we can
-- upgrade to @forall r. w (a -> m r) -> m r@ in a manner similar to how @ContT@ is constructed
-- yielding 'CoT'.
--
-- We could consider unifying the definition of 'Co' and 'Rift', but
-- there are many other arguments for which 'Rift' can form a 'Monad', and this
-- wouldn't give rise to 'CoT'.
----------------------------------------------------------------------------
module Control.Monad.Co
  (
  -- * Monads from Comonads
    Co, co, runCo
  -- * Monad Transformers from Comonads
  , CoT(..)
  -- * Klesili from CoKleisli
  , liftCoT0, liftCoT0M, lowerCoT0, lowerCo0
  , liftCoT1, liftCoT1M, lowerCoT1, lowerCo1
  , diter, dctrlM
  , posW, peekW, peeksW
  , askW, asksW, traceW
  )where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Comonad
import Control.Comonad.Cofree
import Control.Comonad.Density
import Control.Comonad.Env.Class as Env
import Control.Comonad.Store.Class
import Control.Comonad.Traced.Class as Traced
import Control.Monad ((<=<), liftM)
import Control.Monad.Error.Class
import qualified Control.Monad.Fail as Fail
import Control.Monad.IO.Class
import Control.Monad.Identity (Identity(..))
import Control.Monad.Reader.Class as Reader
import Control.Monad.State.Class
import Control.Monad.Trans.Class
import Control.Monad.Writer.Class as Writer
import Data.Functor.Bind
import Data.Functor.Extend

type Co w = CoT w Identity

co :: Functor w => (forall r. w (a -> r) -> r) -> Co w a
co :: forall (w :: * -> *) a.
Functor w =>
(forall r. w (a -> r) -> r) -> Co w a
co forall r. w (a -> r) -> r
f = forall {k} (w :: * -> *) (m :: k -> *) a.
(forall (r :: k). w (a -> m r) -> m r) -> CoT w m a
CoT (forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. w (a -> r) -> r
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Identity a -> a
runIdentity))

runCo :: Functor w => Co w a -> w (a -> r) -> r
runCo :: forall (w :: * -> *) a r. Functor w => Co w a -> w (a -> r) -> r
runCo Co w a
m = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (w :: * -> *) (m :: k -> *) a.
CoT w m a -> forall (r :: k). w (a -> m r) -> m r
runCoT Co w a
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Identity a
Identity)

-- |
-- @
-- 'Co' w a ~ 'Data.Functor.Kan.Rift.Rift' w 'Identity' a
-- @
newtype CoT w m a = CoT { forall {k} (w :: * -> *) (m :: k -> *) a.
CoT w m a -> forall (r :: k). w (a -> m r) -> m r
runCoT :: forall r. w (a -> m r) -> m r }

instance Functor w => Functor (CoT w m) where
  fmap :: forall a b. (a -> b) -> CoT w m a -> CoT w m b
fmap a -> b
f (CoT forall (r :: k). w (a -> m r) -> m r
w) = forall {k} (w :: * -> *) (m :: k -> *) a.
(forall (r :: k). w (a -> m r) -> m r) -> CoT w m a
CoT (forall (r :: k). w (a -> m r) -> m r
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))

instance Extend w => Apply (CoT w m) where
  CoT w m (a -> b)
mf <.> :: forall a b. CoT w m (a -> b) -> CoT w m a -> CoT w m b
<.> CoT w m a
ma = CoT w m (a -> b)
mf forall (m :: * -> *) a b. Bind m => m a -> (a -> m b) -> m b
>>- \a -> b
f -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f CoT w m a
ma

instance Extend w => Bind (CoT w m) where
  CoT forall (r :: k). w (a -> m r) -> m r
k >>- :: forall a b. CoT w m a -> (a -> CoT w m b) -> CoT w m b
>>- a -> CoT w m b
f = forall {k} (w :: * -> *) (m :: k -> *) a.
(forall (r :: k). w (a -> m r) -> m r) -> CoT w m a
CoT (forall (r :: k). w (a -> m r) -> m r
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended (\w (b -> m r)
wa a
a -> forall {k} (w :: * -> *) (m :: k -> *) a.
CoT w m a -> forall (r :: k). w (a -> m r) -> m r
runCoT (a -> CoT w m b
f a
a) w (b -> m r)
wa))

instance Comonad w => Applicative (CoT w m) where
  pure :: forall a. a -> CoT w m a
pure a
a = forall {k} (w :: * -> *) (m :: k -> *) a.
(forall (r :: k). w (a -> m r) -> m r) -> CoT w m a
CoT (forall (w :: * -> *) a. Comonad w => w a -> a
`extract` a
a)
  CoT w m (a -> b)
mf <*> :: forall a b. CoT w m (a -> b) -> CoT w m a -> CoT w m b
<*> CoT w m a
ma = CoT w m (a -> b)
mf forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a -> b
f -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f CoT w m a
ma

instance Comonad w => Monad (CoT w m) where
  return :: forall a. a -> CoT w m a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  CoT forall (r :: k). w (a -> m r) -> m r
k >>= :: forall a b. CoT w m a -> (a -> CoT w m b) -> CoT w m b
>>= a -> CoT w m b
f = forall {k} (w :: * -> *) (m :: k -> *) a.
(forall (r :: k). w (a -> m r) -> m r) -> CoT w m a
CoT (forall (r :: k). w (a -> m r) -> m r
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (w :: * -> *) a b. Comonad w => (w a -> b) -> w a -> w b
extend (\w (b -> m r)
wa a
a -> forall {k} (w :: * -> *) (m :: k -> *) a.
CoT w m a -> forall (r :: k). w (a -> m r) -> m r
runCoT (a -> CoT w m b
f a
a) w (b -> m r)
wa))

instance (Comonad w, Fail.MonadFail m) => Fail.MonadFail (CoT w m) where
  fail :: forall a. String -> CoT w m a
fail String
msg = forall {k} (w :: * -> *) (m :: k -> *) a.
(forall (r :: k). w (a -> m r) -> m r) -> CoT w m a
CoT forall a b. (a -> b) -> a -> b
$ \ w (a -> m r)
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
msg

instance Comonad w => MonadTrans (CoT w) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> CoT w m a
lift m a
m = forall {k} (w :: * -> *) (m :: k -> *) a.
(forall (r :: k). w (a -> m r) -> m r) -> CoT w m a
CoT (forall (w :: * -> *) a. Comonad w => w a -> a
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (m a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=))

instance (Comonad w, MonadIO m) => MonadIO (CoT w m) where
  liftIO :: forall a. IO a -> CoT w m a
liftIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

liftCoT0 :: Comonad w => (forall a. w a -> s) -> CoT w m s
liftCoT0 :: forall {k} (w :: * -> *) s (m :: k -> *).
Comonad w =>
(forall a. w a -> s) -> CoT w m s
liftCoT0 forall a. w a -> s
f = forall {k} (w :: * -> *) (m :: k -> *) a.
(forall (r :: k). w (a -> m r) -> m r) -> CoT w m a
CoT (forall (w :: * -> *) a. Comonad w => w a -> a
extract forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. w a -> s
f)

lowerCoT0 :: (Functor w, Monad m) => CoT w m s -> w a -> m s
lowerCoT0 :: forall (w :: * -> *) (m :: * -> *) s a.
(Functor w, Monad m) =>
CoT w m s -> w a -> m s
lowerCoT0 CoT w m s
m = forall {k} (w :: * -> *) (m :: k -> *) a.
CoT w m a -> forall (r :: k). w (a -> m r) -> m r
runCoT CoT w m s
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (m :: * -> *) a. Monad m => a -> m a
return forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$)

lowerCo0 :: Functor w => Co w s -> w a -> s
lowerCo0 :: forall (w :: * -> *) s a. Functor w => Co w s -> w a -> s
lowerCo0 Co w s
m = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (w :: * -> *) (m :: k -> *) a.
CoT w m a -> forall (r :: k). w (a -> m r) -> m r
runCoT Co w s
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (m :: * -> *) a. Monad m => a -> m a
return forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$)

liftCoT1 :: (forall a. w a -> a) -> CoT w m ()
liftCoT1 :: forall {k} (w :: * -> *) (m :: k -> *).
(forall a. w a -> a) -> CoT w m ()
liftCoT1 forall a. w a -> a
f = forall {k} (w :: * -> *) (m :: k -> *) a.
(forall (r :: k). w (a -> m r) -> m r) -> CoT w m a
CoT (forall a. w a -> a
`f` ())

lowerCoT1 :: (Functor w, Monad m) => CoT w m () -> w a -> m a
lowerCoT1 :: forall (w :: * -> *) (m :: * -> *) a.
(Functor w, Monad m) =>
CoT w m () -> w a -> m a
lowerCoT1 CoT w m ()
m = forall {k} (w :: * -> *) (m :: k -> *) a.
CoT w m a -> forall (r :: k). w (a -> m r) -> m r
runCoT CoT w m ()
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return)

lowerCo1 :: Functor w => Co w () -> w a -> a
lowerCo1 :: forall (w :: * -> *) a. Functor w => Co w () -> w a -> a
lowerCo1 Co w ()
m = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (w :: * -> *) (m :: k -> *) a.
CoT w m a -> forall (r :: k). w (a -> m r) -> m r
runCoT Co w ()
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return)

posW :: ComonadStore s w => CoT w m s
posW :: forall {k} s (w :: * -> *) (m :: k -> *).
ComonadStore s w =>
CoT w m s
posW = forall {k} (w :: * -> *) s (m :: k -> *).
Comonad w =>
(forall a. w a -> s) -> CoT w m s
liftCoT0 forall s (w :: * -> *) a. ComonadStore s w => w a -> s
pos

peekW :: ComonadStore s w => s -> CoT w m ()
peekW :: forall {k} s (w :: * -> *) (m :: k -> *).
ComonadStore s w =>
s -> CoT w m ()
peekW s
s = forall {k} (w :: * -> *) (m :: k -> *).
(forall a. w a -> a) -> CoT w m ()
liftCoT1 (forall s (w :: * -> *) a. ComonadStore s w => s -> w a -> a
peek s
s)

peeksW :: ComonadStore s w => (s -> s) -> CoT w m ()
peeksW :: forall {k} s (w :: * -> *) (m :: k -> *).
ComonadStore s w =>
(s -> s) -> CoT w m ()
peeksW s -> s
f = forall {k} (w :: * -> *) (m :: k -> *).
(forall a. w a -> a) -> CoT w m ()
liftCoT1 (forall s (w :: * -> *) a. ComonadStore s w => (s -> s) -> w a -> a
peeks s -> s
f)

askW :: ComonadEnv e w => CoT w m e
askW :: forall {k} e (w :: * -> *) (m :: k -> *).
ComonadEnv e w =>
CoT w m e
askW = forall {k} (w :: * -> *) s (m :: k -> *).
Comonad w =>
(forall a. w a -> s) -> CoT w m s
liftCoT0 (forall e (w :: * -> *) a. ComonadEnv e w => w a -> e
Env.ask)

asksW :: ComonadEnv e w => (e -> a) -> CoT w m a
asksW :: forall {k} e (w :: * -> *) a (m :: k -> *).
ComonadEnv e w =>
(e -> a) -> CoT w m a
asksW e -> a
f = forall {k} (w :: * -> *) s (m :: k -> *).
Comonad w =>
(forall a. w a -> s) -> CoT w m s
liftCoT0 (forall e (w :: * -> *) e' a.
ComonadEnv e w =>
(e -> e') -> w a -> e'
Env.asks e -> a
f)

traceW :: ComonadTraced e w => e -> CoT w m ()
traceW :: forall {k} e (w :: * -> *) (m :: k -> *).
ComonadTraced e w =>
e -> CoT w m ()
traceW e
e = forall {k} (w :: * -> *) (m :: k -> *).
(forall a. w a -> a) -> CoT w m ()
liftCoT1 (forall m (w :: * -> *) a. ComonadTraced m w => m -> w a -> a
Traced.trace e
e)

liftCoT0M :: (Comonad w, Monad m) => (forall a. w a -> m s) -> CoT w m s
liftCoT0M :: forall (w :: * -> *) (m :: * -> *) s.
(Comonad w, Monad m) =>
(forall a. w a -> m s) -> CoT w m s
liftCoT0M forall a. w a -> m s
f = forall {k} (w :: * -> *) (m :: k -> *) a.
(forall (r :: k). w (a -> m r) -> m r) -> CoT w m a
CoT (\w (s -> m r)
wa -> forall (w :: * -> *) a. Comonad w => w a -> a
extract w (s -> m r)
wa forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. w a -> m s
f w (s -> m r)
wa)

liftCoT1M :: Monad m => (forall a. w a -> m a) -> CoT w m ()
liftCoT1M :: forall (m :: * -> *) (w :: * -> *).
Monad m =>
(forall a. w a -> m a) -> CoT w m ()
liftCoT1M forall a. w a -> m a
f = forall {k} (w :: * -> *) (m :: k -> *) a.
(forall (r :: k). w (a -> m r) -> m r) -> CoT w m a
CoT ((forall a b. (a -> b) -> a -> b
$ ()) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. w a -> m a
f)

diter :: Functor f => a -> (a -> f a) -> Density (Cofree f) a
diter :: forall (f :: * -> *) a.
Functor f =>
a -> (a -> f a) -> Density (Cofree f) a
diter a
x a -> f a
y = forall (w :: * -> *) a. Comonad w => w a -> Density w a
liftDensity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => (a -> f a) -> a -> Cofree f a
coiter a -> f a
y forall a b. (a -> b) -> a -> b
$ a
x

dctrlM :: Monad m => (forall a. w a -> m (w a)) -> CoT (Density w) m ()
dctrlM :: forall {k} (m :: * -> *) (w :: k -> *).
Monad m =>
(forall (a :: k). w a -> m (w a)) -> CoT (Density w) m ()
dctrlM forall (a :: k). w a -> m (w a)
k = forall (m :: * -> *) (w :: * -> *).
Monad m =>
(forall a. w a -> m a) -> CoT w m ()
liftCoT1M (\(Density w b -> a
w w b
a) -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM w b -> a
w (forall (a :: k). w a -> m (w a)
k w b
a))

instance (Comonad w, MonadReader e m) => MonadReader e (CoT w m) where
  ask :: CoT w m e
ask = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall r (m :: * -> *). MonadReader r m => m r
Reader.ask
  local :: forall a. (e -> e) -> CoT w m a -> CoT w m a
local e -> e
f CoT w m a
m = forall {k} (w :: * -> *) (m :: k -> *) a.
(forall (r :: k). w (a -> m r) -> m r) -> CoT w m a
CoT (forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local e -> e
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (w :: * -> *) (m :: k -> *) a.
CoT w m a -> forall (r :: k). w (a -> m r) -> m r
runCoT CoT w m a
m)

instance (Comonad w, MonadState s m) => MonadState s (CoT w m) where
  get :: CoT w m s
get = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall s (m :: * -> *). MonadState s m => m s
get
  put :: s -> CoT w m ()
put = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadState s m => s -> m ()
put

instance (Comonad w, MonadWriter e m) => MonadWriter e (CoT w m) where
  tell :: e -> CoT w m ()
tell = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
  pass :: forall a. CoT w m (a, e -> e) -> CoT w m a
pass CoT w m (a, e -> e)
m = forall {k} (w :: * -> *) (m :: k -> *) a.
(forall (r :: k). w (a -> m r) -> m r) -> CoT w m a
CoT (forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (w :: * -> *) (m :: k -> *) a.
CoT w m a -> forall (r :: k). w (a -> m r) -> m r
runCoT CoT w m (a, e -> e)
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {m :: * -> *} {t} {a} {b}.
Monad m =>
(t -> m a) -> (t, b) -> m (a, b)
aug) where
    aug :: (t -> m a) -> (t, b) -> m (a, b)
aug t -> m a
f (t
a,b
e) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\a
r -> (a
r,b
e)) (t -> m a
f t
a)
  listen :: forall a. CoT w m a -> CoT w m (a, e)
listen = forall a. HasCallStack => String -> a
error String
"Control.Monad.Co.listen: TODO"

instance (Comonad w, MonadError e m) => MonadError e (CoT w m) where
  throwError :: forall a. e -> CoT w m a
throwError = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  catchError :: forall a. CoT w m a -> (e -> CoT w m a) -> CoT w m a
catchError = forall a. HasCallStack => String -> a
error String
"Control.Monad.Co.catchError: TODO"