{-# 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 <[email protected]>
-- 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 :: forall a r. ((a -> r) -> r) -> Cont r a
cont (a -> r) -> r
f = forall r (w :: * -> *) (m :: * -> *) a.
(w (a -> m r) -> m r) -> ContsT r w m a
ContsT forall a b. (a -> b) -> a -> b
$ \ (Identity a -> Identity r
k) -> forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ (a -> r) -> r
f forall a b. (a -> b) -> a -> b
$ forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Identity r
k

runCont :: Cont r a -> (a -> r) -> r
runCont :: forall r a. Cont r a -> (a -> r) -> r
runCont (ContsT Identity (a -> Identity r) -> Identity r
k) a -> r
f = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ Identity (a -> Identity r) -> Identity r
k forall a b. (a -> b) -> a -> b
$ forall a. a -> Identity a
Identity (forall a. a -> Identity a
Identity 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 :: forall (w :: * -> *) a r.
Functor w =>
(w (a -> r) -> r) -> Conts r w a
conts w (a -> r) -> r
k = forall r (w :: * -> *) (m :: * -> *) a.
(w (a -> m r) -> m r) -> ContsT r w m a
ContsT forall a b. (a -> b) -> a -> b
$ forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. w (a -> r) -> r
k 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. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
.)

runConts :: Functor w => Conts r w a -> w (a -> r) -> r
runConts :: forall (w :: * -> *) r a.
Functor w =>
Conts r w a -> w (a -> r) -> r
runConts (ContsT w (a -> Identity r) -> Identity r
k) = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. w (a -> Identity r) -> Identity r
k 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. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
.)

newtype ContsT r w m a = ContsT { forall r (w :: * -> *) (m :: * -> *) a.
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 :: forall a b. (a -> b) -> ContsT r w m a -> ContsT r w m b
fmap a -> b
f (ContsT w (a -> m r) -> m r
k) = forall r (w :: * -> *) (m :: * -> *) a.
(w (a -> m r) -> m r) -> ContsT r w m a
ContsT forall a b. (a -> b) -> a -> b
$ w (a -> m r) -> m r
k 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 Comonad w => Apply (ContsT r w m) where
  <.> :: forall a 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 :: forall a. a -> ContsT r w m a
pure a
x = forall r (w :: * -> *) (m :: * -> *) a.
(w (a -> m r) -> m r) -> ContsT r w m a
ContsT forall a b. (a -> b) -> a -> b
$ \w (a -> m r)
f -> forall (w :: * -> *) a. Comonad w => w a -> a
extract w (a -> m r)
f a
x
  <*> :: forall a 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 :: forall a. a -> ContsT r w m a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ContsT w (a -> m r) -> m r
k >>= :: forall a b.
ContsT r w m a -> (a -> ContsT r w m b) -> ContsT r w m b
>>= a -> ContsT r w m b
f = forall r (w :: * -> *) (m :: * -> *) a.
(w (a -> m r) -> m r) -> ContsT r w m a
ContsT forall a b. (a -> b) -> a -> b
$ 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 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 :: forall (w :: * -> *) a r (m :: * -> *) b.
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
f = forall r (w :: * -> *) (m :: * -> *) a.
(w (a -> m r) -> m r) -> ContsT r w m a
ContsT forall a b. (a -> b) -> a -> b
$ \w (a -> m r)
wamr -> 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 -> forall r (w :: * -> *) (m :: * -> *) a.
(w (a -> m r) -> m r) -> ContsT r w m a
ContsT forall a b. (a -> b) -> a -> b
$ \w (b -> 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 :: forall (m :: * -> *) a. Monad m => m a -> ContsT r w m a
lift m a
m = forall r (w :: * -> *) (m :: * -> *) a.
(w (a -> m r) -> m r) -> ContsT r w m a
ContsT forall a b. (a -> b) -> a -> b
$ 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
>>=)