{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}

{- |
Module: Control.Monad.Failable
Description: Yet another error monad but for people who are not crazy
Copyright: (c) Erick Gonzalez, 2019
License: BSD3
Maintainer: erick@codemonkeylabs.de

This library provides a 'Failable' error monad class to unify errors across monads and
transformers most commonly used to implement pipelines that can fail.

-}

module Control.Monad.Failable (
-- |
-- I am sure a lot of ink has been spilled in forums and around water coolers all around the
-- world, debating the merits and fallacies of one approach or the other. The reason for this
-- package is not to participate in this discussion but rather to provide a simple no nonsense
-- means of signaling a computation "failure" in those monads that provide the inherent means
-- to do so, and to do it in a consistent manner.
--
-- When triggering a failure in a monadic context which is an instance of this class, simply
-- define your custom exception type and abort the computation with 'failure'. For example:
--
-- @
-- data MyException = SomeProblem
--                  | AnotherProblem
--                  deriving (Show, Typeable)
--
-- instance Exception MyException
--
-- foo :: (Failable m) => Int -> m Int
-- foo x = do
--   y <- bar x
--   if y < 0
--     then failure SomeProblem
--     else return y
-- @
--
--
-- if foo is then called in a 'Maybe' Monad, it would return @Nothing@ in case of error
-- or @Just ()@ of course if succesful. In an @Either SomeException@ context, it would
-- return @Left SomeProblem@ in case of error or @Right ()@ upon success, etc.
-- When it comes to monad transformers incorporating the concept of failure, such as 'MaybeT' or
-- 'ExceptT', it preserves the expected semantics upon failure of yielding an @m Nothing@ or
-- @m (Either SomeException a)@ when the transformer is "ran", instead of adopting the strategy
-- of passing the failure to the underlying monad (transformer) which might for example, throw
-- an async exception (as is the case of IO). Since the reason d'etre for something like runMaybeT
-- is to provide the underlying monad (transformer) with `Maybe` like behaviour, i.e. have
-- @Nothing@ be returned in case of aborting the 'Maybe' pipeline so to speak, then throwing an
-- exception defeats IMHO the purpose of using 'MaybeT' in the first place.
--
-- >>> foo 2 :: Maybe Int
-- >>> Nothing
--
-- >>> foo 2 :: Either SomeException Int
-- >>> Left SomeProblem
--
-- >>> foo 2 :: IO Int
-- >>> * * * Exception: SomeProblem
--
-- >>> runMaybeT $ foo 2 :: IO (Maybe Int)
-- >>> Nothing
--
                               Failable(..), Hoistable(..), failableIO) where

import Data.Bifunctor               (second)
import Control.Exception            (Exception(..), SomeException(..), throw, catch)
import Control.Monad.Except         (ExceptT(..), runExceptT, throwError)
import Control.Monad.IO.Class       (MonadIO, liftIO)
import Control.Monad.State.Class    (MonadState, get, put)
import Control.Monad.State.Strict   (StateT, runStateT)
import Control.Monad.Writer.Strict  (WriterT, runWriterT, tell)
import Control.Monad.Reader         (ReaderT, runReaderT, ask)
import Control.Monad.Trans          (MonadTrans, lift)
import Control.Monad.Trans.Maybe    (MaybeT(..), runMaybeT)
import System.IO.Error              (tryIOError)

instance Exception ()

-- | The 'Failable' class. A Monad which is an instance of this class can be used as a context
-- in a function running in one with this class constraint, in order to report error conditions

class (Monad m) => Failable m where
    -- | trigger a failure. It takes an exception value as argument and it returns whatever
    -- might be used to abort a monadic computation in the monad instantiating this class.
    failure :: (Exception e) => e -> m a

    -- | recover from a possible failure. Basically a generalized @catch@ for a @Failable@.
    recover :: (e ~ SomeException) => m a -> (e -> m a) -> m a


-- | A 'Hoistable' is a type that can be "promoted" or "hoisted" to a Failable monad.
class (Failable m) => Hoistable m t e' | t -> e' where
  -- | Given a transformation function to obtain an error in the target 'Failable' context from
  -- an eventual errored value from the value being hoisted, It promotes such value to a 'Failable'
  -- operation. For example:
  --
  -- @
  -- foo :: (Failable m) => String -> m Int
  -- foo = hoist BadValue . readEither
  -- @
  --
  -- >>> λ> runExceptT $ foo "5"
  -- >>> Right 5
  -- >>> λ> foo "X5"
  -- >>> *** Exception: BadValue "Prelude.read: no parse"
  -- >>> λ> runMaybeT $ foo "X5"
  -- >>> Nothing
  --
  hoist :: (Exception e) => (e' -> e) -> t a -> m a


instance Failable IO where
    failure = throw
    recover = catch

instance Failable [] where
    failure _   = []
    recover [] f = f $ toException ()
    recover xs _ = xs

instance Failable Maybe where
    failure _         = Nothing
    recover Nothing f = f $ toException ()
    recover v       _ = v

instance e ~ SomeException => Failable (Either e) where
    failure = Left . toException
    recover (Left err) f = f err
    recover v          _ = v

instance (Monad m) => Failable (MaybeT m) where
    failure _   = MaybeT $ return Nothing
    recover a f = MaybeT $ runMaybeT a >>= recover'
      where recover' Nothing = runMaybeT . f $ toException ()
            recover' x       = return x

instance (Monad m, e ~ SomeException) => Failable (ExceptT e m) where
    failure = throwError . toException
    recover a f = ExceptT $ runExceptT a >>= recover'
      where recover' (Left err) = runExceptT $ f err
            recover' x          = return x

class (MonadTrans t, Monad m) => RunnableStateT t s m where
  runS :: t m a -> s -> m (a, s)

instance (Monad m) => RunnableStateT (StateT s) s m where
  runS = runStateT

instance (Monad m) => RunnableStateT (ReaderT r) r m where
  runS a s = (, s) <$> runReaderT a s

instance (Monad m, Monoid w) => RunnableStateT (WriterT w) w m where
  runS a s = fmap (second $ mappend s) $ runWriterT a

instance {-# OVERLAPPABLE #-} (Monad (t m), MonadTrans t, Failable m, RunnableStateT t s m, MonadState s (t m)) => Failable (t m) where
    failure     = lift . failure
    recover a f = get >>= foo
      where foo s  = do
              (r, s') <- lift $ runS a s `recover` \e -> runS (f e) s
              put s'
              return r

instance (Monoid w, Failable m) => Failable (WriterT w m) where
      failure = lift . failure
      recover a f = do
        (x, w) <- lift $ runWriterT a `recover` \e -> runWriterT (f e)
        tell w
        return x

instance (Failable m) => Failable (ReaderT r m) where
      failure = lift . failure
      recover a f = do
        r <- ask
        lift $ runReaderT a r `recover` \e -> runReaderT (f e) r

instance (Failable m) => Hoistable m Maybe () where
  hoist f = maybe (failure $ f ()) return

instance (Failable m) => Hoistable m (Either e') e' where
  hoist f = either (failure . f) return

-- | Perform a set of IO actions in a 'Failable' 'MonadIO' instance, triggering a
-- 'failure' upon an IO exception, instead of blindly triggering an asynchronos exception. This
-- serves ultimately to unify error handling in the 'Failable' context. For example:
--
-- @
-- foo :: (Failable m, MonadIO m) => m ()
-- foo = do
--   failableIO $ do
--     txt <- readFile "foo.txt"
--     putStrLn txt
-- @
--
-- >>> λ> runExceptT foo
-- >>> Left foo.txt: openFile: does not exist (No such file or directory)
-- >>>
-- >>> λ> runMaybeT foo
-- >>> Nothing
-- >>>
-- >>> λ> foo
-- >>> *** Exception: foo.txt: openFile: does not exist (No such file or directory)
--
failableIO :: (Failable m, MonadIO m) => IO a -> m a
failableIO actions = do
  result <- liftIO $ tryIOError actions
  either failure return result