-- 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

Interpreter and elaborator for the t'Data.Effect.Reader.Local' / t'Data.Effect.Reader.Catch' effect
classes.
-}
module Control.Effect.Interpreter.Heftia.Reader where

import Control.Arrow ((>>>))
import Control.Effect (type (~>))
import Control.Effect.Hefty (
    Eff,
    Elab,
    interposeRec,
    interpretRec,
    interpretRecH,
 )
import Control.Freer (Freer)
import Data.Effect.HFunctor (HFunctor)
import Data.Effect.Reader (Ask (..), LAsk, Local (..), ask)
import Data.Function ((&))
import Data.Hefty.Union (ForallHFunctor, HFunctorUnion, Member, Union)

runReader ::
    forall r rh rf fr u c.
    ( Freer c fr
    , HFunctorUnion u
    , ForallHFunctor u rh
    , Member u (Ask r) (LAsk r ': rf)
    , Functor (Eff u fr rh (LAsk r ': rf))
    , Applicative (Eff u fr rh rf)
    ) =>
    r ->
    Eff u fr (Local r ': rh) (LAsk r ': rf) ~> Eff u fr rh rf
runReader :: forall r (rh :: [SigClass]) (rf :: [SigClass]) (fr :: SigClass)
       (u :: [SigClass] -> SigClass) (c :: (* -> *) -> Constraint).
(Freer c fr, HFunctorUnion u, ForallHFunctor u rh,
 Member u (Ask r) (LAsk r : rf),
 Functor (Eff u fr rh (LAsk r : rf)),
 Applicative (Eff u fr rh rf)) =>
r -> Eff u fr (Local r : rh) (LAsk r : rf) ~> Eff u fr rh rf
runReader r
r = forall r (rh :: [SigClass]) (ef :: [SigClass]) (fr :: SigClass)
       (u :: [SigClass] -> SigClass) (c :: (* -> *) -> Constraint).
(Freer c fr, HFunctorUnion u, ForallHFunctor u rh,
 Member u (Ask r) ef, Functor (Eff u fr rh ef)) =>
Eff u fr (Local r : rh) ef ~> Eff u fr rh ef
runLocal forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall r (rs :: [SigClass]) (eh :: [SigClass]) (fr :: SigClass)
       (u :: [SigClass] -> SigClass) (c :: (* -> *) -> Constraint).
(Freer c fr, Union u, Applicative (Eff u fr eh rs),
 HFunctor (u eh)) =>
r -> Eff u fr eh (LAsk r : rs) ~> Eff u fr eh rs
runAsk r
r
{-# INLINE runReader #-}

-- | Elaborate the t'Local' effect.
runLocal ::
    forall r rh ef fr u c.
    ( Freer c fr
    , HFunctorUnion u
    , ForallHFunctor u rh
    , Member u (Ask r) ef
    , Functor (Eff u fr rh ef)
    ) =>
    Eff u fr (Local r ': rh) ef ~> Eff u fr rh ef
runLocal :: forall r (rh :: [SigClass]) (ef :: [SigClass]) (fr :: SigClass)
       (u :: [SigClass] -> SigClass) (c :: (* -> *) -> Constraint).
(Freer c fr, HFunctorUnion u, ForallHFunctor u rh,
 Member u (Ask r) ef, Functor (Eff u fr rh ef)) =>
Eff u fr (Local r : rh) ef ~> Eff u fr rh ef
runLocal = forall (e :: SigClass) (rs :: [SigClass]) (efs :: [SigClass])
       (fr :: SigClass) (u :: [SigClass] -> SigClass)
       (c :: (* -> *) -> Constraint).
(Freer c fr, Union u, HFunctor e, HFunctor (u rs),
 HFunctor (u (e : rs))) =>
(e (Eff u fr rs efs) ~> Eff u fr rs efs)
-> Eff u fr (e : rs) efs ~> Eff u fr rs efs
interpretRecH forall r (eh :: [SigClass]) (ef :: [SigClass]) (fr :: SigClass)
       (u :: [SigClass] -> SigClass) (c :: (* -> *) -> Constraint).
(Member u (Ask r) ef, Freer c fr, Union u, HFunctor (u eh),
 Functor (Eff u fr eh ef)) =>
Elab (Local r) (Eff u fr eh ef)
elabLocal
{-# INLINE runLocal #-}

elabLocal ::
    forall r eh ef fr u c.
    (Member u (Ask r) ef, Freer c fr, Union u, HFunctor (u eh), Functor (Eff u fr eh ef)) =>
    Elab (Local r) (Eff u fr eh ef)
elabLocal :: forall r (eh :: [SigClass]) (ef :: [SigClass]) (fr :: SigClass)
       (u :: [SigClass] -> SigClass) (c :: (* -> *) -> Constraint).
(Member u (Ask r) ef, Freer c fr, Union u, HFunctor (u eh),
 Functor (Eff u fr eh ef)) =>
Elab (Local r) (Eff u fr eh ef)
elabLocal (Local r -> r
f Eff u fr eh ef x
a) = Eff u fr eh ef x
a forall a b. a -> (a -> b) -> b
& forall (e :: * -> *) (ehs :: [SigClass]) (efs :: [SigClass])
       (fr :: SigClass) (u :: [SigClass] -> SigClass)
       (c :: (* -> *) -> Constraint).
(Freer c fr, Union u, HFunctor (u ehs), Member u e efs) =>
(e ~> Eff u fr ehs efs) -> Eff u fr ehs efs ~> Eff u fr ehs efs
interposeRec @(Ask r) \Ask r x
Ask -> r -> r
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (f :: * -> *). SendIns (Ask r) f => f r
ask

-- | Interpret the t'Ask' effect.
runAsk ::
    forall r rs eh fr u c.
    (Freer c fr, Union u, Applicative (Eff u fr eh rs), HFunctor (u eh)) =>
    r ->
    Eff u fr eh (LAsk r ': rs) ~> Eff u fr eh rs
runAsk :: forall r (rs :: [SigClass]) (eh :: [SigClass]) (fr :: SigClass)
       (u :: [SigClass] -> SigClass) (c :: (* -> *) -> Constraint).
(Freer c fr, Union u, Applicative (Eff u fr eh rs),
 HFunctor (u eh)) =>
r -> Eff u fr eh (LAsk r : rs) ~> Eff u fr eh rs
runAsk r
r = forall (e :: SigClass) (rs :: [SigClass]) (ehs :: [SigClass])
       (fr :: SigClass) (u :: [SigClass] -> SigClass)
       (c :: (* -> *) -> Constraint).
(Freer c fr, Union u, HFunctor (u ehs), HeadIns e) =>
(UnliftIfSingle e ~> Eff u fr ehs rs)
-> Eff u fr ehs (e : rs) ~> Eff u fr ehs rs
interpretRec \Ask r x
UnliftIfSingle (LAsk r) x
Ask -> forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r
{-# INLINE runAsk #-}