{-# LANGUAGE DerivingVia #-}
module Control.Effect.Regional
  ( -- * Effects
    Regional(..)
  , Hoist

    -- * Actions
  , regionally
  , hoist

    -- * Interpretations
  , runHoist

  , hoistToFinal

    -- * Threading utilities
  , threadRegionalViaOptional

    -- * Combinators for 'Algebra's
    -- Intended to be used for custom 'Carrier' instances when
    -- defining 'algPrims'.
  , powerAlgHoist
  , powerAlgHoistFinal

    -- * Carriers
  , HoistC
  , HoistToFinalC
  ) where

import Control.Effect
import Control.Effect.Carrier

import Control.Effect.Type.Regional
import Control.Effect.Type.Optional
import Control.Effect.Internal.Regional

import Control.Monad.Trans.Control (control)

-- | Execute a computation modified in some way, providing
-- the interpreter of @'Regional' s@ a constant to indicate
-- how the computation should be modified.
regionally :: Eff (Regional s) m => s -> m a -> m a
regionally :: s -> m a -> m a
regionally s
s m a
m = Regional s m a -> m a
forall (e :: Effect) (m :: * -> *) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send (s -> m a -> Regional s m a
forall s (m :: * -> *) a. s -> m a -> Regional s m a
Regionally s
s m a
m)
{-# INLINE regionally #-}

-- | Lift a natural transformation of a base monad to the
-- current monad.
hoist :: Eff (Hoist b) m => (forall x. b x -> b x) -> m a -> m a
hoist :: (forall x. b x -> b x) -> m a -> m a
hoist forall x. b x -> b x
n = HoistCall b -> m a -> m a
forall s (m :: * -> *) a. Eff (Regional s) m => s -> m a -> m a
regionally ((forall x. b x -> b x) -> HoistCall b
forall k (b :: k -> *).
(forall (x :: k). b x -> b x) -> HoistCall b
HoistCall forall x. b x -> b x
n)
{-# INLINE hoist #-}

type HoistToFinalC b = InterpretPrimC HoistToFinalH (Hoist b)

-- | Run a @'Hoist' m@ effect, where the base monad @m@ is the current monad.
--
-- @'Derivs' ('HoistC' m) = 'Hoist' m ': 'Derivs' m@
--
-- @'Prims'  ('HoistC' m) = 'Hoist' m ': 'Prims' m@
runHoist :: Carrier m
         => HoistC m a
         -> m a
runHoist :: HoistC m a -> m a
runHoist = HoistC m a -> m a
forall k (m :: k -> *) (a :: k). HoistC m a -> m a
unHoistC
{-# INLINE runHoist #-}

-- | Run a @'Hoist' b@ effect, where the base monad @b@ is the final base monad.
--
-- @'Derivs' ('HoistToFinalC' b m) = 'Hoist' b ': 'Derivs' m@
--
-- @'Prims'  ('HoistToFinalC' b m) = 'Hoist' b ': 'Prims' m@
hoistToFinal :: ( MonadBaseControl b m
                , Carrier m
                )
             => HoistToFinalC b m a
             -> m a
hoistToFinal :: HoistToFinalC b m a -> m a
hoistToFinal = HoistToFinalC b m a -> m a
forall h (e :: Effect) (m :: * -> *) a.
PrimHandler h e m =>
InterpretPrimC h e m a -> m a
interpretPrimViaHandler
{-# INLINE hoistToFinal #-}

-- | Strengthen an @'Algebra' p m@ by adding a @'Hoist' m@ handler
powerAlgHoist :: forall m p a
               . Algebra' p m a
              -> Algebra' (Hoist m ': p) m a
powerAlgHoist :: Algebra' p m a -> Algebra' (Hoist m : p) m a
powerAlgHoist Algebra' p m a
alg = Algebra' p m a
-> (Regional (HoistCall m) m a -> m a)
-> Algebra' (Hoist m : p) m a
forall (e :: Effect) (r :: [Effect]) (m :: * -> *) a.
RepresentationalEff e =>
Algebra' r m a -> (e m a -> m a) -> Algebra' (e : r) m a
powerAlg Algebra' p m a
alg ((Regional (HoistCall m) m a -> m a) -> Algebra' (Hoist m : p) m a)
-> (Regional (HoistCall m) m a -> m a)
-> Algebra' (Hoist m : p) m a
forall a b. (a -> b) -> a -> b
$ \(Regionally (HoistCall forall x. m x -> m x
n) m a
m) -> m a -> m a
forall x. m x -> m x
n m a
m
{-# INLINE powerAlgHoist #-}

-- | Strengthen an @'Algebra' p m@ by adding a @'Hoist' b@ handler, where
-- @b@ is the final base monad.
powerAlgHoistFinal :: forall b m p a
                    . MonadBaseControl b m
                   => Algebra' p m a
                   -> Algebra' (Hoist b ': p) m a
powerAlgHoistFinal :: Algebra' p m a -> Algebra' (Hoist b : p) m a
powerAlgHoistFinal Algebra' p m a
alg = Algebra' p m a
-> (Regional (HoistCall b) m a -> m a)
-> Algebra' (Hoist b : p) m a
forall (e :: Effect) (r :: [Effect]) (m :: * -> *) a.
RepresentationalEff e =>
Algebra' r m a -> (e m a -> m a) -> Algebra' (e : r) m a
powerAlg Algebra' p m a
alg ((Regional (HoistCall b) m a -> m a) -> Algebra' (Hoist b : p) m a)
-> (Regional (HoistCall b) m a -> m a)
-> Algebra' (Hoist b : p) m a
forall a b. (a -> b) -> a -> b
$ \case
  Regionally (HoistCall forall x. b x -> b x
n) m a
m -> (RunInBase m b -> b (StM m a)) -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b (StM m a)) -> m a
control ((RunInBase m b -> b (StM m a)) -> m a)
-> (RunInBase m b -> b (StM m a)) -> m a
forall a b. (a -> b) -> a -> b
$ \RunInBase m b
lower -> b (StM m a) -> b (StM m a)
forall x. b x -> b x
n (m a -> b (StM m a)
RunInBase m b
lower m a
m)
{-# INLINE powerAlgHoistFinal #-}