{-# options_haddock prune #-}
-- |Description: Scoped Effect, Internal
module Polysemy.Conc.Effect.Scoped where

import Polysemy (transform)
import Polysemy.Internal (Sem (Sem, runSem), liftSem, send)
import Polysemy.Internal.Union (Weaving (Weaving), decomp, hoist, injWeaving)

-- |@Scoped@ transforms a program so that @effect@ is associated with a @resource@ within that program.
-- This requires the interpreter for @effect@ to be parameterized by @resource@ and constructed for every program using
-- @Scoped@ separately.
--
-- An application for this is 'Polysemy.Conc.Events', in which each program using the effect 'Consume' is interpreted
-- with its own copy of the event channel; or a database transaction, in which a transaction handle is created for the
-- wrapped program and passed to the interpreter for the database effect.
--
-- Resource creation is performed by the function passed to 'runScoped'.
--
-- The constructors are not intended to be used directly; the smart constructor 'scoped' is used like a local
-- interpreter for @effect@.
data Scoped (resource :: Type) (effect :: Effect) :: Effect where
  Run :: ∀ resource effect m a . resource -> effect m a -> Scoped resource effect m a
  InScope :: ∀ resource effect m a . (resource -> m a) -> Scoped resource effect m a

interpretH' ::
  ∀ e r .
  (∀ x . Weaving e (Sem (e : r)) x -> Sem r x) ->
  InterpreterFor e r
interpretH' :: (forall x. Weaving e (Sem (e : r)) x -> Sem r x)
-> InterpreterFor e r
interpretH' forall x. Weaving e (Sem (e : r)) x -> Sem r x
h Sem (e : r) a
sem =
  (forall (m :: * -> *).
 Monad m =>
 (forall x. Union r (Sem r) x -> m x) -> m a)
-> Sem r a
forall (r :: EffectRow) a.
(forall (m :: * -> *).
 Monad m =>
 (forall x. Union r (Sem r) x -> m x) -> m a)
-> Sem r a
Sem \ forall x. Union r (Sem r) x -> m x
k -> Sem (e : r) a
-> forall (m :: * -> *).
   Monad m =>
   (forall x. Union (e : r) (Sem (e : r)) x -> m x) -> m a
forall (r :: EffectRow) a.
Sem r a
-> forall (m :: * -> *).
   Monad m =>
   (forall x. Union r (Sem r) x -> m x) -> m a
runSem Sem (e : r) a
sem ((forall x. Union (e : r) (Sem (e : r)) x -> m x) -> m a)
-> (forall x. Union (e : r) (Sem (e : r)) x -> m x) -> m a
forall a b. (a -> b) -> a -> b
$ Union (e : r) (Sem (e : r)) x
-> Either (Union r (Sem (e : r)) x) (Weaving e (Sem (e : r)) x)
forall (e :: Effect) (r :: EffectRow) (m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp (Union (e : r) (Sem (e : r)) x
 -> Either (Union r (Sem (e : r)) x) (Weaving e (Sem (e : r)) x))
-> (Either (Union r (Sem (e : r)) x) (Weaving e (Sem (e : r)) x)
    -> m x)
-> Union (e : r) (Sem (e : r)) x
-> m x
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
    Right Weaving e (Sem (e : r)) x
wav -> Sem r x -> (forall x. Union r (Sem r) x -> m x) -> m x
forall (r :: EffectRow) a.
Sem r a
-> forall (m :: * -> *).
   Monad m =>
   (forall x. Union r (Sem r) x -> m x) -> m a
runSem (Weaving e (Sem (e : r)) x -> Sem r x
forall x. Weaving e (Sem (e : r)) x -> Sem r x
h Weaving e (Sem (e : r)) x
wav) forall x. Union r (Sem r) x -> m x
k
    Left Union r (Sem (e : r)) x
g -> Union r (Sem r) x -> m x
forall x. Union r (Sem r) x -> m x
k (Union r (Sem r) x -> m x) -> Union r (Sem r) x -> m x
forall a b. (a -> b) -> a -> b
$ InterpreterFor e r -> Union r (Sem (e : r)) x -> Union r (Sem r) x
forall (m :: * -> *) (n :: * -> *) (r :: EffectRow) a.
(forall x. m x -> n x) -> Union r m a -> Union r n a
hoist ((forall x. Weaving e (Sem (e : r)) x -> Sem r x)
-> InterpreterFor e r
forall (e :: Effect) (r :: EffectRow).
(forall x. Weaving e (Sem (e : r)) x -> Sem r x)
-> InterpreterFor e r
interpretH' forall x. Weaving e (Sem (e : r)) x -> Sem r x
h) Union r (Sem (e : r)) x
g

-- |Constructor for 'Scoped', taking a nested program and transforming all instances of @effect@ to
-- @Scoped resource effect@.
scoped ::
  ∀ resource effect r .
  Member (Scoped resource effect) r =>
  InterpreterFor effect r
scoped :: InterpreterFor effect r
scoped Sem (effect : r) a
main =
  Scoped resource effect (Sem r) a -> Sem r a
forall (e :: Effect) (r :: EffectRow) a.
Member e r =>
e (Sem r) a -> Sem r a
send (Scoped resource effect (Sem r) a -> Sem r a)
-> Scoped resource effect (Sem r) a -> Sem r a
forall a b. (a -> b) -> a -> b
$ (resource -> Sem r a) -> Scoped resource effect (Sem r) a
forall resource (effect :: Effect) (m :: * -> *) a.
(resource -> m a) -> Scoped resource effect m a
InScope @resource @effect \ resource
resource ->
    (forall (rInitial :: EffectRow) x.
 effect (Sem rInitial) x -> Scoped resource effect (Sem rInitial) x)
-> Sem (effect : r) a -> Sem r a
forall (e1 :: Effect) (e2 :: Effect) (r :: EffectRow) a.
Member e2 r =>
(forall (rInitial :: EffectRow) x.
 e1 (Sem rInitial) x -> e2 (Sem rInitial) x)
-> Sem (e1 : r) a -> Sem r a
transform @effect (resource
-> effect (Sem rInitial) x
-> Scoped resource effect (Sem rInitial) x
forall resource (effect :: Effect) (m :: * -> *) a.
resource -> effect m a -> Scoped resource effect m a
Run resource
resource) Sem (effect : r) a
main

-- |Interpreter for 'Scoped', taking a @resource@ allocation function and a parameterized interpreter for the plain
-- @effect@.
--
-- @withResource@ is a callback function, allowing the user to acquire the resource for each program from other effects.
--
-- @scopedInterpreter@ is a regular interpreter that is called with the @resource@ argument produced by @scope@.
-- /Note/: This function will be called for each action in the program, so if the interpreter allocates any resources,
-- they will be scoped to a single action. Move them to @withResource@ instead.
runScoped ::
  ∀ resource effect r .
  (∀ x . (resource -> Sem r x) -> Sem r x) ->
  (resource -> InterpreterFor effect r) ->
  InterpreterFor (Scoped resource effect) r
runScoped :: (forall x. (resource -> Sem r x) -> Sem r x)
-> (resource -> InterpreterFor effect r)
-> InterpreterFor (Scoped resource effect) r
runScoped forall x. (resource -> Sem r x) -> Sem r x
withResource resource -> InterpreterFor effect r
scopedInterpreter =
  Sem (Scoped resource effect : r) a -> Sem r a
InterpreterFor (Scoped resource effect) r
run
  where
    run :: InterpreterFor (Scoped resource effect) r
    run :: Sem (Scoped resource effect : r) a -> Sem r a
run =
      (forall x.
 Weaving
   (Scoped resource effect) (Sem (Scoped resource effect : r)) x
 -> Sem r x)
-> InterpreterFor (Scoped resource effect) r
forall (e :: Effect) (r :: EffectRow).
(forall x. Weaving e (Sem (e : r)) x -> Sem r x)
-> InterpreterFor e r
interpretH' \ (Weaving Scoped resource effect (Sem rInitial) a
effect f ()
s forall x.
f (Sem rInitial x) -> Sem (Scoped resource effect : r) (f x)
wv f a -> x
ex forall x. f x -> Maybe x
ins) -> case Scoped resource effect (Sem rInitial) a
effect of
        Run resource act ->
          resource -> Sem (effect : r) x -> Sem r x
resource -> InterpreterFor effect r
scopedInterpreter resource
resource (Union (effect : r) (Sem (effect : r)) x -> Sem (effect : r) x
forall (r :: EffectRow) a. Union r (Sem r) a -> Sem r a
liftSem (Union (effect : r) (Sem (effect : r)) x -> Sem (effect : r) x)
-> Union (effect : r) (Sem (effect : r)) x -> Sem (effect : r) x
forall a b. (a -> b) -> a -> b
$ Weaving effect (Sem (effect : r)) x
-> Union (effect : r) (Sem (effect : r)) x
forall (e :: Effect) (r :: EffectRow) (m :: * -> *) a.
Member e r =>
Weaving e m a -> Union r m a
injWeaving (Weaving effect (Sem (effect : r)) x
 -> Union (effect : r) (Sem (effect : r)) x)
-> Weaving effect (Sem (effect : r)) x
-> Union (effect : r) (Sem (effect : r)) x
forall a b. (a -> b) -> a -> b
$ effect (Sem rInitial) a
-> f ()
-> (forall x. f (Sem rInitial x) -> Sem (effect : r) (f x))
-> (f a -> x)
-> (forall x. f x -> Maybe x)
-> Weaving effect (Sem (effect : r)) x
forall (f :: * -> *) (e :: Effect) (rInitial :: EffectRow) a
       resultType (mAfter :: * -> *).
Functor f =>
e (Sem rInitial) a
-> f ()
-> (forall x. f (Sem rInitial x) -> mAfter (f x))
-> (f a -> resultType)
-> (forall x. f x -> Maybe x)
-> Weaving e mAfter resultType
Weaving effect (Sem rInitial) a
act f ()
s (Sem r (f x) -> Sem (effect : r) (f x)
forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
raise (Sem r (f x) -> Sem (effect : r) (f x))
-> (f (Sem rInitial x) -> Sem r (f x))
-> f (Sem rInitial x)
-> Sem (effect : r) (f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Scoped resource effect : r) (f x) -> Sem r (f x)
InterpreterFor (Scoped resource effect) r
run (Sem (Scoped resource effect : r) (f x) -> Sem r (f x))
-> (f (Sem rInitial x) -> Sem (Scoped resource effect : r) (f x))
-> f (Sem rInitial x)
-> Sem r (f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Sem rInitial x) -> Sem (Scoped resource effect : r) (f x)
forall x.
f (Sem rInitial x) -> Sem (Scoped resource effect : r) (f x)
wv) f a -> x
ex forall x. f x -> Maybe x
ins)
        InScope main ->
          f a -> x
ex (f a -> x) -> Sem r (f a) -> Sem r x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (resource -> Sem r (f a)) -> Sem r (f a)
forall x. (resource -> Sem r x) -> Sem r x
withResource \ resource
resource -> Sem (Scoped resource effect : r) (f a) -> Sem r (f a)
InterpreterFor (Scoped resource effect) r
run (f (Sem rInitial a) -> Sem (Scoped resource effect : r) (f a)
forall x.
f (Sem rInitial x) -> Sem (Scoped resource effect : r) (f x)
wv (resource -> Sem rInitial a
main resource
resource Sem rInitial a -> f () -> f (Sem rInitial a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s))

-- |Variant of 'Scoped' in which the resource allocator is a plain action.
runScopedAs ::
  ∀ resource effect r .
  Sem r resource ->
  (resource -> InterpreterFor effect r) ->
  InterpreterFor (Scoped resource effect) r
runScopedAs :: Sem r resource
-> (resource -> InterpreterFor effect r)
-> InterpreterFor (Scoped resource effect) r
runScopedAs Sem r resource
resource =
  (forall x. (resource -> Sem r x) -> Sem r x)
-> (resource -> InterpreterFor effect r)
-> InterpreterFor (Scoped resource effect) r
forall resource (effect :: Effect) (r :: EffectRow).
(forall x. (resource -> Sem r x) -> Sem r x)
-> (resource -> InterpreterFor effect r)
-> InterpreterFor (Scoped resource effect) r
runScoped \ resource -> Sem r x
f -> resource -> Sem r x
f (resource -> Sem r x) -> Sem r resource -> Sem r x
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sem r resource
resource