{-# LANGUAGE ExplicitNamespaces, Rank2Types, TypeOperators #-}
{-# OPTIONS_GHC -Wno-deprecations #-}
module HMGit.Internal.Exceptions (
    invalidArgument
  , noSuchThing
  , BugException (..)
  , MonadThrowable (..)
) where

import           Control.Arrow                ((|||))
import           Control.Exception            (IOException)
import           Control.Exception.Safe       (Exception, MonadThrow, throw,
                                               throwString)
import           Control.Monad                ((>=>))
import           Control.Monad.Error          (ErrorT, runErrorT)
import           Control.Monad.Trans.Except   (ExceptT, runExceptT)
import           Control.Monad.Trans.Identity (IdentityT (..))
import           Control.Monad.Trans.List     (ListT (..))
import           Control.Monad.Trans.Maybe    (MaybeT (..))
import           Control.Natural              (type (~>))
import           Data.Functor.Identity        (Identity (..))
import           GHC.IO.Exception             (IOErrorType (..))
import           System.IO.Error              (doesNotExistErrorType, mkIOError)

invalidArgument :: String -> IOError
invalidArgument :: String -> IOError
invalidArgument String
desc = IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
InvalidArgument String
desc Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing

noSuchThing :: String -> FilePath -> IOException
noSuchThing :: String -> String -> IOError
noSuchThing String
desc String
fp = IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
doesNotExistErrorType String
desc Maybe Handle
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
fp)

newtype BugException = BugException String
    deriving Int -> BugException -> ShowS
[BugException] -> ShowS
BugException -> String
(Int -> BugException -> ShowS)
-> (BugException -> String)
-> ([BugException] -> ShowS)
-> Show BugException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BugException] -> ShowS
$cshowList :: [BugException] -> ShowS
show :: BugException -> String
$cshow :: BugException -> String
showsPrec :: Int -> BugException -> ShowS
$cshowsPrec :: Int -> BugException -> ShowS
Show

instance Exception BugException where

class MonadThrowable m where
    fromMonad :: (MonadThrow n, Exception e) => Maybe e -> m ~> n

instance Exception e => MonadThrowable (Either e) where
    fromMonad :: Maybe e -> Either e ~> n
fromMonad Maybe e
Nothing  = e -> n x
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (e -> n x) -> (x -> n x) -> Either e x -> n x
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| x -> n x
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    fromMonad (Just e
e) = n x -> e -> n x
forall a b. a -> b -> a
const (e -> n x
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw e
e) (e -> n x) -> (x -> n x) -> Either e x -> n x
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| x -> n x
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance MonadThrowable Maybe where
    fromMonad :: Maybe e -> Maybe ~> n
fromMonad Maybe e
Nothing  = String -> n x
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
String -> m a
throwString String
"Nothing" n x -> (x -> n x) -> Maybe x -> n x
forall b a. b -> (a -> b) -> Maybe a -> b
`maybe` x -> n x
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    fromMonad (Just e
e) = e -> n x
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw e
e n x -> (x -> n x) -> Maybe x -> n x
forall b a. b -> (a -> b) -> Maybe a -> b
`maybe` x -> n x
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance MonadThrowable Identity where
    fromMonad :: Maybe e -> Identity ~> n
fromMonad Maybe e
_ = x -> n x
forall (f :: * -> *) a. Applicative f => a -> f a
pure (x -> n x) -> (Identity x -> x) -> Identity x -> n x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity x -> x
forall a. Identity a -> a
runIdentity

instance MonadThrowable [] where
    fromMonad :: Maybe e -> [] ~> n
fromMonad Maybe e
Nothing []  = String -> n x
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
String -> m a
throwString String
"empty"
    fromMonad (Just e
e) [] = e -> n x
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw e
e
    fromMonad Maybe e
_ (x
x:[x]
_)     = x -> n x
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
x

instance (Exception e, MonadThrowable m) => MonadThrowable (ExceptT e m) where
    fromMonad :: Maybe e -> ExceptT e m ~> n
fromMonad Maybe e
e = Maybe e -> m ~> n
forall (m :: * -> *) (n :: * -> *) e.
(MonadThrowable m, MonadThrow n, Exception e) =>
Maybe e -> m ~> n
fromMonad Maybe e
e (m (Either e x) -> n (Either e x))
-> (ExceptT e m x -> m (Either e x))
-> ExceptT e m x
-> n (Either e x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT e m x -> m (Either e x)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT e m x -> n (Either e x))
-> (Either e x -> n x) -> ExceptT e m x -> n x
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Maybe e -> Either e ~> n
forall (m :: * -> *) (n :: * -> *) e.
(MonadThrowable m, MonadThrow n, Exception e) =>
Maybe e -> m ~> n
fromMonad Maybe e
e

instance MonadThrowable m => MonadThrowable (MaybeT m) where
    fromMonad :: Maybe e -> MaybeT m ~> n
fromMonad Maybe e
e = Maybe e -> m ~> n
forall (m :: * -> *) (n :: * -> *) e.
(MonadThrowable m, MonadThrow n, Exception e) =>
Maybe e -> m ~> n
fromMonad Maybe e
e (m (Maybe x) -> n (Maybe x))
-> (MaybeT m x -> m (Maybe x)) -> MaybeT m x -> n (Maybe x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT m x -> m (Maybe x)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m x -> n (Maybe x))
-> (Maybe x -> n x) -> MaybeT m x -> n x
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Maybe e -> Maybe ~> n
forall (m :: * -> *) (n :: * -> *) e.
(MonadThrowable m, MonadThrow n, Exception e) =>
Maybe e -> m ~> n
fromMonad Maybe e
e

instance MonadThrowable m => MonadThrowable (IdentityT m) where
    fromMonad :: Maybe e -> IdentityT m ~> n
fromMonad Maybe e
e = Maybe e -> m ~> n
forall (m :: * -> *) (n :: * -> *) e.
(MonadThrowable m, MonadThrow n, Exception e) =>
Maybe e -> m ~> n
fromMonad Maybe e
e (m x -> n x) -> (IdentityT m x -> m x) -> IdentityT m x -> n x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdentityT m x -> m x
forall k (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT

instance MonadThrowable m => MonadThrowable (ListT m) where
    fromMonad :: Maybe e -> ListT m ~> n
fromMonad Maybe e
e = Maybe e -> m ~> n
forall (m :: * -> *) (n :: * -> *) e.
(MonadThrowable m, MonadThrow n, Exception e) =>
Maybe e -> m ~> n
fromMonad Maybe e
e (m [x] -> n [x]) -> (ListT m x -> m [x]) -> ListT m x -> n [x]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListT m x -> m [x]
forall (m :: * -> *) a. ListT m a -> m [a]
runListT (ListT m x -> n [x]) -> ([x] -> n x) -> ListT m x -> n x
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Maybe e -> [] ~> n
forall (m :: * -> *) (n :: * -> *) e.
(MonadThrowable m, MonadThrow n, Exception e) =>
Maybe e -> m ~> n
fromMonad Maybe e
e

instance (Exception e, MonadThrowable m) => MonadThrowable (ErrorT e m) where
    fromMonad :: Maybe e -> ErrorT e m ~> n
fromMonad Maybe e
e = Maybe e -> m ~> n
forall (m :: * -> *) (n :: * -> *) e.
(MonadThrowable m, MonadThrow n, Exception e) =>
Maybe e -> m ~> n
fromMonad Maybe e
e (m (Either e x) -> n (Either e x))
-> (ErrorT e m x -> m (Either e x))
-> ErrorT e m x
-> n (Either e x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorT e m x -> m (Either e x)
forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
runErrorT (ErrorT e m x -> n (Either e x))
-> (Either e x -> n x) -> ErrorT e m x -> n x
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Maybe e -> Either e ~> n
forall (m :: * -> *) (n :: * -> *) e.
(MonadThrowable m, MonadThrow n, Exception e) =>
Maybe e -> m ~> n
fromMonad Maybe e
e