{-# 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
  | VersionNoParse String

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

-- | Catch 'CE.IOException' and print it.
printHandledIOException :: IO () -> IO ()
printHandledIOException :: IO () -> IO ()
printHandledIOException = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
CE.handle @CE.IOException (\IOException
e -> forall (m :: * -> *). MonadIO m => Doc AnsiStyle -> m ()
printError forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"IOException" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
colon forall ann. Doc ann -> Doc ann -> Doc ann
<+> 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left MyException
x -> forall (m :: * -> *). MonadIO m => Doc AnsiStyle -> m ()
printError forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"Runtime Exception" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
colon forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow MyException
x
    Either MyException ()
_ -> 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 :: forall (r :: EffectRow) a.
Member WithMyErr r =>
Sem r a -> Sem r (Maybe a)
tryMaybe Sem r a
m =
  forall e (r :: EffectRow) a.
Member (Error e) r =>
Sem r a -> Sem r (Either e a)
try @MyException Sem r a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left MyException
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Right a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 :: forall (r :: EffectRow) a.
Members '[WithMyErr, Embed IO] r =>
IO a -> Sem r a
interceptHttpException IO a
io = do
  Either HttpException a
x <- forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed forall a b. (a -> b) -> a -> b
$ 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) -> forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientError -> MyException
NetworkException forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> ClientError
ConnectionError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => e -> SomeException
CE.SomeException forall a b. (a -> b) -> a -> b
$ HttpException
err
    Right a
x' -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x'