Cont.hs

{-# OPTIONS_HADDOCK not-home #-}
module Control.Effect.Internal.Cont where

import Data.Coerce

import Control.Monad.Trans
import Control.Monad.Base
import qualified Control.Monad.Fail as Fail

import Control.Effect
import Control.Effect.Carrier

import Control.Effect.Internal.Utils

import Control.Monad.Trans.Free.Church.Alternate

-- | An effect for abortive continuations.
newtype Cont :: Effect where
  CallCC :: ((forall b. a -> m b) -> m a) -> Cont m a

-- | An effect for non-abortive continuations of a program
-- that eventually produces a result of type @r@.
--
-- This isn't quite as powerful as proper delimited continuations,
-- as this doesn't provide any equivalent of the @reset@ operator.
--
-- This can be useful as a helper effect.
newtype Shift r :: Effect where
  Shift :: ((a -> m r) -> m r) -> Shift r m a

data ContBase mr r a where
  Exit    :: r -> ContBase mr r void
  Attempt :: mr -> ContBase mr r r
  GetCont :: ContBase mr r (Either (a -> mr) a)


newtype ContC r m a = ContC { unContC :: FreeT (ContBase (m r) r) m a }
  deriving ( Functor, Applicative, Monad
           , MonadBase b, Fail.MonadFail, MonadIO
           , MonadThrow, MonadCatch
           )

instance MonadTrans (ContC s) where
  lift = ContC #. lift
  {-# INLINE lift #-}

instance ( Carrier m
         , Threads (FreeT (ContBase (m r) r)) (Prims m)
         )
      => Carrier (ContC r m) where
  type Derivs (ContC r m) = Cont ': Derivs m
  type Prims  (ContC r m) = Prims m

  algPrims = coerce (thread @(FreeT (ContBase (m r) r)) (algPrims @m))
  {-# INLINEABLE algPrims #-}

  reformulate n alg = powerAlg (reformulate (n . lift) alg) $ \case
    CallCC main -> n (ContC $ liftF $ GetCont) >>= \case
      Left c  -> main (\x -> n $ ContC $ liftF (Attempt (c x)) >>= liftF . Exit)
      Right a -> return a
  {-# INLINEABLE reformulate #-}

newtype ShiftC r m a = ShiftC { unShiftC :: FreeT (ContBase (m r) r) m a }
  deriving ( Functor, Applicative, Monad
           , MonadBase b, Fail.MonadFail, MonadIO
           , MonadThrow, MonadCatch
           )

instance MonadTrans (ShiftC s) where
  lift = ShiftC #. lift
  {-# INLINE lift #-}

instance ( Carrier m
         , Threads (FreeT (ContBase (m r) r)) (Prims m)
         )
      => Carrier (ShiftC r m) where
  type Derivs (ShiftC r m) = Shift r ': Derivs m
  type Prims  (ShiftC r m) = Prims m

  algPrims = coerce (thread @(FreeT (ContBase (m r) r)) (algPrims @m))
  {-# INLINEABLE algPrims #-}

  reformulate n alg = powerAlg (reformulate (n . lift) alg) $ \case
    Shift main -> n (ShiftC $ liftF $ GetCont) >>= \case
      Left c  -> main (\x -> n $ ShiftC $ liftF $ Attempt (c x)) >>= \r ->
        n (ShiftC $ liftF $ Exit r)
      Right a -> return a
  {-# INLINEABLE reformulate #-}

-- | 'ContThreads' accepts the following primitive effects:
--
-- * 'Control.Effect.Regional.Regional' @s@
-- * 'Control.Effect.Optional.Optional' @s@ (when @s@ is a functor)
-- * 'Control.Effect.Type.Unravel.Unravel' @p@
-- * 'Control.Effect.Type.ListenPrim.ListenPrim' @o@ (when @o@ is a 'Monoid')
-- * 'Control.Effect.Type.ReaderPrim.ReaderPrim' @i@
type ContThreads = FreeThreads