{-# OPTIONS_HADDOCK not-home #-}

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}

module Control.Effect.Internal where

import qualified Control.Exception as IO
import qualified Data.Type.Coercion as Coercion

import Control.Applicative
import Control.Exception (Exception)
import Control.Monad
import Control.Monad.IO.Class
import Data.Bool (bool)
import Data.Coerce
import Data.Functor
import Data.IORef
import Data.Kind (Constraint, Type)
import Data.Type.Coercion (Coercion(..), gcoerceWith)
import Data.Type.Equality ((:~:)(..), gcastWith)
import GHC.Exts (Any, Int(..), Int#, RealWorld, RuntimeRep(..), SmallArray#, State#, TYPE, reset#, shift#)
import GHC.Types (IO(..))
import System.IO.Unsafe (unsafeDupablePerformIO)
import Unsafe.Coerce (unsafeCoerce)

import Control.Effect.Internal.Debug
import Control.Effect.Internal.SmallArray

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

axiom :: a :~: b
axiom :: a :~: b
axiom = (Any :~: Any) -> a :~: b
forall a b. a -> b
unsafeCoerce Any :~: Any
forall {k} (a :: k). a :~: a
Refl
{-# INLINE axiom #-}

-- | A restricted form of 'unsafeCoerce' that only works for converting to/from
-- 'Any'. Still just as unsafe, but makes it slightly more difficult to
-- accidentally misuse.
pattern Any :: forall a. a -> Any
pattern $bAny :: a -> Any
$mAny :: forall {r} {a}. Any -> (a -> r) -> (Void# -> r) -> r
Any a <- (unsafeCoerce -> a)
  where Any = a -> Any
forall a b. a -> b
unsafeCoerce
{-# COMPLETE Any #-}

anyCo :: forall a. Coercion a Any
anyCo :: Coercion a Any
anyCo = Coercion a a -> Coercion a Any
forall a b. a -> b
unsafeCoerce (Coercible a a => Coercion a a
forall {k} (a :: k) (b :: k). Coercible a b => Coercion a b
Coercion @a @a)
{-# INLINE anyCo #-}

-- | Used to explicitly overwrite references to values that should not be
-- retained by the GC.
null# :: Any
null# :: Any
null# = () -> Any
forall a. a -> Any
Any ()

unIO :: IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO :: IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (IO State# RealWorld -> (# State# RealWorld, a #)
m) = State# RealWorld -> (# State# RealWorld, a #)
m
{-# INLINE unIO #-}

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

data Dict c = c => Dict

type DictRep :: Constraint -> Type
type family DictRep c

type WithDict :: Constraint -> Type -> Type
newtype WithDict c r = WithDict { WithDict c r -> c => r
unWithDict :: c => r }

reflectDict :: forall c r. DictRep c -> (c => r) -> r
reflectDict :: DictRep c -> (c => r) -> r
reflectDict !DictRep c
d c => r
x = WithDict c r -> DictRep c -> r
forall a b. a -> b
unsafeCoerce ((c => r) -> WithDict c r
forall (c :: Constraint) r. (c => r) -> WithDict c r
WithDict @c @r c => r
x) DictRep c
d
{-# INLINE reflectDict #-}

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

-- | The kind of effects.
type Effect = (Type -> Type) -> Type -> Type

type (:<) :: Effect -> [Effect] -> Constraint
class eff :< effs where
  reifyIndex :: Int
instance {-# OVERLAPPING #-} eff :< (eff ': effs) where
  reifyIndex :: Int
reifyIndex = Int
0
  {-# INLINE reifyIndex #-}
instance eff :< effs => eff :< (eff' ': effs) where
  reifyIndex :: Int
reifyIndex = (eff :< effs) => Int
forall (eff :: Effect) (effs :: [Effect]). (eff :< effs) => Int
reifyIndex @eff @effs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
  {-# INLINE reifyIndex #-}

type (:<<) :: [Effect] -> [Effect] -> Constraint
class effs1 :<< effs2 where
  reifySubIndex :: Int
instance {-# OVERLAPPING #-} effs :<< effs where
  reifySubIndex :: Int
reifySubIndex = Int
0
  {-# INLINE reifySubIndex #-}
instance (effs2 ~ (eff ': effs3), effs1 :<< effs3) => effs1 :<< effs2 where
  reifySubIndex :: Int
reifySubIndex = (effs1 :<< effs3) => Int
forall (effs1 :: [Effect]) (effs2 :: [Effect]).
(effs1 :<< effs2) =>
Int
reifySubIndex @effs1 @effs3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
  {-# INLINE reifySubIndex #-}

type instance DictRep (eff :< effs) = Int
type instance DictRep (effs1 :<< effs2) = Int

type (:<#) :: Effect -> [Effect] -> TYPE 'IntRep
-- see Note [Manual worker/wrapper]
newtype eff :<# effs = ReflectIndex# { (eff :<# effs) -> Int#
reifyIndex# :: Int# }
pattern IndexDict# :: forall eff effs. () => eff :< effs => eff :<# effs
pattern $bIndexDict# :: eff :<# effs
$mIndexDict# :: forall {r} {eff :: Effect} {effs :: [Effect]}.
(eff :<# effs) -> ((eff :< effs) => r) -> (Void# -> r) -> r
IndexDict# <- ReflectIndex# ((\idx -> reflectDict @(eff :< effs) (I# idx) (Dict @(eff :< effs))) -> Dict)
  where IndexDict# = case (eff :< effs) => Int
forall (eff :: Effect) (effs :: [Effect]). (eff :< effs) => Int
reifyIndex @eff @effs of I# Int#
idx -> Int# -> eff :<# effs
forall (eff :: Effect) (effs :: [Effect]). Int# -> eff :<# effs
ReflectIndex# Int#
idx
{-# COMPLETE IndexDict# #-}

{- -----------------------------------------------------------------------------
-- Note [The Eff Machine]
~~~~~~~~~~~~~~~~~~~~~~~~~
The Eff monad is best thought of as a “embedded virtual machine.” Given
primitive support for continuation manipulation from the host, Eff efficiently
implements a complement of complex control operations.

At any time, the Eff machine conceptually manages two pieces of state:

  1. The /metacontinuation stack/, which holds metacontinuation frames.
     Metacontinuation frames correspond to things like effect handlers,
     “thread-local” state, and dynamic winders.

  2. The /targets vector/, which maps a list of effects to the corresponding
     metacontinuation frames that handle them. (See Note [The targets vector].)

However, the representation of the metacontinuation stack is not explicit: it is
implicitly encoded as stack frames on the ordinary GHC RTS stack that cooperate
using a particular calling convention.

Note [Manual worker/wrapper]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC performs an optimization called the /worker-wrapper transformation/, which
is used to propagate strictness information, unboxing, and more. The idea is
simple: if a function strictly operates on a boxed value, like

    f :: Int -> Foo
    f !n = ...

then GHC will internally rewrite it into a pair of definitions, a /worker/ and a
/wrapper/:

    $wf :: Int# -> Foo
    $wf n = ...

    f :: Int -> Foo
    f (I# n) = $wf n
    {-# INLINE f #-}

If some other code uses f, the wrapper will be inlined at the call site, and the
exposed unfolding allows GHC to make a direct call to $wf passing an unboxed
Int#.

This is great, but the automatic transformation can only do so much. The
worker/wrapper transformation relies on inlining, so it only works for known
calls. This means it can be advantageous to /manually/ perform this kind of
transformation to ensure unboxing happens, especially on datatypes (where the
“worker” is the datatype definition itself and the “wrapper” is a pattern
synonym.) -}

-- | All @eff@ computations operate in the 'Eff' monad. 'Eff' computations are
-- parameterized by a type-level list that specifies which effects they are
-- allowed to perform. For example, a computation of type
-- @'Eff' '['Control.Effect.Error' e, 'Control.Effect.Reader' r, 'Control.Effect.State' s] a@
-- can raise exceptions of type @e@, can access a global environment of type
-- @r@, and can read and modify a single cell of mutable state of type @s@.
--
-- To run an 'Eff' computation that performs effects, the effects must be
-- explicitly /handled/. Functions that handle effects are called
-- /effect handlers/, and they usually have types like the following:
--
-- @
-- runX :: 'Eff' (X ': effs) a -> 'Eff' effs a
-- @
--
-- Note that the argument to @runX@ can perform the @X@ effect, but the result
-- cannot! Any @X@ operations have been handled by @runX@, which interprets
-- their meaning. Examples of effect handlers include
-- 'Control.Effect.Error.runError', 'Control.Effect.Reader.runReader', and
-- 'Control.Effect.State.Strict.runState'.
--
-- After all effects have been handled, the resulting computation will have type
-- @'Eff' '[] a@, a computation that performs no effects. A computation with
-- this type is pure, so it can be converted to an ordinary value using 'run'.
--
-- Some effects cannot be handled locally, but instead require performing I/O.
-- These effects will delegate to the 'IOE' effect, which provides low-level
-- interop with Haskell’s built-in 'IO' monad. After all other effects have been
-- handled, a computation of type @'Eff' '['IOE'] a@ can be converted to an
-- ordinary @'IO' a@ computation using 'runIO'.
type Eff :: [Effect] -> Type -> Type
type role Eff nominal representational
newtype Eff effs a = Eff# { Eff effs a -> EVM a
unEff# :: EVM a }
  deriving (a -> Eff effs b -> Eff effs a
(a -> b) -> Eff effs a -> Eff effs b
(forall a b. (a -> b) -> Eff effs a -> Eff effs b)
-> (forall a b. a -> Eff effs b -> Eff effs a)
-> Functor (Eff effs)
forall (effs :: [Effect]) a b. a -> Eff effs b -> Eff effs a
forall (effs :: [Effect]) a b. (a -> b) -> Eff effs a -> Eff effs b
forall a b. a -> Eff effs b -> Eff effs a
forall a b. (a -> b) -> Eff effs a -> Eff effs b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Eff effs b -> Eff effs a
$c<$ :: forall (effs :: [Effect]) a b. a -> Eff effs b -> Eff effs a
fmap :: (a -> b) -> Eff effs a -> Eff effs b
$cfmap :: forall (effs :: [Effect]) a b. (a -> b) -> Eff effs a -> Eff effs b
Functor, Functor (Eff effs)
a -> Eff effs a
Functor (Eff effs)
-> (forall a. a -> Eff effs a)
-> (forall a b. Eff effs (a -> b) -> Eff effs a -> Eff effs b)
-> (forall a b c.
    (a -> b -> c) -> Eff effs a -> Eff effs b -> Eff effs c)
-> (forall a b. Eff effs a -> Eff effs b -> Eff effs b)
-> (forall a b. Eff effs a -> Eff effs b -> Eff effs a)
-> Applicative (Eff effs)
Eff effs a -> Eff effs b -> Eff effs b
Eff effs a -> Eff effs b -> Eff effs a
Eff effs (a -> b) -> Eff effs a -> Eff effs b
(a -> b -> c) -> Eff effs a -> Eff effs b -> Eff effs c
forall {effs :: [Effect]}. Functor (Eff effs)
forall (effs :: [Effect]) a. a -> Eff effs a
forall (effs :: [Effect]) a b.
Eff effs a -> Eff effs b -> Eff effs a
forall (effs :: [Effect]) a b.
Eff effs a -> Eff effs b -> Eff effs b
forall (effs :: [Effect]) a b.
Eff effs (a -> b) -> Eff effs a -> Eff effs b
forall (effs :: [Effect]) a b c.
(a -> b -> c) -> Eff effs a -> Eff effs b -> Eff effs c
forall a. a -> Eff effs a
forall a b. Eff effs a -> Eff effs b -> Eff effs a
forall a b. Eff effs a -> Eff effs b -> Eff effs b
forall a b. Eff effs (a -> b) -> Eff effs a -> Eff effs b
forall a b c.
(a -> b -> c) -> Eff effs a -> Eff effs b -> Eff effs 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
<* :: Eff effs a -> Eff effs b -> Eff effs a
$c<* :: forall (effs :: [Effect]) a b.
Eff effs a -> Eff effs b -> Eff effs a
*> :: Eff effs a -> Eff effs b -> Eff effs b
$c*> :: forall (effs :: [Effect]) a b.
Eff effs a -> Eff effs b -> Eff effs b
liftA2 :: (a -> b -> c) -> Eff effs a -> Eff effs b -> Eff effs c
$cliftA2 :: forall (effs :: [Effect]) a b c.
(a -> b -> c) -> Eff effs a -> Eff effs b -> Eff effs c
<*> :: Eff effs (a -> b) -> Eff effs a -> Eff effs b
$c<*> :: forall (effs :: [Effect]) a b.
Eff effs (a -> b) -> Eff effs a -> Eff effs b
pure :: a -> Eff effs a
$cpure :: forall (effs :: [Effect]) a. a -> Eff effs a
$cp1Applicative :: forall {effs :: [Effect]}. Functor (Eff effs)
Applicative, Applicative (Eff effs)
a -> Eff effs a
Applicative (Eff effs)
-> (forall a b. Eff effs a -> (a -> Eff effs b) -> Eff effs b)
-> (forall a b. Eff effs a -> Eff effs b -> Eff effs b)
-> (forall a. a -> Eff effs a)
-> Monad (Eff effs)
Eff effs a -> (a -> Eff effs b) -> Eff effs b
Eff effs a -> Eff effs b -> Eff effs b
forall {effs :: [Effect]}. Applicative (Eff effs)
forall (effs :: [Effect]) a. a -> Eff effs a
forall (effs :: [Effect]) a b.
Eff effs a -> Eff effs b -> Eff effs b
forall (effs :: [Effect]) a b.
Eff effs a -> (a -> Eff effs b) -> Eff effs b
forall a. a -> Eff effs a
forall a b. Eff effs a -> Eff effs b -> Eff effs b
forall a b. Eff effs a -> (a -> Eff effs b) -> Eff effs 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 -> Eff effs a
$creturn :: forall (effs :: [Effect]) a. a -> Eff effs a
>> :: Eff effs a -> Eff effs b -> Eff effs b
$c>> :: forall (effs :: [Effect]) a b.
Eff effs a -> Eff effs b -> Eff effs b
>>= :: Eff effs a -> (a -> Eff effs b) -> Eff effs b
$c>>= :: forall (effs :: [Effect]) a b.
Eff effs a -> (a -> Eff effs b) -> Eff effs b
$cp1Monad :: forall {effs :: [Effect]}. Applicative (Eff effs)
Monad)

pattern Eff :: (Registers -> IO (Registers, a)) -> Eff effs a
pattern $bEff :: (Registers -> IO (Registers, a)) -> Eff effs a
$mEff :: forall {r} {a} {effs :: [Effect]}.
Eff effs a
-> ((Registers -> IO (Registers, a)) -> r) -> (Void# -> r) -> r
Eff{Eff effs a -> Registers -> IO (Registers, a)
unEff} = Eff# (EVM unEff) -- see Note [Manual worker/wrapper]
{-# COMPLETE Eff #-}

newtype EVM a = EVM# { EVM a -> Registers# -> IO (Result a)
unEVM# :: Registers# -> IO (Result a) }
data Result a = Result Registers# ~a

pattern EVM :: (Registers -> IO (Registers, a)) -> EVM a
-- see Note [Manual worker/wrapper]
pattern $bEVM :: (Registers -> IO (Registers, a)) -> EVM a
$mEVM :: forall {r} {a}.
EVM a
-> ((Registers -> IO (Registers, a)) -> r) -> (Void# -> r) -> r
EVM{EVM a -> Registers -> IO (Registers, a)
unEVM} <- EVM# ((\m (BoxRegisters rs1) -> m rs1 <&> \(Result rs2 a) -> (BoxRegisters rs2, a)) -> unEVM)
  where EVM Registers -> IO (Registers, a)
m = (Registers# -> IO (Result a)) -> EVM a
forall a. (Registers# -> IO (Result a)) -> EVM a
EVM# \Registers#
rs1 -> Registers -> IO (Registers, a)
m (Registers# -> Registers
BoxRegisters Registers#
rs1) IO (Registers, a) -> ((Registers, a) -> Result a) -> IO (Result a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(BoxRegisters Registers#
rs2, a
a) -> Registers# -> a -> Result a
forall a. Registers# -> a -> Result a
Result Registers#
rs2 a
a
{-# COMPLETE EVM #-}

packIOResult :: IO (Registers, a) -> IO (Result a)
-- see Note [Manual worker/wrapper]
packIOResult :: IO (Registers, a) -> IO (Result a)
packIOResult IO (Registers, a)
m = IO (Registers, a)
m IO (Registers, a)
-> ((Registers, a) -> IO (Result a)) -> IO (Result a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(BoxRegisters Registers#
rs, a
a) -> Result a -> IO (Result a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result a -> IO (Result a)) -> Result a -> IO (Result a)
forall a b. (a -> b) -> a -> b
$! Registers# -> a -> Result a
forall a. Registers# -> a -> Result a
Result Registers#
rs a
a
{-# INLINE packIOResult #-}

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

newtype Registers# = Registers# (# PromptId, Targets# #)
data Registers = BoxRegisters { Registers -> Registers#
unboxRegisters :: Registers# }
pattern Registers :: PromptId -> Targets -> Registers
-- see Note [Manual worker/wrapper]
pattern $bRegisters :: PromptId -> Targets -> Registers
$mRegisters :: forall {r}.
Registers -> (PromptId -> Targets -> r) -> (Void# -> r) -> r
Registers pid ts <- BoxRegisters (Registers# (# pid, (BoxTargets -> ts) #))
  where Registers PromptId
pid (BoxTargets Targets#
ts) = Registers# -> Registers
BoxRegisters ((# PromptId, Targets# #) -> Registers#
Registers# (# PromptId
pid, Targets#
ts #))
{-# COMPLETE Registers #-}

initialRegisters :: Registers
initialRegisters :: Registers
initialRegisters = PromptId -> Targets -> Registers
Registers (Int -> PromptId
PromptId Int
0) Targets
noTargets

newtype PromptId = PromptId# Int#
pattern PromptId :: Int -> PromptId
-- see Note [Manual worker/wrapper]
pattern $bPromptId :: Int -> PromptId
$mPromptId :: forall {r}. PromptId -> (Int -> r) -> (Void# -> r) -> r
PromptId{PromptId -> Int
unPromptId} <- PromptId# (I# -> unPromptId)
  where PromptId (I# Int#
n) = Int# -> PromptId
PromptId# Int#
n
{-# COMPLETE PromptId #-}

data Unwind
  = UnwindAbort PromptId ~Any
  | UnwindControl (Capture Any)

instance Show Unwind where
  show :: Unwind -> String
show (UnwindAbort (PromptId Int
pid) Any
_)
    = String
"<<Control.Eff.Internal.abort:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
pid String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">>"
  show (UnwindControl (Capture (PromptId Int
pid) CaptureMode
_ (b -> EVM c) -> EVM d
_ b -> EVM Any
_))
    = String
"<<Control.Eff.Internal.control:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
pid String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">>"
instance Exception Unwind

data Capture a where
  Capture
    :: PromptId
    -- ^ The prompt to capture up to.
    -> CaptureMode
    -> ((b -> EVM c) -> EVM d)
    -- ^ The replacement continuation passed by the user to the original call to
    -- 'control'. This should be invoked with the fully-composed continuation
    -- after capturing is complete.
    -> (b -> EVM a)
    -- ^ The composed continuation captured so far.
    -> Capture a

data CaptureMode
  -- | The captured continuation should include the prompt being captured up to.
  -- This mode corresponds to the 'control' operator.
  = IncludePrompt
  -- | The captured continuation should include frames up to the the prompt, but
  -- not the prompt itself. This mode corresponds to the 'control0' operator.
  | ExcludePrompt

captureVM :: forall a b. Capture a -> IO b
captureVM :: Capture a -> IO b
captureVM Capture a
a = Coercion Any a -> (Coercible Any a => IO b) -> IO b
forall {k} (a :: k) (b :: k) r.
Coercion a b -> (Coercible a b => r) -> r
gcoerceWith (Coercion a Any -> Coercion Any a
forall {k} (a :: k) (b :: k). Coercion a b -> Coercion b a
Coercion.sym (Coercion a Any -> Coercion Any a)
-> Coercion a Any -> Coercion Any a
forall a b. (a -> b) -> a -> b
$ Coercion a Any
forall {k} (a :: k). Coercion a Any
anyCo @a) ((Coercible Any a => IO b) -> IO b)
-> (Coercible Any a => IO b) -> IO b
forall a b. (a -> b) -> a -> b
$
  Unwind -> IO b
forall e a. Exception e => e -> IO a
IO.throwIO (Unwind -> IO b) -> Unwind -> IO b
forall a b. (a -> b) -> a -> b
$! Capture Any -> Unwind
UnwindControl (Capture a -> Capture Any
forall a b. Coercible a b => a -> b
coerce Capture a
a)
{-# INLINE captureVM #-}

-- | Runs an 'EVM' action with a new prompt installed. The arguments specify
-- what happens when control exits the action.
promptVM
  :: forall a b
   . IO (Registers, a)
  -> (a -> IO b)
  -- ^ return handler
  -> (PromptId -> Any -> IO b)
  -- ^ abort handler
  -> (Capture a -> IO b)
  -- ^ capture handler
  -> IO b
promptVM :: IO (Registers, a)
-> (a -> IO b)
-> (PromptId -> Any -> IO b)
-> (Capture a -> IO b)
-> IO b
promptVM IO (Registers, a)
m a -> IO b
onReturn PromptId -> Any -> IO b
onAbort Capture a -> IO b
onControl = (Unwind -> IO b) -> IO b -> IO b
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
IO.handle Unwind -> IO b
handleUnwind do
  -- TODO: Explain why it is crucial that the exception handler is installed
  -- outside of the frame where we replace the registers!
  Result Registers#
_ a
a <- (State# RealWorld -> (# State# RealWorld, Result a #))
-> IO (Result a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Result a #))
-> State# RealWorld -> (# State# RealWorld, Result a #)
forall a.
(State# RealWorld -> (# State# RealWorld, a #))
-> State# RealWorld -> (# State# RealWorld, a #)
reset# (IO (Result a)
-> State# RealWorld -> (# State# RealWorld, Result a #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (IO (Registers, a) -> IO (Result a)
forall a. IO (Registers, a) -> IO (Result a)
packIOResult IO (Registers, a)
m)))
  a -> IO b
onReturn a
a
  where
    handleUnwind :: Unwind -> IO b
handleUnwind (UnwindAbort PromptId
pid Any
a) = PromptId -> Any -> IO b
onAbort PromptId
pid Any
a
    handleUnwind (UnwindControl Capture Any
cap) = Coercion a Any -> (Coercible a Any => IO b) -> IO b
forall {k} (a :: k) (b :: k) r.
Coercion a b -> (Coercible a b => r) -> r
gcoerceWith (Coercion a Any
forall {k} (a :: k). Coercion a Any
anyCo @a) ((Coercible a Any => IO b) -> IO b)
-> (Coercible a Any => IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ Capture a -> IO b
onControl (Capture Any -> Capture a
forall a b. Coercible a b => a -> b
coerce Capture Any
cap)
{-# INLINE promptVM #-}

-- | Like 'promptVM', but for prompts that cannot be the target of a capture or
-- abort (that is, prompts that only install winders/unwinders).
promptVM_
  :: forall a
   . IO (Registers, a)
  -> Registers
  -- ^ registers to restore on normal return
  -> (Capture a -> IO (Registers, a))
  -- ^ capture handler
  -> IO (Registers, a)
promptVM_ :: IO (Registers, a)
-> Registers
-> (Capture a -> IO (Registers, a))
-> IO (Registers, a)
promptVM_ IO (Registers, a)
m Registers
rs Capture a -> IO (Registers, a)
onCapture = IO (Registers, a)
-> (a -> IO (Registers, a))
-> (PromptId -> Any -> IO (Registers, a))
-> (Capture a -> IO (Registers, a))
-> IO (Registers, a)
forall a b.
IO (Registers, a)
-> (a -> IO b)
-> (PromptId -> Any -> IO b)
-> (Capture a -> IO b)
-> IO b
promptVM IO (Registers, a)
m a -> IO (Registers, a)
onReturn PromptId -> Any -> IO (Registers, a)
forall {a}. PromptId -> Any -> IO a
rethrowAbort Capture a -> IO (Registers, a)
onCapture where
  onReturn :: a -> IO (Registers, a)
onReturn a
a = (Registers, a) -> IO (Registers, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Registers
rs, a
a)
  -- TODO: Check if this unwrapping/rewrapping is eliminated at the STG level.
  rethrowAbort :: PromptId -> Any -> IO a
rethrowAbort PromptId
pid Any
a = Unwind -> IO a
forall e a. Exception e => e -> IO a
IO.throwIO (Unwind -> IO a) -> Unwind -> IO a
forall a b. (a -> b) -> a -> b
$! PromptId -> Any -> Unwind
UnwindAbort PromptId
pid Any
a
{-# INLINE promptVM_ #-}

controlVM :: ((a -> EVM b) -> IO (Registers, b)) -> IO (Registers, a)
controlVM :: ((a -> EVM b) -> IO (Registers, b)) -> IO (Registers, a)
controlVM (a -> EVM b) -> IO (Registers, b)
f = (State# RealWorld -> (# State# RealWorld, Result a #))
-> IO (Result a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((((State# RealWorld -> (# State# RealWorld, Result a #))
  -> State# RealWorld -> (# State# RealWorld, Result b #))
 -> State# RealWorld -> (# State# RealWorld, Result b #))
-> State# RealWorld -> (# State# RealWorld, Result a #)
forall a b.
(((State# RealWorld -> (# State# RealWorld, a #))
  -> State# RealWorld -> (# State# RealWorld, b #))
 -> State# RealWorld -> (# State# RealWorld, b #))
-> State# RealWorld -> (# State# RealWorld, a #)
shift# ((State# RealWorld -> (# State# RealWorld, Result a #))
 -> State# RealWorld -> (# State# RealWorld, Result b #))
-> State# RealWorld -> (# State# RealWorld, Result b #)
f#) IO (Result a) -> (Result a -> (Registers, a)) -> IO (Registers, a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Result Registers#
rs a
a) -> (Registers# -> Registers
BoxRegisters Registers#
rs, a
a) where
  f# :: ((State# RealWorld -> (# State# RealWorld, Result a #))
 -> State# RealWorld -> (# State# RealWorld, Result b #))
-> State# RealWorld -> (# State# RealWorld, Result b #)
f# (State# RealWorld -> (# State# RealWorld, Result a #))
-> State# RealWorld -> (# State# RealWorld, Result b #)
k# = IO (Result b)
-> State# RealWorld -> (# State# RealWorld, Result b #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO ((a -> EVM b) -> IO (Registers, b)
f a -> EVM b
k IO (Registers, b) -> ((Registers, b) -> Result b) -> IO (Result b)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(BoxRegisters Registers#
rs, b
a) -> Registers# -> b -> Result b
forall a. Registers# -> a -> Result a
Result Registers#
rs b
a) where
    k :: a -> EVM b
k a
a = (Registers# -> IO (Result b)) -> EVM b
forall a. (Registers# -> IO (Result a)) -> EVM a
EVM# \Registers#
rs -> (State# RealWorld -> (# State# RealWorld, Result b #))
-> IO (Result b)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Result b #))
 -> IO (Result b))
-> (State# RealWorld -> (# State# RealWorld, Result b #))
-> IO (Result b)
forall a b. (a -> b) -> a -> b
$ (State# RealWorld -> (# State# RealWorld, Result a #))
-> State# RealWorld -> (# State# RealWorld, Result b #)
k# \State# RealWorld
s -> (# State# RealWorld
s, Registers# -> a -> Result a
forall a. Registers# -> a -> Result a
Result Registers#
rs a
a #)
{-# INLINE controlVM #-}

-- TODO: Share some code between `parameterizeVM` and `handle`.
parameterizeVM :: (Registers -> Registers) -> EVM a -> EVM a
parameterizeVM :: (Registers -> Registers) -> EVM a -> EVM a
parameterizeVM Registers -> Registers
adjust (EVM Registers -> IO (Registers, a)
m0) = (Registers -> IO (Registers, a)) -> EVM a
forall a. (Registers -> IO (Registers, a)) -> EVM a
EVM \Registers
rs -> do
  IO (Registers, a)
-> Registers
-> (Capture a -> IO (Registers, a))
-> IO (Registers, a)
forall a.
IO (Registers, a)
-> Registers
-> (Capture a -> IO (Registers, a))
-> IO (Registers, a)
promptVM_ (Registers -> IO (Registers, a)
m0 (Registers -> Registers
adjust Registers
rs)) Registers
rs \(Capture PromptId
target CaptureMode
mode (b -> EVM c) -> EVM d
f b -> EVM a
k1) ->
    ((a -> EVM Any) -> IO (Registers, Any)) -> IO (Registers, a)
forall a b.
((a -> EVM b) -> IO (Registers, b)) -> IO (Registers, a)
controlVM \a -> EVM Any
k2 -> Capture Any -> IO (Registers, Any)
forall a b. Capture a -> IO b
captureVM (Capture Any -> IO (Registers, Any))
-> Capture Any -> IO (Registers, Any)
forall a b. (a -> b) -> a -> b
$! PromptId
-> CaptureMode
-> ((b -> EVM c) -> EVM d)
-> (b -> EVM a)
-> (a -> EVM Any)
-> Capture Any
forall a d e b c.
PromptId
-> CaptureMode
-> ((a -> EVM d) -> EVM e)
-> (a -> EVM b)
-> (b -> EVM c)
-> Capture c
handleCapture PromptId
target CaptureMode
mode (b -> EVM c) -> EVM d
f b -> EVM a
k1 a -> EVM Any
k2
  where
    handleCapture
      :: PromptId
      -> CaptureMode
      -> ((a -> EVM d) -> EVM e)
      -> (a -> EVM b)
      -> (b -> EVM c)
      -> Capture c
    handleCapture :: PromptId
-> CaptureMode
-> ((a -> EVM d) -> EVM e)
-> (a -> EVM b)
-> (b -> EVM c)
-> Capture c
handleCapture PromptId
target1 CaptureMode
mode1 (a -> EVM d) -> EVM e
f1 a -> EVM b
k1 b -> EVM c
k2 =
      let k3 :: a -> EVM c
k3 a
a = (Registers -> IO (Registers, c)) -> EVM c
forall a. (Registers -> IO (Registers, a)) -> EVM a
EVM \Registers
rs1 -> do
            let m :: IO (Registers, b)
m = EVM b -> Registers -> IO (Registers, b)
forall a. EVM a -> Registers -> IO (Registers, a)
unEVM (a -> EVM b
k1 a
a) (Registers -> Registers
adjust Registers
rs1)
            (Registers
rs2, b
b) <- IO (Registers, b)
-> Registers
-> (Capture b -> IO (Registers, b))
-> IO (Registers, b)
forall a.
IO (Registers, a)
-> Registers
-> (Capture a -> IO (Registers, a))
-> IO (Registers, a)
promptVM_ IO (Registers, b)
m Registers
rs1 \(Capture PromptId
target2 CaptureMode
mode2 (b -> EVM c) -> EVM d
f2 b -> EVM b
k4) ->
              Capture c -> IO (Registers, b)
forall a b. Capture a -> IO b
captureVM (Capture c -> IO (Registers, b)) -> Capture c -> IO (Registers, b)
forall a b. (a -> b) -> a -> b
$! PromptId
-> CaptureMode
-> ((b -> EVM c) -> EVM d)
-> (b -> EVM b)
-> (b -> EVM c)
-> Capture c
forall a d e b c.
PromptId
-> CaptureMode
-> ((a -> EVM d) -> EVM e)
-> (a -> EVM b)
-> (b -> EVM c)
-> Capture c
handleCapture PromptId
target2 CaptureMode
mode2 (b -> EVM c) -> EVM d
f2 b -> EVM b
k4 b -> EVM c
k2
            EVM c -> Registers -> IO (Registers, c)
forall a. EVM a -> Registers -> IO (Registers, a)
unEVM (b -> EVM c
k2 b
b) Registers
rs2
      in PromptId
-> CaptureMode
-> ((a -> EVM d) -> EVM e)
-> (a -> EVM c)
-> Capture c
forall b c d a.
PromptId
-> CaptureMode
-> ((b -> EVM c) -> EVM d)
-> (b -> EVM a)
-> Capture a
Capture PromptId
target1 CaptureMode
mode1 (a -> EVM d) -> EVM e
f1 a -> EVM c
k3
{-# INLINE parameterizeVM #-}

{- -----------------------------------------------------------------------------
-- Note [The targets vector]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In most implementations of delimited control or algebraic effects, handling an
effect involves walking the prompt/handler stack looking for a frame with the
right tag. This is a little unfortunate, as in the large majority of use cases,
the handler stack changes infrequently relative to the number of effectful
operations that are performed. Therefore, we take a slightly different approach,
and we cache which effects are handled by which handlers at any given time.

This cache is stored in the /targets vector/ (represented by type `Targets`), an
immutable SmallArray that contains pointers to `Handler`s. Each effect is mapped
to a handler using its index in the type-level list. For example, if we have a
computation of type

    Eff '[Reader Int, NonDet, Error String] a

then the targets vector will be three elements long. Index 0 will point to a
handler for `Reader Int`, index 1 will point to a handler for `NonDet`, and
index 2 will point to a handler for `Error String`.

The targets vector makes `send` a constant-time operation, regardless of the
number of effects. The `:<` class provides the effect’s index, so `send` need
only look up the index in the targets vector and invoke the handler. This is a
particularly good tradeoff in situations where the following conditions hold:

  1. Most effects are handled at the top-level of the program and changed
     infrequently during runtime.

  2. Most calls to `send` do not need to capture the continuation.

In practice, these conditions seem usually true. However, if they aren’t,
maintaining the targets vector has a cost: it needs to be recomputed on every
use of `handle` or `lift`, and continuation restore requires recomputing the
vector for every `handle` or `lift` frame in the captured continuation! In most
cases, the vector is very small, so this isn’t a big deal.

If the overhead of maintaining the targets vector ever turns out to be
significant, there are a variety of potential optimizations that we currently
don’t do. Here are a couple possibilities:

  * Most continuations are restored in the same context where they’re captured,
    so there’s no need to recompute the targets vectors upon restore. Skipping
    is the recomputation in that case is likely a particularly easy win.

  * If the list of effects grows very large, the cost of copying the whole
    vector could become prohibitive. In those situations, we could switch to a
    more sophisticated representation that allows more sharing while still
    providing decent access time, avoiding the need for unbounded copying. -}

newtype Targets# = Targets# (SmallArray# Any)
newtype Targets = Targets (SmallArray Any)
pattern BoxTargets :: Targets# -> Targets
pattern $bBoxTargets :: Targets# -> Targets
$mBoxTargets :: forall {r}. Targets -> (Targets# -> r) -> (Void# -> r) -> r
BoxTargets ts <- Targets (SmallArray (Targets# -> ts))
  where BoxTargets (Targets# SmallArray# Any
ts) = SmallArray Any -> Targets
Targets (SmallArray# Any -> SmallArray Any
forall a. SmallArray# a -> SmallArray a
SmallArray SmallArray# Any
ts)
{-# COMPLETE BoxTargets #-}

noTargets :: Targets
noTargets :: Targets
noTargets = SmallArray Any -> Targets
Targets SmallArray Any
forall a. Monoid a => a
mempty

lookupTarget :: forall effs eff. (DebugCallStack, eff :< effs) => Targets -> Handler eff
lookupTarget :: Targets -> Handler eff
lookupTarget (Targets SmallArray Any
ts) = case SmallArray Any -> Int -> (# Any #)
forall a. DebugCallStack => SmallArray a -> Int -> (# a #)
indexSmallArray SmallArray Any
ts ((eff :< effs) => Int
forall (eff :: Effect) (effs :: [Effect]). (eff :< effs) => Int
reifyIndex @eff @effs) of (# Any h #) -> Handler eff
h

pushTarget :: Handler eff -> Targets -> Targets
pushTarget :: Handler eff -> Targets -> Targets
pushTarget Handler eff
h (Targets SmallArray Any
ts1) = SmallArray Any -> Targets
Targets (SmallArray Any -> Targets) -> SmallArray Any -> Targets
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (SmallMutableArray s Any)) -> SmallArray Any
forall a. (forall s. ST s (SmallMutableArray s a)) -> SmallArray a
runSmallArray do
  let len :: Int
len = SmallArray Any -> Int
forall a. DebugCallStack => SmallArray a -> Int
sizeofSmallArray SmallArray Any
ts1
  SmallMutableArray s Any
ts2 <- Int -> Any -> ST s (SmallMutableArray (PrimState (ST s)) Any)
forall (m :: * -> *) a.
(DebugCallStack, PrimMonad m) =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
newSmallArray (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Any
null#
  SmallMutableArray (PrimState (ST s)) Any -> Int -> Any -> ST s ()
forall (m :: * -> *) a.
(DebugCallStack, PrimMonad m) =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
writeSmallArray SmallMutableArray s Any
SmallMutableArray (PrimState (ST s)) Any
ts2 Int
0 (Handler eff -> Any
forall a. a -> Any
Any Handler eff
h)
  SmallMutableArray (PrimState (ST s)) Any
-> Int -> SmallArray Any -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
(DebugCallStack, PrimMonad m) =>
SmallMutableArray (PrimState m) a
-> Int -> SmallArray a -> Int -> Int -> m ()
copySmallArray SmallMutableArray s Any
SmallMutableArray (PrimState (ST s)) Any
ts2 Int
1 SmallArray Any
ts1 Int
0 Int
len
  SmallMutableArray s Any -> ST s (SmallMutableArray s Any)
forall (f :: * -> *) a. Applicative f => a -> f a
pure SmallMutableArray s Any
ts2

dropTargets :: DebugCallStack => Int -> Targets -> Targets
dropTargets :: Int -> Targets -> Targets
dropTargets Int
idx (Targets SmallArray Any
ts) = SmallArray Any -> Targets
Targets (SmallArray Any -> Targets) -> SmallArray Any -> Targets
forall a b. (a -> b) -> a -> b
$ SmallArray Any -> Int -> Int -> SmallArray Any
forall a.
DebugCallStack =>
SmallArray a -> Int -> Int -> SmallArray a
cloneSmallArray SmallArray Any
ts Int
idx (SmallArray Any -> Int
forall a. DebugCallStack => SmallArray a -> Int
sizeofSmallArray SmallArray Any
ts Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
idx)

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

instance Functor EVM where
  fmap :: (a -> b) -> EVM a -> EVM b
fmap a -> b
f EVM a
m = EVM a
m EVM a -> (a -> EVM b) -> EVM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> EVM b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> EVM b) -> (a -> b) -> a -> EVM b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f
  {-# INLINE fmap #-}

instance Applicative EVM where
  pure :: a -> EVM a
pure a
a = (Registers# -> IO (Result a)) -> EVM a
forall a. (Registers# -> IO (Result a)) -> EVM a
EVM# \Registers#
rs -> Result a -> IO (Result a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result a -> IO (Result a)) -> Result a -> IO (Result a)
forall a b. (a -> b) -> a -> b
$ Registers# -> a -> Result a
forall a. Registers# -> a -> Result a
Result Registers#
rs a
a
  {-# INLINE pure #-}
  <*> :: EVM (a -> b) -> EVM a -> EVM b
(<*>) = EVM (a -> b) -> EVM a -> EVM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
  {-# INLINE (<*>) #-}

instance Monad EVM where
  EVM# Registers# -> IO (Result a)
m >>= :: EVM a -> (a -> EVM b) -> EVM b
>>= a -> EVM b
f = (Registers# -> IO (Result b)) -> EVM b
forall a. (Registers# -> IO (Result a)) -> EVM a
EVM# \Registers#
rs1 -> Registers# -> IO (Result a)
m Registers#
rs1 IO (Result a) -> (Result a -> IO (Result b)) -> IO (Result b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Result Registers#
rs2 a
a) -> EVM b -> Registers# -> IO (Result b)
forall a. EVM a -> Registers# -> IO (Result a)
unEVM# (a -> EVM b
f a
a) Registers#
rs2
  {-# INLINE (>>=) #-}

instance MonadIO EVM where
  liftIO :: IO a -> EVM a
liftIO IO a
m = (Registers# -> IO (Result a)) -> EVM a
forall a. (Registers# -> IO (Result a)) -> EVM a
EVM# \Registers#
rs -> Registers# -> a -> Result a
forall a. Registers# -> a -> Result a
Result Registers#
rs (a -> Result a) -> IO a -> IO (Result a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
m
  {-# INLINE liftIO #-}

-- | Runs a pure 'Eff' computation to produce a value.
--
-- @
-- >>> 'run' '$' 'pure' 42
-- 42
-- >>> 'run' '$' 'Control.Effect.Error.runError' '$' 'Control.Effect.Error.throw' "bang"
-- 'Left' "bang"
-- @
run :: Eff '[] a -> a
run :: Eff '[] a -> a
run (Eff Registers -> IO (Registers, a)
m) = IO a -> a
forall a. IO a -> a
unsafeDupablePerformIO ((Registers, a) -> a
forall a b. (a, b) -> b
snd ((Registers, a) -> a) -> IO (Registers, a) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Registers -> IO (Registers, a)
m Registers
initialRegisters)

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

-- | The monad that effect handlers run in.
--
--   * The @eff@ parameter is the effect being handled, and the @effs@ parameter
--     includes the other effects in scope at the point of the 'handle' call
--     (used by 'liftH').
--
--   * The @i@ parameter is the return type of the handled computation before
--     the exit handler has been applied (used by 'control0').
--
--   * The @r@ parameter is the final return type of the handled computation
--     (used by 'abort', 'control', and 'control0').
--
--   * The @effs'@ parameter is the list of effects in scope at the point of the
--     originating 'send' call (used by 'locally').
--
-- See 'handle' for more details.
type Handle :: Effect -> [Effect] -> Type -> Type -> [Effect] -> Type -> Type
type role Handle nominal nominal representational representational nominal representational
newtype Handle eff effs i r effs' a = Handle# { Handle eff effs i r effs' a -> Registers# -> Eff effs' a
runHandle# :: Registers# -> Eff effs' a }
pattern Handle :: (Registers -> Eff effs' a) -> Handle eff effs i r effs' a
-- see Note [Manual worker/wrapper]
pattern $bHandle :: (Registers -> Eff effs' a) -> Handle eff effs i r effs' a
$mHandle :: forall {r} {effs' :: [Effect]} {a} {eff :: Effect}
       {effs :: [Effect]} {i} {r}.
Handle eff effs i r effs' a
-> ((Registers -> Eff effs' a) -> r) -> (Void# -> r) -> r
Handle{Handle eff effs i r effs' a -> Registers -> Eff effs' a
runHandle} <- Handle# ((\f (BoxRegisters rs) -> f rs) -> runHandle)
  where Handle Registers -> Eff effs' a
f = (Registers# -> Eff effs' a) -> Handle eff effs i r effs' a
forall (eff :: Effect) (effs :: [Effect]) i r (effs' :: [Effect])
       a.
(Registers# -> Eff effs' a) -> Handle eff effs i r effs' a
Handle# \Registers#
rs -> Registers -> Eff effs' a
f (Registers# -> Registers
BoxRegisters Registers#
rs)
{-# COMPLETE Handle #-}

instance Functor (Handle eff effs i r effs') where
  fmap :: (a -> b)
-> Handle eff effs i r effs' a -> Handle eff effs i r effs' b
fmap a -> b
f Handle eff effs i r effs' a
m = Handle eff effs i r effs' a
m Handle eff effs i r effs' a
-> (a -> Handle eff effs i r effs' b)
-> Handle eff effs i r effs' b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> Handle eff effs i r effs' b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Handle eff effs i r effs' b)
-> (a -> b) -> a -> Handle eff effs i r effs' b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f
  {-# INLINE fmap #-}

instance Applicative (Handle eff effs i r effs') where
  pure :: a -> Handle eff effs i r effs' a
pure a
a = (Registers# -> Eff effs' a) -> Handle eff effs i r effs' a
forall (eff :: Effect) (effs :: [Effect]) i r (effs' :: [Effect])
       a.
(Registers# -> Eff effs' a) -> Handle eff effs i r effs' a
Handle# \Registers#
_ -> a -> Eff effs' a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  {-# INLINE pure #-}
  <*> :: Handle eff effs i r effs' (a -> b)
-> Handle eff effs i r effs' a -> Handle eff effs i r effs' b
(<*>) = Handle eff effs i r effs' (a -> b)
-> Handle eff effs i r effs' a -> Handle eff effs i r effs' b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
  {-# INLINE (<*>) #-}

instance Monad (Handle eff effs i r effs') where
  Handle# Registers# -> Eff effs' a
m >>= :: Handle eff effs i r effs' a
-> (a -> Handle eff effs i r effs' b)
-> Handle eff effs i r effs' b
>>= a -> Handle eff effs i r effs' b
f = (Registers# -> Eff effs' b) -> Handle eff effs i r effs' b
forall (eff :: Effect) (effs :: [Effect]) i r (effs' :: [Effect])
       a.
(Registers# -> Eff effs' a) -> Handle eff effs i r effs' a
Handle# \Registers#
rs -> Registers# -> Eff effs' a
m Registers#
rs Eff effs' a -> (a -> Eff effs' b) -> Eff effs' b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> Handle eff effs i r effs' b -> Registers# -> Eff effs' b
forall (eff :: Effect) (effs :: [Effect]) i r (effs' :: [Effect])
       a.
Handle eff effs i r effs' a -> Registers# -> Eff effs' a
runHandle# (a -> Handle eff effs i r effs' b
f a
a) Registers#
rs
  {-# INLINE (>>=) #-}

newtype Handler eff
  = Handler# { Handler eff
-> forall (effs :: [Effect]) a.
   (eff :<# effs) -> eff (Eff effs) a -> Eff effs a
runHandler# :: forall effs a. eff :<# effs -> eff (Eff effs) a -> Eff effs a }
newtype WrappedHandler eff
  -- Unfortunately necessary to avoid the need for impredicative polymorphism in
  -- the definition of the Handler pattern synonym.
  = WrapHandler (forall effs a. eff :< effs => eff (Eff effs) a -> Eff effs a)
pattern Handler :: (forall effs a. eff :< effs => eff (Eff effs) a -> Eff effs a) -> Handler eff
-- see Note [Manual worker/wrapper]
pattern $bHandler :: (forall (effs :: [Effect]) a.
 (eff :< effs) =>
 eff (Eff effs) a -> Eff effs a)
-> Handler eff
$mHandler :: forall {r} {eff :: Effect}.
Handler eff
-> ((forall (effs :: [Effect]) a.
     (eff :< effs) =>
     eff (Eff effs) a -> Eff effs a)
    -> r)
-> (Void# -> r)
-> r
Handler{Handler eff
-> forall (effs :: [Effect]) a.
   (eff :< effs) =>
   eff (Eff effs) a -> Eff effs a
runHandler} <- ((\(Handler# f) -> WrapHandler (f IndexDict#)) -> WrapHandler runHandler)
  where Handler forall (effs :: [Effect]) a.
(eff :< effs) =>
eff (Eff effs) a -> Eff effs a
f = (forall (effs :: [Effect]) a.
 (eff :<# effs) -> eff (Eff effs) a -> Eff effs a)
-> Handler eff
forall (eff :: Effect).
(forall (effs :: [Effect]) a.
 (eff :<# effs) -> eff (Eff effs) a -> Eff effs a)
-> Handler eff
Handler# \eff :<# effs
IndexDict# -> eff (Eff effs) a -> Eff effs a
forall (effs :: [Effect]) a.
(eff :< effs) =>
eff (Eff effs) a -> Eff effs a
f
{-# COMPLETE Handler #-}

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

send :: forall eff a effs. eff :< effs => eff (Eff effs) a -> Eff effs a
send :: eff (Eff effs) a -> Eff effs a
send !eff (Eff effs) a
e = (Registers -> IO (Registers, a)) -> Eff effs a
forall a (effs :: [Effect]).
(Registers -> IO (Registers, a)) -> Eff effs a
Eff \rs :: Registers
rs@(Registers PromptId
_ Targets
ts) -> Eff effs a -> Registers -> IO (Registers, a)
forall a (effs :: [Effect]).
Eff effs a -> Registers -> IO (Registers, a)
unEff (Handler eff -> eff (Eff effs) a -> Eff effs a
forall (eff :: Effect).
Handler eff
-> forall (effs :: [Effect]) a.
   (eff :< effs) =>
   eff (Eff effs) a -> Eff effs a
runHandler (Targets -> Handler eff
forall (effs :: [Effect]) (eff :: Effect).
(DebugCallStack, eff :< effs) =>
Targets -> Handler eff
lookupTarget @effs Targets
ts) eff (Eff effs) a
e) Registers
rs

-- | Handles the topmost effect in an 'Eff' computation. The given handler
-- function must provide an interpretation for each effectful operation. The
-- handler runs in the restrictive 'Handle' monad, which generally uses one of
-- the following core 'Handle' operations:
--
--   * 'liftH' — Runs an action in the context of the original 'handle' call.
--     This is the most common way to handle an effect.
--
--   * 'abort' — Aborts the computation to the 'handle' call and returns a value
--     directly. This is usually used to implement exception-like operations.
--
--   * 'control' — Captures the current continuation up to and including the
--     'handle' call and aborts, passing the captured continuation to the
--     handler. This can be used to implement complex control operators such as
--     coroutines or resumable exceptions.
--
--   * 'control0' — Like 'control', but does not include the 'handle' call
--     itself in the captured continuation, so a different handler may be
--     installed before resuming the computation.
--
--   * 'locally' — Runs an action directly in the context of the originating
--     'send' call. This can be used to implement “scoped” operations like
--     'Control.Effect.local' and 'Control.Effect.catch'.
--
-- See the documentation for each of the above functions for examples and more
-- details.
handle
  :: forall eff a r effs
   . (a -> Eff effs r)
  -- ^ The exit handler, aka the action to take on normal returns (often just 'pure').
  -> (forall effs' b. eff :< effs' => eff (Eff effs') b -> Handle eff effs a r effs' b)
  -- ^ The handler function.
  -> Eff (eff ': effs) a
  -- ^ The action to handle.
  -> Eff effs r
handle :: (a -> Eff effs r)
-> (forall (effs' :: [Effect]) b.
    (eff :< effs') =>
    eff (Eff effs') b -> Handle eff effs a r effs' b)
-> Eff (eff : effs) a
-> Eff effs r
handle a -> Eff effs r
onReturn forall (effs' :: [Effect]) b.
(eff :< effs') =>
eff (Eff effs') b -> Handle eff effs a r effs' b
f = (a -> Eff effs r)
-> (Registers# -> Handler eff) -> Eff (eff : effs) a -> Eff effs r
forall (eff :: Effect) a r (effs :: [Effect]).
(a -> Eff effs r)
-> (Registers# -> Handler eff) -> Eff (eff : effs) a -> Eff effs r
handleVM a -> Eff effs r
onReturn \Registers#
rs -> (forall (effs :: [Effect]) a.
 (eff :< effs) =>
 eff (Eff effs) a -> Eff effs a)
-> Handler eff
forall (eff :: Effect).
(forall (effs :: [Effect]) a.
 (eff :< effs) =>
 eff (Eff effs) a -> Eff effs a)
-> Handler eff
Handler \eff (Eff effs) a
e -> Handle eff effs a r effs a -> Registers# -> Eff effs a
forall (eff :: Effect) (effs :: [Effect]) i r (effs' :: [Effect])
       a.
Handle eff effs i r effs' a -> Registers# -> Eff effs' a
runHandle# (eff (Eff effs) a -> Handle eff effs a r effs a
forall (effs' :: [Effect]) b.
(eff :< effs') =>
eff (Eff effs') b -> Handle eff effs a r effs' b
f eff (Eff effs) a
e) Registers#
rs
{-# INLINE handle #-}

handleVM
  :: forall eff a r effs
   . (a -> Eff effs r)
  -> (Registers# -> Handler eff)
  -> Eff (eff ': effs) a
  -> Eff effs r
handleVM :: (a -> Eff effs r)
-> (Registers# -> Handler eff) -> Eff (eff : effs) a -> Eff effs r
handleVM a -> Eff effs r
onReturn Registers# -> Handler eff
f (Eff Registers -> IO (Registers, a)
m1) = EVM r -> Eff effs r
forall (effs :: [Effect]) a. EVM a -> Eff effs a
Eff# ((Registers -> IO (Registers, a)) -> EVM r
withHandler Registers -> IO (Registers, a)
m1)
  where
    withHandler :: (Registers -> IO (Registers, a)) -> EVM r
    -- GHC can’t figure out how to pull this small bit of unboxing out of the
    -- recursive knot we’re tying, so we do it manually here
    withHandler :: (Registers -> IO (Registers, a)) -> EVM r
withHandler Registers -> IO (Registers, a)
g = (Registers# -> IO (Result a)) -> EVM r
withHandler# (EVM a -> Registers# -> IO (Result a)
forall a. EVM a -> Registers# -> IO (Result a)
unEVM# ((Registers -> IO (Registers, a)) -> EVM a
forall a. (Registers -> IO (Registers, a)) -> EVM a
EVM Registers -> IO (Registers, a)
g))
    {-# INLINE withHandler #-}

    withHandler# :: (Registers# -> IO (Result a)) -> EVM r
    withHandler# :: (Registers# -> IO (Result a)) -> EVM r
withHandler# Registers# -> IO (Result a)
m2 = (Registers -> IO (Registers, r)) -> EVM r
forall a. (Registers -> IO (Registers, a)) -> EVM a
EVM \Registers
rs -> do
      EVM a
-> Registers
-> (Capture a -> IO (Registers, r))
-> IO (Registers, r)
resetPrompt ((Registers# -> IO (Result a)) -> EVM a
forall a. (Registers# -> IO (Result a)) -> EVM a
EVM# Registers# -> IO (Result a)
m2) Registers
rs \(Capture PromptId
target CaptureMode
mode (b -> EVM c) -> EVM d
g b -> EVM a
k1) ->
        ((r -> EVM Any) -> IO (Registers, Any)) -> IO (Registers, r)
forall a b.
((a -> EVM b) -> IO (Registers, b)) -> IO (Registers, a)
controlVM \r -> EVM Any
k2 -> Capture Any -> IO (Registers, Any)
forall a b. Capture a -> IO b
captureVM (Capture Any -> IO (Registers, Any))
-> Capture Any -> IO (Registers, Any)
forall a b. (a -> b) -> a -> b
$! PromptId
-> CaptureMode
-> ((b -> EVM c) -> EVM d)
-> (b -> EVM a)
-> (r -> EVM Any)
-> Capture Any
forall b d e c.
PromptId
-> CaptureMode
-> ((b -> EVM d) -> EVM e)
-> (b -> EVM a)
-> (r -> EVM c)
-> Capture c
handleCaptureElsewhere PromptId
target CaptureMode
mode (b -> EVM c) -> EVM d
g b -> EVM a
k1 r -> EVM Any
k2

    pushPrompt :: Registers -> Registers
pushPrompt (Registers PromptId
pid1 Targets
ts1) =
      let pid2 :: PromptId
pid2 = Int -> PromptId
PromptId (PromptId -> Int
unPromptId PromptId
pid1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          ts2 :: Targets
ts2 = Handler eff -> Targets -> Targets
forall (eff :: Effect). Handler eff -> Targets -> Targets
pushTarget (Registers# -> Handler eff
f (Registers -> Registers#
unboxRegisters Registers
rs2)) Targets
ts1
          rs2 :: Registers
rs2 = PromptId -> Targets -> Registers
Registers PromptId
pid2 Targets
ts2
      in Registers
rs2

    resetPrompt
      :: EVM a
      -> Registers
      -> (Capture a -> IO (Registers, r))
      -> IO (Registers, r)
    resetPrompt :: EVM a
-> Registers
-> (Capture a -> IO (Registers, r))
-> IO (Registers, r)
resetPrompt EVM a
m Registers
rs1 Capture a -> IO (Registers, r)
onCaptureElsewhere =
      IO (Registers, a)
-> (a -> IO (Registers, r))
-> (PromptId -> Any -> IO (Registers, r))
-> (Capture a -> IO (Registers, r))
-> IO (Registers, r)
forall a b.
IO (Registers, a)
-> (a -> IO b)
-> (PromptId -> Any -> IO b)
-> (Capture a -> IO b)
-> IO b
promptVM (EVM a -> Registers -> IO (Registers, a)
forall a. EVM a -> Registers -> IO (Registers, a)
unEVM EVM a
m Registers
rs2) a -> IO (Registers, r)
handleReturn PromptId -> Any -> IO (Registers, r)
handleAbort Capture a -> IO (Registers, r)
handleCapture
      where
        !rs2 :: Registers
rs2@(Registers PromptId
pid Targets
_) = Registers -> Registers
pushPrompt Registers
rs1

        handleReturn :: a -> IO (Registers, r)
handleReturn a
a = Eff effs r -> Registers -> IO (Registers, r)
forall a (effs :: [Effect]).
Eff effs a -> Registers -> IO (Registers, a)
unEff (a -> Eff effs r
onReturn a
a) Registers
rs1

        handleAbort :: PromptId -> Any -> IO (Registers, r)
handleAbort PromptId
target Any
a
          | PromptId -> Int
unPromptId PromptId
target Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== PromptId -> Int
unPromptId PromptId
pid = case Any
a of { Any b -> (Registers, r) -> IO (Registers, r)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Registers
rs1, r
b) }
          | Bool
otherwise = Unwind -> IO (Registers, r)
forall e a. Exception e => e -> IO a
IO.throwIO (Unwind -> IO (Registers, r)) -> Unwind -> IO (Registers, r)
forall a b. (a -> b) -> a -> b
$! PromptId -> Any -> Unwind
UnwindAbort PromptId
target Any
a

        handleCapture :: Capture a -> IO (Registers, r)
handleCapture = \case
          Capture PromptId
target CaptureMode
mode ((b -> EVM c) -> EVM d
g :: (b -> EVM c) -> EVM d) b -> EVM a
k1
            | PromptId -> Int
unPromptId PromptId
target Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== PromptId -> Int
unPromptId PromptId
pid ->
                -- We’re capturing up to this prompt, so the new continuation’s
                -- result type must be this function’s result type.
                (r :~: d) -> ((r ~ d) => IO (Registers, r)) -> IO (Registers, r)
forall {k} (a :: k) (b :: k) r. (a :~: b) -> ((a ~ b) => r) -> r
gcastWith (r :~: d
forall {k} (a :: k) (b :: k). a :~: b
axiom @r @d) case CaptureMode
mode of
                  -- If we’re capturing the prompt, then the captured
                  -- continuation include onReturn, so its result type is the
                  -- final result type.
                  CaptureMode
IncludePrompt -> (r :~: c) -> ((r ~ c) => IO (Registers, r)) -> IO (Registers, r)
forall {k} (a :: k) (b :: k) r. (a :~: b) -> ((a ~ b) => r) -> r
gcastWith (r :~: c
forall {k} (a :: k) (b :: k). a :~: b
axiom @r @c) (((r ~ c) => IO (Registers, r)) -> IO (Registers, r))
-> ((r ~ c) => IO (Registers, r)) -> IO (Registers, r)
forall a b. (a -> b) -> a -> b
$ EVM d -> Registers -> IO (Registers, d)
forall a. EVM a -> Registers -> IO (Registers, a)
unEVM ((b -> EVM c) -> EVM d
g ((Registers -> IO (Registers, a)) -> EVM r
withHandler ((Registers -> IO (Registers, a)) -> EVM r)
-> (b -> Registers -> IO (Registers, a)) -> b -> EVM r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EVM a -> Registers -> IO (Registers, a)
forall a. EVM a -> Registers -> IO (Registers, a)
unEVM (EVM a -> Registers -> IO (Registers, a))
-> (b -> EVM a) -> b -> Registers -> IO (Registers, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> EVM a
k1)) Registers
rs1
                  -- If we’re not capturing the prompt, the captured
                  -- continuation does NOT include onReturn, so its result type
                  -- is the intermediate result type.
                  CaptureMode
ExcludePrompt -> (a :~: c) -> ((a ~ c) => IO (Registers, r)) -> IO (Registers, r)
forall {k} (a :: k) (b :: k) r. (a :~: b) -> ((a ~ b) => r) -> r
gcastWith (a :~: c
forall {k} (a :: k) (b :: k). a :~: b
axiom @a @c) (((a ~ c) => IO (Registers, r)) -> IO (Registers, r))
-> ((a ~ c) => IO (Registers, r)) -> IO (Registers, r)
forall a b. (a -> b) -> a -> b
$ EVM d -> Registers -> IO (Registers, d)
forall a. EVM a -> Registers -> IO (Registers, a)
unEVM ((b -> EVM c) -> EVM d
g b -> EVM a
b -> EVM c
k1) Registers
rs1
          Capture a
cap -> Capture a -> IO (Registers, r)
onCaptureElsewhere Capture a
cap

    handleCaptureElsewhere
      :: PromptId
      -> CaptureMode
      -> ((b -> EVM d) -> EVM e)
      -> (b -> EVM a)
      -> (r -> EVM c)
      -> Capture c
    handleCaptureElsewhere :: PromptId
-> CaptureMode
-> ((b -> EVM d) -> EVM e)
-> (b -> EVM a)
-> (r -> EVM c)
-> Capture c
handleCaptureElsewhere PromptId
target1 CaptureMode
mode1 (b -> EVM d) -> EVM e
f1 b -> EVM a
k1 r -> EVM c
k2 =
      let k3 :: b -> EVM c
k3 b
a = (Registers -> IO (Registers, c)) -> EVM c
forall a. (Registers -> IO (Registers, a)) -> EVM a
EVM \Registers
rs1 -> do
            (Registers
rs2, r
b) <- EVM a
-> Registers
-> (Capture a -> IO (Registers, r))
-> IO (Registers, r)
resetPrompt (b -> EVM a
k1 b
a) Registers
rs1 \(Capture PromptId
target2 CaptureMode
mode2 (b -> EVM c) -> EVM d
g b -> EVM a
k4) ->
              Capture c -> IO (Registers, r)
forall a b. Capture a -> IO b
captureVM (Capture c -> IO (Registers, r)) -> Capture c -> IO (Registers, r)
forall a b. (a -> b) -> a -> b
$! PromptId
-> CaptureMode
-> ((b -> EVM c) -> EVM d)
-> (b -> EVM a)
-> (r -> EVM c)
-> Capture c
forall b d e c.
PromptId
-> CaptureMode
-> ((b -> EVM d) -> EVM e)
-> (b -> EVM a)
-> (r -> EVM c)
-> Capture c
handleCaptureElsewhere PromptId
target2 CaptureMode
mode2 (b -> EVM c) -> EVM d
g b -> EVM a
k4 r -> EVM c
k2
            EVM c -> Registers -> IO (Registers, c)
forall a. EVM a -> Registers -> IO (Registers, a)
unEVM (r -> EVM c
k2 r
b) Registers
rs2
      in PromptId
-> CaptureMode
-> ((b -> EVM d) -> EVM e)
-> (b -> EVM c)
-> Capture c
forall b c d a.
PromptId
-> CaptureMode
-> ((b -> EVM c) -> EVM d)
-> (b -> EVM a)
-> Capture a
Capture PromptId
target1 CaptureMode
mode1 (b -> EVM d) -> EVM e
f1 b -> EVM c
k3

locally :: Eff effs' a -> Handle eff effs i r effs' a
locally :: Eff effs' a -> Handle eff effs i r effs' a
locally Eff effs' a
m = (Registers -> Eff effs' a) -> Handle eff effs i r effs' a
forall (effs' :: [Effect]) a (eff :: Effect) (effs :: [Effect]) i
       r.
(Registers -> Eff effs' a) -> Handle eff effs i r effs' a
Handle \Registers
_ -> Eff effs' a
m

liftH :: Eff (eff ': effs) a -> Handle eff effs i r effs' a
liftH :: Eff (eff : effs) a -> Handle eff effs i r effs' a
liftH (Eff# EVM a
m) = (Registers -> Eff effs' a) -> Handle eff effs i r effs' a
forall (effs' :: [Effect]) a (eff :: Effect) (effs :: [Effect]) i
       r.
(Registers -> Eff effs' a) -> Handle eff effs i r effs' a
Handle \(Registers PromptId
_ Targets
ts) ->
  EVM a -> Eff effs' a
forall (effs :: [Effect]) a. EVM a -> Eff effs a
Eff# ((Registers -> Registers) -> EVM a -> EVM a
forall a. (Registers -> Registers) -> EVM a -> EVM a
parameterizeVM (\(Registers PromptId
pid Targets
_) -> PromptId -> Targets -> Registers
Registers PromptId
pid Targets
ts) EVM a
m)

abort :: r -> Handle eff effs i r effs' a
abort :: r -> Handle eff effs i r effs' a
abort r
a = (Registers -> Eff effs' a) -> Handle eff effs i r effs' a
forall (effs' :: [Effect]) a (eff :: Effect) (effs :: [Effect]) i
       r.
(Registers -> Eff effs' a) -> Handle eff effs i r effs' a
Handle \(Registers PromptId
pid Targets
_) -> (Registers -> IO (Registers, a)) -> Eff effs' a
forall a (effs :: [Effect]).
(Registers -> IO (Registers, a)) -> Eff effs a
Eff \Registers
_ -> Unwind -> IO (Registers, a)
forall e a. Exception e => e -> IO a
IO.throwIO (Unwind -> IO (Registers, a)) -> Unwind -> IO (Registers, a)
forall a b. (a -> b) -> a -> b
$! PromptId -> Any -> Unwind
UnwindAbort PromptId
pid (r -> Any
forall a. a -> Any
Any r
a)

control :: ((a -> Eff effs r) -> Eff effs r) -> Handle eff effs i r effs' a
control :: ((a -> Eff effs r) -> Eff effs r) -> Handle eff effs i r effs' a
control (a -> Eff effs r) -> Eff effs r
f = (Registers -> Eff effs' a) -> Handle eff effs i r effs' a
forall (effs' :: [Effect]) a (eff :: Effect) (effs :: [Effect]) i
       r.
(Registers -> Eff effs' a) -> Handle eff effs i r effs' a
Handle \(Registers PromptId
pid Targets
_) -> (Registers -> IO (Registers, a)) -> Eff effs' a
forall a (effs :: [Effect]).
(Registers -> IO (Registers, a)) -> Eff effs a
Eff \Registers
_ ->
  ((a -> EVM Any) -> IO (Registers, Any)) -> IO (Registers, a)
forall a b.
((a -> EVM b) -> IO (Registers, b)) -> IO (Registers, a)
controlVM \a -> EVM Any
k1 -> Capture Any -> IO (Registers, Any)
forall a b. Capture a -> IO b
captureVM (Capture Any -> IO (Registers, Any))
-> Capture Any -> IO (Registers, Any)
forall a b. (a -> b) -> a -> b
$! PromptId
-> CaptureMode
-> ((a -> EVM r) -> EVM r)
-> (a -> EVM Any)
-> Capture Any
forall b c d a.
PromptId
-> CaptureMode
-> ((b -> EVM c) -> EVM d)
-> (b -> EVM a)
-> Capture a
Capture PromptId
pid CaptureMode
IncludePrompt (\a -> EVM r
k2 -> Eff effs r -> EVM r
forall (effs :: [Effect]) a. Eff effs a -> EVM a
unEff# ((a -> Eff effs r) -> Eff effs r
f (EVM r -> Eff effs r
forall (effs :: [Effect]) a. EVM a -> Eff effs a
Eff# (EVM r -> Eff effs r) -> (a -> EVM r) -> a -> Eff effs r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> EVM r
k2))) a -> EVM Any
k1

control0 :: ((a -> Eff (eff ': effs) i) -> Eff effs r) -> Handle eff effs i r effs' a
control0 :: ((a -> Eff (eff : effs) i) -> Eff effs r)
-> Handle eff effs i r effs' a
control0 (a -> Eff (eff : effs) i) -> Eff effs r
f = (Registers -> Eff effs' a) -> Handle eff effs i r effs' a
forall (effs' :: [Effect]) a (eff :: Effect) (effs :: [Effect]) i
       r.
(Registers -> Eff effs' a) -> Handle eff effs i r effs' a
Handle \(Registers PromptId
pid Targets
_) -> (Registers -> IO (Registers, a)) -> Eff effs' a
forall a (effs :: [Effect]).
(Registers -> IO (Registers, a)) -> Eff effs a
Eff \Registers
_ ->
  ((a -> EVM Any) -> IO (Registers, Any)) -> IO (Registers, a)
forall a b.
((a -> EVM b) -> IO (Registers, b)) -> IO (Registers, a)
controlVM \a -> EVM Any
k1 -> Capture Any -> IO (Registers, Any)
forall a b. Capture a -> IO b
captureVM (Capture Any -> IO (Registers, Any))
-> Capture Any -> IO (Registers, Any)
forall a b. (a -> b) -> a -> b
$! PromptId
-> CaptureMode
-> ((a -> EVM i) -> EVM r)
-> (a -> EVM Any)
-> Capture Any
forall b c d a.
PromptId
-> CaptureMode
-> ((b -> EVM c) -> EVM d)
-> (b -> EVM a)
-> Capture a
Capture PromptId
pid CaptureMode
ExcludePrompt (\a -> EVM i
k2 -> Eff effs r -> EVM r
forall (effs :: [Effect]) a. Eff effs a -> EVM a
unEff# ((a -> Eff (eff : effs) i) -> Eff effs r
f (EVM i -> Eff (eff : effs) i
forall (effs :: [Effect]) a. EVM a -> Eff effs a
Eff# (EVM i -> Eff (eff : effs) i)
-> (a -> EVM i) -> a -> Eff (eff : effs) i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> EVM i
k2))) a -> EVM Any
k1

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

-- TODO: Fuse uses of liftTargets using RULES.
type Lift :: [Effect] -> [Effect] -> Constraint
class Lift effs1 effs2 where
  liftTargets :: Targets -> Targets
instance {-# INCOHERENT #-} effs1 :<< effs2 => Lift effs1 effs2 where
  liftTargets :: Targets -> Targets
liftTargets = Int -> Targets -> Targets
DebugCallStack => Int -> Targets -> Targets
dropTargets ((effs1 :<< effs2) => Int
forall (effs1 :: [Effect]) (effs2 :: [Effect]).
(effs1 :<< effs2) =>
Int
reifySubIndex @effs1 @effs2)
  {-# INLINE liftTargets #-}
instance Lift '[] effs where
  liftTargets :: Targets -> Targets
liftTargets Targets
_ = Targets
noTargets
  {-# INLINE liftTargets #-}
instance (eff :< effs2, Lift effs1 effs2) => Lift (eff ': effs1) effs2 where
  liftTargets :: Targets -> Targets
liftTargets Targets
ts = Handler eff -> Targets -> Targets
forall (eff :: Effect). Handler eff -> Targets -> Targets
pushTarget (Targets -> Handler eff
forall (effs :: [Effect]) (eff :: Effect).
(DebugCallStack, eff :< effs) =>
Targets -> Handler eff
lookupTarget @effs2 @eff Targets
ts) (Targets -> Targets) -> Targets -> Targets
forall a b. (a -> b) -> a -> b
$! Targets -> Targets
forall (effs1 :: [Effect]) (effs2 :: [Effect]).
Lift effs1 effs2 =>
Targets -> Targets
liftTargets @effs1 @effs2 Targets
ts

-- | Lifts an 'Eff' computation into one that performs all the same effects, and
-- possibly more. For example, if you have a computation
--
-- @
-- m :: 'Eff' '[Foo, Bar] ()
-- @
--
-- then 'lift' will transform it into a polymorphic computation with the
-- following type:
--
-- @
-- 'lift' m :: (Foo ':<' effs, Bar ':<' effs) => 'Eff' effs ()
-- @
--
-- This type is much more general, and @effs@ can now be instantiated at many
-- different types. Generally, 'lift' can manipulate the list of effects in any
-- of the following ways:
--
--   * Effects can be reordered.
--   * New effects can be inserted anywhere in the list.
--   * Duplicate effects can be collapsed.
--
-- More generally, the list of effects doesn’t need to be entirely concrete in
-- order for 'lift' to work. For example, if you have a computation
--
-- @
-- n :: 'Eff' (Foo ': Bar ': effs1) ()
-- @
--
-- then @'lift' n@ will have the following type:
--
-- @
-- 'lift' n :: (Foo ':<' effs2, Bar ':<' effs2, effs1 ':<<' effs2) => 'Eff' effs2 ()
-- @
--
-- This type is extremely general, and it allows 'lift' to manipulate the /head/
-- of the effects list even if the entire list is not completely known.
--
-- The 'Lift' typeclass provides some type-level programming machinery to
-- implement 'lift', but it should be treated as an implementation detail. In
-- most situations, the machinery should “just work,” but if it doesn’t, the
-- type errors can be somewhat inscrutable. In those situations, adding some
-- explicit type annotations (or using @TypeApplications@) can improve the type
-- errors significantly.
lift :: forall effs1 effs2 a. Lift effs1 effs2 => Eff effs1 a -> Eff effs2 a
lift :: Eff effs1 a -> Eff effs2 a
lift = EVM a -> Eff effs2 a
forall (effs :: [Effect]) a. EVM a -> Eff effs a
Eff# (EVM a -> Eff effs2 a)
-> (Eff effs1 a -> EVM a) -> Eff effs1 a -> Eff effs2 a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Registers -> Registers) -> EVM a -> EVM a
forall a. (Registers -> Registers) -> EVM a -> EVM a
parameterizeVM Registers -> Registers
liftRegisters (EVM a -> EVM a) -> (Eff effs1 a -> EVM a) -> Eff effs1 a -> EVM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff effs1 a -> EVM a
forall (effs :: [Effect]) a. Eff effs a -> EVM a
unEff# where
  liftRegisters :: Registers -> Registers
liftRegisters (Registers PromptId
pid Targets
ts) = PromptId -> Targets -> Registers
Registers PromptId
pid (Targets -> Targets
forall (effs1 :: [Effect]) (effs2 :: [Effect]).
Lift effs1 effs2 =>
Targets -> Targets
liftTargets @effs1 @effs2 Targets
ts)

-- | Like 'lift', but restricted to introducing a single additional effect in the result. This is
-- behaviorally identical to just using 'lift', but the restricted type can produce better type
-- inference.
lift1 :: forall eff effs a. Eff effs a -> Eff (eff ': effs) a
lift1 :: Eff effs a -> Eff (eff : effs) a
lift1 = Eff effs a -> Eff (eff : effs) a
forall (effs1 :: [Effect]) (effs2 :: [Effect]) a.
Lift effs1 effs2 =>
Eff effs1 a -> Eff effs2 a
lift
{-# INLINE lift1 #-}

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

-- | An effect used to run 'IO' operations via 'liftIO'. Handled by the special
-- 'runIO' handler.
data IOE :: Effect where
  LiftIO :: IO a -> IOE m a

unsafeIOToEff :: IO a -> Eff effs a
unsafeIOToEff :: IO a -> Eff effs a
unsafeIOToEff = EVM a -> Eff effs a
forall (effs :: [Effect]) a. EVM a -> Eff effs a
Eff# (EVM a -> Eff effs a) -> (IO a -> EVM a) -> IO a -> Eff effs a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> EVM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
{-# INLINE unsafeIOToEff #-}

-- | Converts an 'Eff' computation to 'IO'. Unlike most handlers, 'IOE' must be
-- the final effect handled, and 'runIO' completely replaces the call to 'run'.
runIO :: Eff '[IOE] a -> IO a
runIO :: Eff '[IOE] a -> IO a
runIO Eff '[IOE] a
m0 = (Registers, a) -> a
forall a b. (a, b) -> b
snd ((Registers, a) -> a) -> IO (Registers, a) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff '[] a -> Registers -> IO (Registers, a)
forall a (effs :: [Effect]).
Eff effs a -> Registers -> IO (Registers, a)
unEff (Eff '[IOE] a -> Eff '[] a
forall {effs :: [Effect]} {r}. Eff (IOE : effs) r -> Eff effs r
handleIO Eff '[IOE] a
m0) Registers
initialRegisters where
  handleIO :: Eff (IOE : effs) r -> Eff effs r
handleIO = (r -> Eff effs r)
-> (forall (effs' :: [Effect]) b.
    (IOE :< effs') =>
    IOE (Eff effs') b -> Handle IOE effs r r effs' b)
-> Eff (IOE : effs) r
-> Eff effs r
forall (eff :: Effect) a r (effs :: [Effect]).
(a -> Eff effs r)
-> (forall (effs' :: [Effect]) b.
    (eff :< effs') =>
    eff (Eff effs') b -> Handle eff effs a r effs' b)
-> Eff (eff : effs) a
-> Eff effs r
handle r -> Eff effs r
forall (f :: * -> *) a. Applicative f => a -> f a
pure \case
    LiftIO m -> Eff effs' b -> Handle IOE effs r r effs' b
forall (effs' :: [Effect]) a (eff :: Effect) (effs :: [Effect]) i
       r.
Eff effs' a -> Handle eff effs i r effs' a
locally (IO b -> Eff effs' b
forall a (effs :: [Effect]). IO a -> Eff effs a
unsafeIOToEff IO b
m)

instance IOE :< effs => MonadIO (Eff effs) where
  liftIO :: IO a -> Eff effs a
liftIO = IOE (Eff effs) a -> Eff effs a
forall (eff :: Effect) a (effs :: [Effect]).
(eff :< effs) =>
eff (Eff effs) a -> Eff effs a
send (IOE (Eff effs) a -> Eff effs a)
-> (IO a -> IOE (Eff effs) a) -> IO a -> Eff effs a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IOE (Eff effs) a
forall a (m :: * -> *). IO a -> IOE m a
LiftIO
  {-# INLINE liftIO #-}

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

-- | The @'State' s@ effect provides access to a single cell of mutable state of
-- type @s@.
data State s :: Effect where
  Get :: State s m s
  Put :: ~s -> State s m ()

evalState :: s -> Eff (State s ': effs) a -> Eff effs a
evalState :: s -> Eff (State s : effs) a -> Eff effs a
evalState (s
s0 :: s) (Eff Registers -> IO (Registers, a)
m0) = (Registers -> IO (Registers, a)) -> Eff effs a
forall a (effs :: [Effect]).
(Registers -> IO (Registers, a)) -> Eff effs a
Eff \Registers
rs -> do
  IORef s
ref <- s -> IO (IORef s)
forall a. a -> IO (IORef a)
newIORef s
s0
  IO (Registers, a)
-> Registers
-> (Capture a -> IO (Registers, a))
-> IO (Registers, a)
forall a.
IO (Registers, a)
-> Registers
-> (Capture a -> IO (Registers, a))
-> IO (Registers, a)
promptVM_ (Registers -> IO (Registers, a)
m0 (IORef s -> Registers -> Registers
pushHandler IORef s
ref Registers
rs)) Registers
rs \(Capture PromptId
target CaptureMode
mode (b -> EVM c) -> EVM d
f b -> EVM a
k1) ->
    ((a -> EVM a) -> IO (Registers, a)) -> IO (Registers, a)
forall a b.
((a -> EVM b) -> IO (Registers, b)) -> IO (Registers, a)
controlVM \a -> EVM a
k2 -> IORef s
-> PromptId
-> CaptureMode
-> ((b -> EVM c) -> EVM d)
-> (b -> EVM a)
-> (a -> EVM a)
-> IO (Registers, a)
forall a d e b c.
IORef s
-> PromptId
-> CaptureMode
-> ((a -> EVM d) -> EVM e)
-> (a -> EVM b)
-> (b -> EVM c)
-> IO (Registers, b)
handleCapture IORef s
ref PromptId
target CaptureMode
mode (b -> EVM c) -> EVM d
f b -> EVM a
k1 a -> EVM a
k2
  where
    pushHandler :: IORef s -> Registers -> Registers
    pushHandler :: IORef s -> Registers -> Registers
pushHandler IORef s
ref (Registers PromptId
pid Targets
ts) =
      let h :: Handler (State s)
          h :: Handler (State s)
h = (forall (effs :: [Effect]) a.
 (State s :< effs) =>
 State s (Eff effs) a -> Eff effs a)
-> Handler (State s)
forall (eff :: Effect).
(forall (effs :: [Effect]) a.
 (eff :< effs) =>
 eff (Eff effs) a -> Eff effs a)
-> Handler eff
Handler \case
            State s (Eff effs) a
Get -> EVM s -> Eff effs s
forall (effs :: [Effect]) a. EVM a -> Eff effs a
Eff# (EVM s -> Eff effs s) -> EVM s -> Eff effs s
forall a b. (a -> b) -> a -> b
$ IO s -> EVM s
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO s -> EVM s) -> IO s -> EVM s
forall a b. (a -> b) -> a -> b
$ IORef s -> IO s
forall a. IORef a -> IO a
readIORef IORef s
ref
            Put !s -> EVM () -> Eff effs ()
forall (effs :: [Effect]) a. EVM a -> Eff effs a
Eff# (EVM () -> Eff effs ()) -> EVM () -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ IO () -> EVM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EVM ()) -> IO () -> EVM ()
forall a b. (a -> b) -> a -> b
$ IORef s -> s -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef s
ref s
s
      in PromptId -> Targets -> Registers
Registers PromptId
pid (Handler (State s) -> Targets -> Targets
forall (eff :: Effect). Handler eff -> Targets -> Targets
pushTarget Handler (State s)
h Targets
ts)

    handleCapture
      :: IORef s
      -> PromptId
      -> CaptureMode
      -> ((a -> EVM d) -> EVM e)
      -> (a -> EVM b)
      -> (b -> EVM c)
      -> IO (Registers, b)
    handleCapture :: IORef s
-> PromptId
-> CaptureMode
-> ((a -> EVM d) -> EVM e)
-> (a -> EVM b)
-> (b -> EVM c)
-> IO (Registers, b)
handleCapture IORef s
ref1 PromptId
target1 CaptureMode
mode1 (a -> EVM d) -> EVM e
f1 a -> EVM b
k1 b -> EVM c
k2 = do
      s
s <- IORef s -> IO s
forall a. IORef a -> IO a
readIORef IORef s
ref1
      let k3 :: a -> EVM c
k3 a
a = (Registers -> IO (Registers, c)) -> EVM c
forall a. (Registers -> IO (Registers, a)) -> EVM a
EVM \Registers
rs1 -> do
            IORef s
ref2 <- s -> IO (IORef s)
forall a. a -> IO (IORef a)
newIORef s
s
            let m :: IO (Registers, b)
m = EVM b -> Registers -> IO (Registers, b)
forall a. EVM a -> Registers -> IO (Registers, a)
unEVM (a -> EVM b
k1 a
a) (IORef s -> Registers -> Registers
pushHandler IORef s
ref2 Registers
rs1)
            (Registers
rs2, b
b) <- IO (Registers, b)
-> Registers
-> (Capture b -> IO (Registers, b))
-> IO (Registers, b)
forall a.
IO (Registers, a)
-> Registers
-> (Capture a -> IO (Registers, a))
-> IO (Registers, a)
promptVM_ IO (Registers, b)
m Registers
rs1 \(Capture PromptId
target2 CaptureMode
mode2 (b -> EVM c) -> EVM d
f2 b -> EVM b
k4) ->
              IORef s
-> PromptId
-> CaptureMode
-> ((b -> EVM c) -> EVM d)
-> (b -> EVM b)
-> (b -> EVM c)
-> IO (Registers, b)
forall a d e b c.
IORef s
-> PromptId
-> CaptureMode
-> ((a -> EVM d) -> EVM e)
-> (a -> EVM b)
-> (b -> EVM c)
-> IO (Registers, b)
handleCapture IORef s
ref2 PromptId
target2 CaptureMode
mode2 (b -> EVM c) -> EVM d
f2 b -> EVM b
k4 b -> EVM c
k2
            EVM c -> Registers -> IO (Registers, c)
forall a. EVM a -> Registers -> IO (Registers, a)
unEVM (b -> EVM c
k2 b
b) Registers
rs2
      Capture c -> IO (Registers, b)
forall a b. Capture a -> IO b
captureVM (Capture c -> IO (Registers, b)) -> Capture c -> IO (Registers, b)
forall a b. (a -> b) -> a -> b
$! PromptId
-> CaptureMode
-> ((a -> EVM d) -> EVM e)
-> (a -> EVM c)
-> Capture c
forall b c d a.
PromptId
-> CaptureMode
-> ((b -> EVM c) -> EVM d)
-> (b -> EVM a)
-> Capture a
Capture PromptId
target1 CaptureMode
mode1 (a -> EVM d) -> EVM e
f1 a -> EVM c
k3

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

-- | The 'NonDet' effect provides so-called /nondeterministic execution/, which
-- runs all branches of a computation and collects some or all of their results.
-- Actual execution is not usually truly nondeterministic in the sense that it
-- is somehow random; rather, 'NonDet' models nondeterministic binary choice by
-- executing /both/ possibilities rather than choosing just one.
data NonDet :: Effect where
  Empty :: NonDet m a
  Choose :: NonDet m Bool

instance NonDet :< effs => Alternative (Eff effs) where
  empty :: Eff effs a
empty = NonDet (Eff effs) a -> Eff effs a
forall (eff :: Effect) a (effs :: [Effect]).
(eff :< effs) =>
eff (Eff effs) a -> Eff effs a
send NonDet (Eff effs) a
forall (m :: * -> *) a. NonDet m a
Empty
  {-# INLINE empty #-}
  Eff effs a
a <|> :: Eff effs a -> Eff effs a -> Eff effs a
<|> Eff effs a
b = NonDet (Eff effs) Bool -> Eff effs Bool
forall (eff :: Effect) a (effs :: [Effect]).
(eff :< effs) =>
eff (Eff effs) a -> Eff effs a
send NonDet (Eff effs) Bool
forall (m :: * -> *). NonDet m Bool
Choose Eff effs Bool -> (Bool -> Eff effs a) -> Eff effs a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Eff effs a -> Eff effs a -> Bool -> Eff effs a
forall a. a -> a -> Bool -> a
bool Eff effs a
b Eff effs a
a
  {-# INLINE (<|>) #-}