Optional.hs

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 m = send (Optionally s 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 n = optionally (HoistOptionCall 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 = unHoistOptionC
{-# INLINE runHoistOption #-}

data HoistOptionToFinalH

instance ( Carrier m
         , MonadBaseControl b m
         )
      => PrimHandler HoistOptionToFinalH (HoistOption b) m where
  effPrimHandler (Optionally (HoistOptionCall b) m) =
    join $ liftBaseWith $ \lower ->
      b pure (restoreM <$> lower 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 = 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 alg = powerAlg alg $ \case
  Optionally (HoistOptionCall b) m -> b id 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 alg = powerAlg alg $ \case
  Optionally (HoistOptionCall b) m -> join $ liftBaseWith $ \lower ->
    b pure (restoreM <$> lower m)
{-# INLINE powerAlgHoistOptionFinal #-}