-- SPDX-License-Identifier: MPL-2.0

{- |
Copyright   :  (c) 2025 Sayo contributors
License     :  MPL-2.0 (see the LICENSE file)
Maintainer  :  ymdfield@outlook.jp
-}
module Control.Monad.Hefty.Shift (
    module Control.Monad.Hefty.Shift,
    module Data.Effect.Shift,
)
where

import Control.Monad.Hefty (AlgHandler, Eff, interpretBy)
import Data.Effect.OpenUnion (FOEs)
import Data.Effect.Shift
import Data.Functor.Contravariant (Op (Op))

runShift :: (FOEs es) => (a -> Eff es ans) -> Eff (Shift ans (Op (Eff es ans)) ': es) a -> Eff es ans
runShift :: forall (es :: [Effect]) a ans.
FOEs es =>
(a -> Eff es ans)
-> Eff (Shift ans (Op (Eff es ans)) : es) a -> Eff es ans
runShift a -> Eff es ans
k = (a -> Eff es ans)
-> AlgHandler
     (Shift ans (Op (Eff es ans)))
     (Eff (Shift ans (Op (Eff es ans)) : es))
     (Eff es)
     ans
-> Eff (Shift ans (Op (Eff es ans)) : es) a
-> Eff es ans
forall (e :: Effect) (es :: [Effect]) ans a.
(KnownOrder e, FOEs es) =>
(a -> Eff es ans)
-> AlgHandler e (Eff (e : es)) (Eff es) ans
-> Eff (e : es) a
-> Eff es ans
interpretBy a -> Eff es ans
k Shift
  ans (Op (Eff es ans)) (Eff (Shift ans (Op (Eff es ans)) : es)) x
-> (x -> Eff es ans) -> Eff es ans
AlgHandler
  (Shift ans (Op (Eff es ans)))
  (Eff (Shift ans (Op (Eff es ans)) : es))
  (Eff es)
  ans
forall (m :: * -> *) ans (n :: * -> *).
Monad m =>
AlgHandler (Shift ans (Op (m ans))) n m ans
handleShift
{-# INLINE runShift #-}

handleShift :: (Monad m) => AlgHandler (Shift ans (Op (m ans))) n m ans
handleShift :: forall (m :: * -> *) ans (n :: * -> *).
Monad m =>
AlgHandler (Shift ans (Op (m ans))) n m ans
handleShift = \case
    Shift ans (Op (m ans)) n x
SubShiftFork -> \x -> m ans
exit -> x -> m ans
exit (x -> m ans) -> ((a1 -> m ans) -> x) -> (a1 -> m ans) -> m ans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Op (m ans) a1 -> x
Op (m ans) a1 -> Either (Op (m ans) a1) a1
forall a b. a -> Either a b
Left (Op (m ans) a1 -> x)
-> ((a1 -> m ans) -> Op (m ans) a1) -> (a1 -> m ans) -> x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a1 -> m ans) -> Op (m ans) a1
forall a b. (b -> a) -> Op a b
Op ((a1 -> m ans) -> m ans) -> (a1 -> m ans) -> m ans
forall a b. (a -> b) -> a -> b
$ x -> m ans
exit (x -> m ans) -> (a1 -> x) -> a1 -> m ans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a1 -> x
a1 -> Either (Op (m ans) a1) a1
forall a b. b -> Either a b
Right
    Call (Op a1 -> m ans
exit) a1
x -> (a1 -> m ans
exit a1
x >>=)
    Abort ans
ans -> m ans -> (x -> m ans) -> m ans
forall a b. a -> b -> a
const (m ans -> (x -> m ans) -> m ans) -> m ans -> (x -> m ans) -> m ans
forall a b. (a -> b) -> a -> b
$ ans -> m ans
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ans
ans
{-# INLINE handleShift #-}

evalShift :: (FOEs es) => Eff (Shift a (Op (Eff es a)) ': es) a -> Eff es a
evalShift :: forall (es :: [Effect]) a.
FOEs es =>
Eff (Shift a (Op (Eff es a)) : es) a -> Eff es a
evalShift = (a -> Eff es a) -> Eff (Shift a (Op (Eff es a)) : es) a -> Eff es a
forall (es :: [Effect]) a ans.
FOEs es =>
(a -> Eff es ans)
-> Eff (Shift ans (Op (Eff es ans)) : es) a -> Eff es ans
runShift a -> Eff es a
forall a. a -> Eff Freer es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE evalShift #-}