{-# LANGUAGE AllowAmbiguousTypes #-}

-- SPDX-License-Identifier: MPL-2.0

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

import Control.Monad ((<=<))
import Data.Effect (CC (Jump, SubFork))
import Data.Function (fix)
import Data.Functor.Contravariant (Op (Op))

data Shift ans ref :: Effect where
    SubShiftFork :: Shift ans ref f (Either (ref a) a)
    Call :: ref a -> a -> Shift ans ref f ans
    Abort :: ans -> Shift ans ref f a
makeEffectF ''Shift

subShift
    :: forall a b es ans ref ff c
     . (Shift ans ref :> es, Monad (Eff ff es), Free c ff)
    => (ref a -> Eff ff es b)
    -> (a -> Eff ff es b)
    -> Eff ff es b
subShift :: forall a b (es :: [Effect]) ans (ref :: * -> *) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Shift ans ref :> es, Monad (Eff ff es), Free c ff) =>
(ref a -> Eff ff es b) -> (a -> Eff ff es b) -> Eff ff es b
subShift ref a -> Eff ff es b
p a -> Eff ff es b
q = Eff ff es (Either (ref a) a)
forall ans (ref :: * -> *) a (f :: * -> *) (es :: [Effect])
       (ff :: Effect) (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, Shift ans ref :> es) =>
f (Either (ref a) a)
subShiftFork Eff ff es (Either (ref a) a)
-> (Either (ref a) a -> Eff ff es b) -> Eff ff es b
forall a b. Eff ff es a -> (a -> Eff ff es b) -> Eff ff es b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ref a -> Eff ff es b)
-> (a -> Eff ff es b) -> Either (ref a) a -> Eff ff es b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ref a -> Eff ff es b
p a -> Eff ff es b
q
{-# INLINE subShift #-}

shift
    :: forall a es ans ref ff c
     . (Shift ans ref :> es, Monad (Eff ff es), Free c ff)
    => ((a -> Eff ff es ans) -> Eff ff es ans)
    -> Eff ff es a
shift :: forall a (es :: [Effect]) ans (ref :: * -> *) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Shift ans ref :> es, Monad (Eff ff es), Free c ff) =>
((a -> Eff ff es ans) -> Eff ff es ans) -> Eff ff es a
shift (a -> Eff ff es ans) -> Eff ff es ans
f = (ref a -> Eff ff es a) -> (a -> Eff ff es a) -> Eff ff es a
forall a b (es :: [Effect]) ans (ref :: * -> *) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Shift ans ref :> es, Monad (Eff ff es), Free c ff) =>
(ref a -> Eff ff es b) -> (a -> Eff ff es b) -> Eff ff es b
subShift (ans -> Eff ff es a
forall ans (ref :: * -> *) a (f :: * -> *) (es :: [Effect])
       (ff :: Effect) (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, Shift ans ref :> es) =>
ans -> f a
abort (ans -> Eff ff es a)
-> (ref a -> Eff ff es ans) -> ref a -> Eff ff es a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (a -> Eff ff es ans) -> Eff ff es ans
f ((a -> Eff ff es ans) -> Eff ff es ans)
-> (ref a -> a -> Eff ff es ans) -> ref a -> Eff ff es ans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ref a -> a -> Eff ff es ans
forall (ref :: * -> *) a ans (f :: * -> *) (es :: [Effect])
       (ff :: Effect) (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, Shift ans ref :> es) =>
ref a -> a -> f ans
call) a -> Eff ff es a
forall a. a -> Eff ff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE shift #-}

getShiftCC
    :: forall es ans ref ff c
     . (Shift ans ref :> es, Monad (Eff ff es), Free c ff)
    => Eff ff es (Eff ff es ans)
getShiftCC :: forall (es :: [Effect]) ans (ref :: * -> *) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Shift ans ref :> es, Monad (Eff ff es), Free c ff) =>
Eff ff es (Eff ff es ans)
getShiftCC = ((Eff ff es ans -> Eff ff es ans) -> Eff ff es ans)
-> Eff ff es (Eff ff es ans)
forall a (es :: [Effect]) ans (ref :: * -> *) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Shift ans ref :> es, Monad (Eff ff es), Free c ff) =>
((a -> Eff ff es ans) -> Eff ff es ans) -> Eff ff es a
shift (Eff ff es ans -> Eff ff es ans) -> Eff ff es ans
forall a. (a -> a) -> a
fix
{-# INLINE getShiftCC #-}

runCCAsShift
    :: forall a es ans ref ff c
     . (Shift ans ref :> es, Monad (Eff ff es), Free c ff)
    => Eff ff (CC ref ': es) a
    -> Eff ff es a
runCCAsShift :: forall a (es :: [Effect]) ans (ref :: * -> *) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Shift ans ref :> es, Monad (Eff ff es), Free c ff) =>
Eff ff (CC ref : es) a -> Eff ff es a
runCCAsShift = (CC ref ~~> Eff ff es) -> Eff ff (CC ref : es) a -> Eff ff es a
forall (e :: Effect) (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(KnownOrder e, Free c ff) =>
(e ~~> Eff ff es) -> Eff ff (e : es) a -> Eff ff es a
interpret \case
    CC ref (Eff ff es) x
SubFork -> Eff ff es x
Eff ff es (Either (ref a1) a1)
forall ans (ref :: * -> *) a (f :: * -> *) (es :: [Effect])
       (ff :: Effect) (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, Shift ans ref :> es) =>
f (Either (ref a) a)
subShiftFork
    Jump ref a1
ref a1
x -> ref a1 -> a1 -> Eff ff es ans
forall (ref :: * -> *) a ans (f :: * -> *) (es :: [Effect])
       (ff :: Effect) (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, Shift ans ref :> es) =>
ref a -> a -> f ans
call ref a1
ref a1
x Eff ff es ans -> (ans -> Eff ff es x) -> Eff ff es x
forall a b. Eff ff es a -> (a -> Eff ff es b) -> Eff ff es b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ans -> Eff ff es x
forall ans (ref :: * -> *) a (f :: * -> *) (es :: [Effect])
       (ff :: Effect) (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, Shift ans ref :> es) =>
ans -> f a
abort
{-# INLINE runCCAsShift #-}

runCCOnShift
    :: forall a es ans ref ff c
     . (Shift ans ref :> es, Monad (Eff ff es), Free c ff)
    => Eff ff (CC (Op (Eff ff es ans)) ': es) a
    -> Eff ff es a
runCCOnShift :: forall a (es :: [Effect]) ans (ref :: * -> *) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Shift ans ref :> es, Monad (Eff ff es), Free c ff) =>
Eff ff (CC (Op (Eff ff es ans)) : es) a -> Eff ff es a
runCCOnShift = (CC (Op (Eff ff es ans)) ~~> Eff ff es)
-> Eff ff (CC (Op (Eff ff es ans)) : es) a -> Eff ff es a
forall (e :: Effect) (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(KnownOrder e, Free c ff) =>
(e ~~> Eff ff es) -> Eff ff (e : es) a -> Eff ff es a
interpret \case
    CC (Op (Eff ff es ans)) (Eff ff es) x
SubFork -> ((x -> Eff ff es ans) -> Eff ff es ans) -> Eff ff es x
forall a (es :: [Effect]) ans (ref :: * -> *) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Shift ans ref :> es, Monad (Eff ff es), Free c ff) =>
((a -> Eff ff es ans) -> Eff ff es ans) -> Eff ff es a
shift \x -> Eff ff es ans
exit -> x -> Eff ff es ans
exit (x -> Eff ff es ans)
-> ((a1 -> Eff ff es ans) -> x)
-> (a1 -> Eff ff es ans)
-> Eff ff es ans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Op (Eff ff es ans) a1 -> x
Op (Eff ff es ans) a1 -> Either (Op (Eff ff es ans) a1) a1
forall a b. a -> Either a b
Left (Op (Eff ff es ans) a1 -> x)
-> ((a1 -> Eff ff es ans) -> Op (Eff ff es ans) a1)
-> (a1 -> Eff ff es ans)
-> x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a1 -> Eff ff es ans) -> Op (Eff ff es ans) a1
forall a b. (b -> a) -> Op a b
Op ((a1 -> Eff ff es ans) -> Eff ff es ans)
-> (a1 -> Eff ff es ans) -> Eff ff es ans
forall a b. (a -> b) -> a -> b
$ x -> Eff ff es ans
exit (x -> Eff ff es ans) -> (a1 -> x) -> a1 -> Eff ff es ans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a1 -> x
a1 -> Either (Op (Eff ff es ans) a1) a1
forall a b. b -> Either a b
Right
    Jump (Op a1 -> Eff ff es ans
exit) a1
x -> a1 -> Eff ff es ans
exit a1
x Eff ff es ans -> (ans -> Eff ff es x) -> Eff ff es x
forall a b. Eff ff es a -> (a -> Eff ff es b) -> Eff ff es b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ans -> Eff ff es x
forall ans (ref :: * -> *) a (f :: * -> *) (es :: [Effect])
       (ff :: Effect) (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, Shift ans ref :> es) =>
ans -> f a
abort
{-# INLINE runCCOnShift #-}