{-# LANGUAGE AllowAmbiguousTypes #-}

-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.

{- |
Copyright   :  (c) 2023-2024 Sayo Koyoneda
License     :  MPL-2.0 (see the file LICENSE)
Maintainer  :  ymdfield@outlook.jp

This module provides the `Provider` effect, like [@Effectful.Provider@](https://hackage.haskell.org/package/effectful-core-2.3.0.0/docs/Effectful-Provider.html)
in the @effectful@ package.
-}
module Data.Effect.Provider where

import Data.Effect.HFunctor (HFunctor, hfmap)
import Data.Effect.Key (type (##>))
import Data.Functor.Const (Const (Const))
import Data.Functor.Identity (Identity, runIdentity)

-- | An effect to introduce a new local scope that provides effect context @b@.
data Provider' ctx i b (f :: Type -> Type) (a :: Type) where
    -- | Introduces a new local scope that provides an effect context @b p@ parameterized by type @i p@ and with results wrapped in @ctx p@.
    Provide
        :: i p
        -> ((forall x. f x -> b p x) -> b p a)
        -> Provider' ctx i b f (ctx p a)

makeEffectH [''Provider']

-- | A type-level key to uniquely resolve the effect context carrier @b@ from @ctx@ and @i@.
data ProviderKey ctx i

-- | An effect to introduce a new local scope that provides effect context @b@.
type Provider ctx i b = ProviderKey ctx i ##> Provider' ctx i b

{- |
An effect to introduce a new local scope that provides effect context @b@.
A version of `Provider` where the result is not wrapped in a specific container.
-}
type Provider_ i b = Provider (Const1 Identity) (Const i :: () -> Type) (Const1 b)

newtype Const1 f x a = Const1 {forall {k} {k} (f :: k -> *) (x :: k) (a :: k). Const1 f x a -> f a
getConst1 :: f a}

newtype Const2 ff x f a = Const2 {forall {k} {k} {k} (ff :: k -> k -> *) (x :: k) (f :: k) (a :: k).
Const2 ff x f a -> ff f a
getConst2 :: ff f a}
instance (HFunctor ff) => HFunctor (Const2 ff x) where
    hfmap :: forall (f :: * -> *) (g :: * -> *).
(f :-> g) -> Const2 ff x f :-> Const2 ff x g
hfmap f :-> g
phi (Const2 ff f i
ff) = ff g i -> Const2 ff x g i
forall {k} {k} {k} (ff :: k -> k -> *) (x :: k) (f :: k) (a :: k).
ff f a -> Const2 ff x f a
Const2 (ff g i -> Const2 ff x g i) -> ff g i -> Const2 ff x g i
forall a b. (a -> b) -> a -> b
$ (f :-> g) -> ff f :-> ff g
forall (f :: * -> *) (g :: * -> *). (f :-> g) -> ff f :-> ff g
forall (h :: (* -> *) -> * -> *) (f :: * -> *) (g :: * -> *).
HFunctor h =>
(f :-> g) -> h f :-> h g
hfmap f i -> g i
f :-> g
phi ff f i
ff
    {-# INLINE hfmap #-}

infix 2 .!

{- | A operator to introduce a new local scope that provides effect context @b@.
A version of `..!` where the result is not wrapped in a specific container.
-}
(.!)
    :: forall i f a b
     . ( SendHOEBy
            (ProviderKey (Const1 Identity :: () -> Type -> Type) (Const i :: () -> Type))
            (Provider' (Const1 Identity) (Const i) (Const1 b))
            f
       , Functor f
       )
    => i
    -> ((f ~> b) -> b a)
    -> f a
i
i .! :: forall {k} i (f :: * -> *) a (b :: * -> *).
(SendHOEBy
   (ProviderKey (Const1 Identity) (Const i))
   (Provider' (Const1 Identity) (Const i) (Const1 b))
   f,
 Functor f) =>
i -> ((f ~> b) -> b a) -> f a
.! (f ~> b) -> b a
f =
    Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a)
-> (Const1 Identity Any a -> Identity a)
-> Const1 Identity Any a
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const1 Identity Any a -> Identity a
forall {k} {k} (f :: k -> *) (x :: k) (a :: k). Const1 f x a -> f a
getConst1
        (Const1 Identity Any a -> a) -> f (Const1 Identity Any a) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (key :: k) {k} (i :: k -> *) (p :: k) (b :: k -> * -> *)
       a (ctx :: k -> * -> *) (f :: * -> *).
SendHOEBy key (Provider' ctx i b) f =>
i p -> ((forall x. f x -> b p x) -> b p a) -> f (ctx p a)
forall key {k} (i :: k -> *) (p :: k) (b :: k -> * -> *) a
       (ctx :: k -> * -> *) (f :: * -> *).
SendHOEBy key (Provider' ctx i b) f =>
i p -> ((forall x. f x -> b p x) -> b p a) -> f (ctx p a)
provide'' @(ProviderKey (Const1 Identity :: () -> _ -> _) (Const i :: () -> _))
            (i -> Const i Any
forall {k} a (b :: k). a -> Const a b
Const i
i)
            \forall x. f x -> Const1 b Any x
run -> b a -> Const1 b Any a
forall {k} {k} (f :: k -> *) (x :: k) (a :: k). f a -> Const1 f x a
Const1 (b a -> Const1 b Any a) -> b a -> Const1 b Any a
forall a b. (a -> b) -> a -> b
$ (f ~> b) -> b a
f ((f ~> b) -> b a) -> (f ~> b) -> b a
forall a b. (a -> b) -> a -> b
$ Const1 b Any x -> b x
forall {k} {k} (f :: k -> *) (x :: k) (a :: k). Const1 f x a -> f a
getConst1 (Const1 b Any x -> b x) -> (f x -> Const1 b Any x) -> f x -> b x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> Const1 b Any x
forall x. f x -> Const1 b Any x
run
{-# INLINE (.!) #-}

infix 2 ..!

-- | A operator to introduce a new local scope that provides effect context @b p@.
(..!)
    :: forall ctx i p f a b
     . (SendHOEBy (ProviderKey ctx i) (Provider' ctx i b) f)
    => i p
    -> ((f ~> b p) -> b p a)
    -> f (ctx p a)
i p
i ..! :: forall {k} (ctx :: k -> * -> *) (i :: k -> *) (p :: k)
       (f :: * -> *) a (b :: k -> * -> *).
SendHOEBy (ProviderKey ctx i) (Provider' ctx i b) f =>
i p -> ((f ~> b p) -> b p a) -> f (ctx p a)
..! (f ~> b p) -> b p a
f = forall {k} (key :: k) {k} (i :: k -> *) (p :: k) (b :: k -> * -> *)
       a (ctx :: k -> * -> *) (f :: * -> *).
SendHOEBy key (Provider' ctx i b) f =>
i p -> ((forall x. f x -> b p x) -> b p a) -> f (ctx p a)
forall key {k} (i :: k -> *) (p :: k) (b :: k -> * -> *) a
       (ctx :: k -> * -> *) (f :: * -> *).
SendHOEBy key (Provider' ctx i b) f =>
i p -> ((forall x. f x -> b p x) -> b p a) -> f (ctx p a)
provide'' @(ProviderKey ctx i) i p
i (f ~> b p) -> b p a
f
{-# INLINE (..!) #-}