{-|
Copyright   : (c) Hisaket VioletRed, 2022
License     : AGPL-3.0-or-later
Maintainer  : hisaket@outlook.jp
Stability   : experimental

This module provides a scoped-reader manner.

In contrast to a normal 'Reader' effect, this manner makes connection of parameter type and effect explicit.

Example\:

>>> import Polysemy ( interpret, runM, embed )
>>> import Polysemy.Output ( Output (Output), output, runOutputSem )

>>> :{
runDebug :: Member (Output String) r => String -> InterpreterFor (ScopedReader String (Output String)) r
runDebug = runScopedReader \i -> interpret \(Output o) -> output $ "[" <> i <> "] " <> o
:}

>>> :{
runM $ runOutputSem (embed . putStrLn) $ runDebug "root" do
    scopedReader $ output "test message 0"
    scopedLocal (<> ".scope-A") do
        scopedReader $ output "test message 1"
        scopedReader $ output "test message 2"
        scopedLocal (<> ".scope-B") do
            scopedReader $ output "test message 3"
:}
[root] test message 0
[root.scope-A] test message 1
[root.scope-A] test message 2
[root.scope-A.scope-B] test message 3

-}

{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}

module Polysemy.ScopedReader where

import Polysemy
    ( Member, Sem, raise, raiseUnder, InterpreterFor, transform )
import Polysemy.Scoped.Path ( ScopedP, scopedP_local, runScopedP )
import Polysemy.Scoped.Path.Internal ( interpretH' )
import Control.Category ((>>>))
import Polysemy.Internal ( liftSem )
import Polysemy.Internal.Union
    ( ElemOf (Here), Union (Union), Weaving (Weaving) )


scopedLocal
    ::  ∀i p resource effect r
    .   Member (ScopedReader i effect) r
    =>  (i -> i) -> InterpreterFor (ScopedFix i effect) r
scopedLocal :: (i -> i) -> InterpreterFor (ScopedFix i effect) r
scopedLocal i -> i
f = Sem (ScopedP () i (ScopedFix i effect) : r) a -> Sem r a
forall p resource (effect :: (* -> *) -> * -> *) (r :: EffectRow)
       a.
Member (ScopedFixP p resource effect) r =>
Sem (ScopedP p resource (ScopedFixP p resource effect) : r) a
-> Sem r a
scopedFix (Sem (ScopedP () i (ScopedFix i effect) : r) a -> Sem r a)
-> (Sem (ScopedFix i effect : r) a
    -> Sem (ScopedP () i (ScopedFix i effect) : r) a)
-> Sem (ScopedFix i effect : r) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i -> i)
-> ()
-> InterpreterFor
     (ScopedFix i effect) (ScopedP () i (ScopedFix i effect) : r)
forall k1 k2 (e :: k1) path resource (effect :: (* -> *) -> * -> *)
       (r :: EffectRow) (a :: k2).
Member (ScopedP path resource effect) r =>
(resource -> resource) -> path -> InterpreterFor effect r
scopedP_local i -> i
f () (Sem (ScopedFix i effect : ScopedP () i (ScopedFix i effect) : r) a
 -> Sem (ScopedP () i (ScopedFix i effect) : r) a)
-> (Sem (ScopedFix i effect : r) a
    -> Sem
         (ScopedFix i effect : ScopedP () i (ScopedFix i effect) : r) a)
-> Sem (ScopedFix i effect : r) a
-> Sem (ScopedP () i (ScopedFix i effect) : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (ScopedFix i effect : r) a
-> Sem
     (ScopedFix i effect : ScopedP () i (ScopedFix i effect) : r) a
forall (e2 :: (* -> *) -> * -> *) (e1 :: (* -> *) -> * -> *)
       (r :: EffectRow) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder

scopedReader :: Member (ScopedReader i effect) r => Sem (effect ': r) a -> Sem r a
scopedReader :: Sem (effect : r) a -> Sem r a
scopedReader = Sem (effect : r) a -> Sem r a
forall p resource (effect :: (* -> *) -> * -> *) (r :: EffectRow)
       a.
Member (ScopedFixP p resource effect) r =>
Sem (effect : r) a -> Sem r a
scopedEffect

type ScopedReader i effect = ScopedFix i effect

runScopedReader :: (i -> InterpreterFor effect r) -> i -> Sem (ScopedReader i effect ': r) a -> Sem r a
runScopedReader :: (i -> InterpreterFor effect r)
-> i -> Sem (ScopedReader i effect : r) a -> Sem r a
runScopedReader i -> InterpreterFor effect r
int i
localEnv = 
    (forall x.
 Weaving (ScopedReader i effect) (Sem (ScopedReader i effect : r)) x
 -> Sem r x)
-> InterpreterFor (ScopedReader i effect) r
forall (e :: (* -> *) -> * -> *) (r :: EffectRow).
(forall x. Weaving e (Sem (e : r)) x -> Sem r x)
-> InterpreterFor e r
interpretH' \(Weaving ScopedReader i effect (Sem rInitial) a
e f ()
s forall x.
f (Sem rInitial x) -> Sem (ScopedReader i effect : r) (f x)
wv f a -> x
ex forall x. f x -> Maybe x
ins) ->
        let send' :: _ -> Sem (_ ': _) _
            send' :: e (Sem rInitial) a -> Sem (e : r) x
send' e (Sem rInitial) a
e' =
                Union (e : r) (Sem (e : r)) x -> Sem (e : r) x
forall (r :: EffectRow) a. Union r (Sem r) a -> Sem r a
liftSem (Union (e : r) (Sem (e : r)) x -> Sem (e : r) x)
-> Union (e : r) (Sem (e : r)) x -> Sem (e : r) x
forall a b. (a -> b) -> a -> b
$ ElemOf e (e : r)
-> Weaving e (Sem (e : r)) x -> Union (e : r) (Sem (e : r)) x
forall (e :: (* -> *) -> * -> *) (r :: EffectRow)
       (mWoven :: * -> *) a.
ElemOf e r -> Weaving e mWoven a -> Union r mWoven a
Union ElemOf e (e : r)
forall k (r :: [k]) (e :: k) (r' :: [k]).
(r ~ (e : r')) =>
ElemOf e r
Here
                    (Weaving e (Sem (e : r)) x -> Union (e : r) (Sem (e : r)) x)
-> Weaving e (Sem (e : r)) x -> Union (e : r) (Sem (e : r)) x
forall a b. (a -> b) -> a -> b
$ e (Sem rInitial) a
-> f ()
-> (forall x. f (Sem rInitial x) -> Sem (e : r) (f x))
-> (f a -> x)
-> (forall x. f x -> Maybe x)
-> Weaving e (Sem (e : r)) x
forall (f :: * -> *) (e :: (* -> *) -> * -> *)
       (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 e (Sem rInitial) a
e' f ()
s (Sem r (f x) -> Sem (e : r) (f x)
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem r a -> Sem (e : r) a
raise (Sem r (f x) -> Sem (e : r) (f x))
-> (f (Sem rInitial x) -> Sem r (f x))
-> f (Sem rInitial x)
-> Sem (e : r) (f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i -> InterpreterFor effect r)
-> i -> Sem (ScopedReader i effect : r) (f x) -> Sem r (f x)
forall i (effect :: (* -> *) -> * -> *) (r :: EffectRow) a.
(i -> InterpreterFor effect r)
-> i -> Sem (ScopedReader i effect : r) a -> Sem r a
runScopedReader i -> InterpreterFor effect r
int i
localEnv (Sem (ScopedReader i effect : r) (f x) -> Sem r (f x))
-> (f (Sem rInitial x) -> Sem (ScopedReader i 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 (ScopedReader i effect : r) (f x)
forall x.
f (Sem rInitial x) -> Sem (ScopedReader i effect : r) (f x)
wv) f a -> x
ex forall x. f x -> Maybe x
ins
        in case ScopedReader i effect (Sem rInitial) a
e of
            ScopedEffect e' -> i -> InterpreterFor effect r
int i
localEnv (Sem (effect : r) x -> Sem r x) -> Sem (effect : r) x -> Sem r x
forall a b. (a -> b) -> a -> b
$ effect (Sem rInitial) a -> Sem (effect : r) x
forall (e :: (* -> *) -> * -> *).
e (Sem rInitial) a -> Sem (e : r) x
send' effect (Sem rInitial) a
e'
            ScopedFix e' ->
                (forall x. () -> (i -> Sem r x) -> Sem r x)
-> (i -> InterpreterFor (ScopedReader i effect) r)
-> InterpreterFor (ScopedP () i (ScopedReader i effect)) r
forall path resource (effect :: (* -> *) -> * -> *)
       (r :: EffectRow).
(forall x. path -> (resource -> Sem r x) -> Sem r x)
-> (resource -> InterpreterFor effect r)
-> InterpreterFor (ScopedP path resource effect) r
runScopedP (\() i -> Sem r x
inner -> i -> Sem r x
inner i
localEnv) ((i -> InterpreterFor effect r)
-> i -> Sem (ScopedReader i effect : r) a -> Sem r a
forall i (effect :: (* -> *) -> * -> *) (r :: EffectRow) a.
(i -> InterpreterFor effect r)
-> i -> Sem (ScopedReader i effect : r) a -> Sem r a
runScopedReader i -> InterpreterFor effect r
int) (Sem (ScopedP () i (ScopedReader i effect) : r) x -> Sem r x)
-> Sem (ScopedP () i (ScopedReader i effect) : r) x -> Sem r x
forall a b. (a -> b) -> a -> b
$ ScopedP () i (ScopedReader i effect) (Sem rInitial) a
-> Sem (ScopedP () i (ScopedReader i effect) : r) x
forall (e :: (* -> *) -> * -> *).
e (Sem rInitial) a -> Sem (e : r) x
send' ScopedP () i (ScopedReader i effect) (Sem rInitial) a
e'


data ScopedFixP p resource effect m a where
    ScopedEffect :: effect m a -> ScopedFixP p resource effect m a
    ScopedFix
        ::  ScopedP p resource (ScopedFixP p resource effect) m a
        ->  ScopedFixP p resource effect m a

type ScopedFix = ScopedFixP ()

scopedEffect :: Member (ScopedFixP p resource effect) r => Sem (effect ': r) a -> Sem r a
scopedEffect :: Sem (effect : r) a -> Sem r a
scopedEffect = (forall (rInitial :: EffectRow) x.
 effect (Sem rInitial) x
 -> ScopedFixP p resource effect (Sem rInitial) x)
-> Sem (effect : r) a -> Sem r a
forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
       (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 forall (rInitial :: EffectRow) x.
effect (Sem rInitial) x
-> ScopedFixP p resource effect (Sem rInitial) x
forall k (effect :: (k -> *) -> k -> *) (m :: k -> *) (a :: k) p
       resource.
effect m a -> ScopedFixP p resource effect m a
ScopedEffect

scopedFix
    ::  Member (ScopedFixP p resource effect) r
    =>  Sem (ScopedP p resource (ScopedFixP p resource effect) ': r) a
    ->  Sem r a
scopedFix :: Sem (ScopedP p resource (ScopedFixP p resource effect) : r) a
-> Sem r a
scopedFix = (forall (rInitial :: EffectRow) x.
 ScopedP p resource (ScopedFixP p resource effect) (Sem rInitial) x
 -> ScopedFixP p resource effect (Sem rInitial) x)
-> Sem (ScopedP p resource (ScopedFixP p resource effect) : r) a
-> Sem r a
forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
       (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 forall (rInitial :: EffectRow) x.
ScopedP p resource (ScopedFixP p resource effect) (Sem rInitial) x
-> ScopedFixP p resource effect (Sem rInitial) x
forall k p resource (effect :: (k -> *) -> k -> *) (m :: k -> *)
       (a :: k).
ScopedP p resource (ScopedFixP p resource effect) m a
-> ScopedFixP p resource effect m a
ScopedFix