Util.hs

{-# LANGUAGE CPP #-}

-- | This module exports miscellaneous error-handling functions.

module Control.Error.Util (
    -- * Conversion
    -- $conversion
    hush,
    hushT,
    note,
    noteT,
    hoistMaybe,
    hoistEither,
    (??),
    (!?),
    failWith,
    failWithM,

    -- * Bool
    bool,

    -- * Maybe
    (?:),

    -- * MaybeT
    maybeT,
    just,
    nothing,
    isJustT,
    isNothingT,

    -- * Either
    isLeft,
    isRight,
    fmapR,
    AllE(..),
    AnyE(..),

    -- * ExceptT
    isLeftT,
    isRightT,
    fmapRT,
    exceptT,
    bimapExceptT,

    -- * Error Reporting
    err,
    errLn,

    -- * Exceptions
    tryIO,
    handleExceptT,
    syncIO
    ) where

import Control.Applicative (Applicative, pure, (<$>))
import Control.Exception (IOException, SomeException, Exception)
import Control.Monad (liftM)
import Control.Monad.Catch (MonadCatch, try)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT)
import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT)
import Data.Monoid (Monoid(mempty, mappend))
#if MIN_VERSION_base(4,9,0)
import Data.Semigroup
#endif
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import System.IO (stderr)

import qualified Control.Exception as Exception
import qualified Data.Text.IO

-- | Fold an 'ExceptT' by providing one continuation for each constructor
exceptT :: Monad m => (a -> m c) -> (b -> m c) -> ExceptT a m b -> m c
exceptT f g (ExceptT m) = m >>= \z -> case z of
    Left  a -> f a
    Right b -> g b
{-# INLINEABLE exceptT #-}

-- | Transform the left and right value
bimapExceptT :: Functor m => (e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b
bimapExceptT f g (ExceptT m) = ExceptT (fmap h m)
  where
    h (Left e)  = Left  (f e)
    h (Right a) = Right (g a)
{-# INLINEABLE bimapExceptT #-}

-- | Upgrade an 'Either' to an 'ExceptT'
hoistEither :: Monad m => Either e a -> ExceptT e m a
hoistEither = ExceptT . return
{-# INLINEABLE hoistEither #-}

{- $conversion
    Use these functions to convert between 'Maybe', 'Either', 'MaybeT', and
    'ExceptT'.
-}
-- | Suppress the 'Left' value of an 'Either'
hush :: Either a b -> Maybe b
hush = either (const Nothing) Just

-- | Suppress the 'Left' value of an 'ExceptT'
hushT :: (Monad m) => ExceptT a m b -> MaybeT m b
hushT = MaybeT . liftM hush . runExceptT

-- | Tag the 'Nothing' value of a 'Maybe'
note :: a -> Maybe b -> Either a b
note a = maybe (Left a) Right

-- | Tag the 'Nothing' value of a 'MaybeT'
noteT :: (Monad m) => a -> MaybeT m b -> ExceptT a m b
noteT a = ExceptT . liftM (note a) . runMaybeT

-- | Lift a 'Maybe' to the 'MaybeT' monad
hoistMaybe :: (Monad m) => Maybe b -> MaybeT m b
hoistMaybe = MaybeT . return

-- | Convert a 'Maybe' value into the 'ExceptT' monad
(??) :: Applicative m => Maybe a -> e -> ExceptT e m a
(??) a e = ExceptT (pure $ note e a)

-- | Convert an applicative 'Maybe' value into the 'ExceptT' monad
(!?) :: Applicative m => m (Maybe a) -> e -> ExceptT e m a
(!?) a e = ExceptT (note e <$> a)

-- | An infix form of 'fromMaybe' with arguments flipped.
(?:) :: Maybe a -> a -> a
maybeA ?: b = fromMaybe b maybeA
{-# INLINABLE (?:) #-}

infixr 0 ?:

{-| Convert a 'Maybe' value into the 'ExceptT' monad

    Named version of ('??') with arguments flipped
-}
failWith :: Applicative m => e -> Maybe a -> ExceptT e m a
failWith e a = a ?? e

{- | Convert an applicative 'Maybe' value into the 'ExceptT' monad

    Named version of ('!?') with arguments flipped
-}
failWithM :: Applicative m => e -> m (Maybe a) -> ExceptT e m a
failWithM e a = a !? e

{- | Case analysis for the 'Bool' type.

   > bool a b c == if c then b else a
-}
bool :: a -> a -> Bool -> a
bool a b = \c -> if c then b else a
{-# INLINABLE bool #-}

{-| Case analysis for 'MaybeT'

    Use the first argument if the 'MaybeT' computation fails, otherwise apply
    the function to the successful result.
-}
maybeT :: Monad m => m b -> (a -> m b) -> MaybeT m a -> m b
maybeT mb kb (MaybeT ma) = ma >>= maybe mb kb

-- | Analogous to 'Just' and equivalent to 'return'
just :: (Monad m) => a -> MaybeT m a
just a = MaybeT (return (Just a))

-- | Analogous to 'Nothing' and equivalent to 'mzero'
nothing :: (Monad m) => MaybeT m a
nothing = MaybeT (return Nothing)

-- | Analogous to 'Data.Maybe.isJust', but for 'MaybeT'
isJustT :: (Monad m) => MaybeT m a -> m Bool
isJustT = maybeT (return False) (\_ -> return True)
{-# INLINABLE isJustT #-}

-- | Analogous to 'Data.Maybe.isNothing', but for 'MaybeT'
isNothingT :: (Monad m) => MaybeT m a -> m Bool
isNothingT = maybeT (return True) (\_ -> return False)
{-# INLINABLE isNothingT #-}

-- | Returns whether argument is a 'Left'
isLeft :: Either a b -> Bool
isLeft = either (const True) (const False)

-- | Returns whether argument is a 'Right'
isRight :: Either a b -> Bool
isRight = either (const False) (const True)

{- | 'fmap' specialized to 'Either', given a name symmetric to
     'Data.EitherR.fmapL'
-}
fmapR :: (a -> b) -> Either l a -> Either l b
fmapR = fmap

{-| Run multiple 'Either' computations and succeed if all of them succeed

    'mappend's all successes or failures
-}
newtype AllE e r = AllE { runAllE :: Either e r }

#if MIN_VERSION_base(4,9,0)
instance (Semigroup e, Semigroup r) => Semigroup (AllE e r) where
    AllE (Right x) <> AllE (Right y) = AllE (Right (x <> y))
    AllE (Right _) <> AllE (Left  y) = AllE (Left y)
    AllE (Left  x) <> AllE (Right _) = AllE (Left x)
    AllE (Left  x) <> AllE (Left  y) = AllE (Left  (x <> y))
#endif

instance (Monoid e, Monoid r) => Monoid (AllE e r) where
    mempty = AllE (Right mempty)
#if !(MIN_VERSION_base(4,11,0))
    mappend (AllE (Right x)) (AllE (Right y)) = AllE (Right (mappend x y))
    mappend (AllE (Right _)) (AllE (Left  y)) = AllE (Left y)
    mappend (AllE (Left  x)) (AllE (Right _)) = AllE (Left x)
    mappend (AllE (Left  x)) (AllE (Left  y)) = AllE (Left  (mappend x y))
#endif

{-| Run multiple 'Either' computations and succeed if any of them succeed

    'mappend's all successes or failures
-}
newtype AnyE e r = AnyE { runAnyE :: Either e r }

#if MIN_VERSION_base(4,9,0)
instance (Semigroup e, Semigroup r) => Semigroup (AnyE e r) where
    AnyE (Right x) <> AnyE (Right y) = AnyE (Right (x <> y))
    AnyE (Right x) <> AnyE (Left  _) = AnyE (Right x)
    AnyE (Left  _) <> AnyE (Right y) = AnyE (Right y)
    AnyE (Left  x) <> AnyE (Left  y) = AnyE (Left  (x <> y))
#endif

instance (Monoid e, Monoid r) => Monoid (AnyE e r) where
    mempty = AnyE (Right mempty)
#if !(MIN_VERSION_base(4,11,0))
    mappend (AnyE (Right x)) (AnyE (Right y)) = AnyE (Right (mappend x y))
    mappend (AnyE (Right x)) (AnyE (Left  _)) = AnyE (Right x)
    mappend (AnyE (Left  _)) (AnyE (Right y)) = AnyE (Right y)
    mappend (AnyE (Left  x)) (AnyE (Left  y)) = AnyE (Left  (mappend x y))
#endif

-- | Analogous to 'isLeft', but for 'ExceptT'
isLeftT :: (Monad m) => ExceptT a m b -> m Bool
isLeftT = exceptT (\_ -> return True) (\_ -> return False)
{-# INLINABLE isLeftT #-}

-- | Analogous to 'isRight', but for 'ExceptT'
isRightT :: (Monad m) => ExceptT a m b -> m Bool
isRightT = exceptT (\_ -> return False) (\_ -> return True)
{-# INLINABLE isRightT #-}

{- | 'fmap' specialized to 'ExceptT', given a name symmetric to
     'Data.EitherR.fmapLT'
-}
fmapRT :: (Monad m) => (a -> b) -> ExceptT l m a -> ExceptT l m b
fmapRT = liftM

-- | Write a string to standard error
err :: Text -> IO ()
err = Data.Text.IO.hPutStr stderr

-- | Write a string with a newline to standard error
errLn :: Text -> IO ()
errLn = Data.Text.IO.hPutStrLn stderr

-- | Catch 'IOException's and convert them to the 'ExceptT' monad
tryIO :: MonadIO m => IO a -> ExceptT IOException m a
tryIO = ExceptT . liftIO . Exception.try

-- | Run a monad action which may throw an exception in the `ExceptT` monad
handleExceptT :: (Exception e, Functor m, MonadCatch m) => (e -> x) -> m a -> ExceptT x m a
handleExceptT handler = bimapExceptT handler id . ExceptT . try


{-| Catch all exceptions, except for asynchronous exceptions found in @base@
    and convert them to the 'ExceptT' monad
-}
syncIO :: MonadIO m => IO a -> ExceptT SomeException m a
syncIO = ExceptT . liftIO . trySync

trySync :: IO a -> IO (Either SomeException a)
trySync io = (fmap Right io) `Exception.catch` \e ->
  case Exception.fromException e of
    Just (Exception.SomeAsyncException _) -> Exception.throwIO e
    Nothing -> return (Left e)