{-# LANGUAGE FlexibleInstances, FunctionalDependencies, GADTs, MultiParamTypeClasses #-}
{- |
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 Control.Exception            (Exception(..), SomeException(..), throw, catch)
import Control.Monad                (join)
import Control.Monad.Except         (ExceptT(..), runExceptT, throwError)
import Control.Monad.IO.Class       (MonadIO, liftIO)
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

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