module Control.Effect.Optional
  ( -- * Effects
    Optional(..)
  , HoistOption
  , HoistOptionCall(..)

    -- * Actions
  , optionally
  , hoistOption

    -- * Interpretations
  , runHoistOption

  , hoistOptionToFinal

    -- * Threading utilities
  , threadOptionalViaBaseControl

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

    -- * Carriers
  , HoistOptionC
  , HoistOptionToFinalC
  ) where

import Control.Monad
import Control.Monad.Trans.Control

import Control.Effect
import Control.Effect.Carrier
import Control.Effect.Internal.Optional

import Control.Effect.Type.Internal.BaseControl
import Control.Effect.Type.Optional


-- | Execute the provided computation, providing the
-- interpretation of @'Optional' s@ the option to execute
-- it in full or in part.
optionally :: Eff (Optional s) m => s a -> m a -> m a
optionally :: s a -> m a -> m a
optionally s a
s m a
m = Optional s m a -> m a
forall (e :: Effect) (m :: * -> *) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send (s a -> m a -> Optional s m a
forall k (s :: k -> *) (a :: k) (m :: k -> *).
s a -> m a -> Optional s m a
Optionally s a
s m a
m)
{-# INLINE optionally #-}

-- | Hoist a natural transformation of the base monad into the current
-- monad, equipped with the option to execute the provided computation
-- in full or in part.
hoistOption :: Eff (HoistOption b) m
            => (forall x. (a -> x) -> b x -> b x)
            -> m a -> m a
hoistOption :: (forall x. (a -> x) -> b x -> b x) -> m a -> m a
hoistOption forall x. (a -> x) -> b x -> b x
n = HoistOptionCall b a -> m a -> m a
forall (s :: * -> *) (m :: * -> *) a.
Eff (Optional s) m =>
s a -> m a -> m a
optionally ((forall x. (a -> x) -> b x -> b x) -> HoistOptionCall b a
forall (b :: * -> *) a.
(forall x. (a -> x) -> b x -> b x) -> HoistOptionCall b a
HoistOptionCall forall x. (a -> x) -> b x -> b x
n)
{-# INLINE hoistOption #-}

-- | Runs a @'HoistOption' m@ effect, where the base monad
-- @m@ is the current monad.
--
-- @'Derivs' ('HoistOptionC' m) = 'HoistOption' m ': 'Derivs' m@
--
-- @'Prims'  ('HoistOptionC' m) = 'HoistOption' m ': 'Prims' m@
runHoistOption :: Carrier m
               => HoistOptionC m a
               -> m a
runHoistOption :: HoistOptionC m a -> m a
runHoistOption = HoistOptionC m a -> m a
forall k (m :: k -> *) (a :: k). HoistOptionC m a -> m a
unHoistOptionC
{-# INLINE runHoistOption #-}

data HoistOptionToFinalH

instance ( Carrier m
         , MonadBaseControl b m
         )
      => PrimHandler HoistOptionToFinalH (HoistOption b) m where
  effPrimHandler :: HoistOption b m x -> m x
effPrimHandler (Optionally (HoistOptionCall forall x. (x -> x) -> b x -> b x
b) m x
m) =
    m (m x) -> m x
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m x) -> m x) -> m (m x) -> m x
forall a b. (a -> b) -> a -> b
$ (RunInBase m b -> b (m x)) -> m (m x)
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith ((RunInBase m b -> b (m x)) -> m (m x))
-> (RunInBase m b -> b (m x)) -> m (m x)
forall a b. (a -> b) -> a -> b
$ \RunInBase m b
lower ->
      (x -> m x) -> b (m x) -> b (m x)
forall x. (x -> x) -> b x -> b x
b x -> m x
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StM m x -> m x
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM (StM m x -> m x) -> b (StM m x) -> b (m x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m x -> b (StM m x)
RunInBase m b
lower m x
m)
  {-# INLINEABLE effPrimHandler #-}

type HoistOptionToFinalC b = InterpretPrimC HoistOptionToFinalH (HoistOption b)

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

-- | Strengthen an @'Algebra' p m@ by adding a @'HoistOption' m@ handler
powerAlgHoistOption :: forall m p a
                     . Algebra' p m a
                    -> Algebra' (HoistOption m ': p) m a
powerAlgHoistOption :: Algebra' p m a -> Algebra' (HoistOption m : p) m a
powerAlgHoistOption Algebra' p m a
alg = Algebra' p m a
-> (Optional (HoistOptionCall m) m a -> m a)
-> Algebra' (HoistOption 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 ((Optional (HoistOptionCall m) m a -> m a)
 -> Algebra' (HoistOption m : p) m a)
-> (Optional (HoistOptionCall m) m a -> m a)
-> Algebra' (HoistOption m : p) m a
forall a b. (a -> b) -> a -> b
$ \case
  Optionally (HoistOptionCall forall x. (a -> x) -> m x -> m x
b) m a
m -> (a -> a) -> m a -> m a
forall x. (a -> x) -> m x -> m x
b a -> a
forall a. a -> a
id m a
m
{-# INLINE powerAlgHoistOption #-}

-- | Strengthen an @'Algebra' p m@ by adding a @'HoistOption' b@ handler, where
-- @b@ is the final base monad.
powerAlgHoistOptionFinal :: forall b m p a
                          . MonadBaseControl b m
                         => Algebra' p m a
                         -> Algebra' (HoistOption b ': p) m a
powerAlgHoistOptionFinal :: Algebra' p m a -> Algebra' (HoistOption b : p) m a
powerAlgHoistOptionFinal Algebra' p m a
alg = Algebra' p m a
-> (Optional (HoistOptionCall b) m a -> m a)
-> Algebra' (HoistOption 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 ((Optional (HoistOptionCall b) m a -> m a)
 -> Algebra' (HoistOption b : p) m a)
-> (Optional (HoistOptionCall b) m a -> m a)
-> Algebra' (HoistOption b : p) m a
forall a b. (a -> b) -> a -> b
$ \case
  Optionally (HoistOptionCall forall x. (a -> x) -> b x -> b x
b) m a
m -> m (m a) -> m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m a) -> m a) -> m (m a) -> m a
forall a b. (a -> b) -> a -> b
$ (RunInBase m b -> b (m a)) -> m (m a)
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith ((RunInBase m b -> b (m a)) -> m (m a))
-> (RunInBase m b -> b (m a)) -> m (m a)
forall a b. (a -> b) -> a -> b
$ \RunInBase m b
lower ->
    (a -> m a) -> b (m a) -> b (m a)
forall x. (a -> x) -> b x -> b x
b a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StM m a -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM (StM m a -> m a) -> b (StM m a) -> b (m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a -> b (StM m a)
RunInBase m b
lower m a
m)
{-# INLINE powerAlgHoistOptionFinal #-}