{- |
Module:      PFile.Error
Copyright:   (c) 2024 Illia Shkroba
License:     BSD3
Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>
Stability:   unstable
Portability: non-portable (Non-Unix systems are not supported)

Functions for error handling.
-}

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}

module PFile.Error
  ( modifyError
  , tellError
  , liftIOWithError
  , onIOError
  , consumeWriterT
  , fallback
  , untilError
  ) where

import           Control.Monad.Writer (MonadWriter (..), WriterT (..))
import           Protolude

-- | Modify error in @ExceptT e1 m@ with a @(e1 -> e2)@ function and then
-- 'throwError' the new error in @m@.
--
-- @since 0.1.0.0
modifyError :: MonadError e2 m => (e1 -> e2) -> ExceptT e1 m a -> m a
modifyError :: forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError e1 -> e2
f = ExceptT e1 m a -> m (Either e1 a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT e1 m a -> m (Either e1 a))
-> (Either e1 a -> m a) -> ExceptT e1 m a -> m a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (e1 -> m a) -> (a -> m a) -> Either e1 a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (e2 -> m a
forall a. e2 -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e2 -> m a) -> (e1 -> e2) -> e1 -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e1 -> e2
f) a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Modify error in @ExceptT e1 m@ with a @(e1 -> e2)@ function and then
-- 'tell' the new error as a singleton list in @m@.
--
-- @since 0.1.0.0
tellError :: MonadWriter [e2] m => (e1 -> e2) -> ExceptT e1 m a -> m ()
tellError :: forall e2 (m :: * -> *) e1 a.
MonadWriter [e2] m =>
(e1 -> e2) -> ExceptT e1 m a -> m ()
tellError e1 -> e2
f = ExceptT e1 m a -> m (Either e1 a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT e1 m a -> m (Either e1 a))
-> (Either e1 a -> m ()) -> ExceptT e1 m a -> m ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (e1 -> m ()) -> (a -> m ()) -> Either e1 a -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([e2] -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([e2] -> m ()) -> (e1 -> [e2]) -> e1 -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e2 -> [e2] -> [e2]
forall a. a -> [a] -> [a]
: []) (e2 -> [e2]) -> (e1 -> e2) -> e1 -> [e2]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e1 -> e2
f) (m () -> a -> m ()
forall a b. a -> b -> a
const (m () -> a -> m ()) -> m () -> a -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Catch 'IOException' of 'IO', modify it with a @(IOException -> e)@
-- function and then 'throwError' the new error in @m@ (lifted 'IO').
--
-- @since 0.1.0.0
liftIOWithError :: (MonadError e m, MonadIO m) => IO a -> (IOException -> e) -> m a
liftIOWithError :: forall e (m :: * -> *) a.
(MonadError e m, MonadIO m) =>
IO a -> (IOException -> e) -> m a
liftIOWithError IO a
action IOException -> e
f = IO (Either IOException a) -> m (Either IOException a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO (Either IOException a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
action) m (Either IOException a) -> (Either IOException 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
>>= (IOException -> m a) -> (a -> m a) -> Either IOException a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (e -> m a
forall a. e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e -> m a) -> (IOException -> e) -> IOException -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> e
f) a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Catch 'IOException' of the first 'IO', ignore it and call the second 'IO'.
-- The second 'IO' will not be called if the first 'IO' doesn't throw.
--
-- @since 0.1.0.0
onIOError :: IO a -> IO a -> IO a
onIOError :: forall a. IO a -> IO a -> IO a
onIOError IO a
action IO a
f = IO a
action IO a -> (IOException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` forall a b. a -> b -> a
const @_ @IOException IO a
f

-- | Unpack inner @WriterT w m@ of @ExceptT e (WriterT w m)@ and consume its
-- @w@ with @(w -> m ())@ function.
--
-- @since 0.1.0.0
consumeWriterT ::
     Monad m => (w -> m ()) -> ExceptT e (WriterT w m) a -> ExceptT e m a
consumeWriterT :: forall (m :: * -> *) w e a.
Monad m =>
(w -> m ()) -> ExceptT e (WriterT w m) a -> ExceptT e m a
consumeWriterT w -> m ()
f = (WriterT w m (Either e a) -> m (Either e a))
-> ExceptT e (WriterT w m) a -> ExceptT e m a
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT ((WriterT w m (Either e a) -> m (Either e a))
 -> ExceptT e (WriterT w m) a -> ExceptT e m a)
-> (WriterT w m (Either e a) -> m (Either e a))
-> ExceptT e (WriterT w m) a
-> ExceptT e m a
forall a b. (a -> b) -> a -> b
$ WriterT w m (Either e a) -> m (Either e a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT w m (Either e a) -> m (Either e a, w))
-> ((Either e a, w) -> m (Either e a))
-> WriterT w m (Either e a)
-> m (Either e a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \(Either e a
y, w
w) -> Either e a
y Either e a -> m () -> m (Either e a)
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ w -> m ()
f w
w

-- | When @ExceptT e (WriterT w m)@ throws an error, pass its error @e@ and
-- writer's result @w@ to @(e -> w -> m b)@ function. A result of @(e -> w ->
-- m b)@ is ignored. Always return @w@.
--
-- @since 0.1.0.0
fallback :: Monad m => (e -> w -> m b) -> ExceptT e (WriterT w m) a -> m w
fallback :: forall (m :: * -> *) e w b a.
Monad m =>
(e -> w -> m b) -> ExceptT e (WriterT w m) a -> m w
fallback e -> w -> m b
f ExceptT e (WriterT w m) a
action = do
  (Maybe e
maybeCause, w
result) <- ExceptT e (WriterT w m) a -> m (Maybe e, w)
forall (m :: * -> *) e w a.
Functor m =>
ExceptT e (WriterT w m) a -> m (Maybe e, w)
untilError ExceptT e (WriterT w m) a
action
  Maybe e
maybeCause Maybe e -> (Maybe e -> m w) -> m w
forall a b. a -> (a -> b) -> b
& m w -> (e -> m w) -> Maybe e -> m w
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (w -> m w
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure w
result) (\e
cause -> w
result w -> m b -> m w
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ e -> w -> m b
f e
cause w
result)

-- | Unpack @ExceptT e (WriterT w m)@. A result @a@ of @ExceptT e (WriterT w m)
-- a@ is ignored.
--
-- @since 0.1.0.0
untilError :: Functor m => ExceptT e (WriterT w m) a -> m (Maybe e, w)
untilError :: forall (m :: * -> *) e w a.
Functor m =>
ExceptT e (WriterT w m) a -> m (Maybe e, w)
untilError ExceptT e (WriterT w m) a
action = ExceptT e (WriterT w m) a
action ExceptT e (WriterT w m) a
-> (ExceptT e (WriterT w m) a -> m (Either e a, w))
-> m (Either e a, w)
forall a b. a -> (a -> b) -> b
& WriterT w m (Either e a) -> m (Either e a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT w m (Either e a) -> m (Either e a, w))
-> (ExceptT e (WriterT w m) a -> WriterT w m (Either e a))
-> ExceptT e (WriterT w m) a
-> m (Either e a, w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT e (WriterT w m) a -> WriterT w m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT m (Either e a, w)
-> ((Either e a, w) -> (Maybe e, w)) -> m (Maybe e, w)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Either e a -> Maybe e) -> (Either e a, w) -> (Maybe e, w)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Either e a -> Maybe e
forall l r. Either l r -> Maybe l
leftToMaybe