{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- Due to sendM.
{-# OPTIONS_HADDOCK not-home #-}

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}

-- The following is needed to define MonadPlus instance. It is decidable
-- (there is no recursion!), but GHC cannot see that.
--
-- TODO: Remove once GHC can deduce the decidability of this instance.
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module:       Control.Monad.Freer.Internal
-- Description:  Mechanisms to make effects work.
-- Copyright:    (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King
-- License:      BSD3
-- Maintainer:   Alexis King <lexi.lambda@gmail.com>
-- Stability:    experimental
-- Portability:  GHC specific language extensions.
--
-- Internal machinery for this effects library. This includes:
--
-- * 'Eff' data type, for expressing effects.
-- * 'NonDet' data type, for nondeterministic effects.
-- * Functions for facilitating the construction of effects and their handlers.
--
-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.
module Control.Monad.Freer.Internal
  ( -- * Effect Monad
    Eff(..)
  , Arr
  , Arrs

    -- ** Open Union
    --
    -- | Open Union (type-indexed co-product) of effects.
  , module Data.OpenUnion

    -- ** Fast Type-aligned Queue
    --
    -- | Fast type-aligned queue optimized to effectful functions of type
    -- @(a -> m b)@.
  , module Data.FTCQueue

    -- ** Sending Arbitrary Effect
  , send
  , sendM

    -- ** Lifting Effect Stacks
  , raise

    -- * Handling Effects
  , run
  , runM

    -- ** Building Effect Handlers
  , handleRelay
  , handleRelayS
  , interpose
  , interposeS
  , replaceRelay
  , replaceRelayS
  , replaceRelayN

    -- *** Low-level Functions for Building Effect Handlers
  , qApp
  , qComp

    -- ** Nondeterminism Effect
  , NonDet(..)
  ) where

import Control.Applicative (Alternative(..))
import Control.Monad (MonadPlus(..))
import Control.Monad.Base (MonadBase, liftBase)
import Control.Monad.IO.Class (MonadIO, liftIO)

import Data.FTCQueue
import Data.OpenUnion

-- | Effectful arrow type: a function from @a :: *@ to @b :: *@ that also does
-- effects denoted by @effs :: [* -> *]@.
type Arr effs a b = a -> Eff effs b

-- | An effectful function from @a :: *@ to @b :: *@ that is a composition of
-- several effectful functions. The paremeter @effs :: [* -> *]@ describes the
-- overall effect. The composition members are accumulated in a type-aligned
-- queue.
type Arrs effs a b = FTCQueue (Eff effs) a b

-- | The 'Eff' monad provides the implementation of a computation that performs
-- an arbitrary set of algebraic effects. In @'Eff' effs a@, @effs@ is a
-- type-level list that contains all the effects that the computation may
-- perform. For example, a computation that produces an 'Integer' by consuming a
-- 'String' from the global environment and acting upon a single mutable cell
-- containing a 'Bool' would have the following type:
--
-- @
-- 'Eff' '['Control.Monad.Freer.Reader.Reader' 'String', 'Control.Monad.Freer.State.State' 'Bool'] 'Integer'
-- @
--
-- Normally, a concrete list of effects is not used to parameterize 'Eff'.
-- Instead, the 'Member' or 'Members' constraints are used to express
-- constraints on the list of effects without coupling a computation to a
-- concrete list of effects. For example, the above example would more commonly
-- be expressed with the following type:
--
-- @
-- 'Members' '['Control.Monad.Freer.Reader.Reader' 'String', 'Control.Monad.Freer.State.State' 'Bool'] effs => 'Eff' effs 'Integer'
-- @
--
-- This abstraction allows the computation to be used in functions that may
-- perform other effects, and it also allows the effects to be handled in any
-- order.
data Eff effs a
  = Val a
  -- ^ Pure value (@'return' = 'pure' = 'Val'@).
  | forall b. E (Union effs b) (Arrs effs b a)
  -- ^ Sending a request of type @Union effs@ with the continuation
  -- @'Arrs' r b a@.

-- | Function application in the context of an array of effects,
-- @'Arrs' effs b w@.
qApp :: Arrs effs b w -> b -> Eff effs w
qApp :: Arrs effs b w -> b -> Eff effs w
qApp Arrs effs b w
q' b
x = case Arrs effs b w -> ViewL (Eff effs) b w
forall (m :: * -> *) a b. FTCQueue m a b -> ViewL m a b
tviewl Arrs effs b w
q' of
  TOne b -> Eff effs w
k  -> b -> Eff effs w
k b
x
  b -> Eff effs x
k :| FTCQueue (Eff effs) x w
t -> case b -> Eff effs x
k b
x of
    Val x
y -> FTCQueue (Eff effs) x w -> x -> Eff effs w
forall (effs :: [* -> *]) b w. Arrs effs b w -> b -> Eff effs w
qApp FTCQueue (Eff effs) x w
t x
y
    E Union effs b
u Arrs effs b x
q -> Union effs b -> Arrs effs b w -> Eff effs w
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E Union effs b
u (Arrs effs b x
q Arrs effs b x -> FTCQueue (Eff effs) x w -> Arrs effs b w
forall (m :: * -> *) a x b.
FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
>< FTCQueue (Eff effs) x w
t)

-- | Composition of effectful arrows ('Arrs'). Allows for the caller to change
-- the effect environment, as well.
qComp :: Arrs effs a b -> (Eff effs b -> Eff effs' c) -> Arr effs' a c
qComp :: Arrs effs a b -> (Eff effs b -> Eff effs' c) -> Arr effs' a c
qComp Arrs effs a b
g Eff effs b -> Eff effs' c
h a
a = Eff effs b -> Eff effs' c
h (Eff effs b -> Eff effs' c) -> Eff effs b -> Eff effs' c
forall a b. (a -> b) -> a -> b
$ Arrs effs a b -> a -> Eff effs b
forall (effs :: [* -> *]) b w. Arrs effs b w -> b -> Eff effs w
qApp Arrs effs a b
g a
a

instance Functor (Eff effs) where
  fmap :: (a -> b) -> Eff effs a -> Eff effs b
fmap a -> b
f (Val a
x) = b -> Eff effs b
forall (effs :: [* -> *]) a. a -> Eff effs a
Val (a -> b
f a
x)
  fmap a -> b
f (E Union effs b
u Arrs effs b a
q) = Union effs b -> Arrs effs b b -> Eff effs b
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E Union effs b
u (Arrs effs b a
q Arrs effs b a -> (a -> Eff effs b) -> Arrs effs b b
forall (m :: * -> *) a x b.
FTCQueue m a x -> (x -> m b) -> FTCQueue m a b
|> (b -> Eff effs b
forall (effs :: [* -> *]) a. a -> Eff effs a
Val (b -> Eff effs b) -> (a -> b) -> a -> Eff effs b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))
  {-# INLINE fmap #-}

instance Applicative (Eff effs) where
  pure :: a -> Eff effs a
pure = a -> Eff effs a
forall (effs :: [* -> *]) a. a -> Eff effs a
Val
  {-# INLINE pure #-}

  Val a -> b
f <*> :: Eff effs (a -> b) -> Eff effs a -> Eff effs b
<*> Val a
x = b -> Eff effs b
forall (effs :: [* -> *]) a. a -> Eff effs a
Val (b -> Eff effs b) -> b -> Eff effs b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
x
  Val a -> b
f <*> E Union effs b
u Arrs effs b a
q = Union effs b -> Arrs effs b b -> Eff effs b
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E Union effs b
u (Arrs effs b a
q Arrs effs b a -> (a -> Eff effs b) -> Arrs effs b b
forall (m :: * -> *) a x b.
FTCQueue m a x -> (x -> m b) -> FTCQueue m a b
|> (b -> Eff effs b
forall (effs :: [* -> *]) a. a -> Eff effs a
Val (b -> Eff effs b) -> (a -> b) -> a -> Eff effs b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))
  E Union effs b
u Arrs effs b (a -> b)
q <*> Eff effs a
m     = Union effs b -> Arrs effs b b -> Eff effs b
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E Union effs b
u (Arrs effs b (a -> b)
q Arrs effs b (a -> b) -> ((a -> b) -> Eff effs b) -> Arrs effs b b
forall (m :: * -> *) a x b.
FTCQueue m a x -> (x -> m b) -> FTCQueue m a b
|> ((a -> b) -> Eff effs a -> Eff effs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Eff effs a
m))
  {-# INLINE (<*>) #-}

instance Monad (Eff effs) where
  Val a
x >>= :: Eff effs a -> (a -> Eff effs b) -> Eff effs b
>>= a -> Eff effs b
k = a -> Eff effs b
k a
x
  E Union effs b
u Arrs effs b a
q >>= a -> Eff effs b
k = Union effs b -> Arrs effs b b -> Eff effs b
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E Union effs b
u (Arrs effs b a
q Arrs effs b a -> (a -> Eff effs b) -> Arrs effs b b
forall (m :: * -> *) a x b.
FTCQueue m a x -> (x -> m b) -> FTCQueue m a b
|> a -> Eff effs b
k)
  {-# INLINE (>>=) #-}

instance (MonadBase b m, LastMember m effs) => MonadBase b (Eff effs) where
  liftBase :: b α -> Eff effs α
liftBase = m α -> Eff effs α
forall (m :: * -> *) (effs :: [* -> *]) a.
(Monad m, LastMember m effs) =>
m a -> Eff effs a
sendM (m α -> Eff effs α) -> (b α -> m α) -> b α -> Eff effs α
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase
  {-# INLINE liftBase #-}

instance (MonadIO m, LastMember m effs) => MonadIO (Eff effs) where
  liftIO :: IO a -> Eff effs a
liftIO = m a -> Eff effs a
forall (m :: * -> *) (effs :: [* -> *]) a.
(Monad m, LastMember m effs) =>
m a -> Eff effs a
sendM (m a -> Eff effs a) -> (IO a -> m a) -> IO a -> Eff effs a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
  {-# INLINE liftIO #-}

-- | “Sends” an effect, which should be a value defined as part of an effect
-- algebra (see the module documentation for "Control.Monad.Freer"), to an
-- effectful computation. This is used to connect the definition of an effect to
-- the 'Eff' monad so that it can be used and handled.
send :: Member eff effs => eff a -> Eff effs a
send :: eff a -> Eff effs a
send eff a
t = Union effs a -> Arrs effs a a -> Eff effs a
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E (eff a -> Union effs a
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Union effs a
inj eff a
t) ((a -> Eff effs a) -> Arrs effs a a
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton a -> Eff effs a
forall (effs :: [* -> *]) a. a -> Eff effs a
Val)
{-# INLINE send #-}

-- | Identical to 'send', but specialized to the final effect in @effs@ to
-- assist type inference. This is useful for running actions in a monad
-- transformer stack used in conjunction with 'runM'.
sendM :: (Monad m, LastMember m effs) => m a -> Eff effs a
sendM :: m a -> Eff effs a
sendM = m a -> Eff effs a
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send
{-# INLINE sendM #-}

--------------------------------------------------------------------------------
                       -- Base Effect Runner --
--------------------------------------------------------------------------------

-- | Runs a pure 'Eff' computation, since an 'Eff' computation that performs no
-- effects (i.e. has no effects in its type-level list) is guaranteed to be
-- pure. This is usually used as the final step of running an effectful
-- computation, after all other effects have been discharged using effect
-- handlers.
--
-- Typically, this function is composed as follows:
--
-- @
-- someProgram
--   'Data.Function.&' runEff1 eff1Arg
--   'Data.Function.&' runEff2 eff2Arg1 eff2Arg2
--   'Data.Function.&' 'run'
-- @
run :: Eff '[] a -> a
run :: Eff '[] a -> a
run (Val a
x) = a
x
run Eff '[] a
_       = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal:run - This (E) should never happen"

-- | Like 'run', 'runM' runs an 'Eff' computation and extracts the result.
-- /Unlike/ 'run', 'runM' allows a single effect to remain within the type-level
-- list, which must be a monad. The value returned is a computation in that
-- monad, which is useful in conjunction with 'sendM' or 'liftBase' for plugging
-- in traditional transformer stacks.
runM :: Monad m => Eff '[m] a -> m a
runM :: Eff '[m] a -> m a
runM (Val a
x) = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
runM (E Union '[m] b
u Arrs '[m] b a
q) = case Union '[m] b -> m b
forall (t :: * -> *) a. Union '[t] a -> t a
extract Union '[m] b
u of
  m b
mb -> m b
mb m b -> (b -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Eff '[m] a -> m a
forall (m :: * -> *) a. Monad m => Eff '[m] a -> m a
runM (Eff '[m] a -> m a) -> (b -> Eff '[m] a) -> b -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arrs '[m] b a -> b -> Eff '[m] a
forall (effs :: [* -> *]) b w. Arrs effs b w -> b -> Eff effs w
qApp Arrs '[m] b a
q
  -- The other case is unreachable since Union [] a cannot be constructed.
  -- Therefore, run is a total function if its argument terminates.

-- | Like 'replaceRelay', but with support for an explicit state to help
-- implement the interpreter.
replaceRelayS
  :: s
  -> (s -> a -> Eff (v ': effs) w)
  -> (forall x. s -> t x -> (s -> Arr (v ': effs) x w) -> Eff (v ': effs) w)
  -> Eff (t ': effs) a
  -> Eff (v ': effs) w
replaceRelayS :: s
-> (s -> a -> Eff (v : effs) w)
-> (forall x.
    s -> t x -> (s -> Arr (v : effs) x w) -> Eff (v : effs) w)
-> Eff (t : effs) a
-> Eff (v : effs) w
replaceRelayS s
s' s -> a -> Eff (v : effs) w
pure' forall x. s -> t x -> (s -> Arr (v : effs) x w) -> Eff (v : effs) w
bind = s -> Eff (t : effs) a -> Eff (v : effs) w
loop s
s'
  where
    loop :: s -> Eff (t : effs) a -> Eff (v : effs) w
loop s
s (Val a
x)  = s -> a -> Eff (v : effs) w
pure' s
s a
x
    loop s
s (E Union (t : effs) b
u' Arrs (t : effs) b a
q) = case Union (t : effs) b -> Either (Union effs b) (t b)
forall (t :: * -> *) (r :: [* -> *]) a.
Union (t : r) a -> Either (Union r a) (t a)
decomp Union (t : effs) b
u' of
        Right t b
x -> s -> t b -> (s -> Arr (v : effs) b w) -> Eff (v : effs) w
forall x. s -> t x -> (s -> Arr (v : effs) x w) -> Eff (v : effs) w
bind s
s t b
x s -> Arr (v : effs) b w
k
        Left  Union effs b
u -> Union (v : effs) b -> Arrs (v : effs) b w -> Eff (v : effs) w
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E (Union effs b -> Union (v : effs) b
forall k (r :: [* -> *]) (a :: k) (any :: * -> *).
Union r a -> Union (any : r) a
weaken Union effs b
u) (Arr (v : effs) b w -> Arrs (v : effs) b w
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton (s -> Arr (v : effs) b w
k s
s))
      where
        k :: s -> Arr (v : effs) b w
k s
s'' b
x = s -> Eff (t : effs) a -> Eff (v : effs) w
loop s
s'' (Eff (t : effs) a -> Eff (v : effs) w)
-> Eff (t : effs) a -> Eff (v : effs) w
forall a b. (a -> b) -> a -> b
$ Arrs (t : effs) b a -> b -> Eff (t : effs) a
forall (effs :: [* -> *]) b w. Arrs effs b w -> b -> Eff effs w
qApp Arrs (t : effs) b a
q b
x
{-# INLINE replaceRelayS #-}

-- | Interpret an effect by transforming it into another effect on top of the
-- stack. The primary use case of this function is allow interpreters to be
-- defined in terms of other ones without leaking intermediary implementation
-- details through the type signature.
replaceRelay
  :: (a -> Eff (v ': effs) w)
  -> (forall x. t x -> Arr (v ': effs) x w -> Eff (v ': effs) w)
  -> Eff (t ': effs) a
  -> Eff (v ': effs) w
replaceRelay :: (a -> Eff (v : effs) w)
-> (forall x. t x -> Arr (v : effs) x w -> Eff (v : effs) w)
-> Eff (t : effs) a
-> Eff (v : effs) w
replaceRelay a -> Eff (v : effs) w
pure' forall x. t x -> Arr (v : effs) x w -> Eff (v : effs) w
bind = Eff (t : effs) a -> Eff (v : effs) w
loop
  where
    loop :: Eff (t : effs) a -> Eff (v : effs) w
loop (Val a
x)  = a -> Eff (v : effs) w
pure' a
x
    loop (E Union (t : effs) b
u' Arrs (t : effs) b a
q) = case Union (t : effs) b -> Either (Union effs b) (t b)
forall (t :: * -> *) (r :: [* -> *]) a.
Union (t : r) a -> Either (Union r a) (t a)
decomp Union (t : effs) b
u' of
        Right t b
x -> t b -> Arr (v : effs) b w -> Eff (v : effs) w
forall x. t x -> Arr (v : effs) x w -> Eff (v : effs) w
bind t b
x Arr (v : effs) b w
k
        Left  Union effs b
u -> Union (v : effs) b -> Arrs (v : effs) b w -> Eff (v : effs) w
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E (Union effs b -> Union (v : effs) b
forall k (r :: [* -> *]) (a :: k) (any :: * -> *).
Union r a -> Union (any : r) a
weaken Union effs b
u) (Arr (v : effs) b w -> Arrs (v : effs) b w
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton Arr (v : effs) b w
k)
      where
        k :: Arr (v : effs) b w
k = Arrs (t : effs) b a
-> (Eff (t : effs) a -> Eff (v : effs) w) -> Arr (v : effs) b w
forall (effs :: [* -> *]) a b (effs' :: [* -> *]) c.
Arrs effs a b -> (Eff effs b -> Eff effs' c) -> Arr effs' a c
qComp Arrs (t : effs) b a
q Eff (t : effs) a -> Eff (v : effs) w
loop
{-# INLINE replaceRelay #-}

replaceRelayN
  :: forall gs t a effs w
   . Weakens gs
  => (a -> Eff (gs :++: effs) w)
  -> (forall x. t x -> Arr (gs :++: effs) x w -> Eff (gs :++: effs) w)
  -> Eff (t ': effs) a
  -> Eff (gs :++: effs) w
replaceRelayN :: (a -> Eff (gs :++: effs) w)
-> (forall x.
    t x -> Arr (gs :++: effs) x w -> Eff (gs :++: effs) w)
-> Eff (t : effs) a
-> Eff (gs :++: effs) w
replaceRelayN a -> Eff (gs :++: effs) w
pure' forall x. t x -> Arr (gs :++: effs) x w -> Eff (gs :++: effs) w
bind = Eff (t : effs) a -> Eff (gs :++: effs) w
loop
  where
    loop :: Eff (t ': effs) a -> Eff (gs :++: effs) w
    loop :: Eff (t : effs) a -> Eff (gs :++: effs) w
loop (Val a
x)  = a -> Eff (gs :++: effs) w
pure' a
x
    loop (E Union (t : effs) b
u' (Arrs (t : effs) b a
q :: Arrs (t ': effs) b a)) = case Union (t : effs) b -> Either (Union effs b) (t b)
forall (t :: * -> *) (r :: [* -> *]) a.
Union (t : r) a -> Either (Union r a) (t a)
decomp Union (t : effs) b
u' of
        Right t b
x -> t b -> Arr (gs :++: effs) b w -> Eff (gs :++: effs) w
forall x. t x -> Arr (gs :++: effs) x w -> Eff (gs :++: effs) w
bind t b
x Arr (gs :++: effs) b w
k
        Left  Union effs b
u -> Union (gs :++: effs) b
-> Arrs (gs :++: effs) b w -> Eff (gs :++: effs) w
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E (Union effs b -> Union (gs :++: effs) b
forall (q :: [* -> *]) k (r :: [* -> *]) (a :: k).
Weakens q =>
Union r a -> Union (q :++: r) a
weakens @gs Union effs b
u) (Arr (gs :++: effs) b w -> Arrs (gs :++: effs) b w
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton Arr (gs :++: effs) b w
k)
      where
        k :: Arr (gs :++: effs) b w
        k :: Arr (gs :++: effs) b w
k = Arrs (t : effs) b a
-> (Eff (t : effs) a -> Eff (gs :++: effs) w)
-> Arr (gs :++: effs) b w
forall (effs :: [* -> *]) a b (effs' :: [* -> *]) c.
Arrs effs a b -> (Eff effs b -> Eff effs' c) -> Arr effs' a c
qComp Arrs (t : effs) b a
q Eff (t : effs) a -> Eff (gs :++: effs) w
loop
{-# INLINE replaceRelayN #-}

-- | Given a request, either handle it or relay it.
handleRelay
  :: (a -> Eff effs b)
  -- ^ Handle a pure value.
  -> (forall v. eff v -> Arr effs v b -> Eff effs b)
  -- ^ Handle a request for effect of type @eff :: * -> *@.
  -> Eff (eff ': effs) a
  -> Eff effs b
  -- ^ Result with effects of type @eff :: * -> *@ handled.
handleRelay :: (a -> Eff effs b)
-> (forall v. eff v -> Arr effs v b -> Eff effs b)
-> Eff (eff : effs) a
-> Eff effs b
handleRelay a -> Eff effs b
ret forall v. eff v -> Arr effs v b -> Eff effs b
h = Eff (eff : effs) a -> Eff effs b
loop
  where
    loop :: Eff (eff : effs) a -> Eff effs b
loop (Val a
x)  = a -> Eff effs b
ret a
x
    loop (E Union (eff : effs) b
u' Arrs (eff : effs) b a
q) = case Union (eff : effs) b -> Either (Union effs b) (eff b)
forall (t :: * -> *) (r :: [* -> *]) a.
Union (t : r) a -> Either (Union r a) (t a)
decomp Union (eff : effs) b
u' of
        Right eff b
x -> eff b -> Arr effs b b -> Eff effs b
forall v. eff v -> Arr effs v b -> Eff effs b
h eff b
x Arr effs b b
k
        Left  Union effs b
u -> Union effs b -> Arrs effs b b -> Eff effs b
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E Union effs b
u (Arr effs b b -> Arrs effs b b
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton Arr effs b b
k)
      where
        k :: Arr effs b b
k = Arrs (eff : effs) b a
-> (Eff (eff : effs) a -> Eff effs b) -> Arr effs b b
forall (effs :: [* -> *]) a b (effs' :: [* -> *]) c.
Arrs effs a b -> (Eff effs b -> Eff effs' c) -> Arr effs' a c
qComp Arrs (eff : effs) b a
q Eff (eff : effs) a -> Eff effs b
loop
{-# INLINE handleRelay #-}

-- | Parameterized 'handleRelay'. Allows sending along some state of type
-- @s :: *@ to be handled for the target effect, or relayed to a handler that
-- can- handle the target effect.
handleRelayS
  :: s
  -> (s -> a -> Eff effs b)
  -- ^ Handle a pure value.
  -> (forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b)
  -- ^ Handle a request for effect of type @eff :: * -> *@.
  -> Eff (eff ': effs) a
  -> Eff effs b
  -- ^ Result with effects of type @eff :: * -> *@ handled.
handleRelayS :: s
-> (s -> a -> Eff effs b)
-> (forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b)
-> Eff (eff : effs) a
-> Eff effs b
handleRelayS s
s' s -> a -> Eff effs b
ret forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b
h = s -> Eff (eff : effs) a -> Eff effs b
loop s
s'
  where
    loop :: s -> Eff (eff : effs) a -> Eff effs b
loop s
s (Val a
x)  = s -> a -> Eff effs b
ret s
s a
x
    loop s
s (E Union (eff : effs) b
u' Arrs (eff : effs) b a
q) = case Union (eff : effs) b -> Either (Union effs b) (eff b)
forall (t :: * -> *) (r :: [* -> *]) a.
Union (t : r) a -> Either (Union r a) (t a)
decomp Union (eff : effs) b
u' of
        Right eff b
x -> s -> eff b -> (s -> Arr effs b b) -> Eff effs b
forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b
h s
s eff b
x s -> Arr effs b b
k
        Left  Union effs b
u -> Union effs b -> Arrs effs b b -> Eff effs b
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E Union effs b
u (Arr effs b b -> Arrs effs b b
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton (s -> Arr effs b b
k s
s))
      where
        k :: s -> Arr effs b b
k s
s'' b
x = s -> Eff (eff : effs) a -> Eff effs b
loop s
s'' (Eff (eff : effs) a -> Eff effs b)
-> Eff (eff : effs) a -> Eff effs b
forall a b. (a -> b) -> a -> b
$ Arrs (eff : effs) b a -> b -> Eff (eff : effs) a
forall (effs :: [* -> *]) b w. Arrs effs b w -> b -> Eff effs w
qApp Arrs (eff : effs) b a
q b
x
{-# INLINE handleRelayS #-}

-- | Intercept the request and possibly reply to it, but leave it unhandled.
interpose
  :: Member eff effs
  => (a -> Eff effs b)
  -> (forall v. eff v -> Arr effs v b -> Eff effs b)
  -> Eff effs a
  -> Eff effs b
interpose :: (a -> Eff effs b)
-> (forall v. eff v -> Arr effs v b -> Eff effs b)
-> Eff effs a
-> Eff effs b
interpose a -> Eff effs b
ret forall v. eff v -> Arr effs v b -> Eff effs b
h = Eff effs a -> Eff effs b
loop
  where
    loop :: Eff effs a -> Eff effs b
loop (Val a
x) = a -> Eff effs b
ret a
x
    loop (E Union effs b
u Arrs effs b a
q) = case Union effs b -> Maybe (eff b)
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
Union effs a -> Maybe (eff a)
prj Union effs b
u of
        Just eff b
x -> eff b -> Arr effs b b -> Eff effs b
forall v. eff v -> Arr effs v b -> Eff effs b
h eff b
x Arr effs b b
k
        Maybe (eff b)
_      -> Union effs b -> Arrs effs b b -> Eff effs b
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E Union effs b
u (Arr effs b b -> Arrs effs b b
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton Arr effs b b
k)
      where
        k :: Arr effs b b
k = Arrs effs b a -> (Eff effs a -> Eff effs b) -> Arr effs b b
forall (effs :: [* -> *]) a b (effs' :: [* -> *]) c.
Arrs effs a b -> (Eff effs b -> Eff effs' c) -> Arr effs' a c
qComp Arrs effs b a
q Eff effs a -> Eff effs b
loop
{-# INLINE interpose #-}

-- | Like 'interpose', but with support for an explicit state to help implement
-- the interpreter.
interposeS
  :: Member eff effs
  => s
  -> (s -> a -> Eff effs b)
  -> (forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b)
  -> Eff effs a
  -> Eff effs b
interposeS :: s
-> (s -> a -> Eff effs b)
-> (forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b)
-> Eff effs a
-> Eff effs b
interposeS s
s' s -> a -> Eff effs b
ret forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b
h = s -> Eff effs a -> Eff effs b
loop s
s'
  where
    loop :: s -> Eff effs a -> Eff effs b
loop s
s (Val a
x) = s -> a -> Eff effs b
ret s
s a
x
    loop s
s (E Union effs b
u Arrs effs b a
q) = case Union effs b -> Maybe (eff b)
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
Union effs a -> Maybe (eff a)
prj Union effs b
u of
        Just eff b
x -> s -> eff b -> (s -> Arr effs b b) -> Eff effs b
forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b
h s
s eff b
x s -> Arr effs b b
k
        Maybe (eff b)
_      -> Union effs b -> Arrs effs b b -> Eff effs b
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E Union effs b
u (Arr effs b b -> Arrs effs b b
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton (s -> Arr effs b b
k s
s))
      where
        k :: s -> Arr effs b b
k s
s'' b
x = s -> Eff effs a -> Eff effs b
loop s
s'' (Eff effs a -> Eff effs b) -> Eff effs a -> Eff effs b
forall a b. (a -> b) -> a -> b
$ Arrs effs b a -> b -> Eff effs a
forall (effs :: [* -> *]) b w. Arrs effs b w -> b -> Eff effs w
qApp Arrs effs b a
q b
x
{-# INLINE interposeS #-}

-- | Embeds a less-constrained 'Eff' into a more-constrained one. Analogous to
-- MTL's 'lift'.
raise :: Eff effs a -> Eff (e ': effs) a
raise :: Eff effs a -> Eff (e : effs) a
raise = Eff effs a -> Eff (e : effs) a
forall (effs :: [* -> *]) a (any :: * -> *).
Eff effs a -> Eff (any : effs) a
loop
  where
    loop :: Eff effs a -> Eff (any : effs) a
loop (Val a
x) = a -> Eff (any : effs) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    loop (E Union effs b
u Arrs effs b a
q) = Union (any : effs) b -> Arrs (any : effs) b a -> Eff (any : effs) a
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E (Union effs b -> Union (any : effs) b
forall k (r :: [* -> *]) (a :: k) (any :: * -> *).
Union r a -> Union (any : r) a
weaken Union effs b
u) (Arrs (any : effs) b a -> Eff (any : effs) a)
-> ((b -> Eff (any : effs) a) -> Arrs (any : effs) b a)
-> (b -> Eff (any : effs) a)
-> Eff (any : effs) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> Eff (any : effs) a) -> Arrs (any : effs) b a
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton ((b -> Eff (any : effs) a) -> Eff (any : effs) a)
-> (b -> Eff (any : effs) a) -> Eff (any : effs) a
forall a b. (a -> b) -> a -> b
$ Arrs effs b a
-> (Eff effs a -> Eff (any : effs) a) -> b -> Eff (any : effs) a
forall (effs :: [* -> *]) a b (effs' :: [* -> *]) c.
Arrs effs a b -> (Eff effs b -> Eff effs' c) -> Arr effs' a c
qComp Arrs effs b a
q Eff effs a -> Eff (any : effs) a
loop
{-# INLINE raise #-}

--------------------------------------------------------------------------------
                    -- Nondeterministic Choice --
--------------------------------------------------------------------------------

-- | A data type for representing nondeterminstic choice.
data NonDet a where
  MZero :: NonDet a
  MPlus :: NonDet Bool

instance Member NonDet effs => Alternative (Eff effs) where
  empty :: Eff effs a
empty = Eff effs a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  <|> :: Eff effs a -> Eff effs a -> Eff effs a
(<|>) = Eff effs a -> Eff effs a -> Eff effs a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance Member NonDet effs => MonadPlus (Eff effs) where
  mzero :: Eff effs a
mzero       = NonDet a -> Eff effs a
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send NonDet a
forall a. NonDet a
MZero
  mplus :: Eff effs a -> Eff effs a -> Eff effs a
mplus Eff effs a
m1 Eff effs a
m2 = NonDet Bool -> Eff effs Bool
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send NonDet Bool
MPlus Eff effs Bool -> (Bool -> Eff effs a) -> Eff effs a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
x -> if Bool
x then Eff effs a
m1 else Eff effs a
m2