{-# LANGUAGE UndecidableInstances #-}

-- 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 Yamada Ryo
License     :  MPL-2.0 (see the file LICENSE)
Maintainer  :  ymdfield@outlook.jp
Stability   :  experimental
Portability :  portable

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

import Control.Effect.Class (
    EffectDataHandler,
    EffectsVia (EffectsVia),
    SendSig,
    runEffectsVia,
    sendSig,
    type (~>),
 )
import Control.Effect.Class.Machinery.HFunctor (HFunctor, hfmap)
import Data.Effect.Class.TH (
    makeSignature,
 )

class Provider c e i g (f :: Type -> Type) where
    provide :: i -> (forall h. (c h, e h) => (f ~> h) -> h a) -> f (g a)

makeSignature ''Provider

instance HFunctor (ProviderS c e i g) where
    hfmap :: forall (f :: * -> *) (g :: * -> *).
(f :-> g) -> ProviderS c e i g f :-> ProviderS c e i g g
hfmap f :-> g
phi (Provide i
i forall (h :: * -> *). (c h, e h) => (f ~> h) -> h a
f) = forall (c :: (* -> *) -> Constraint) (e :: (* -> *) -> Constraint)
       i (g :: * -> *) (f :: * -> *) a.
i
-> (forall (h :: * -> *). (c h, e h) => (f ~> h) -> h a)
-> ProviderS c e i g f (g a)
Provide i
i \g ~> h
l -> forall (h :: * -> *). (c h, e h) => (f ~> h) -> h a
f forall a b. (a -> b) -> a -> b
$ g ~> h
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. f :-> g
phi

instance
    SendSig (ProviderS c e i g) f =>
    Provider c e i g (EffectsVia EffectDataHandler f)
    where
    {-# INLINE provide #-}
    provide :: forall a.
i
-> (forall (h :: * -> *).
    (c h, e h) =>
    (EffectsVia EffectDataHandler f ~> h) -> h a)
-> EffectsVia EffectDataHandler f (g a)
provide i
i forall (h :: * -> *).
(c h, e h) =>
(EffectsVia EffectDataHandler f ~> h) -> h a
f =
        forall {k} (handlerSystem :: k) (f :: * -> *) a.
f a -> EffectsVia handlerSystem f a
EffectsVia
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sig :: (* -> *) -> * -> *) (f :: * -> *) a.
SendSig sig f =>
sig f a -> f a
sendSig
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: (* -> *) -> * -> *) (f :: * -> *) (g :: * -> *).
HFunctor h =>
(f :-> g) -> h f :-> h g
hfmap (forall {k} (handlerSystem :: k) (f :: * -> *) a.
EffectsVia handlerSystem f a -> f a
runEffectsVia @EffectDataHandler)
            forall a b. (a -> b) -> a -> b
$ forall (c :: (* -> *) -> Constraint) (e :: (* -> *) -> Constraint)
       i (g :: * -> *) (f :: * -> *) a.
i
-> (forall (h :: * -> *). (c h, e h) => (f ~> h) -> h a)
-> ProviderS c e i g f (g a)
Provide @c @e i
i forall (h :: * -> *).
(c h, e h) =>
(EffectsVia EffectDataHandler f ~> h) -> h a
f

type MonadProvider = Provider Monad
type ApplicativeProvider = Provider Applicative

mprovide ::
    MonadProvider e i g f =>
    i ->
    (forall h. (Monad h, e h) => (f ~> h) -> h a) ->
    f (g a)
mprovide :: forall (e :: (* -> *) -> Constraint) i (g :: * -> *) (f :: * -> *)
       a.
MonadProvider e i g f =>
i
-> (forall (h :: * -> *). (Monad h, e h) => (f ~> h) -> h a)
-> f (g a)
mprovide = forall (c :: (* -> *) -> Constraint) (e :: (* -> *) -> Constraint)
       i (g :: * -> *) (f :: * -> *) a.
Provider c e i g f =>
i
-> (forall (h :: * -> *). (c h, e h) => (f ~> h) -> h a) -> f (g a)
provide
{-# INLINE mprovide #-}

aprovide ::
    ApplicativeProvider e i g f =>
    i ->
    (forall h. (Applicative h, e h) => (f ~> h) -> h a) ->
    f (g a)
aprovide :: forall (e :: (* -> *) -> Constraint) i (g :: * -> *) (f :: * -> *)
       a.
ApplicativeProvider e i g f =>
i
-> (forall (h :: * -> *). (Applicative h, e h) => (f ~> h) -> h a)
-> f (g a)
aprovide = forall (c :: (* -> *) -> Constraint) (e :: (* -> *) -> Constraint)
       i (g :: * -> *) (f :: * -> *) a.
Provider c e i g f =>
i
-> (forall (h :: * -> *). (c h, e h) => (f ~> h) -> h a) -> f (g a)
provide
{-# INLINE aprovide #-}