{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Safe #-}
#endif
#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif
#if __GLASGOW_HASKELL__ >= 710
{-# LANGUAGE AutoDeriveTypeable #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Trans.Cont
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  R.Paterson@city.ac.uk
-- Stability   :  experimental
-- Portability :  portable
--
-- Continuation monads.
--
-- Delimited continuation operators are taken from Kenichi Asai and Oleg
-- Kiselyov's tutorial at CW 2011, \"Introduction to programming with
-- shift and reset\" (<http://okmij.org/ftp/continuations/#tutorial>).
--
-----------------------------------------------------------------------------

module Control.Monad.Trans.Cont (
    -- * The Cont monad
    Cont,
    cont,
    runCont,
    evalCont,
    mapCont,
    withCont,
    -- ** Delimited continuations
    reset, shift,
    -- * The ContT monad transformer
    ContT(..),
    evalContT,
    mapContT,
    withContT,
    callCC,
    -- ** Delimited continuations
    resetT, shiftT,
    -- * Lifting other operations
    liftLocal,
  ) where

import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Data.Functor.Identity

import Control.Applicative
#if MIN_VERSION_base(4,9,0)
import qualified Control.Monad.Fail as Fail
#endif

{- |
Continuation monad.
@Cont r a@ is a CPS ("continuation-passing style") computation that produces an
intermediate result of type @a@ within a CPS computation whose final result type
is @r@.

The @return@ function simply creates a continuation which passes the value on.

The @>>=@ operator adds the bound function into the continuation chain.
-}
type Cont r = ContT r Identity

-- | Construct a continuation-passing computation from a function.
-- (The inverse of 'runCont')
cont :: ((a -> r) -> r) -> Cont r a
cont :: ((a -> r) -> r) -> Cont r a
cont (a -> r) -> r
f = ((a -> Identity r) -> Identity r) -> Cont r a
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (\ a -> Identity r
c -> r -> Identity r
forall a. a -> Identity a
Identity ((a -> r) -> r
f (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
c)))
{-# INLINE cont #-}

-- | The result of running a CPS computation with a given final continuation.
-- (The inverse of 'cont')
runCont
    :: Cont r a         -- ^ continuation computation (@Cont@).
    -> (a -> r)         -- ^ the final continuation, which produces
                        -- the final result (often 'id').
    -> r
runCont :: Cont r a -> (a -> r) -> r
runCont Cont r a
m a -> r
k = Identity r -> r
forall a. Identity a -> a
runIdentity (Cont r a -> (a -> Identity r) -> Identity r
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
runContT Cont r a
m (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
k))
{-# INLINE runCont #-}

-- | The result of running a CPS computation with the identity as the
-- final continuation.
--
-- * @'evalCont' ('return' x) = x@
evalCont :: Cont r r -> r
evalCont :: Cont r r -> r
evalCont Cont r r
m = Identity r -> r
forall a. Identity a -> a
runIdentity (Cont r r -> Identity r
forall (m :: * -> *) r. Monad m => ContT r m r -> m r
evalContT Cont r r
m)
{-# INLINE evalCont #-}

-- | Apply a function to transform the result of a continuation-passing
-- computation.
--
-- * @'runCont' ('mapCont' f m) = f . 'runCont' m@
mapCont :: (r -> r) -> Cont r a -> Cont r a
mapCont :: (r -> r) -> Cont r a -> Cont r a
mapCont r -> r
f = (Identity r -> Identity r) -> Cont r a -> Cont r a
forall k (m :: k -> *) (r :: k) a.
(m r -> m r) -> ContT r m a -> ContT r m a
mapContT (r -> Identity r
forall a. a -> Identity a
Identity (r -> Identity r) -> (Identity r -> r) -> Identity r -> Identity r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> r
f (r -> r) -> (Identity r -> r) -> Identity r -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity r -> r
forall a. Identity a -> a
runIdentity)
{-# INLINE mapCont #-}

-- | Apply a function to transform the continuation passed to a CPS
-- computation.
--
-- * @'runCont' ('withCont' f m) = 'runCont' m . f@
withCont :: ((b -> r) -> (a -> r)) -> Cont r a -> Cont r b
withCont :: ((b -> r) -> a -> r) -> Cont r a -> Cont r b
withCont (b -> r) -> a -> r
f = ((b -> Identity r) -> a -> Identity r) -> Cont r a -> Cont r b
forall k b (m :: k -> *) (r :: k) a.
((b -> m r) -> a -> m r) -> ContT r m a -> ContT r m b
withContT ((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) -> a -> Identity r)
-> ((b -> Identity r) -> a -> r)
-> (b -> Identity r)
-> a
-> Identity r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> r) -> a -> r
f ((b -> r) -> a -> r)
-> ((b -> Identity r) -> b -> r) -> (b -> Identity r) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identity r -> r
forall a. Identity a -> a
runIdentity (Identity r -> r) -> (b -> Identity r) -> b -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.))
{-# INLINE withCont #-}

-- | @'reset' m@ delimits the continuation of any 'shift' inside @m@.
--
-- * @'reset' ('return' m) = 'return' m@
--
reset :: Cont r r -> Cont r' r
reset :: Cont r r -> Cont r' r
reset = Cont r r -> Cont r' r
forall (m :: * -> *) r r'. Monad m => ContT r m r -> ContT r' m r
resetT
{-# INLINE reset #-}

-- | @'shift' f@ captures the continuation up to the nearest enclosing
-- 'reset' and passes it to @f@:
--
-- * @'reset' ('shift' f >>= k) = 'reset' (f ('evalCont' . k))@
--
shift :: ((a -> r) -> Cont r r) -> Cont r a
shift :: ((a -> r) -> Cont r r) -> Cont r a
shift (a -> r) -> Cont r r
f = ((a -> Identity r) -> Cont r r) -> Cont r a
forall (m :: * -> *) a r.
Monad m =>
((a -> m r) -> ContT r m r) -> ContT r m a
shiftT ((a -> r) -> Cont r r
f ((a -> r) -> Cont r r)
-> ((a -> Identity r) -> a -> r) -> (a -> Identity r) -> Cont r r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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
.))
{-# INLINE shift #-}

-- | The continuation monad transformer.
-- Can be used to add continuation handling to any type constructor:
-- the 'Monad' instance and most of the operations do not require @m@
-- to be a monad.
--
-- 'ContT' is not a functor on the category of monads, and many operations
-- cannot be lifted through it.
newtype ContT r m a = ContT { ContT r m a -> (a -> m r) -> m r
runContT :: (a -> m r) -> m r }

-- | The result of running a CPS computation with 'return' as the
-- final continuation.
--
-- * @'evalContT' ('lift' m) = m@
evalContT :: (Monad m) => ContT r m r -> m r
evalContT :: ContT r m r -> m r
evalContT ContT r m r
m = ContT r m r -> (r -> m r) -> m r
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
runContT ContT r m r
m r -> m r
forall (m :: * -> *) a. Monad m => a -> m a
return
{-# INLINE evalContT #-}

-- | Apply a function to transform the result of a continuation-passing
-- computation.  This has a more restricted type than the @map@ operations
-- for other monad transformers, because 'ContT' does not define a functor
-- in the category of monads.
--
-- * @'runContT' ('mapContT' f m) = f . 'runContT' m@
mapContT :: (m r -> m r) -> ContT r m a -> ContT r m a
mapContT :: (m r -> m r) -> ContT r m a -> ContT r m a
mapContT m r -> m r
f ContT r m a
m = ((a -> m r) -> m r) -> ContT r m a
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((a -> m r) -> m r) -> ContT r m a)
-> ((a -> m r) -> m r) -> ContT r m a
forall a b. (a -> b) -> a -> b
$ m r -> m r
f (m r -> m r) -> ((a -> m r) -> m r) -> (a -> m r) -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContT r m a -> (a -> m r) -> m r
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
runContT ContT r m a
m
{-# INLINE mapContT #-}

-- | Apply a function to transform the continuation passed to a CPS
-- computation.
--
-- * @'runContT' ('withContT' f m) = 'runContT' m . f@
withContT :: ((b -> m r) -> (a -> m r)) -> ContT r m a -> ContT r m b
withContT :: ((b -> m r) -> a -> m r) -> ContT r m a -> ContT r m b
withContT (b -> m r) -> a -> m r
f ContT r m a
m = ((b -> m r) -> m r) -> ContT r m b
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((b -> m r) -> m r) -> ContT r m b)
-> ((b -> m r) -> m r) -> ContT r m b
forall a b. (a -> b) -> a -> b
$ ContT r m a -> (a -> m r) -> m r
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
runContT ContT r m a
m ((a -> m r) -> m r)
-> ((b -> m r) -> a -> m r) -> (b -> m r) -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> m r) -> a -> m r
f
{-# INLINE withContT #-}

instance Functor (ContT r m) where
    fmap :: (a -> b) -> ContT r m a -> ContT r m b
fmap a -> b
f ContT r m a
m = ((b -> m r) -> m r) -> ContT r m b
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((b -> m r) -> m r) -> ContT r m b)
-> ((b -> m r) -> m r) -> ContT r m b
forall a b. (a -> b) -> a -> b
$ \ b -> m r
c -> ContT r m a -> (a -> m r) -> m r
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
runContT ContT r m a
m (b -> m r
c (b -> m r) -> (a -> b) -> a -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)
    {-# INLINE fmap #-}

instance Applicative (ContT r m) where
    pure :: a -> ContT r m a
pure a
x  = ((a -> m r) -> m r) -> ContT r m a
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT ((a -> m r) -> a -> m r
forall a b. (a -> b) -> a -> b
$ a
x)
    {-# INLINE pure #-}
    ContT r m (a -> b)
f <*> :: ContT r m (a -> b) -> ContT r m a -> ContT r m b
<*> ContT r m a
v = ((b -> m r) -> m r) -> ContT r m b
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((b -> m r) -> m r) -> ContT r m b)
-> ((b -> m r) -> m r) -> ContT r m b
forall a b. (a -> b) -> a -> b
$ \ b -> m r
c -> ContT r m (a -> b) -> ((a -> b) -> m r) -> m r
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
runContT ContT r m (a -> b)
f (((a -> b) -> m r) -> m r) -> ((a -> b) -> m r) -> m r
forall a b. (a -> b) -> a -> b
$ \ a -> b
g -> ContT r m a -> (a -> m r) -> m r
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
runContT ContT r m a
v (b -> m r
c (b -> m r) -> (a -> b) -> a -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
g)
    {-# INLINE (<*>) #-}
    ContT r m a
m *> :: ContT r m a -> ContT r m b -> ContT r m b
*> ContT r m b
k = ContT r m a
m ContT r m a -> (a -> ContT r m b) -> ContT r m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
_ -> ContT r m b
k
    {-# INLINE (*>) #-}

instance Monad (ContT r m) where
#if !(MIN_VERSION_base(4,8,0))
    return x = ContT ($ x)
    {-# INLINE return #-}
#endif
    ContT r m a
m >>= :: ContT r m a -> (a -> ContT r m b) -> ContT r m b
>>= a -> ContT r m b
k  = ((b -> m r) -> m r) -> ContT r m b
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((b -> m r) -> m r) -> ContT r m b)
-> ((b -> m r) -> m r) -> ContT r m b
forall a b. (a -> b) -> a -> b
$ \ b -> m r
c -> ContT r m a -> (a -> m r) -> m r
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
runContT ContT r m a
m (\ a
x -> ContT r m b -> (b -> m r) -> m r
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
runContT (a -> ContT r m b
k a
x) b -> m r
c)
    {-# INLINE (>>=) #-}

#if MIN_VERSION_base(4,9,0)
instance (Fail.MonadFail m) => Fail.MonadFail (ContT r m) where
    fail :: String -> ContT r m a
fail String
msg = ((a -> m r) -> m r) -> ContT r m a
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((a -> m r) -> m r) -> ContT r m a)
-> ((a -> m r) -> m r) -> ContT r m a
forall a b. (a -> b) -> a -> b
$ \ a -> m r
_ -> String -> m r
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
msg
    {-# INLINE fail #-}
#endif

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

instance (MonadIO m) => MonadIO (ContT r m) where
    liftIO :: IO a -> ContT r m a
liftIO = m a -> ContT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ContT r m a) -> (IO a -> m a) -> IO a -> ContT r 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 #-}

-- | @callCC@ (call-with-current-continuation) calls its argument
-- function, passing it the current continuation.  It provides
-- an escape continuation mechanism for use with continuation
-- monads.  Escape continuations one allow to abort the current
-- computation and return a value immediately.  They achieve
-- a similar effect to 'Control.Monad.Trans.Except.throwE'
-- and 'Control.Monad.Trans.Except.catchE' within an
-- 'Control.Monad.Trans.Except.ExceptT' monad.  The advantage of this
-- function over calling 'return' is that it makes the continuation
-- explicit, allowing more flexibility and better control.
--
-- The standard idiom used with @callCC@ is to provide a lambda-expression
-- to name the continuation. Then calling the named continuation anywhere
-- within its scope will escape from the computation, even if it is many
-- layers deep within nested computations.
callCC :: ((a -> ContT r m b) -> ContT r m a) -> ContT r m a
callCC :: ((a -> ContT r m b) -> ContT r m a) -> ContT r m a
callCC (a -> ContT r m b) -> ContT r m a
f = ((a -> m r) -> m r) -> ContT r m a
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((a -> m r) -> m r) -> ContT r m a)
-> ((a -> m r) -> m r) -> ContT r m a
forall a b. (a -> b) -> a -> b
$ \ a -> m r
c -> ContT r m a -> (a -> m r) -> m r
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
runContT ((a -> ContT r m b) -> ContT r m a
f (\ a
x -> ((b -> m r) -> m r) -> ContT r m b
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((b -> m r) -> m r) -> ContT r m b)
-> ((b -> m r) -> m r) -> ContT r m b
forall a b. (a -> b) -> a -> b
$ \ b -> m r
_ -> a -> m r
c a
x)) a -> m r
c
{-# INLINE callCC #-}

-- | @'resetT' m@ delimits the continuation of any 'shiftT' inside @m@.
--
-- * @'resetT' ('lift' m) = 'lift' m@
--
resetT :: (Monad m) => ContT r m r -> ContT r' m r
resetT :: ContT r m r -> ContT r' m r
resetT = m r -> ContT r' m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m r -> ContT r' m r)
-> (ContT r m r -> m r) -> ContT r m r -> ContT r' m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContT r m r -> m r
forall (m :: * -> *) r. Monad m => ContT r m r -> m r
evalContT
{-# INLINE resetT #-}

-- | @'shiftT' f@ captures the continuation up to the nearest enclosing
-- 'resetT' and passes it to @f@:
--
-- * @'resetT' ('shiftT' f >>= k) = 'resetT' (f ('evalContT' . k))@
--
shiftT :: (Monad m) => ((a -> m r) -> ContT r m r) -> ContT r m a
shiftT :: ((a -> m r) -> ContT r m r) -> ContT r m a
shiftT (a -> m r) -> ContT r m r
f = ((a -> m r) -> m r) -> ContT r m a
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (ContT r m r -> m r
forall (m :: * -> *) r. Monad m => ContT r m r -> m r
evalContT (ContT r m r -> m r)
-> ((a -> m r) -> ContT r m r) -> (a -> m r) -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m r) -> ContT r m r
f)
{-# INLINE shiftT #-}

-- | @'liftLocal' ask local@ yields a @local@ function for @'ContT' r m@.
liftLocal :: (Monad m) => m r' -> ((r' -> r') -> m r -> m r) ->
    (r' -> r') -> ContT r m a -> ContT r m a
liftLocal :: m r'
-> ((r' -> r') -> m r -> m r)
-> (r' -> r')
-> ContT r m a
-> ContT r m a
liftLocal m r'
ask (r' -> r') -> m r -> m r
local r' -> r'
f ContT r m a
m = ((a -> m r) -> m r) -> ContT r m a
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((a -> m r) -> m r) -> ContT r m a)
-> ((a -> m r) -> m r) -> ContT r m a
forall a b. (a -> b) -> a -> b
$ \ a -> m r
c -> do
    r'
r <- m r'
ask
    (r' -> r') -> m r -> m r
local r' -> r'
f (ContT r m a -> (a -> m r) -> m r
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
runContT ContT r m a
m ((r' -> r') -> m r -> m r
local (r' -> r' -> r'
forall a b. a -> b -> a
const r'
r) (m r -> m r) -> (a -> m r) -> a -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m r
c))
{-# INLINE liftLocal #-}