{-# 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/.

module Data.Effect.ShiftReset where

import Control.Monad (void, (>=>))
import Data.Effect.Key.TH qualified as Keyed
import Data.Effect.TH (noExtTemplate)
import Data.Effect.TH.Internal (noDeriveHFunctor)

data Shift' (r :: Type) m a where
    Shift :: forall r m a. ((a -> m r) -> m r) -> Shift' r m a

makeEffect'
    (def & noDeriveHFunctor & Keyed.changeNormalSenderFnNameFormat)
    Keyed.genEffectKey
    []
    [''Shift']

callCC :: forall r m a. (SendSigBy ShiftKey (Shift' r) m, Monad m) => ((a -> m r) -> m a) -> m a
callCC :: forall r (m :: * -> *) a.
(SendSigBy ShiftKey (Shift' r) m, Monad m) =>
((a -> m r) -> m a) -> m a
callCC (a -> m r) -> m a
f = forall r a (m :: * -> *).
SendSigBy ShiftKey (Shift' r) m =>
((a -> m r) -> m r) -> m a
shift \a -> m r
k -> (a -> m r) -> m a
f (a -> m r
k forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall r (f :: * -> *) a.
(SendSigBy ShiftKey (Shift' r) f, Applicative f) =>
r -> f a
exit) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m r
k

exit :: (SendSigBy ShiftKey (Shift' r) f, Applicative f) => r -> f a
exit :: forall r (f :: * -> *) a.
(SendSigBy ShiftKey (Shift' r) f, Applicative f) =>
r -> f a
exit r
r = forall r a (m :: * -> *).
SendSigBy ShiftKey (Shift' r) m =>
((a -> m r) -> m r) -> m a
shift \a -> f r
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r
{-# INLINE exit #-}

getCC :: (SendSigBy ShiftKey (Shift' r) m, Monad m) => m (m r)
getCC :: forall r (m :: * -> *).
(SendSigBy ShiftKey (Shift' r) m, Monad m) =>
m (m r)
getCC = forall r (m :: * -> *) a.
(SendSigBy ShiftKey (Shift' r) m, Monad m) =>
((a -> m r) -> m a) -> m a
callCC \m r -> m r
exit' -> let a :: m r
a = m r -> m r
exit' m r
a in forall (f :: * -> *) a. Applicative f => a -> f a
pure m r
a

data Shift_ m a where
    Shift_ :: (forall (r :: Type). (a -> m r) -> m r) -> Shift_ m a

makeEffect' (def & noDeriveHFunctor) noExtTemplate [] [''Shift_]

getCC_ :: (Shift_ <<: m, Monad m) => m (m ())
getCC_ :: forall (m :: * -> *). (Shift_ <<: m, Monad m) => m (m ())
getCC_ = forall a (m :: * -> *).
SendSig Shift_ m =>
(forall r. (a -> m r) -> m r) -> m a
shift_ \m () -> m r
k -> let k' :: m r
k' = m () -> m r
k forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void m r
k' in m r
k'

data Reset m (a :: Type) where
    Reset :: m a -> Reset m a

makeEffectH [''Reset]