{-# LANGUAGE TemplateHaskell #-}
-----------------------------------------------------------------------------

-- |

-- Module      :  Control.Effect.Cont

-- Copyright   :  (c) Michael Szvetits, 2020

-- License     :  BSD3 (see the file LICENSE)

-- Maintainer  :  typedbyte@qualified.name

-- Stability   :  stable

-- Portability :  portable

--

-- The continuation effect, similar to the @MonadCont@ type class from the

-- @mtl@ library.

-----------------------------------------------------------------------------

module Control.Effect.Cont
  ( -- * Tagged Continuation Effect

    Cont'(..)
    -- * Untagged Continuation Effect

    -- | If you don't require disambiguation of multiple continuation effects

    -- (i.e., you only have one continuation effect in your monadic context),

    -- it is recommended to always use the untagged continuation effect.

  , Cont
  , callCC
    -- * Interpretations

  , runCont'
  , runCont
  , evalCont'
  , evalCont
    -- * Tagging and Untagging

    -- | Conversion functions between the tagged and untagged continuation effect,

    -- usually used in combination with type applications, like:

    --

    -- @

    --     'tagCont'' \@\"newTag\" program

    --     'retagCont'' \@\"oldTag\" \@\"newTag\" program

    --     'untagCont'' \@\"erasedTag\" program

    -- @

    -- 

  , tagCont'
  , retagCont'
  , untagCont'
  ) where

-- transformers

import qualified Control.Monad.Trans.Cont as C

import Control.Effect.Machinery

-- | An effect that adds an abortive continuation to a computation.

class Monad m => Cont' tag m where
  -- | Adapted from the @mtl@ library documentation:

  --

  -- @callCC'@ (call-with-current-continuation) calls a function with the

  -- current continuation as its argument. Provides an escape continuation

  -- mechanism for use with continuation monads. Escape continuations allow to

  -- abort the current computation and return a value immediately. They achieve

  -- a similar result to 'Control.Effect.Error.throwError'' and

  -- 'Control.Effect.Error.catchError'' of the 'Control.Effect.Error.Error''

  -- effect. 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 -> m b) -> m a) -> m a

makeHandler ''Cont'
makeFinder  ''Cont'
makeTagger  ''Cont'

instance Control (Cont' tag) t m => Cont' tag (EachVia '[] t m) where
  callCC' :: ((a -> EachVia '[] t m b) -> EachVia '[] t m a)
-> EachVia '[] t m a
callCC' f :: (a -> EachVia '[] t m b) -> EachVia '[] t m a
f =
    (Run (EachVia '[] t) -> m (StT t a)) -> EachVia '[] t m (StT t a)
forall (t :: Transformer) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run t -> m a) -> t m a
liftWith
      ( \run :: Run (EachVia '[] t)
run -> forall k (tag :: k) (m :: * -> *) a b.
Cont' tag m =>
((a -> m b) -> m a) -> m a
forall (m :: * -> *) a b. Cont' tag m => ((a -> m b) -> m a) -> m a
callCC' @tag (((StT t a -> m b) -> m (StT t a)) -> m (StT t a))
-> ((StT t a -> m b) -> m (StT t a)) -> m (StT t a)
forall a b. (a -> b) -> a -> b
$ \c :: StT t a -> m b
c -> EachVia '[] t m a -> m (StT t a)
Run (EachVia '[] t)
run (EachVia '[] t m a -> m (StT t a))
-> ((a -> EachVia '[] t m b) -> EachVia '[] t m a)
-> (a -> EachVia '[] t m b)
-> m (StT t a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> EachVia '[] t m b) -> EachVia '[] t m a
f ((a -> EachVia '[] t m b) -> m (StT t a))
-> (a -> EachVia '[] t m b) -> m (StT t a)
forall a b. (a -> b) -> a -> b
$
          \a :: a
a -> m b -> EachVia '[] t m b
forall (t :: Transformer) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EachVia '[] t m a -> m (StT (EachVia '[] t) a)
Run (EachVia '[] t)
run (a -> EachVia '[] t m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a) m (StT t a) -> (StT t a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StT t a -> m b
c)
      )
      EachVia '[] t m (StT t a)
-> (StT t a -> EachVia '[] t m a) -> EachVia '[] t m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (StT t a) -> EachVia '[] t m a
forall (t :: Transformer) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
m (StT t a) -> t m a
restoreT (m (StT t a) -> EachVia '[] t m a)
-> (StT t a -> m (StT t a)) -> StT t a -> EachVia '[] t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StT t a -> m (StT t a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINEABLE callCC' #-}

instance Cont' tag (C.ContT r m) where
  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
forall k a (r :: k) (m :: k -> *) b.
((a -> ContT r m b) -> ContT r m a) -> ContT r m a
C.callCC
  {-# INLINE callCC' #-}

-- | Runs the continuation effect with a given final continuation.

runCont' :: forall tag r m a. (a -> m r) -> (Cont' tag `Via` C.ContT r) m a -> m r
runCont' :: (a -> m r) -> Via (Cont' tag) (ContT r) m a -> m r
runCont' f :: a -> m r
f = (ContT r m a -> (a -> m r) -> m r)
-> (a -> m r) -> ContT r m a -> m r
forall a b c. (a -> b -> c) -> b -> a -> c
flip 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
C.runContT a -> m r
f (ContT r m a -> m r)
-> (Via (Cont' tag) (ContT r) m a -> ContT r m a)
-> Via (Cont' tag) (ContT r) m a
-> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Via (Cont' tag) (ContT r) m a -> ContT r m a
forall (effs :: [(* -> *) -> Constraint]) (t :: Transformer)
       (m :: * -> *) a.
EachVia effs t m a -> t m a
runVia
{-# INLINE runCont' #-}

-- | The untagged version of 'runCont''.

runCont :: (a -> m r) -> (Cont `Via` C.ContT r) m a -> m r
runCont :: (a -> m r) -> Via (Cont' G) (ContT r) m a -> m r
runCont = forall k (tag :: k) r (m :: * -> *) a.
(a -> m r) -> Via (Cont' tag) (ContT r) m a -> m r
forall r (m :: * -> *) a.
(a -> m r) -> Via (Cont' G) (ContT r) m a -> m r
runCont' @G
{-# INLINE runCont #-}

-- | Runs the continuation effect with 'pure' as final continuation.

evalCont' :: forall tag r m. Applicative m => (Cont' tag `Via` C.ContT r) m r -> m r
evalCont' :: Via (Cont' tag) (ContT r) m r -> m r
evalCont' = (r -> m r) -> Via (Cont' tag) (ContT r) m r -> m r
forall k (tag :: k) r (m :: * -> *) a.
(a -> m r) -> Via (Cont' tag) (ContT r) m a -> m r
runCont' r -> m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE evalCont' #-}

-- | The untagged version of 'evalCont''.

evalCont :: Applicative m => (Cont `Via` C.ContT r) m r -> m r
evalCont :: Via (Cont' G) (ContT r) m r -> m r
evalCont = forall k (tag :: k) r (m :: * -> *).
Applicative m =>
Via (Cont' tag) (ContT r) m r -> m r
forall r (m :: * -> *).
Applicative m =>
Via (Cont' G) (ContT r) m r -> m r
evalCont' @G
{-# INLINE evalCont #-}