{-# 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 { ContC r m a -> FreeT (ContBase (m r) r) m a
unContC :: FreeT (ContBase (m r) r) m a }
  deriving ( a -> ContC r m b -> ContC r m a
(a -> b) -> ContC r m a -> ContC r m b
(forall a b. (a -> b) -> ContC r m a -> ContC r m b)
-> (forall a b. a -> ContC r m b -> ContC r m a)
-> Functor (ContC r m)
forall a b. a -> ContC r m b -> ContC r m a
forall a b. (a -> b) -> ContC r m a -> ContC r m b
forall r (m :: * -> *) a b. a -> ContC r m b -> ContC r m a
forall r (m :: * -> *) a b. (a -> b) -> ContC r m a -> ContC r m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ContC r m b -> ContC r m a
$c<$ :: forall r (m :: * -> *) a b. a -> ContC r m b -> ContC r m a
fmap :: (a -> b) -> ContC r m a -> ContC r m b
$cfmap :: forall r (m :: * -> *) a b. (a -> b) -> ContC r m a -> ContC r m b
Functor, Functor (ContC r m)
a -> ContC r m a
Functor (ContC r m)
-> (forall a. a -> ContC r m a)
-> (forall a b. ContC r m (a -> b) -> ContC r m a -> ContC r m b)
-> (forall a b c.
    (a -> b -> c) -> ContC r m a -> ContC r m b -> ContC r m c)
-> (forall a b. ContC r m a -> ContC r m b -> ContC r m b)
-> (forall a b. ContC r m a -> ContC r m b -> ContC r m a)
-> Applicative (ContC r m)
ContC r m a -> ContC r m b -> ContC r m b
ContC r m a -> ContC r m b -> ContC r m a
ContC r m (a -> b) -> ContC r m a -> ContC r m b
(a -> b -> c) -> ContC r m a -> ContC r m b -> ContC r m c
forall a. a -> ContC r m a
forall a b. ContC r m a -> ContC r m b -> ContC r m a
forall a b. ContC r m a -> ContC r m b -> ContC r m b
forall a b. ContC r m (a -> b) -> ContC r m a -> ContC r m b
forall a b c.
(a -> b -> c) -> ContC r m a -> ContC r m b -> ContC r m c
forall r (m :: * -> *). Functor (ContC r m)
forall r (m :: * -> *) a. a -> ContC r m a
forall r (m :: * -> *) a b.
ContC r m a -> ContC r m b -> ContC r m a
forall r (m :: * -> *) a b.
ContC r m a -> ContC r m b -> ContC r m b
forall r (m :: * -> *) a b.
ContC r m (a -> b) -> ContC r m a -> ContC r m b
forall r (m :: * -> *) a b c.
(a -> b -> c) -> ContC r m a -> ContC r m b -> ContC r m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: ContC r m a -> ContC r m b -> ContC r m a
$c<* :: forall r (m :: * -> *) a b.
ContC r m a -> ContC r m b -> ContC r m a
*> :: ContC r m a -> ContC r m b -> ContC r m b
$c*> :: forall r (m :: * -> *) a b.
ContC r m a -> ContC r m b -> ContC r m b
liftA2 :: (a -> b -> c) -> ContC r m a -> ContC r m b -> ContC r m c
$cliftA2 :: forall r (m :: * -> *) a b c.
(a -> b -> c) -> ContC r m a -> ContC r m b -> ContC r m c
<*> :: ContC r m (a -> b) -> ContC r m a -> ContC r m b
$c<*> :: forall r (m :: * -> *) a b.
ContC r m (a -> b) -> ContC r m a -> ContC r m b
pure :: a -> ContC r m a
$cpure :: forall r (m :: * -> *) a. a -> ContC r m a
$cp1Applicative :: forall r (m :: * -> *). Functor (ContC r m)
Applicative, Applicative (ContC r m)
a -> ContC r m a
Applicative (ContC r m)
-> (forall a b. ContC r m a -> (a -> ContC r m b) -> ContC r m b)
-> (forall a b. ContC r m a -> ContC r m b -> ContC r m b)
-> (forall a. a -> ContC r m a)
-> Monad (ContC r m)
ContC r m a -> (a -> ContC r m b) -> ContC r m b
ContC r m a -> ContC r m b -> ContC r m b
forall a. a -> ContC r m a
forall a b. ContC r m a -> ContC r m b -> ContC r m b
forall a b. ContC r m a -> (a -> ContC r m b) -> ContC r m b
forall r (m :: * -> *). Applicative (ContC r m)
forall r (m :: * -> *) a. a -> ContC r m a
forall r (m :: * -> *) a b.
ContC r m a -> ContC r m b -> ContC r m b
forall r (m :: * -> *) a b.
ContC r m a -> (a -> ContC r m b) -> ContC r m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> ContC r m a
$creturn :: forall r (m :: * -> *) a. a -> ContC r m a
>> :: ContC r m a -> ContC r m b -> ContC r m b
$c>> :: forall r (m :: * -> *) a b.
ContC r m a -> ContC r m b -> ContC r m b
>>= :: ContC r m a -> (a -> ContC r m b) -> ContC r m b
$c>>= :: forall r (m :: * -> *) a b.
ContC r m a -> (a -> ContC r m b) -> ContC r m b
$cp1Monad :: forall r (m :: * -> *). Applicative (ContC r m)
Monad
           , MonadBase b, Monad (ContC r m)
Monad (ContC r m)
-> (forall a. String -> ContC r m a) -> MonadFail (ContC r m)
String -> ContC r m a
forall a. String -> ContC r m a
forall r (m :: * -> *). MonadFail m => Monad (ContC r m)
forall r (m :: * -> *) a. MonadFail m => String -> ContC r m a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: String -> ContC r m a
$cfail :: forall r (m :: * -> *) a. MonadFail m => String -> ContC r m a
$cp1MonadFail :: forall r (m :: * -> *). MonadFail m => Monad (ContC r m)
Fail.MonadFail, Monad (ContC r m)
Monad (ContC r m)
-> (forall a. IO a -> ContC r m a) -> MonadIO (ContC r m)
IO a -> ContC r m a
forall a. IO a -> ContC r m a
forall r (m :: * -> *). MonadIO m => Monad (ContC r m)
forall r (m :: * -> *) a. MonadIO m => IO a -> ContC r m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> ContC r m a
$cliftIO :: forall r (m :: * -> *) a. MonadIO m => IO a -> ContC r m a
$cp1MonadIO :: forall r (m :: * -> *). MonadIO m => Monad (ContC r m)
MonadIO
           , Monad (ContC r m)
e -> ContC r m a
Monad (ContC r m)
-> (forall e a. Exception e => e -> ContC r m a)
-> MonadThrow (ContC r m)
forall e a. Exception e => e -> ContC r m a
forall r (m :: * -> *). MonadThrow m => Monad (ContC r m)
forall r (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> ContC r m a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: e -> ContC r m a
$cthrowM :: forall r (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> ContC r m a
$cp1MonadThrow :: forall r (m :: * -> *). MonadThrow m => Monad (ContC r m)
MonadThrow, MonadThrow (ContC r m)
MonadThrow (ContC r m)
-> (forall e a.
    Exception e =>
    ContC r m a -> (e -> ContC r m a) -> ContC r m a)
-> MonadCatch (ContC r m)
ContC r m a -> (e -> ContC r m a) -> ContC r m a
forall e a.
Exception e =>
ContC r m a -> (e -> ContC r m a) -> ContC r m a
forall r (m :: * -> *). MonadCatch m => MonadThrow (ContC r m)
forall r (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
ContC r m a -> (e -> ContC r m a) -> ContC r m a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: ContC r m a -> (e -> ContC r m a) -> ContC r m a
$ccatch :: forall r (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
ContC r m a -> (e -> ContC r m a) -> ContC r m a
$cp1MonadCatch :: forall r (m :: * -> *). MonadCatch m => MonadThrow (ContC r m)
MonadCatch
           )

instance MonadTrans (ContC s) where
  lift :: m a -> ContC s m a
lift = FreeT (ContBase (m s) s) m a -> ContC s m a
forall r (m :: * -> *) a.
FreeT (ContBase (m r) r) m a -> ContC r m a
ContC (FreeT (ContBase (m s) s) m a -> ContC s m a)
-> (m a -> FreeT (ContBase (m s) s) m a) -> m a -> ContC s m a
forall c b a. Coercible c b => (b -> c) -> (a -> b) -> a -> c
#. m a -> FreeT (ContBase (m s) s) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
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 :: Algebra' (Prims (ContC r m)) (ContC r m) a
algPrims = (Union (Prims m) (FreeT (ContBase (m r) r) m) a
 -> FreeT (ContBase (m r) r) m a)
-> Algebra' (Prims m) (ContC r m) a
coerce (Algebra (Prims m) m
-> Algebra (Prims m) (FreeT (ContBase (m r) r) m)
forall (t :: (* -> *) -> * -> *) (p :: [(* -> *) -> * -> *])
       (m :: * -> *).
(Threads t p, Monad m) =>
Algebra p m -> Algebra p (t m)
thread @(FreeT (ContBase (m r) r)) (Carrier m => Algebra (Prims m) m
forall (m :: * -> *) a. Carrier m => Algebra' (Prims m) m a
algPrims @m))
  {-# INLINEABLE algPrims #-}

  reformulate :: Reformulation'
  (Derivs (ContC r m)) (Prims (ContC r m)) (ContC r m) z a
reformulate forall x. ContC r m x -> z x
n Algebra (Prims (ContC r m)) z
alg = Algebra' (Derivs m) z a
-> (Cont z a -> z a) -> Algebra' (Cont : Derivs m) z a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *])
       (m :: * -> *) a.
RepresentationalEff e =>
Algebra' r m a -> (e m a -> m a) -> Algebra' (e : r) m a
powerAlg (Reformulation' (Derivs m) (Prims m) m z a
forall (m :: * -> *) (z :: * -> *) a.
(Carrier m, Monad z) =>
Reformulation' (Derivs m) (Prims m) m z a
reformulate (ContC r m x -> z x
forall x. ContC r m x -> z x
n (ContC r m x -> z x) -> (m x -> ContC r m x) -> m x -> z x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m x -> ContC r m x
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) forall x. Union (Prims m) z x -> z x
Algebra (Prims (ContC r m)) z
alg) ((Cont z a -> z a) -> Algebra' (Cont : Derivs m) z a)
-> (Cont z a -> z a) -> Algebra' (Cont : Derivs m) z a
forall a b. (a -> b) -> a -> b
$ \case
    CallCC (forall b. a -> z b) -> z a
main -> ContC r m (Either (a -> m r) a) -> z (Either (a -> m r) a)
forall x. ContC r m x -> z x
n (FreeT (ContBase (m r) r) m (Either (a -> m r) a)
-> ContC r m (Either (a -> m r) a)
forall r (m :: * -> *) a.
FreeT (ContBase (m r) r) m a -> ContC r m a
ContC (FreeT (ContBase (m r) r) m (Either (a -> m r) a)
 -> ContC r m (Either (a -> m r) a))
-> FreeT (ContBase (m r) r) m (Either (a -> m r) a)
-> ContC r m (Either (a -> m r) a)
forall a b. (a -> b) -> a -> b
$ ContBase (m r) r (Either (a -> m r) a)
-> FreeT (ContBase (m r) r) m (Either (a -> m r) a)
forall (f :: * -> *) a (m :: * -> *). f a -> FreeT f m a
liftF (ContBase (m r) r (Either (a -> m r) a)
 -> FreeT (ContBase (m r) r) m (Either (a -> m r) a))
-> ContBase (m r) r (Either (a -> m r) a)
-> FreeT (ContBase (m r) r) m (Either (a -> m r) a)
forall a b. (a -> b) -> a -> b
$ ContBase (m r) r (Either (a -> m r) a)
forall mr r a. ContBase mr r (Either (a -> mr) a)
GetCont) z (Either (a -> m r) a) -> (Either (a -> m r) a -> z a) -> z a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left a -> m r
c  -> (forall b. a -> z b) -> z a
main (\a
x -> ContC r m b -> z b
forall x. ContC r m x -> z x
n (ContC r m b -> z b) -> ContC r m b -> z b
forall a b. (a -> b) -> a -> b
$ FreeT (ContBase (m r) r) m b -> ContC r m b
forall r (m :: * -> *) a.
FreeT (ContBase (m r) r) m a -> ContC r m a
ContC (FreeT (ContBase (m r) r) m b -> ContC r m b)
-> FreeT (ContBase (m r) r) m b -> ContC r m b
forall a b. (a -> b) -> a -> b
$ ContBase (m r) r r -> FreeT (ContBase (m r) r) m r
forall (f :: * -> *) a (m :: * -> *). f a -> FreeT f m a
liftF (m r -> ContBase (m r) r r
forall mr r. mr -> ContBase mr r r
Attempt (a -> m r
c a
x)) FreeT (ContBase (m r) r) m r
-> (r -> FreeT (ContBase (m r) r) m b)
-> FreeT (ContBase (m r) r) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ContBase (m r) r b -> FreeT (ContBase (m r) r) m b
forall (f :: * -> *) a (m :: * -> *). f a -> FreeT f m a
liftF (ContBase (m r) r b -> FreeT (ContBase (m r) r) m b)
-> (r -> ContBase (m r) r b) -> r -> FreeT (ContBase (m r) r) m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> ContBase (m r) r b
forall r mr void. r -> ContBase mr r void
Exit)
      Right a
a -> a -> z a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
  {-# INLINEABLE reformulate #-}

newtype ShiftC r m a = ShiftC { ShiftC r m a -> FreeT (ContBase (m r) r) m a
unShiftC :: FreeT (ContBase (m r) r) m a }
  deriving ( a -> ShiftC r m b -> ShiftC r m a
(a -> b) -> ShiftC r m a -> ShiftC r m b
(forall a b. (a -> b) -> ShiftC r m a -> ShiftC r m b)
-> (forall a b. a -> ShiftC r m b -> ShiftC r m a)
-> Functor (ShiftC r m)
forall a b. a -> ShiftC r m b -> ShiftC r m a
forall a b. (a -> b) -> ShiftC r m a -> ShiftC r m b
forall r (m :: * -> *) a b. a -> ShiftC r m b -> ShiftC r m a
forall r (m :: * -> *) a b.
(a -> b) -> ShiftC r m a -> ShiftC r m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ShiftC r m b -> ShiftC r m a
$c<$ :: forall r (m :: * -> *) a b. a -> ShiftC r m b -> ShiftC r m a
fmap :: (a -> b) -> ShiftC r m a -> ShiftC r m b
$cfmap :: forall r (m :: * -> *) a b.
(a -> b) -> ShiftC r m a -> ShiftC r m b
Functor, Functor (ShiftC r m)
a -> ShiftC r m a
Functor (ShiftC r m)
-> (forall a. a -> ShiftC r m a)
-> (forall a b.
    ShiftC r m (a -> b) -> ShiftC r m a -> ShiftC r m b)
-> (forall a b c.
    (a -> b -> c) -> ShiftC r m a -> ShiftC r m b -> ShiftC r m c)
-> (forall a b. ShiftC r m a -> ShiftC r m b -> ShiftC r m b)
-> (forall a b. ShiftC r m a -> ShiftC r m b -> ShiftC r m a)
-> Applicative (ShiftC r m)
ShiftC r m a -> ShiftC r m b -> ShiftC r m b
ShiftC r m a -> ShiftC r m b -> ShiftC r m a
ShiftC r m (a -> b) -> ShiftC r m a -> ShiftC r m b
(a -> b -> c) -> ShiftC r m a -> ShiftC r m b -> ShiftC r m c
forall a. a -> ShiftC r m a
forall a b. ShiftC r m a -> ShiftC r m b -> ShiftC r m a
forall a b. ShiftC r m a -> ShiftC r m b -> ShiftC r m b
forall a b. ShiftC r m (a -> b) -> ShiftC r m a -> ShiftC r m b
forall a b c.
(a -> b -> c) -> ShiftC r m a -> ShiftC r m b -> ShiftC r m c
forall r (m :: * -> *). Functor (ShiftC r m)
forall r (m :: * -> *) a. a -> ShiftC r m a
forall r (m :: * -> *) a b.
ShiftC r m a -> ShiftC r m b -> ShiftC r m a
forall r (m :: * -> *) a b.
ShiftC r m a -> ShiftC r m b -> ShiftC r m b
forall r (m :: * -> *) a b.
ShiftC r m (a -> b) -> ShiftC r m a -> ShiftC r m b
forall r (m :: * -> *) a b c.
(a -> b -> c) -> ShiftC r m a -> ShiftC r m b -> ShiftC r m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: ShiftC r m a -> ShiftC r m b -> ShiftC r m a
$c<* :: forall r (m :: * -> *) a b.
ShiftC r m a -> ShiftC r m b -> ShiftC r m a
*> :: ShiftC r m a -> ShiftC r m b -> ShiftC r m b
$c*> :: forall r (m :: * -> *) a b.
ShiftC r m a -> ShiftC r m b -> ShiftC r m b
liftA2 :: (a -> b -> c) -> ShiftC r m a -> ShiftC r m b -> ShiftC r m c
$cliftA2 :: forall r (m :: * -> *) a b c.
(a -> b -> c) -> ShiftC r m a -> ShiftC r m b -> ShiftC r m c
<*> :: ShiftC r m (a -> b) -> ShiftC r m a -> ShiftC r m b
$c<*> :: forall r (m :: * -> *) a b.
ShiftC r m (a -> b) -> ShiftC r m a -> ShiftC r m b
pure :: a -> ShiftC r m a
$cpure :: forall r (m :: * -> *) a. a -> ShiftC r m a
$cp1Applicative :: forall r (m :: * -> *). Functor (ShiftC r m)
Applicative, Applicative (ShiftC r m)
a -> ShiftC r m a
Applicative (ShiftC r m)
-> (forall a b.
    ShiftC r m a -> (a -> ShiftC r m b) -> ShiftC r m b)
-> (forall a b. ShiftC r m a -> ShiftC r m b -> ShiftC r m b)
-> (forall a. a -> ShiftC r m a)
-> Monad (ShiftC r m)
ShiftC r m a -> (a -> ShiftC r m b) -> ShiftC r m b
ShiftC r m a -> ShiftC r m b -> ShiftC r m b
forall a. a -> ShiftC r m a
forall a b. ShiftC r m a -> ShiftC r m b -> ShiftC r m b
forall a b. ShiftC r m a -> (a -> ShiftC r m b) -> ShiftC r m b
forall r (m :: * -> *). Applicative (ShiftC r m)
forall r (m :: * -> *) a. a -> ShiftC r m a
forall r (m :: * -> *) a b.
ShiftC r m a -> ShiftC r m b -> ShiftC r m b
forall r (m :: * -> *) a b.
ShiftC r m a -> (a -> ShiftC r m b) -> ShiftC r m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> ShiftC r m a
$creturn :: forall r (m :: * -> *) a. a -> ShiftC r m a
>> :: ShiftC r m a -> ShiftC r m b -> ShiftC r m b
$c>> :: forall r (m :: * -> *) a b.
ShiftC r m a -> ShiftC r m b -> ShiftC r m b
>>= :: ShiftC r m a -> (a -> ShiftC r m b) -> ShiftC r m b
$c>>= :: forall r (m :: * -> *) a b.
ShiftC r m a -> (a -> ShiftC r m b) -> ShiftC r m b
$cp1Monad :: forall r (m :: * -> *). Applicative (ShiftC r m)
Monad
           , MonadBase b, Monad (ShiftC r m)
Monad (ShiftC r m)
-> (forall a. String -> ShiftC r m a) -> MonadFail (ShiftC r m)
String -> ShiftC r m a
forall a. String -> ShiftC r m a
forall r (m :: * -> *). MonadFail m => Monad (ShiftC r m)
forall r (m :: * -> *) a. MonadFail m => String -> ShiftC r m a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: String -> ShiftC r m a
$cfail :: forall r (m :: * -> *) a. MonadFail m => String -> ShiftC r m a
$cp1MonadFail :: forall r (m :: * -> *). MonadFail m => Monad (ShiftC r m)
Fail.MonadFail, Monad (ShiftC r m)
Monad (ShiftC r m)
-> (forall a. IO a -> ShiftC r m a) -> MonadIO (ShiftC r m)
IO a -> ShiftC r m a
forall a. IO a -> ShiftC r m a
forall r (m :: * -> *). MonadIO m => Monad (ShiftC r m)
forall r (m :: * -> *) a. MonadIO m => IO a -> ShiftC r m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> ShiftC r m a
$cliftIO :: forall r (m :: * -> *) a. MonadIO m => IO a -> ShiftC r m a
$cp1MonadIO :: forall r (m :: * -> *). MonadIO m => Monad (ShiftC r m)
MonadIO
           , Monad (ShiftC r m)
e -> ShiftC r m a
Monad (ShiftC r m)
-> (forall e a. Exception e => e -> ShiftC r m a)
-> MonadThrow (ShiftC r m)
forall e a. Exception e => e -> ShiftC r m a
forall r (m :: * -> *). MonadThrow m => Monad (ShiftC r m)
forall r (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> ShiftC r m a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: e -> ShiftC r m a
$cthrowM :: forall r (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> ShiftC r m a
$cp1MonadThrow :: forall r (m :: * -> *). MonadThrow m => Monad (ShiftC r m)
MonadThrow, MonadThrow (ShiftC r m)
MonadThrow (ShiftC r m)
-> (forall e a.
    Exception e =>
    ShiftC r m a -> (e -> ShiftC r m a) -> ShiftC r m a)
-> MonadCatch (ShiftC r m)
ShiftC r m a -> (e -> ShiftC r m a) -> ShiftC r m a
forall e a.
Exception e =>
ShiftC r m a -> (e -> ShiftC r m a) -> ShiftC r m a
forall r (m :: * -> *). MonadCatch m => MonadThrow (ShiftC r m)
forall r (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
ShiftC r m a -> (e -> ShiftC r m a) -> ShiftC r m a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: ShiftC r m a -> (e -> ShiftC r m a) -> ShiftC r m a
$ccatch :: forall r (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
ShiftC r m a -> (e -> ShiftC r m a) -> ShiftC r m a
$cp1MonadCatch :: forall r (m :: * -> *). MonadCatch m => MonadThrow (ShiftC r m)
MonadCatch
           )

instance MonadTrans (ShiftC s) where
  lift :: m a -> ShiftC s m a
lift = FreeT (ContBase (m s) s) m a -> ShiftC s m a
forall r (m :: * -> *) a.
FreeT (ContBase (m r) r) m a -> ShiftC r m a
ShiftC (FreeT (ContBase (m s) s) m a -> ShiftC s m a)
-> (m a -> FreeT (ContBase (m s) s) m a) -> m a -> ShiftC s m a
forall c b a. Coercible c b => (b -> c) -> (a -> b) -> a -> c
#. m a -> FreeT (ContBase (m s) s) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
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 :: Algebra' (Prims (ShiftC r m)) (ShiftC r m) a
algPrims = (Union (Prims m) (FreeT (ContBase (m r) r) m) a
 -> FreeT (ContBase (m r) r) m a)
-> Algebra' (Prims m) (ShiftC r m) a
coerce (Algebra (Prims m) m
-> Algebra (Prims m) (FreeT (ContBase (m r) r) m)
forall (t :: (* -> *) -> * -> *) (p :: [(* -> *) -> * -> *])
       (m :: * -> *).
(Threads t p, Monad m) =>
Algebra p m -> Algebra p (t m)
thread @(FreeT (ContBase (m r) r)) (Carrier m => Algebra (Prims m) m
forall (m :: * -> *) a. Carrier m => Algebra' (Prims m) m a
algPrims @m))
  {-# INLINEABLE algPrims #-}

  reformulate :: Reformulation'
  (Derivs (ShiftC r m)) (Prims (ShiftC r m)) (ShiftC r m) z a
reformulate forall x. ShiftC r m x -> z x
n Algebra (Prims (ShiftC r m)) z
alg = Algebra' (Derivs m) z a
-> (Shift r z a -> z a) -> Algebra' (Shift r : Derivs m) z a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *])
       (m :: * -> *) a.
RepresentationalEff e =>
Algebra' r m a -> (e m a -> m a) -> Algebra' (e : r) m a
powerAlg (Reformulation' (Derivs m) (Prims m) m z a
forall (m :: * -> *) (z :: * -> *) a.
(Carrier m, Monad z) =>
Reformulation' (Derivs m) (Prims m) m z a
reformulate (ShiftC r m x -> z x
forall x. ShiftC r m x -> z x
n (ShiftC r m x -> z x) -> (m x -> ShiftC r m x) -> m x -> z x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m x -> ShiftC r m x
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) forall x. Union (Prims m) z x -> z x
Algebra (Prims (ShiftC r m)) z
alg) ((Shift r z a -> z a) -> Algebra' (Shift r : Derivs m) z a)
-> (Shift r z a -> z a) -> Algebra' (Shift r : Derivs m) z a
forall a b. (a -> b) -> a -> b
$ \case
    Shift (a -> z r) -> z r
main -> ShiftC r m (Either (a -> m r) a) -> z (Either (a -> m r) a)
forall x. ShiftC r m x -> z x
n (FreeT (ContBase (m r) r) m (Either (a -> m r) a)
-> ShiftC r m (Either (a -> m r) a)
forall r (m :: * -> *) a.
FreeT (ContBase (m r) r) m a -> ShiftC r m a
ShiftC (FreeT (ContBase (m r) r) m (Either (a -> m r) a)
 -> ShiftC r m (Either (a -> m r) a))
-> FreeT (ContBase (m r) r) m (Either (a -> m r) a)
-> ShiftC r m (Either (a -> m r) a)
forall a b. (a -> b) -> a -> b
$ ContBase (m r) r (Either (a -> m r) a)
-> FreeT (ContBase (m r) r) m (Either (a -> m r) a)
forall (f :: * -> *) a (m :: * -> *). f a -> FreeT f m a
liftF (ContBase (m r) r (Either (a -> m r) a)
 -> FreeT (ContBase (m r) r) m (Either (a -> m r) a))
-> ContBase (m r) r (Either (a -> m r) a)
-> FreeT (ContBase (m r) r) m (Either (a -> m r) a)
forall a b. (a -> b) -> a -> b
$ ContBase (m r) r (Either (a -> m r) a)
forall mr r a. ContBase mr r (Either (a -> mr) a)
GetCont) z (Either (a -> m r) a) -> (Either (a -> m r) a -> z a) -> z a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left a -> m r
c  -> (a -> z r) -> z r
main (\a
x -> ShiftC r m r -> z r
forall x. ShiftC r m x -> z x
n (ShiftC r m r -> z r) -> ShiftC r m r -> z r
forall a b. (a -> b) -> a -> b
$ FreeT (ContBase (m r) r) m r -> ShiftC r m r
forall r (m :: * -> *) a.
FreeT (ContBase (m r) r) m a -> ShiftC r m a
ShiftC (FreeT (ContBase (m r) r) m r -> ShiftC r m r)
-> FreeT (ContBase (m r) r) m r -> ShiftC r m r
forall a b. (a -> b) -> a -> b
$ ContBase (m r) r r -> FreeT (ContBase (m r) r) m r
forall (f :: * -> *) a (m :: * -> *). f a -> FreeT f m a
liftF (ContBase (m r) r r -> FreeT (ContBase (m r) r) m r)
-> ContBase (m r) r r -> FreeT (ContBase (m r) r) m r
forall a b. (a -> b) -> a -> b
$ m r -> ContBase (m r) r r
forall mr r. mr -> ContBase mr r r
Attempt (a -> m r
c a
x)) z r -> (r -> z a) -> z a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \r
r ->
        ShiftC r m a -> z a
forall x. ShiftC r m x -> z x
n (FreeT (ContBase (m r) r) m a -> ShiftC r m a
forall r (m :: * -> *) a.
FreeT (ContBase (m r) r) m a -> ShiftC r m a
ShiftC (FreeT (ContBase (m r) r) m a -> ShiftC r m a)
-> FreeT (ContBase (m r) r) m a -> ShiftC r m a
forall a b. (a -> b) -> a -> b
$ ContBase (m r) r a -> FreeT (ContBase (m r) r) m a
forall (f :: * -> *) a (m :: * -> *). f a -> FreeT f m a
liftF (ContBase (m r) r a -> FreeT (ContBase (m r) r) m a)
-> ContBase (m r) r a -> FreeT (ContBase (m r) r) m a
forall a b. (a -> b) -> a -> b
$ r -> ContBase (m r) r a
forall r mr void. r -> ContBase mr r void
Exit r
r)
      Right a
a -> a -> z a
forall (m :: * -> *) a. Monad m => a -> m a
return a
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