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

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

import qualified Colourista as C
import qualified Control.Exception as CE
import qualified Data.Text as T
import Distribution.ArchHs.Internal.Prelude
import Distribution.ArchHs.Name
import Distribution.ArchHs.Types
import Network.HTTP.Req (HttpException (..))

-- | 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 HttpException

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 (PackageName -> String) -> PackageName -> String
forall a b. (a -> b) -> a -> b
$ n -> PackageName
forall n. HasMyName n => n -> PackageName
toHackageName n
name) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"] (hackage name) / [" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (CommunityName -> String
unCommunityName (CommunityName -> String) -> CommunityName -> String
forall a b. (a -> b) -> a -> b
$ n -> CommunityName
forall n. HasMyName n => n -> CommunityName
toCommunityName n
name) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"] (community name)"
  show (VersionNotFound PackageName
name Version
version) = String
"Unable to find [" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (PackageName -> String
unPackageName (PackageName -> String) -> PackageName -> String
forall a b. (a -> b) -> a -> b
$ PackageName -> PackageName
forall n. HasMyName n => n -> PackageName
toHackageName PackageName
name) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"] (hackage name) / [" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (CommunityName -> String
unCommunityName (CommunityName -> String) -> CommunityName -> String
forall a b. (a -> b) -> a -> b
$ PackageName -> CommunityName
forall n. HasMyName n => n -> CommunityName
toCommunityName PackageName
name) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"] (community 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 ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (PackageName -> String) -> [PackageName] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageName -> String
unPackageName [PackageName]
c)
  show (NetworkException (JsonHttpException String
s)) = String
"Failed to parse response " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s
  show (NetworkException (VanillaHttpException HttpException
e)) = HttpException -> String
forall a. Show a => a -> String
show HttpException
e

-- | 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 -> Text -> IO ()
C.errorMessage (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"IOException: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> (IOException -> String) -> IOException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> String
forall a. Show a => a -> String
show (IOException -> Text) -> IOException -> Text
forall a b. (a -> b) -> a -> b
$ 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 -> Text -> IO ()
C.errorMessage (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Runtime Exception: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> (MyException -> String) -> MyException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MyException -> String
forall a. Show a => a -> String
show (MyException -> Text) -> MyException -> Text
forall a b. (a -> b) -> a -> b
$ MyException
x)
    Either MyException ()
_ -> Text -> IO ()
C.successMessage Text
"Success!"

-- | 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 -> MyException -> Sem r a
forall e (r :: [(* -> *) -> * -> *]) a.
MemberWithError (Error e) r =>
e -> Sem r a
throw (MyException -> Sem r a) -> MyException -> Sem r a
forall a b. (a -> b) -> a -> b
$ HttpException -> MyException
NetworkException HttpException
err
    Right a
x' -> a -> Sem r a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x'