{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiParamTypeClasses #-}
#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710
{-# LANGUAGE Trustworthy #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2011-2013 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  MPTCs, fundeps
--
-- > Cont r ~ Contravariant.Adjoint (Op r) (Op r)
-- > Conts r ~ Contravariant.AdjointT (Op r) (Op r)
-- > ContsT r w m ~ Contravariant.AdjointT (Op (m r)) (Op (m r)) w
----------------------------------------------------------------------------

module Control.Monad.Trans.Conts
  (
  -- * Continuation passing style
    Cont
  , cont
  , runCont
  -- * Multiple-continuation passing style
  , Conts
  , runConts
  , conts
  -- * Multiple-continuation passing style transformer
  , ContsT(..)
  , callCC
  ) where

import Prelude hiding (sequence)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Comonad
import Control.Monad.Trans.Class
import Control.Monad (ap)
import Data.Functor.Apply
import Data.Functor.Identity

type Cont r = ContsT r Identity Identity

cont :: ((a -> r) -> r) -> Cont r a
cont :: ((a -> r) -> r) -> Cont r a
cont (a -> r) -> r
f = (Identity (a -> Identity r) -> Identity r) -> Cont r a
forall r (w :: * -> *) (m :: * -> *) a.
(w (a -> m r) -> m r) -> ContsT r w m a
ContsT ((Identity (a -> Identity r) -> Identity r) -> Cont r a)
-> (Identity (a -> Identity r) -> Identity r) -> Cont r a
forall a b. (a -> b) -> a -> b
$ \ (Identity a -> Identity r
k) -> r -> Identity r
forall a. a -> Identity a
Identity (r -> Identity r) -> r -> Identity r
forall a b. (a -> b) -> a -> b
$ (a -> r) -> r
f ((a -> r) -> r) -> (a -> r) -> r
forall a b. (a -> b) -> a -> b
$ Identity r -> r
forall a. Identity a -> a
runIdentity (Identity r -> r) -> (a -> Identity r) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Identity r
k

runCont :: Cont r a -> (a -> r) -> r
runCont :: Cont r a -> (a -> r) -> r
runCont (ContsT Identity (a -> Identity r) -> Identity r
k) a -> r
f = Identity r -> r
forall a. Identity a -> a
runIdentity (Identity r -> r) -> Identity r -> r
forall a b. (a -> b) -> a -> b
$ Identity (a -> Identity r) -> Identity r
k (Identity (a -> Identity r) -> Identity r)
-> Identity (a -> Identity r) -> Identity r
forall a b. (a -> b) -> a -> b
$ (a -> Identity r) -> Identity (a -> Identity r)
forall a. a -> Identity a
Identity (r -> Identity r
forall a. a -> Identity a
Identity (r -> Identity r) -> (a -> r) -> a -> Identity r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> r
f)

type Conts r w = ContsT r w Identity

conts :: Functor w => (w (a -> r) -> r) -> Conts r w a
conts :: (w (a -> r) -> r) -> Conts r w a
conts w (a -> r) -> r
k = (w (a -> Identity r) -> Identity r) -> Conts r w a
forall r (w :: * -> *) (m :: * -> *) a.
(w (a -> m r) -> m r) -> ContsT r w m a
ContsT ((w (a -> Identity r) -> Identity r) -> Conts r w a)
-> (w (a -> Identity r) -> Identity r) -> Conts r w a
forall a b. (a -> b) -> a -> b
$ r -> Identity r
forall a. a -> Identity a
Identity (r -> Identity r)
-> (w (a -> Identity r) -> r) -> w (a -> Identity r) -> Identity r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w (a -> r) -> r
k (w (a -> r) -> r)
-> (w (a -> Identity r) -> w (a -> r)) -> w (a -> Identity r) -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> Identity r) -> a -> r) -> w (a -> Identity r) -> w (a -> r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Identity r -> r
forall a. Identity a -> a
runIdentity (Identity r -> r) -> (a -> Identity r) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)

runConts :: Functor w => Conts r w a -> w (a -> r) -> r
runConts :: Conts r w a -> w (a -> r) -> r
runConts (ContsT w (a -> Identity r) -> Identity r
k) = Identity r -> r
forall a. Identity a -> a
runIdentity (Identity r -> r) -> (w (a -> r) -> Identity r) -> w (a -> r) -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w (a -> Identity r) -> Identity r
k (w (a -> Identity r) -> Identity r)
-> (w (a -> r) -> w (a -> Identity r)) -> w (a -> r) -> Identity r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> r) -> a -> Identity r) -> w (a -> r) -> w (a -> Identity r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (r -> Identity r
forall a. a -> Identity a
Identity (r -> Identity r) -> (a -> r) -> a -> Identity r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)

newtype ContsT r w m a = ContsT { ContsT r w m a -> w (a -> m r) -> m r
runContsT :: w (a -> m r) -> m r }

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

instance Comonad w => Apply (ContsT r w m) where
  <.> :: ContsT r w m (a -> b) -> ContsT r w m a -> ContsT r w m b
(<.>) = ContsT r w m (a -> b) -> ContsT r w m a -> ContsT r w m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Comonad w => Applicative (ContsT r w m) where
  pure :: a -> ContsT r w m a
pure a
x = (w (a -> m r) -> m r) -> ContsT r w m a
forall r (w :: * -> *) (m :: * -> *) a.
(w (a -> m r) -> m r) -> ContsT r w m a
ContsT ((w (a -> m r) -> m r) -> ContsT r w m a)
-> (w (a -> m r) -> m r) -> ContsT r w m a
forall a b. (a -> b) -> a -> b
$ \w (a -> m r)
f -> w (a -> m r) -> a -> m r
forall (w :: * -> *) a. Comonad w => w a -> a
extract w (a -> m r)
f a
x
  <*> :: ContsT r w m (a -> b) -> ContsT r w m a -> ContsT r w m b
(<*>) = ContsT r w m (a -> b) -> ContsT r w m a -> ContsT r w m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Comonad w => Monad (ContsT r w m) where
  return :: a -> ContsT r w m a
return = a -> ContsT r w m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ContsT w (a -> m r) -> m r
k >>= :: ContsT r w m a -> (a -> ContsT r w m b) -> ContsT r w m b
>>= a -> ContsT r w m b
f = (w (b -> m r) -> m r) -> ContsT r w m b
forall r (w :: * -> *) (m :: * -> *) a.
(w (a -> m r) -> m r) -> ContsT r w m a
ContsT ((w (b -> m r) -> m r) -> ContsT r w m b)
-> (w (b -> m r) -> m r) -> ContsT r w m b
forall a b. (a -> b) -> a -> b
$ w (a -> m r) -> m r
k (w (a -> m r) -> m r)
-> (w (b -> m r) -> w (a -> m r)) -> w (b -> m r) -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (w (b -> m r) -> a -> m r) -> w (b -> m r) -> w (a -> m r)
forall (w :: * -> *) a b. Comonad w => (w a -> b) -> w a -> w b
extend (\w (b -> m r)
wa a
a -> ContsT r w m b -> w (b -> m r) -> m r
forall r (w :: * -> *) (m :: * -> *) a.
ContsT r w m a -> w (a -> m r) -> m r
runContsT (a -> ContsT r w m b
f a
a) w (b -> m r)
wa)

callCC :: Comonad w => ((a -> ContsT r w m b) -> ContsT r w m a) -> ContsT r w m a
callCC :: ((a -> ContsT r w m b) -> ContsT r w m a) -> ContsT r w m a
callCC (a -> ContsT r w m b) -> ContsT r w m a
f = (w (a -> m r) -> m r) -> ContsT r w m a
forall r (w :: * -> *) (m :: * -> *) a.
(w (a -> m r) -> m r) -> ContsT r w m a
ContsT ((w (a -> m r) -> m r) -> ContsT r w m a)
-> (w (a -> m r) -> m r) -> ContsT r w m a
forall a b. (a -> b) -> a -> b
$ \w (a -> m r)
wamr -> ContsT r w m a -> w (a -> m r) -> m r
forall r (w :: * -> *) (m :: * -> *) a.
ContsT r w m a -> w (a -> m r) -> m r
runContsT ((a -> ContsT r w m b) -> ContsT r w m a
f (\a
a -> (w (b -> m r) -> m r) -> ContsT r w m b
forall r (w :: * -> *) (m :: * -> *) a.
(w (a -> m r) -> m r) -> ContsT r w m a
ContsT ((w (b -> m r) -> m r) -> ContsT r w m b)
-> (w (b -> m r) -> m r) -> ContsT r w m b
forall a b. (a -> b) -> a -> b
$ \w (b -> m r)
_ -> w (a -> m r) -> a -> m r
forall (w :: * -> *) a. Comonad w => w a -> a
extract w (a -> m r)
wamr a
a)) w (a -> m r)
wamr

{-
callCCs :: Comonad w => (w (a -> ContsT r w m b) -> ContsT r w m a) -> ContsT r w m a
callCCs f =
-}

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