{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

-- | Copyright: (c) 2020-2021 berberman
-- SPDX-License-Identifier: MIT
-- Maintainer: berberman <berberman@yandex.com>
-- Stability: experimental
-- Portability: portable
-- Exceptions used in this project.
module Distribution.ArchHs.Exception
  ( WithMyErr,
    MyException (..),
    printHandledIOException,
    printAppResult,
    tryMaybe,
    interceptHttpException,
  )
where

import qualified Control.Exception as CE
import Distribution.ArchHs.Internal.Prelude
import Distribution.ArchHs.Name
import Distribution.ArchHs.PP (colon, printError, printSuccess, viaShow, (<+>))
import Distribution.ArchHs.Types
import Network.HTTP.Client (HttpException)
import Servant.Client (ClientError (ConnectionError))

-- | Error effect of 'MyException'
type WithMyErr = Error MyException

-- | Custom exception used in this project
data MyException
  = forall n. (HasMyName n) => PkgNotFound n
  | VersionNotFound PackageName Version
  | TargetExist PackageName DependencyProvider
  | CyclicExist [PackageName]
  | NetworkException ClientError
  | TargetDisappearException PackageName

instance Show MyException where
  show :: MyException -> String
show (PkgNotFound n
name) = String
"Unable to find \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PackageName -> String
unPackageName (n -> PackageName
forall n. HasMyName n => n -> PackageName
toHackageName n
name) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\""
  show (VersionNotFound PackageName
name Version
version) = String
"Unable to find \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PackageName -> String
unPackageName (PackageName -> PackageName
forall n. HasMyName n => n -> PackageName
toHackageName PackageName
name) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Version -> String
forall a. Pretty a => a -> String
prettyShow Version
version
  show (TargetExist PackageName
name DependencyProvider
provider) = String
"Target \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PackageName -> String
unPackageName PackageName
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" has been provided by " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> DependencyProvider -> String
forall a. Show a => a -> String
show DependencyProvider
provider
  show (CyclicExist [PackageName]
c) = String
"Graph contains a cycle \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
forall a. Show a => a -> String
show ((PackageName -> String) -> [PackageName] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageName -> String
unPackageName [PackageName]
c) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\""
  show (NetworkException ClientError
e) = ClientError -> String
forall a. Show a => a -> String
show ClientError
e
  show (TargetDisappearException PackageName
name) = String
"Target \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PackageName -> String
unPackageName PackageName
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" is discarded during the dependency resolving"

-- | Catch 'CE.IOException' and print it.
printHandledIOException :: IO () -> IO ()
printHandledIOException :: IO () -> IO ()
printHandledIOException = (IOException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
CE.handle @CE.IOException (\IOException
e -> Doc AnsiStyle -> IO ()
forall (m :: * -> *). MonadIO m => Doc AnsiStyle -> m ()
printError (Doc AnsiStyle -> IO ()) -> Doc AnsiStyle -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"IOException" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
colon Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> IOException -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
viaShow IOException
e)

-- | Print the result of 'errorToIOFinal'.
printAppResult :: IO (Either MyException ()) -> IO ()
printAppResult :: IO (Either MyException ()) -> IO ()
printAppResult IO (Either MyException ())
io =
  IO (Either MyException ())
io IO (Either MyException ())
-> (Either MyException () -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left MyException
x -> Doc AnsiStyle -> IO ()
forall (m :: * -> *). MonadIO m => Doc AnsiStyle -> m ()
printError (Doc AnsiStyle -> IO ()) -> Doc AnsiStyle -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"Runtime Exception" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
colon Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> MyException -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
viaShow MyException
x
    Either MyException ()
_ -> Doc AnsiStyle -> IO ()
forall (m :: * -> *). MonadIO m => Doc AnsiStyle -> m ()
printSuccess Doc AnsiStyle
"Success!"

-- | Like 'try' but discard the concrete exception.
tryMaybe :: Member WithMyErr r => Sem r a -> Sem r (Maybe a)
tryMaybe :: Sem r a -> Sem r (Maybe a)
tryMaybe Sem r a
m =
  Sem r a -> Sem r (Either MyException a)
forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
Sem r a -> Sem r (Either e a)
try @MyException Sem r a
m Sem r (Either MyException a)
-> (Either MyException a -> Sem r (Maybe a)) -> Sem r (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left MyException
_ -> Maybe a -> Sem r (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    Right a
x -> Maybe a -> Sem r (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> Sem r (Maybe a)) -> Maybe a -> Sem r (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x

-- | Catch the 'HttpException' thrown in 'IO' monad, then re-throw it with 'NetworkException'.
interceptHttpException :: Members [WithMyErr, Embed IO] r => IO a -> Sem r a
interceptHttpException :: IO a -> Sem r a
interceptHttpException IO a
io = do
  Either HttpException a
x <- IO (Either HttpException a) -> Sem r (Either HttpException a)
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO (Either HttpException a) -> Sem r (Either HttpException a))
-> IO (Either HttpException a) -> Sem r (Either HttpException a)
forall a b. (a -> b) -> a -> b
$ IO a -> IO (Either HttpException a)
forall e a. Exception e => IO a -> IO (Either e a)
CE.try IO a
io
  case Either HttpException a
x of
    Left (HttpException
err :: HttpException) -> MyException -> Sem r a
forall e (r :: [(* -> *) -> * -> *]) a.
MemberWithError (Error e) r =>
e -> Sem r a
throw (MyException -> Sem r a)
-> (HttpException -> MyException) -> HttpException -> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientError -> MyException
NetworkException (ClientError -> MyException)
-> (HttpException -> ClientError) -> HttpException -> MyException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> ClientError
ConnectionError (SomeException -> ClientError)
-> (HttpException -> SomeException) -> HttpException -> ClientError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpException -> SomeException
forall e. Exception e => e -> SomeException
CE.SomeException (HttpException -> Sem r a) -> HttpException -> Sem r a
forall a b. (a -> b) -> a -> b
$ HttpException
err
    Right a
x' -> a -> Sem r a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x'