Fail.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
#if MIN_VERSION_mtl(2,3,0)
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE StandaloneDeriving #-}
#endif

-- |
-- Module      : Control.Monad.Trans.Fail
-- Copyright   : (c) Alexey Kuleshevich 2022-2023
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <alexey@kuleshevi.ch>
-- Stability   : experimental
-- Portability : non-portable
module Control.Monad.Trans.Fail (
  -- * Fail
  Fail,
  runFail,
  runFailLast,
  runFailAgg,
  errorFail,
  errorFailWithoutStackTrace,

  -- * FailT
  FailT (..),
  FailException (..),
  failT,
  runFailT,
  runFailLastT,
  runFailAggT,
  hoistFailT,
  mapFailT,
  mapErrorFailT,
  mapErrorsFailT,
  exceptFailT,
  throwErrorFailT,
  throwFailT,

  -- * Helpers
  liftCatch,
  liftListen,
  liftPass,
) where

import Control.Applicative
import Control.Exception
import Control.Monad.Catch (MonadThrow (throwM))
import Control.Monad.Cont
import Control.Monad.Except
import qualified Control.Monad.Fail as F
import Control.Monad.RWS.Class (MonadRWS)
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.Zip
import Data.Bifunctor (first)
import Data.Functor.Classes
import Data.Functor.Identity
import Data.List (intersperse)
import qualified Data.List.NonEmpty as NE
import qualified Data.Semigroup as Semi
import Data.Typeable
import GHC.Exts
import GHC.Stack
#if MIN_VERSION_base(4,12,0)
import Data.Functor.Contravariant
#endif
#if MIN_VERSION_mtl(2,3,0)
import Control.Monad.Accum
import Control.Monad.Select
#endif

#if !(MIN_VERSION_base(4,13,0))
#define IS_MONAD_STRING IsString e,
#else
#define IS_MONAD_STRING
#endif

-- | `FailT` transformer with `Identity` as the base monad.
type Fail e = FailT e Identity

-- | Unwrap the pure `Fail` monad and reveal the underlying result of monadic
-- computation.
--
-- >>> runFail (fail "Something went wrong") :: Either String ()
-- Left "Something went wrong"
-- >>> runFail (failT "Something went wrong" >> pure ())
-- Left "Something went wrong"
-- >>> import Control.Applicative
-- >>> runFail (failT "Something could have gone wrong" <|> pure ())
-- Right ()
--
-- All errors accrued during the monadic computation will be combined using the
-- `Semi.Semigroup` instance and delimited by a comma:
--
-- >>> runFail (fail "One thing went wrong" <|> fail "Another thing went wrong") :: Either String ()
-- Left "One thing went wrong, Another thing went wrong"
--
-- Failing with one of instances functions `mempty` or `empty` will yield a no-reason
-- error report:
--
-- >>> runFail mempty :: Either String ()
-- Left "No failure reason given"
runFail :: (IsString e, Semi.Semigroup e) => Fail e a -> Either e a
runFail = runIdentity . runFailT
{-# INLINE runFail #-}

-- | This is a variant of `runFailAgg` where only the error reported for the very last
-- failed computation will be produced and others discarded. This is useful when it is not
-- relevant to retain information about all the attempts and only the last one matters,
-- eg. parsing with backtracking.
runFailLast :: IsString e => Fail e a -> Either e a
runFailLast = runIdentity . runFailLastT
{-# INLINE runFailLast #-}

-- | Convert a `Fail` monad computation in an `Either`, where the `Left` will contain all
-- failures in the same order they where received, or `Right` upon a successful computation.
--
-- >>> runFailAgg (fail "One bad thing" <|> fail "Another bad thing") :: Either [String] ()
-- Left ["One bad thing","Another bad thing"]
-- >>> runFailAgg (fail "A bad thing" <|> pure "A good thing") :: Either [String] String
-- Right "A good thing"
runFailAgg :: Fail e a -> Either [e] a
runFailAgg = runIdentity . runFailAggT
{-# INLINE runFailAgg #-}

-- | Throw an error if there was a failure, otherwise return the result of
-- computation. Use `throwFailT` in case you'd like to handle an actual exception in some
-- other underlying monad.
--
-- >>> errorFail (fail "This didn't work" :: Fail String ())
-- *** Exception: "This didn't work"
-- CallStack (from HasCallStack):
-- ...
-- >>> errorFail (fail "This didn't work" <|> pure "That Worked" :: Fail String String)
-- "That Worked"
errorFail :: (Show e, HasCallStack) => Fail e a -> a
errorFail = either (error . toFailureDelimited . fmap show) id . runFailAgg

-- | Same as `errorFail`, but without the stack trace:
--
-- >>> errorFailWithoutStackTrace (fail "This didn't work" :: Fail String ())
-- *** Exception: "This didn't work"
-- >>> errorFailWithoutStackTrace (fail "This didn't work" <|> pure "That Worked" :: Fail String String)
-- "That Worked"
errorFailWithoutStackTrace :: Show e => Fail e a -> a
errorFailWithoutStackTrace =
  either (errorWithoutStackTrace . toFailureDelimited . fmap show) id . runFailAgg

-- | Fail monad transformer that plays well with `F.MonadFail` type class.
newtype FailT e m a = FailT (m (Either [e] a))

-- | Similar to `fail`, but it is not restricted to `String`.
failT :: Applicative m => e -> FailT e m a
failT = FailT . pure . Left . pure

-- | Similar to `runFail`, except underlying monad is not restricted to `Identity`.
--
-- Unwrap the `FailT` monad transformer and produce an action that can be executed in
-- the underlying monad and, which will produce either a comma delimited error message
-- upon a failure or the result otherwise.
--
-- >>> runFailT (failT "Could have failed" <|> liftIO (putStrLn "Nothing went wrong"))
-- Nothing went wrong
-- Right ()
runFailT :: (IsString e, Semi.Semigroup e, Functor m) => FailT e m a -> m (Either e a)
runFailT (FailT f) = either (Left . toFailureDelimited) Right <$> f
{-# INLINE runFailT #-}

-- | Similar to `runFailLast`, except underlying monad is not restricted to `Identity`.
runFailLastT :: (IsString e, Functor m) => FailT e m a -> m (Either e a)
runFailLastT (FailT f) = either (Left . NE.last . toFailureNonEmpty) Right <$> f
{-# INLINE runFailLastT #-}

-- | Similar to `runFailAgg`, except underlying monad is not restricted to `Identity`.
runFailAggT :: FailT e m a -> m (Either [e] a)
runFailAggT (FailT f) = f
{-# INLINE runFailAggT #-}

-- | Change the underlying monad with the hoisting function.
hoistFailT :: (forall a. m a -> n a) -> FailT e m b -> FailT e n b
hoistFailT f = FailT . f . runFailAggT
{-# INLINE hoistFailT #-}

-- | Map a function over the underlying representation of the `FailT` monad.
mapFailT :: (m (Either [e] a) -> n (Either [e] b)) -> FailT e m a -> FailT e n b
mapFailT f = FailT . f . runFailAggT
{-# INLINE mapFailT #-}

-- | Map a function over the error type in the `FailT` monad.
mapErrorFailT :: Functor m => (e -> e') -> FailT e m a -> FailT e' m a
mapErrorFailT f = mapErrorsFailT (map f)
{-# INLINE mapErrorFailT #-}

-- | Map a function over the aggregation of errors in the `FailT` monad. Could be used for
-- example for clearing our all of the aggregated error messages:
--
-- >>> runFail (mapErrorsFailT (const []) $ failT "Something went wrong") :: Either String ()
-- Left "No failure reason given"
mapErrorsFailT :: Functor m => ([e] -> [e']) -> FailT e m a -> FailT e' m a
mapErrorsFailT f (FailT m) = FailT (fmap (first f) m)
{-# INLINE mapErrorsFailT #-}

-- | Convert a `FailT` computation into an `ExceptT`.
--
-- >>> exceptFailT (fail "A bad thing" >> pure () :: Fail String ())
-- ExceptT (Identity (Left FailException
-- "A bad thing"
-- CallStack (from HasCallStack):
-- ...
exceptFailT :: (HasCallStack, Typeable e, Show e, Monad m) => FailT e m a -> ExceptT FailException m a
exceptFailT m =
  ExceptT $
    runFailAggT m >>= \case
      Right x -> pure $ Right x
      Left errMsgs ->
        pure $
          Left $
            FailException
              { failMessages = errMsgs
              , failCallStack = ?callStack
              }
{-# INLINE exceptFailT #-}

-- | Same as `exceptFailT`, but works with any `MonadError`.
--
-- >>> throwErrorFailT (fail "A bad thing" >> pure () :: FailT String (Except FailException) ())
-- ExceptT (Identity (Left FailException
-- "A bad thing"
-- CallStack (from HasCallStack):
-- ...
throwErrorFailT
  :: (HasCallStack, Typeable e, Show e, MonadError FailException m)
  => FailT e m a
  -> m a
throwErrorFailT m =
  runFailAggT m >>= \case
    Right x -> pure x
    Left errMsgs ->
      throwError $
        FailException
          { failMessages = errMsgs
          , failCallStack = ?callStack
          }
{-# INLINE throwErrorFailT #-}

-- | An exception that is produced by the `FailT` monad transformer.
data FailException where
  FailException
    :: (Typeable e, Show e)
    => { failMessages :: [e]
       , failCallStack :: CallStack
       }
    -> FailException

instance Show FailException where
  show FailException{failMessages, failCallStack} =
    mconcat $
      intersperse "\n" $
        "FailException"
          : NE.toList (toFailureNonEmpty (show <$> failMessages))
          ++ [prettyCallStack failCallStack]

instance Exception FailException

toFailureNonEmpty :: IsString e => [e] -> NE.NonEmpty e
toFailureNonEmpty xs =
  case NE.nonEmpty xs of
    Nothing -> "No failure reason given" NE.:| []
    Just ne -> ne

toFailureDelimited :: (IsString e, Semi.Semigroup e) => [e] -> e
toFailureDelimited = Semi.sconcat . NE.intersperse ", " . toFailureNonEmpty

-- | Use the `MonadThrow` instance to raise a `FailException` in the underlying monad.
--
-- >>> throwFailT (failT "One thing went wrong")
-- *** Exception: FailException
-- "One thing went wrong"
-- ...
-- >>> throwFailT (failT "One thing went wrong") :: Maybe ()
-- Nothing
throwFailT :: (HasCallStack, Typeable e, Show e, MonadThrow m) => FailT e m a -> m a
throwFailT f = do
  runFailAggT f >>= \case
    Right x -> pure x
    Left errMsgs ->
      throwM $
        FailException
          { failMessages = errMsgs
          , failCallStack = ?callStack
          }
{-# INLINEABLE throwFailT #-}

instance Functor m => Functor (FailT e m) where
  fmap f (FailT m) = FailT (fmap (fmap f) m)
  {-# INLINE fmap #-}

instance (IS_MONAD_STRING Monad m) => Applicative (FailT e m) where
  pure = FailT . pure . Right
  {-# INLINE pure #-}

  FailT m <*> FailT k =
    FailT $
      m >>= \case
        Left merr -> pure $ Left merr
        Right f ->
          k >>= \case
            Left kerr -> pure $ Left kerr
            Right a -> pure $ Right (f a)
  {-# INLINE (<*>) #-}
  m *> k = m >>= \_ -> k
  {-# INLINE (*>) #-}

-- | Short-circuites on the first failing operation.
instance (IS_MONAD_STRING Monad m) => Monad (FailT e m) where
  FailT m >>= k =
    FailT $
      m >>= \case
        Left merr -> return $ Left merr
        Right a -> runFailAggT $ k a
  {-# INLINE (>>=) #-}

#if !(MIN_VERSION_base(4,13,0))
  fail = FailT . return . Left . pure . fromString
  {-# INLINE fail #-}
#endif

instance (IsString e, Monad m) => F.MonadFail (FailT e m) where
  fail = FailT . return . Left . pure . fromString
  {-# INLINE fail #-}

instance Foldable f => Foldable (FailT e f) where
  foldMap f (FailT m) = foldMap (either (const mempty) f) m
  {-# INLINE foldMap #-}

instance Traversable f => Traversable (FailT e f) where
  traverse f (FailT m) = FailT <$> traverse (either (pure . Left) (fmap Right . f)) m
  {-# INLINE traverse #-}

-- | Short-circuits on the first successful operation, combines failures otherwise.
instance (IS_MONAD_STRING Monad m) => Alternative (FailT e m) where
  empty = FailT $ pure (Left [])
  {-# INLINE empty #-}
  FailT m <|> FailT k = FailT $ do
    m >>= \case
      Left merr ->
        k >>= \case
          Left kerr -> pure $ Left $ merr ++ kerr
          Right result -> pure $ Right result
      Right result -> pure $ Right result
  {-# INLINEABLE (<|>) #-}

-- | Executes all monadic actions and combines all successful results using a `Semi.Semigroup`
-- instance. Combines together all failures as well, until a successful operation.
instance (IS_MONAD_STRING Monad m, Semi.Semigroup a) => Semi.Semigroup (FailT e m a) where
  (<>) (FailT m) (FailT k) = FailT $ do
    mres <- m
    kres <- k
    case mres of
      Left merr ->
        case kres of
          Left kerr -> pure $ Left $ merr ++ kerr
          Right y -> pure $ Right y
      Right x ->
        case kres of
          Left _kerr -> pure $ Right x
          Right y -> pure $ Right (x Semi.<> y)
  {-# INLINEABLE (<>) #-}

instance (IS_MONAD_STRING Monad m, Semi.Semigroup a) => Monoid (FailT e m a) where
  mempty = empty
  {-# INLINE mempty #-}
#if !(MIN_VERSION_base(4,11,0))
  mappend = (Semi.<>)
#endif

instance (IS_MONAD_STRING MonadIO m) => MonadIO (FailT e m) where
  liftIO = lift . liftIO
  {-# INLINE liftIO #-}

instance MonadTrans (FailT e) where
  lift = FailT . fmap Right
  {-# INLINE lift #-}

instance (IS_MONAD_STRING MonadZip m) => MonadZip (FailT e m) where
  mzipWith f (FailT a) (FailT b) = FailT $ mzipWith (liftA2 f) a b
  {-# INLINE mzipWith #-}

instance (IS_MONAD_STRING MonadFix m) => MonadFix (FailT e m) where
  mfix f = FailT (mfix (runFailAggT . f . either explode id))
    where
      explode _errMsgs = error "mfix (FailT): inner computation returned Left value"
  {-# INLINE mfix #-}

#if MIN_VERSION_base(4,12,0)
instance Contravariant f => Contravariant (FailT e f) where
  contramap f = FailT . contramap (fmap f) . runFailAggT
  {-# INLINE contramap #-}
#endif

instance (Eq e, Eq1 m) => Eq1 (FailT e m) where
  liftEq eq (FailT x) (FailT y) = liftEq (liftEq eq) x y
  {-# INLINE liftEq #-}

instance (Ord e, Ord1 m) => Ord1 (FailT e m) where
  liftCompare comp (FailT x) (FailT y) =
    liftCompare (liftCompare comp) x y
  {-# INLINE liftCompare #-}

instance (Read e, Read1 m) => Read1 (FailT e m) where
  liftReadsPrec rp rl =
    readsData $
      readsUnaryWith (liftReadsPrec rp' rl') "FailT" FailT
    where
      rp' = liftReadsPrec rp rl
      rl' = liftReadList rp rl

instance (Show e, Show1 m) => Show1 (FailT e m) where
  liftShowsPrec sp sl d (FailT m) =
    showsUnaryWith (liftShowsPrec sp' sl') "FailT" d m
    where
      sp' = liftShowsPrec sp sl
      sl' = liftShowList sp sl

instance (Eq e, Eq1 m, Eq a) => Eq (FailT e m a) where
  (==) = eq1
  {-# INLINE (==) #-}

instance (Ord e, Ord1 m, Ord a) => Ord (FailT e m a) where
  compare = compare1
  {-# INLINE compare #-}

instance (Read e, Read1 m, Read a) => Read (FailT e m a) where
  readsPrec = readsPrec1

instance (Show e, Show1 m, Show a) => Show (FailT e m a) where
  showsPrec = showsPrec1

instance (IS_MONAD_STRING MonadThrow m) => MonadThrow (FailT e m) where
  throwM = lift . throwM
  {-# INLINE throwM #-}

instance (IS_MONAD_STRING MonadReader r m) => MonadReader r (FailT e m) where
  ask = lift ask
  {-# INLINE ask #-}
  local = mapFailT . local
  {-# INLINE local #-}
  reader = lift . reader
  {-# INLINE reader #-}

instance (IS_MONAD_STRING MonadState s m) => MonadState s (FailT e m) where
  get = lift get
  {-# INLINE get #-}
  put = lift . put
  {-# INLINE put #-}
  state = lift . state
  {-# INLINE state #-}

instance (IS_MONAD_STRING MonadError e m) => MonadError e (FailT e m) where
  throwError = lift . throwError
  {-# INLINE throwError #-}
  catchError = liftCatch catchError
  {-# INLINE catchError #-}

instance (IS_MONAD_STRING MonadWriter w m) => MonadWriter w (FailT e m) where
  writer = lift . writer
  {-# INLINE writer #-}
  tell = lift . tell
  {-# INLINE tell #-}
  listen = liftListen listen
  {-# INLINE listen #-}
  pass = liftPass pass
  {-# INLINE pass #-}

-- | @since 0.1.1
instance (IS_MONAD_STRING MonadRWS r w s m) => MonadRWS r w s (FailT e m)

instance (IS_MONAD_STRING MonadCont m) => MonadCont (FailT e m) where
  callCC = liftCallCC callCC
  {-# INLINE callCC #-}

-- | Lift a @callCC@ operation to the new monad.
liftCallCC
  :: (((Either [e] a -> m (Either [e] b)) -> m (Either [e] a)) -> m (Either [e] a))
  -> ((a -> FailT e m b) -> FailT e m a)
  -> FailT e m a
liftCallCC ccc f = FailT $ ccc $ \c ->
  runFailAggT (f (FailT . c . Right))
{-# INLINE liftCallCC #-}

-- | Lift a @`catchE`@ operation to the new monad.
liftCatch
  :: (m (Either [e] a) -> (e -> m (Either [e] a)) -> m (Either [e] a))
  -> FailT e m a
  -> (e -> FailT e m a)
  -> FailT e m a
liftCatch f m h = FailT $ f (runFailAggT m) (runFailAggT . h)
{-# INLINE liftCatch #-}

-- | Lift a @`listen`@ operation to the new monad.
liftListen
  :: Monad m
  => (m (Either [e] a) -> m (Either [e] a, w))
  -> (FailT e m) a
  -> (FailT e m) (a, w)
liftListen l = mapFailT $ \m -> do
  (a, w) <- l m
  return $! fmap (\r -> (r, w)) a
{-# INLINE liftListen #-}

-- | Lift a @`pass`@ operation to the new monad.
liftPass
  :: Monad m
  => (m (Either [e] a, w -> w) -> m (Either [e] a))
  -> (FailT e m) (a, w -> w)
  -> (FailT e m) a
liftPass p = mapFailT $ \m -> p $ do
  a <- m
  return $! case a of
    Left errs -> (Left errs, id)
    Right (v, f) -> (Right v, f)
{-# INLINE liftPass #-}

#if MIN_VERSION_mtl(2,3,0)
-- | @since 0.1.1
deriving via
  (LiftingAccum (FailT e) m)
  instance
    (MonadAccum w m) =>
    MonadAccum w (FailT e m)

-- | @since 0.1.1
deriving via
  (LiftingSelect (FailT e) m)
  instance
    (MonadSelect r m) =>
    MonadSelect r (FailT e m)
#endif