# LANGUAGE DerivingVia #
# OPTIONS_HADDOCK not - home #
module Control.Effect.Internal.ErrorIO where

import Control.Monad

import Control.Effect
import Control.Effect.Optional
import Control.Effect.Type.ErrorIO

import Control.Exception (SomeException)
import qualified Control.Exception as X
import qualified Control.Monad.Catch as C

-- For coercion purposes
import Control.Effect.Internal.Derive
import Control.Effect.Carrier.Internal.Intro
import Control.Effect.Carrier.Internal.Compose
import Control.Effect.Carrier.Internal.Interpret
import Control.Effect.Internal.Utils

newtype ErrorIOToIOC m a = ErrorIOToIOC {
    unErrorIOToIOC ::
        ReinterpretC ErrorIOFinalH ErrorIO
         '[Optional ((->) SomeException)]
      ( InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))
      ( m
      )) a
  } deriving ( Functor, Applicative, Monad
             , Alternative, MonadPlus
             , MonadFix, MonadFail, MonadIO
             , MonadThrow, MonadCatch, MonadMask
             , MonadBase b, MonadBaseControl b
             )
    deriving (MonadTrans, MonadTransControl)
    via CompositionBaseT
     '[ ReinterpretC ErrorIOFinalH ErrorIO
         '[Optional ((->) SomeException)]
      , InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))
      ]

deriving instance (Carrier m, C.MonadCatch m)
               => Carrier (ErrorIOToIOC m)

  | Run an @'ErrorIO'@ effect by making use of ' IO ' exceptions .
--
  @'Derivs ' ( ErrorIOToIOC e m ) = ' ErrorIO ' ' : ' Derivs ' m@
--
  @'Control . Effect . Carrier .  ' ( ErrorIOToIOC e m ) = ' Control . Effect . Optional . Optional ' ( ( - > ) ' SomeException ' ) ' : ' Control . Effect . Carrier . Prims ' m@
errorIOToIO :: (Carrier m, C.MonadCatch m)
            => ErrorIOToIOC m a
            -> m a
errorIOToIO =
     interpretPrimViaHandler
  .# reinterpretViaHandler
  .# unErrorIOToIOC
# INLINE errorIOToIO #

data ErrorIOFinalH

instance ( C.MonadThrow m
         , Eff (Optional ((->) SomeException)) m
         )
      => Handler ErrorIOFinalH ErrorIO m where
  effHandler = \case
    ThrowIO x   -> liftBase $ C.throwM x
    CatchIO m h -> join $
      optionally
        (\x -> case X.fromException x of
            Just e -> h e
            Nothing -> liftBase $ C.throwM x
        )
        (fmap pure m)
# INLINEABLE effHandler #

instance ( C.MonadCatch m
         , Carrier m
         )
      => PrimHandler ErrorIOFinalH (Optional ((->) SomeException)) m where
  effPrimHandler = \case
    Optionally h m -> m `C.catch` (return . h)
# INLINEABLE effPrimHandler #

 For coercion purposes


# LANGUAGE DerivingVia #
# OPTIONS_HADDOCK not - home #
module Control.Effect.Internal.ErrorIO where

import Control.Monad

import Control.Effect
import Control.Effect.Optional
import Control.Effect.Type.ErrorIO

import Control.Exception (SomeException)
import qualified Control.Exception as X
import qualified Control.Monad.Catch as C

import Control.Effect.Internal.Derive
import Control.Effect.Carrier.Internal.Intro
import Control.Effect.Carrier.Internal.Compose
import Control.Effect.Carrier.Internal.Interpret
import Control.Effect.Internal.Utils

newtype ErrorIOToIOC m a = ErrorIOToIOC {
    unErrorIOToIOC ::
        ReinterpretC ErrorIOFinalH ErrorIO
         '[Optional ((->) SomeException)]
      ( InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))
      ( m
      )) a
  } deriving ( Functor, Applicative, Monad
             , Alternative, MonadPlus
             , MonadFix, MonadFail, MonadIO
             , MonadThrow, MonadCatch, MonadMask
             , MonadBase b, MonadBaseControl b
             )
    deriving (MonadTrans, MonadTransControl)
    via CompositionBaseT
     '[ ReinterpretC ErrorIOFinalH ErrorIO
         '[Optional ((->) SomeException)]
      , InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))
      ]

deriving instance (Carrier m, C.MonadCatch m)
               => Carrier (ErrorIOToIOC m)

  | Run an @'ErrorIO'@ effect by making use of ' IO ' exceptions .
  @'Derivs ' ( ErrorIOToIOC e m ) = ' ErrorIO ' ' : ' Derivs ' m@
  @'Control . Effect . Carrier .  ' ( ErrorIOToIOC e m ) = ' Control . Effect . Optional . Optional ' ( ( - > ) ' SomeException ' ) ' : ' Control . Effect . Carrier . Prims ' m@
errorIOToIO :: (Carrier m, C.MonadCatch m)
            => ErrorIOToIOC m a
            -> m a
errorIOToIO =
     interpretPrimViaHandler
  .# reinterpretViaHandler
  .# unErrorIOToIOC
# INLINE errorIOToIO #

data ErrorIOFinalH

instance ( C.MonadThrow m
         , Eff (Optional ((->) SomeException)) m
         )
      => Handler ErrorIOFinalH ErrorIO m where
  effHandler = \case
    ThrowIO x   -> liftBase $ C.throwM x
    CatchIO m h -> join $
      optionally
        (\x -> case X.fromException x of
            Just e -> h e
            Nothing -> liftBase $ C.throwM x
        )
        (fmap pure m)
# INLINEABLE effHandler #

instance ( C.MonadCatch m
         , Carrier m
         )
      => PrimHandler ErrorIOFinalH (Optional ((->) SomeException)) m where
  effPrimHandler = \case
    Optionally h m -> m `C.catch` (return . h)
# INLINEABLE effPrimHandler #
