content: {-# OPTIONS_HADDOCK not-home #-}
  {-# LANGUAGE BlockArguments, DerivingVia #-}
  module Control.Effect.Internal.Error where
  
  import Data.Coerce
  
  import Control.Applicative
  import Control.Monad
  
  import Control.Effect
  import Control.Effect.ErrorIO
  import Control.Effect.Type.Throw
  import Control.Effect.Type.Catch
  import Control.Effect.Optional
  
  import Control.Effect.Carrier
  
  import Control.Monad.Trans.Except
  
  import qualified Control.Exception as X
  import qualified Control.Monad.Catch as C
  
  -- For coercion purposes
  import Control.Effect.Carrier.Internal.Interpret
  import Control.Effect.Carrier.Internal.Intro
  import Control.Effect.Carrier.Internal.Compose
  import Control.Effect.Internal.ErrorIO
  import Control.Effect.Internal.Utils
  
  -- For errorToIO
  import Data.Unique
  import GHC.Exts (Any)
  import Unsafe.Coerce
  
  newtype ThrowC e m a = ThrowC { unThrowC :: ExceptT e m a }
    deriving ( Functor, Applicative, Monad
             , Alternative, MonadPlus
             , MonadFix, MonadFail, MonadIO
             , MonadThrow, MonadCatch, MonadMask
             , MonadBase b, MonadBaseControl b
             )
    deriving (MonadTrans, MonadTransControl)
  
  newtype ErrorC e m a = ErrorC { unErrorC :: ExceptT e m a }
    deriving ( Functor, Applicative, Monad
             , Alternative, MonadPlus
             , MonadFix, MonadFail, MonadIO
             , MonadThrow, MonadCatch, MonadMask
             , MonadBase b, MonadBaseControl b
             )
    deriving (MonadTrans, MonadTransControl)
  
  instance ( Carrier m
           , Threads (ExceptT e) (Prims m)
           )
        => Carrier (ThrowC e m) where
    type Derivs (ThrowC e m) = Throw e ': Derivs m
    type Prims  (ThrowC e m) = Prims m
  
    algPrims = coerce (thread @(ExceptT e) (algPrims @m))
    {-# INLINEABLE algPrims #-}
  
    reformulate n alg = powerAlg (reformulate (n . lift) alg) $ \case
      Throw e -> n (ThrowC (throwE e))
    {-# INLINEABLE reformulate #-}
  
  
  instance ( Carrier m
           , Threads (ExceptT e) (Prims m)
           )
        => Carrier (ErrorC e m) where
    type Derivs (ErrorC e m) = Catch e ': Throw e ': Derivs m
    type Prims  (ErrorC e m) = Optional ((->) e) ': Prims m
  
    algPrims = powerAlg (coerce (algPrims @(ThrowC e m))) $ \case
      Optionally h m -> ErrorC (unErrorC m `catchE` (return . h))
    {-# INLINEABLE algPrims #-}
  
    reformulate n alg =
      powerAlg (
        coerceReform (reformulate @(ThrowC e m)) n (weakenAlg alg)
      ) $ \case
        Catch m h -> join $ (alg . inj) $ Optionally h (fmap pure m)
    {-# INLINEABLE reformulate #-}
  
  
  -- | 'ErrorThreads' accepts the following primitive effects:
  --
  -- * 'Control.Effect.Regional.Regional' @s@
  -- * 'Control.Effect.Optional.Optional' @s@ (when @s@ is a functor)
  -- * 'Control.Effect.BaseControl.BaseControl' @b@
  -- * 'Control.Effect.Type.Unravel.Unravel' @p@
  -- * 'Control.Effect.Type.ListenPrim.ListenPrim' @o@ (when @o@ is a 'Monoid')
  -- * 'Control.Effect.Type.WriterPrim.WriterPrim' @o@ (when @o@ is a 'Monoid')
  -- * 'Control.Effect.Type.ReaderPrim.ReaderPrim' @i@
  -- * 'Control.Effect.Mask.Mask'
  -- * 'Control.Effect.Bracket.Bracket'
  -- * 'Control.Effect.Fix.Fix'
  class    ( forall e. Threads (ExceptT e) p
           ) => ErrorThreads p
  instance ( forall e. Threads (ExceptT e) p
           ) => ErrorThreads p
  
  type ReifiesErrorHandler s s' e m =
    ( ReifiesHandler s (Catch e) (InterpretC (ViaReifiedH s') (Throw e) m)
    , ReifiesHandler s' (Throw e) m
    )
  
  
  newtype InterpretErrorC' s s' e m a = InterpretErrorC' {
      unInterpretErrorC' ::
          InterpretC (ViaReifiedH s)  (Catch e)
        ( InterpretC (ViaReifiedH s') (Throw e)
        ( m
        )) a
    } deriving ( Functor, Applicative, Monad
               , Alternative, MonadPlus
               , MonadFix, MonadFail, MonadIO
               , MonadThrow, MonadCatch, MonadMask
               , MonadBase b, MonadBaseControl b
               )
      deriving (MonadTrans, MonadTransControl)
      via CompositionBaseT
       '[ InterpretC (ViaReifiedH s)  (Catch e)
        , InterpretC (ViaReifiedH s') (Throw e)
        ]
  
  deriving instance (Carrier m, ReifiesErrorHandler s s' e m)
                 => Carrier (InterpretErrorC' s s' e m)
  
  type InterpretErrorC e m a =
       forall s s'
     . ReifiesErrorHandler s s' e m
    => InterpretErrorC' s s' e m a
  
  
  newtype ErrorToIOC' s s' e m a = ErrorToIOC' {
      unErrorToIOC' ::
          IntroC '[Catch e, Throw e] '[ErrorIO]
        ( InterpretErrorC' s s' e
        ( ErrorIOToIOC
        ( m
        ))) a
    } deriving ( Functor, Applicative, Monad
               , Alternative, MonadPlus
               , MonadFix, MonadFail, MonadIO
               , MonadThrow, MonadCatch, MonadMask
               , MonadBase b, MonadBaseControl b
               )
      deriving (MonadTrans, MonadTransControl)
      via CompositionBaseT
       '[ IntroC '[Catch e, Throw e] '[ErrorIO]
        , InterpretErrorC' s s' e
        , ErrorIOToIOC
        ]
  
  deriving instance ( Carrier m, C.MonadCatch m
                    , ReifiesErrorHandler s s' e (ErrorIOToIOC m)
                    )
                 => Carrier (ErrorToIOC' s s' e m)
  
  type ErrorToIOC e m a =
       forall s s'
     . ReifiesErrorHandler s s' e (ErrorIOToIOC m)
    => ErrorToIOC' s s' e m a
  
  -- KingoftheHomeless: We could skip having to use 'OpaqueExc'
  -- by requiring the exception type @e@ to be typeable. Or have it be
  -- an instance of 'Exception'.
  --
  -- I choose not to for two reasons:
  --   1. By making use of OpaqueExc and checking unique references,
  --      we guarantee that exceptions belonging to an @'Error' e@ effect
  --      interpreted with 'errorToErrorIO' won't get caught by 'catch'es
  --      belonging to /another/, identical @'Error' e@ effect interpreted
  --      using 'errorToErrorIO'. So by using OpaqueExc, we get coherency.
  --
  --  2. In case we eventually implement a system for polymorphic effect
  --     interpreters inside of application code, like something like this:
  --    @
  --    manageError :: HasErrorInterpreter s m
  --                => ProvidedErrorInterpreterC s e m a
  --                -> m (Either e a)
  --    @
  --    of which 'errorToErrorIO' should be a valid implementation, then
  --    we shouldn't place any constraints upon @e@.
  data OpaqueExc = OpaqueExc Unique Any
  
  instance Show OpaqueExc where
    showsPrec _ (OpaqueExc uniq _) =
        showString "errorToIO/errorToErrorIO: Escaped opaque exception. \
                   \Unique hash is: " . shows (hashUnique uniq) . showString ". \
                   \This should only happen if the computation that threw the \
                   \exception was somehow invoked outside of the argument of \
                   \'errorToIO'; for example, if you 'async' an exceptional \
                   \computation inside of the argument provided to 'errorToIO', \
                   \and then 'await' on it *outside* of the argument provided to \
                   \'errorToIO'. \
                   \If that or any similar shenanigans seems unlikely, then \
                   \please open an issue on the GitHub repository."
  
  instance X.Exception OpaqueExc
  
  -- | Runs connected 'Throw' and 'Catch' effects -- i.e. 'Error' --
  -- by transforming them into 'ErrorIO' and @'Embed' IO@
  --
  -- This has a higher-rank type, as it makes use of 'InterpretErrorC'.
  -- __This makes 'errorToErrorIO' very difficult to use partially applied.__
  -- __In particular, it can't be composed using @'.'@.__
  --
  -- If performance is secondary, consider using the slower
  -- 'errorToErrorIOSimple', which doesn't have a higher-rank type.
  errorToErrorIO :: forall e m a
                  . Effs '[ErrorIO, Embed IO] m
                 => InterpretErrorC e m a
                 -> m (Either e a)
  errorToErrorIO main = do
    !uniq <- embed newUnique
    let
      main' =
          interpret \case
            Throw e -> throwIO (OpaqueExc uniq (unsafeCoerce e))
        $ interpret \case
            Catch m h -> m `catchIO` \exc@(OpaqueExc uniq' e) ->
              if uniq == uniq' then
                h (unsafeCoerce e)
              else
                throwIO exc
        $ unInterpretErrorC'
        $ main
    fmap Right main' `catchIO` \exc@(OpaqueExc uniq' e) ->
      if uniq == uniq' then
        return $ Left (unsafeCoerce e)
      else
        throwIO exc
  
  data ErrorToErrorIOAsExcH
  
  instance (Eff ErrorIO m, Exception e)
        => Handler ErrorToErrorIOAsExcH (Throw e) m where
    effHandler (Throw e) = throwIO e
  
  
  instance (Eff ErrorIO m, Exception e)
        => Handler ErrorToErrorIOAsExcH (Catch e) m where
    effHandler (Catch m f) =  m `catchIO` f
  
  newtype ErrorToErrorIOAsExcC e m a = ErrorToErrorIOAsExcC  {
      unErrorToErrorIOAsExcC ::
          InterpretC ErrorToErrorIOAsExcH (Catch e)
        ( InterpretC ErrorToErrorIOAsExcH (Throw e)
        ( m
        )) a
    } deriving ( Functor, Applicative, Monad
               , Alternative, MonadPlus
               , MonadFix, MonadFail, MonadIO
               , MonadThrow, MonadCatch, MonadMask
               , MonadBase b, MonadBaseControl b
               )
      deriving (MonadTrans, MonadTransControl)
      via CompositionBaseT
       '[ InterpretC ErrorToErrorIOAsExcH  (Catch e)
        , InterpretC ErrorToErrorIOAsExcH (Throw e)
        ]
  
  deriving instance (Eff ErrorIO m, Exception e)
                 => Carrier (ErrorToErrorIOAsExcC e m)
  
  -- | Runs connected 'Throw' and 'Catch' effects -- i.e. 'Error' --
  -- by transforming them into 'ErrorIO'.
  --
  -- Unlike 'errorToErrorIO', values of @e@ are thrown and caught directly as 'IO'
  -- exceptions. This means that, for example, 'catchIO' is able to catch
  -- exceptions of @e@ that you throw with 'Control.Effect.Error.throw',
  -- and 'Control.Effect.Error.catch' is able to catch exceptions of type @e@ that
  -- are thrown with 'throwIO', or by 'embed'ded 'IO' actions.
  --
  -- @'Derivs' ('ErrorToErrorIOAsExcC' e m) = 'Catch' e ': 'Throw' e ': 'Derivs' m@
  --
  -- @'Control.Effect.Primitive.Prims' ('ErrorToErrorIOAsExcC' e m) = 'Control.Effect.Primitive.Prims' m@
  --
  -- @since 0.2.0.0
  errorToErrorIOAsExc
    :: (Exception e, Eff ErrorIO m)
    => ErrorToErrorIOAsExcC e m a
    -> m a
  errorToErrorIOAsExc =
       interpretViaHandler
    .# interpretViaHandler
    .# unErrorToErrorIOAsExcC
  {-# INLINE errorToErrorIOAsExc #-}
  
  -- | Runs connected 'Throw' and 'Catch' effects -- i.e. 'Error' --
  -- by making use of 'IO' exceptions.
  --
  -- @'Derivs' ('ErrorToIOC' e m) = 'Catch' e ': 'Throw' e ': 'Derivs' m@
  --
  -- @'Control.Effect.Primitive.Prims'  ('ErrorToIOC' e m) = 'Control.Effect.Optional.Optional' ((->) 'Control.Exception.SomeException') ': 'Control.Effect.Primitive.Prims' m@
  --
  -- This has a higher-rank type, as it makes use of 'ErrorToIOC'.
  -- __This makes 'errorToIO' very difficult to use partially applied.__
  -- __In particular, it can't be composed using @'.'@.__
  --
  -- If performance is secondary, consider using the slower
  -- 'errorToIOSimple', which doesn't have a higher-rank type.
  errorToIO :: forall e m a
             . ( C.MonadCatch m
               , Eff (Embed IO) m
               )
            => ErrorToIOC e m a
            -> m (Either e a)
  errorToIO m =
      errorIOToIO
    $ errorToErrorIO
    $ introUnderMany
    $ unErrorToIOC'
    $ m
  {-# INLINE errorToIO #-}
  
  newtype ErrorToIOAsExcC e m a = ErrorToIOAsExcC {
      unErrorToIOAsExcC ::
          IntroC '[Catch e, Throw e] '[ErrorIO]
        ( ErrorToErrorIOAsExcC e
        ( ErrorIOToIOC
          m
        )) a
    } deriving ( Functor, Applicative, Monad
               , Alternative, MonadPlus
               , MonadFix, MonadFail, MonadIO
               , MonadThrow, MonadCatch, MonadMask
               , MonadBase b, MonadBaseControl b
               )
      deriving (MonadTrans, MonadTransControl)
      via CompositionBaseT
       '[ IntroC '[Catch e, Throw e] '[ErrorIO]
        , ErrorToErrorIOAsExcC e
        , ErrorIOToIOC
        ]
  
  deriving instance (Exception e, C.MonadCatch m, Carrier m)
                 => Carrier (ErrorToIOAsExcC e m)
  
  -- | Runs connected 'Throw' and 'Catch' effects -- i.e. 'Error' --
  -- by treating values of @e@ as 'IO' exceptions.
  --
  -- Unlike 'errorToIO', values of @e@ are thrown and caught directly as 'IO'
  -- exceptions. This means that, for example, 'catchIO' is able to catch
  -- exceptions of @e@ that you throw with 'Control.Effect.Error.throw',
  -- and 'Control.Effect.Error.catch' is able to catch
  -- exceptions of type @e@ that are thrown with 'throwIO', or by 'embed'ded 'IO'
  -- actions.
  --
  -- @'Derivs' ('ErrorToIOAsExcC' e m) = 'Catch' e ': 'Throw' e ': 'Derivs' m@
  --
  -- @'Control.Effect.Primitive.Prims' ('ErrorToIOAsExcC' e m) = 'Control.Effect.Optional.Optional' ((->) 'Control.Exception.SomeException') ': 'Control.Effect.Primitive.Prims' m@
  --
  -- @since 0.2.0.0
  errorToIOAsExc
    :: ( Exception e
       , C.MonadCatch m
       , Carrier m
       )
    => ErrorToIOAsExcC e m a
    -> m a
  errorToIOAsExc =
       errorIOToIO
    .# errorToErrorIOAsExc
    .# introUnderMany
    .# unErrorToIOAsExcC
  {-# INLINE errorToIOAsExc #-}
  
  newtype InterpretErrorSimpleC e m a = InterpretErrorSimpleC {
      unInterpretErrorSimpleC ::
          InterpretSimpleC (Catch e)
        ( InterpretSimpleC (Throw e)
        ( m
        )) a
    } deriving ( Functor, Applicative, Monad
               , Alternative, MonadPlus
               , MonadFix, MonadFail, MonadIO
               , MonadThrow, MonadCatch, MonadMask
               , MonadBase b, MonadBaseControl b
               )
      deriving MonadTrans
      via CompositionBaseT
       '[ InterpretSimpleC (Catch e)
        , InterpretSimpleC (Throw e)
        ]
  
  deriving instance (Carrier m, Threaders '[ReaderThreads] m p)
                 => Carrier (InterpretErrorSimpleC e m)
  
  newtype ErrorToIOSimpleC e m a = ErrorToIOSimpleC {
      unErrorToIOSimpleC ::
          IntroC '[Catch e, Throw e] '[ErrorIO]
        ( InterpretErrorSimpleC e
        ( ErrorIOToIOC
        ( m
        ))) a
    } deriving ( Functor, Applicative, Monad
               , Alternative, MonadPlus
               , MonadFix, MonadFail, MonadIO
               , MonadThrow, MonadCatch, MonadMask
               , MonadBase b, MonadBaseControl b
               )
      deriving MonadTrans
      via CompositionBaseT
       '[ IntroC '[Catch e, Throw e] '[ErrorIO]
        , InterpretErrorSimpleC e
        , ErrorIOToIOC
        ]
  
  deriving instance ( Eff (Embed IO) m, C.MonadCatch m
                    , Threaders '[ReaderThreads] m p
                    )
                 => Carrier (ErrorToIOSimpleC e m)
  
  
  -- | Runs connected 'Throw' and 'Catch' effects -- i.e. 'Error' --
  -- by transforming them into 'ErrorIO' and @'Embed' IO@
  --
  -- This is a less performant version of 'errorToErrorIO' that doesn't have
  -- a higher-rank type, making it much easier to use partially applied.
  errorToErrorIOSimple :: forall e m a p
                        . ( Effs '[ErrorIO, Embed IO] m
                          , Threaders '[ReaderThreads] m p
                          )
                       => InterpretErrorSimpleC e m a
                       -> m (Either e a)
  errorToErrorIOSimple main = do
    !uniq <- embed newUnique
    let
      main' =
          interpretSimple \case
            Throw e -> throwIO (OpaqueExc uniq (unsafeCoerce e))
        $ interpretSimple \case
            Catch m h -> m `catchIO` \exc@(OpaqueExc uniq' e) ->
              if uniq == uniq' then
                h (unsafeCoerce e)
              else
                throwIO exc
        $ unInterpretErrorSimpleC
        $ main
    fmap Right main' `catchIO` \exc@(OpaqueExc uniq' e) ->
      if uniq == uniq' then
        return $ Left (unsafeCoerce e)
      else
        throwIO exc
  
  -- | Runs connected 'Throw' and 'Catch' effects -- i.e. 'Error' --
  -- by making use of 'IO' exceptions.
  --
  -- @'Derivs' ('ErrorToIOSimpleC' e m) = 'Catch' e ': 'Throw' e ': 'Derivs' m@
  --
  -- @'Control.Effect.Primitive.Prims'  ('ErrorToIOSimpleC' e m) = 'Control.Effect.Optional.Optional' ((->) 'Control.Exception.SomeException') ': 'Control.Effect.Primitive.Prims' m@
  --
  -- This is a less performant version of 'errorToIO' that doesn't have
  -- a higher-rank type, making it much easier to use partially applied.
  errorToIOSimple :: forall e m a p
                   . ( Eff (Embed IO) m
                     , MonadCatch m
                     , Threaders '[ReaderThreads] m p
                     )
                  => ErrorToIOSimpleC e m a
                  -> m (Either e a)
  errorToIOSimple =
       errorIOToIO
    #. errorToErrorIOSimple
    .# introUnderMany
    .# unErrorToIOSimpleC
  {-# INLINE errorToIOSimple #-}
  