content: {-# LANGUAGE CPP, TupleSections #-}
  {-# OPTIONS_HADDOCK not-home #-}
  module Control.Effect.Type.Optional
   ( -- * Effects
     Optional(..)
  
     -- * Threading utilities
   , threadRegionalViaOptional
   ) where
  
  import Data.Functor.Const
  import Control.Effect.Internal.Union
  import Control.Effect.Type.Regional
  import Control.Monad.Trans.Reader (ReaderT(..), mapReaderT)
  import Control.Monad.Trans.Except (ExceptT(..), mapExceptT)
  import qualified Control.Monad.Trans.State.Strict as SSt
  import qualified Control.Monad.Trans.State.Lazy as LSt
  import qualified Control.Monad.Trans.Writer.Lazy as LWr
  import qualified Control.Monad.Trans.Writer.Strict as SWr
  import qualified Control.Monad.Trans.Writer.CPS as CPSWr
  
  
  -- | A /helper primitive effect/ for manipulating a region, with the option
  -- to execute it in full or in part. @s@ is expected to be a functor.
  --
  -- Helper primitive effects are effects that allow you to avoid interpreting one
  -- of your own effects as a primitive if the power needed from direct access to
  -- the underlying monad can instead be provided by the relevant helper primitive
  -- effect. The reason why you'd want to do this is that helper primitive effects
  -- already have 'ThreadsEff' instances defined for them, so you don't have to
  -- define any for your own effect.
  --
  -- The helper primitive effects offered in this library are -- in order of
  -- ascending power -- 'Control.Effect.Regional.Regional',
  -- 'Control.Effect.Optional.Optional', 'Control.Effect.BaseControl.BaseControl'
  -- and 'Control.Effect.Unlift.Unlift'.
  --
  -- The typical use-case of 'Optional' is to lift a natural transformation
  -- of a base monad equipped with the power to recover from an exception.
  -- 'Control.Effect.Optional.HoistOption' and accompanying interpreters is
  -- provided as a specialization of 'Optional' for this purpose.
  --
  -- 'Optional' in its most general form lacks a pre-defined interpreter:
  -- when not using 'Control.Effect.Optional.HoistOption', you're expected to
  -- define your own interpreter for 'Optional' (treating it as a primitive effect).
  --
  -- __'Optional' is typically used as a primitive effect.__
  -- If you define a 'Control.Effect.Carrier' that relies on a novel
  -- non-trivial monad transformer @t@, then you need to make
  -- a @Functor s => 'ThreadsEff' t ('Optional' s)@ instance (if possible).
  -- 'Control.Effect.Optional.threadOptionalViaBaseControl'
  -- can help you with that.
  --
  -- The following threading constraints accept 'Optional':
  --
  -- * 'Control.Effect.ReaderThreads'
  -- * 'Control.Effect.State.StateThreads'
  -- * 'Control.Effect.State.StateLazyThreads'
  -- * 'Control.Effect.Error.ErrorThreads'
  -- * 'Control.Effect.Writer.WriterThreads'
  -- * 'Control.Effect.Writer.WriterLazyThreads'
  -- * 'Control.Effect.NonDet.NonDetThreads'
  -- * 'Control.Effect.Stepped.SteppedThreads'
  -- * 'Control.Effect.Cont.ContThreads'
  data Optional s :: Effect where
    Optionally :: s a -> m a -> Optional s m a
  
  -- | A valid definition of 'threadEff' for a @'ThreadsEff' ('Regional' s) t@ instance,
  -- given that @t@ threads @'Optional' f@ for any functor @f@.
  threadRegionalViaOptional :: ( ThreadsEff t (Optional (Const s))
                               , Monad m)
                            => (forall x. Regional s m x -> m x)
                            -> Regional s (t m) a -> t m a
  threadRegionalViaOptional alg (Regionally s m) =
    threadEff
      (\(Optionally (Const s') m') -> alg (Regionally s' m'))
      (Optionally (Const s) m)
  {-# INLINE threadRegionalViaOptional #-}
  
  instance Functor s => ThreadsEff (ExceptT e) (Optional s) where
    threadEff alg (Optionally sa m) = mapExceptT (alg . Optionally (fmap Right sa)) m
    {-# INLINE threadEff #-}
  
  instance ThreadsEff (ReaderT i) (Optional s) where
    threadEff alg (Optionally sa m) = mapReaderT (alg . Optionally sa) m
    {-# INLINE threadEff #-}
  
  instance Functor s => ThreadsEff (SSt.StateT s') (Optional s) where
    threadEff alg (Optionally sa m) = SSt.StateT $ \s ->
      alg $ Optionally (fmap (, s) sa) (SSt.runStateT m s)
    {-# INLINE threadEff #-}
  
  instance Functor s => ThreadsEff (LSt.StateT s') (Optional s) where
    threadEff alg (Optionally sa m) = LSt.StateT $ \s ->
      alg $ Optionally (fmap (, s) sa) (LSt.runStateT m s)
    {-# INLINE threadEff #-}
  
  instance (Functor s, Monoid w) => ThreadsEff (LWr.WriterT w) (Optional s) where
    threadEff alg (Optionally sa m) =
      LWr.mapWriterT (alg . Optionally (fmap (, mempty) sa)) m
    {-# INLINE threadEff #-}
  
  instance (Functor s, Monoid w) => ThreadsEff (SWr.WriterT w) (Optional s) where
    threadEff alg (Optionally sa m) =
      SWr.mapWriterT (alg . Optionally (fmap (, mempty) sa)) m
    {-# INLINE threadEff #-}
  
  instance (Functor s, Monoid w)
        => ThreadsEff (CPSWr.WriterT w) (Optional s) where
    threadEff alg (Optionally sa m) =
      CPSWr.mapWriterT (alg . Optionally (fmap (, mempty) sa)) m
    {-# INLINE threadEff #-}
  