{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE DefaultSignatures      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE UndecidableInstances   #-}

-- | This module provides helper functions for lifting partiality types into
-- error-carrying monads like 'ExceptT'.
--
-- For example, consider the following @App@ monad that may throw @BadPacket@
-- errors:
--
-- @
-- data AppError = BadPacket 'Text'
--
-- newtype App a = App ('EitherT' AppError 'IO') a
--  deriving ('Functor', 'Applicative', 'Monad', 'MonadError' AppError, 'MonadIO')
-- @
--
-- We may have an existing function that attempts to parse a 'ByteString':
--
-- @
-- parsePacket :: 'ByteString' -> 'Either' 'Text' Packet
-- @
--
-- We can lift this error into the @App@ monad using @('<%?>')@:
--
-- @
-- appParsePacket :: 'ByteString' -> 'App' Packet
-- appParsePacket s = parsePacket s \<%?\> BadPacket
-- @
--
-- Instances also exist for extracting errors from other partiality types
-- like @'Either' e@ and @'ExceptT' e m@.

module Control.Monad.Error.Hoist
  ( hoistError
  , hoistErrorM
  -- ** Operators
  -- $mnemonics
  , (<%?>)
  , (<%!?>)
  , (<?>)
  , (<!?>)
  -- * Helper class
  , PluckError(..)
  ) where

import           Control.Monad              ((<=<))
import           Control.Monad.Error.Class  (MonadError (..))

import           Data.Either                (Either, either)

import           Control.Monad.Except       (Except, ExceptT, runExcept,
                                             runExceptT)

-- | Given a conversion from the error in @t a@ to @e'@, we can hoist the
-- computation into @m@.
--
-- @
-- 'hoistError' :: 'MonadError' e m -> (() -> e) -> 'Maybe'       a -> m a
-- 'hoistError' :: 'MonadError' e m -> (a  -> e) -> 'Either'  a   b -> m b
-- 'hoistError' :: 'MonadError' e m -> (a  -> e) -> 'ExceptT' a m b -> m b
-- @
hoistError
  :: (PluckError e t m, MonadError e' m)
  => (e -> e')
  -> t a
  -> m a
hoistError :: forall e (t :: * -> *) (m :: * -> *) e' a.
(PluckError e t m, MonadError e' m) =>
(e -> e') -> t a -> m a
hoistError e -> e'
f = (e -> m a) -> (a -> m a) -> t a -> m a
forall r a. (e -> m r) -> (a -> m r) -> t a -> m r
forall e (t :: * -> *) (m :: * -> *) r a.
PluckError e t m =>
(e -> m r) -> (a -> m r) -> t a -> m r
foldError (e' -> m a
forall a. e' -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e' -> m a) -> (e -> e') -> e -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> e'
f) a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | A version of 'hoistError' that operates on values already in the monad.
--
-- @
-- 'hoistErrorM' :: 'MonadError' e m => (() -> e) -> m ('Maybe'       a) ->           m a
-- 'hoistErrorM' :: 'MonadError' e m => (a  -> e) -> m ('Either'  a   b) ->           m b
-- 'hoistErrorM' :: 'MonadError' e m => (a  -> e) ->    'ExceptT' a m b  -> 'ExceptT' a m b
-- @
hoistErrorM
  :: (PluckError e t m, MonadError e' m)
  => (e -> e')
  -> m (t a)
  -> m a
hoistErrorM :: forall e (t :: * -> *) (m :: * -> *) e' a.
(PluckError e t m, MonadError e' m) =>
(e -> e') -> m (t a) -> m a
hoistErrorM e -> e'
e m (t a)
m = m (t a)
m m (t a) -> (t a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (e -> e') -> t a -> m a
forall e (t :: * -> *) (m :: * -> *) e' a.
(PluckError e t m, MonadError e' m) =>
(e -> e') -> t a -> m a
hoistError e -> e'
e

-- $mnemonics
--
-- The operators in this package are named according to a scheme:
--
-- * @('<?>')@ is the simplest error-handling function: it replaces
--   any error with its second argument.
--
-- * The additional @!@ in @('<!?>')@ and @('<%!?>')@ means the
--   operator handles values that are already "in a monad".
--
-- * The additional @%@ in @('<%?>')@ and @('<%!?>')@ means the
--   operator takes a function argument, which it applies to the error
--   from the partiality type. (The mnemonic is that @%@ sometimes
--   means "mod", and we abuse "mod" as a shorthand for "modify". It's a
--   long bow, but @lens@ uses the same mnemonic.)

-- | A flipped synonym for 'hoistError'.
--
-- @
-- ('<%?>') :: 'MonadError' e m => 'Maybe'       a -> (() -> e) ->           m a
-- ('<%?>') :: 'MonadError' e m => 'Either'  a   b -> (a  -> e) ->           m b
-- ('<%?>') :: 'MonadError' e m => 'ExceptT' a m b -> (a  -> e) -> 'ExceptT' a m b
-- @
(<%?>)
  :: (PluckError e t m, MonadError e' m)
  => t a
  -> (e -> e')
  -> m a
<%?> :: forall e (t :: * -> *) (m :: * -> *) e' a.
(PluckError e t m, MonadError e' m) =>
t a -> (e -> e') -> m a
(<%?>) = ((e -> e') -> t a -> m a) -> t a -> (e -> e') -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (e -> e') -> t a -> m a
forall e (t :: * -> *) (m :: * -> *) e' a.
(PluckError e t m, MonadError e' m) =>
(e -> e') -> t a -> m a
hoistError

infixl 8 <%?>
{-# INLINE (<%?>) #-}

-- | A flipped synonym for 'hoistErrorM'.
--
-- @
-- ('<%!?>') :: 'MonadError' e m => m ('Maybe'       a) -> (() -> e) ->           m a
-- ('<%!?>') :: 'MonadError' e m => m ('Either'  a   b) -> (a  -> e) ->           m b
-- ('<%!?>') :: 'MonadError' e m =>    'ExceptT' a m b  -> (a  -> e) -> 'ExceptT' a m b
-- @
(<%!?>)
  :: (PluckError e t m, MonadError e' m)
  => m (t a)
  -> (e -> e')
  -> m a
<%!?> :: forall e (t :: * -> *) (m :: * -> *) e' a.
(PluckError e t m, MonadError e' m) =>
m (t a) -> (e -> e') -> m a
(<%!?>) = ((e -> e') -> m (t a) -> m a) -> m (t a) -> (e -> e') -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (e -> e') -> m (t a) -> m a
forall e (t :: * -> *) (m :: * -> *) e' a.
(PluckError e t m, MonadError e' m) =>
(e -> e') -> m (t a) -> m a
hoistErrorM

infixl 8 <%!?>
{-# INLINE (<%!?>) #-}

-- | A version of '<%?>' that ignores the error in @t a@ and replaces it
-- with a new one.
--
-- @
-- ('<?>') :: 'MonadError' e m => 'Maybe'       a -> e ->           m a
-- ('<?>') :: 'MonadError' e m => 'Either'  a   b -> e ->           m b
-- ('<?>') :: 'MonadError' e m => 'ExceptT' a m b -> e -> 'ExceptT' a m b
-- @
(<?>)
  :: (PluckError e t m, MonadError e' m)
  => t a
  -> e'
  -> m a
t a
m <?> :: forall e (t :: * -> *) (m :: * -> *) e' a.
(PluckError e t m, MonadError e' m) =>
t a -> e' -> m a
<?> e'
e = t a
m t a -> (e -> e') -> m a
forall e (t :: * -> *) (m :: * -> *) e' a.
(PluckError e t m, MonadError e' m) =>
t a -> (e -> e') -> m a
<%?> e' -> e -> e'
forall a b. a -> b -> a
const e'
e

infixl 8 <?>
{-# INLINE (<?>) #-}

-- | A version of '<?>' that operates on values already in the monad.
--
-- @
-- ('<!?>') :: 'MonadError' e m => m ('Maybe'       a) -> e ->           m a
-- ('<!?>') :: 'MonadError' e m => m ('Either'  a   b) -> e ->           m b
-- ('<!?>') :: 'MonadError' e m =>    'ExceptT' a m b  -> e -> 'ExceptT' a m b
-- @
(<!?>)
  :: (PluckError e t m, MonadError e' m)
  => m (t a)
  -> e'
  -> m a
m (t a)
m <!?> :: forall e (t :: * -> *) (m :: * -> *) e' a.
(PluckError e t m, MonadError e' m) =>
m (t a) -> e' -> m a
<!?> e'
e = do
  t a
x <- m (t a)
m
  t a
x t a -> e' -> m a
forall e (t :: * -> *) (m :: * -> *) e' a.
(PluckError e t m, MonadError e' m) =>
t a -> e' -> m a
<?> e'
e

infixl 8 <!?>
{-# INLINE (<!?>) #-}

-- | A class for plucking an error @e@ out of a partiality type @t@.
class PluckError e t m | t -> e where
  pluckError :: t a -> m (Either e a)
  default pluckError :: Applicative m => t a -> m (Either e a)
  pluckError = (e -> m (Either e a))
-> (a -> m (Either e a)) -> t a -> m (Either e a)
forall r a. (e -> m r) -> (a -> m r) -> t a -> m r
forall e (t :: * -> *) (m :: * -> *) r a.
PluckError e t m =>
(e -> m r) -> (a -> m r) -> t a -> m r
foldError (Either e a -> m (Either e a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a -> m (Either e a))
-> (e -> Either e a) -> e -> m (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e a
forall a b. a -> Either a b
Left) (Either e a -> m (Either e a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a -> m (Either e a))
-> (a -> Either e a) -> a -> m (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either e a
forall a b. b -> Either a b
Right)

  foldError :: (e -> m r) -> (a -> m r) -> t a -> m r
  default foldError :: Monad m => (e -> m r) -> (a -> m r) -> t a -> m r
  foldError e -> m r
f a -> m r
g = (e -> m r) -> (a -> m r) -> Either e a -> m r
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> m r
f a -> m r
g (Either e a -> m r) -> (t a -> m (Either e a)) -> t a -> m r
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< t a -> m (Either e a)
forall a. t a -> m (Either e a)
forall e (t :: * -> *) (m :: * -> *) a.
PluckError e t m =>
t a -> m (Either e a)
pluckError

  {-# MINIMAL pluckError | foldError #-}

instance (Applicative m, e ~ ()) => PluckError e Maybe m where
  pluckError :: forall a. Maybe a -> m (Either e a)
pluckError = Either e a -> m (Either e a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a -> m (Either e a))
-> (Maybe a -> Either e a) -> Maybe a -> m (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either e a -> (a -> Either e a) -> Maybe a -> Either e a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> Either e a
forall a b. a -> Either a b
Left ()) a -> Either e a
forall a b. b -> Either a b
Right
  foldError :: forall r a. (e -> m r) -> (a -> m r) -> Maybe a -> m r
foldError e -> m r
f = m r -> (a -> m r) -> Maybe a -> m r
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> m r
f ())

instance Applicative m => PluckError e (Either e) m where
  pluckError :: forall a. Either e a -> m (Either e a)
pluckError = Either e a -> m (Either e a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  foldError :: forall r a. (e -> m r) -> (a -> m r) -> Either e a -> m r
foldError = (e -> m r) -> (a -> m r) -> Either e a -> m r
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either

instance Monad m => PluckError e (ExceptT e m) m where
  pluckError :: forall a. ExceptT e m a -> m (Either e a)
pluckError = ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
  foldError :: forall r a. (e -> m r) -> (a -> m r) -> ExceptT e m a -> m r
foldError e -> m r
f a -> m r
g = (e -> m r) -> (a -> m r) -> Either e a -> m r
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> m r
f a -> m r
g (Either e a -> m r)
-> (ExceptT e m a -> m (Either e a)) -> ExceptT e m a -> m r
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT