hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Integrate with errors.haskell.org

Browse Source 
Fixes #434
This commit is contained in:
Julian Ospald 2022-12-20 00:10:19 +08:00
parent 109187eb6f
commit 009f9211a9
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
27 changed files with 570 additions and 211 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
app/ghcup/BrickMain.hs
View File

@ -487,7 +487,7 @@ install' _ (_, ListResult {..}) = do
pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
VLeft (V NoUpdate) -> pure $ Right ()
VLeft e -> pure $ Left $ prettyShow e <> "\n"
VLeft e -> pure $ Left $ prettyHFError e <> "\n"
<> "Also check the logs in ~/.ghcup/logs"
@ -524,7 +524,7 @@ set' bs input@(_, ListResult {..}) = do
logInfo "Setting now..."
set' bs input
PromptNo -> pure $ Left (prettyShow e)
PromptNo -> pure $ Left (prettyHFError e)
where
userPrompt = L.toStrict . B.toLazyText . B.fromString $
"This Version of "
@ -532,7 +532,7 @@ set' bs input@(_, ListResult {..}) = do
<> " you are trying to set is not installed.\n"
<> "Would you like to install it first? [Y/N]: "
_ -> pure $ Left (prettyShow e)
_ -> pure $ Left (prettyHFError e)
@ -560,7 +560,7 @@ del' _ (_, ListResult {..}) = do
forM_ (_viPostRemove =<< vi) $ \msg ->
logInfo msg
pure $ Right ()
VLeft e -> pure $ Left (prettyShow e)
VLeft e -> pure $ Left (prettyHFError e)
changelog' :: (MonadReader AppState m, MonadIO m)
@ -580,7 +580,7 @@ changelog' _ (_, ListResult {..}) = do
Windows -> "start"
exec cmd [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing >>= \case
Right _ -> pure $ Right ()
Left e -> pure $ Left $ prettyShow e
Left e -> pure $ Left $ prettyHFError e
settings' :: IORef AppState
@ -638,7 +638,7 @@ getGHCupInfo = do
case r of
VRight a -> pure $ Right a
VLeft e -> pure $ Left (prettyShow e)
VLeft e -> pure $ Left (prettyHFError e)
getAppData :: Maybe GHCupInfo

8
app/ghcup/GHCup/OptParse.hs
View File

@ -108,6 +108,7 @@ data Command
| Prefetch PrefetchCommand
| GC GCOptions
| Run RunOptions
| PrintAppErrors
@ -341,3 +342,10 @@ com =
<> commandGroup "Nuclear Commands:"
<> hidden
)
<|> subparser
(command
"print-app-errors"
(info (pure PrintAppErrors <**> helper)
(progDesc ""))
<> internal
)

3
app/ghcup/GHCup/OptParse/ChangeLog.hs
View File

@ -12,6 +12,7 @@ module GHCup.OptParse.ChangeLog where
import GHCup.Types
import GHCup.Errors
import GHCup.OptParse.Common
import GHCup.Prelude
import GHCup.Prelude.Logger
@ -148,6 +149,6 @@ changelog ChangeLogOptions{..} runAppState runLogger = do
Nothing
>>= \case
Right _ -> pure ExitSuccess
Left e -> logError (T.pack $ prettyShow e)
Left e -> logError (T.pack $ prettyHFError e)
>> pure (ExitFailure 13)
else liftIO $ putStrLn uri' >> pure ExitSuccess

13
app/ghcup/GHCup/OptParse/Compile.hs
View File

@ -40,7 +40,6 @@ import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString hiding ( uriParser )
import qualified Data.Text as T
@ -546,14 +545,14 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
pure ExitSuccess
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
Never -> runLogger $ logError $ T.pack $ prettyHFError err
_ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory "
<> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 9
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 9
(CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do
runLogger $ logError "Hadrian cross compile support is not yet implemented!"
@ -608,12 +607,12 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
pure $ ExitFailure 3
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
Never -> runLogger $ logError $ T.pack $ prettyHFError err
_ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory "
<> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 9
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 9

2
app/ghcup/GHCup/OptParse/DInfo.hs
View File

@ -115,5 +115,5 @@ dinfo runAppState runLogger = do
liftIO $ putStrLn $ prettyDebugInfo di
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 8

3
app/ghcup/GHCup/OptParse/GC.hs
View File

@ -27,7 +27,6 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
@ -139,5 +138,5 @@ gc GCOptions{..} runAppState runLogger = runGC runAppState (do
VRight _ -> do
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 27

33
app/ghcup/GHCup/OptParse/Install.hs
View File

@ -38,7 +38,6 @@ import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString hiding ( uriParser )
import qualified Data.Text as T
@ -351,10 +350,10 @@ install installCommand settings getAppState' runLogger = case installCommand of
pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
pure ExitSuccess
VLeft (V (DirNotEmpty fp)) -> do
@ -368,22 +367,22 @@ install installCommand settings getAppState' runLogger = case installCommand of
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger (logError $ T.pack $ prettyShow err)
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
Never -> runLogger (logError $ T.pack $ prettyHFError err)
_ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 3
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger (logError $ T.pack $ prettyShow err)
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
Never -> runLogger (logError $ T.pack $ prettyHFError err)
_ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ T.pack $ prettyHFError e
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
pure $ ExitFailure 3
@ -418,14 +417,14 @@ install installCommand settings getAppState' runLogger = case installCommand of
runLogger $ logInfo msg
pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
@ -433,7 +432,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ T.pack $ prettyHFError e
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
pure $ ExitFailure 4
@ -468,14 +467,14 @@ install installCommand settings getAppState' runLogger = case installCommand of
runLogger $ logInfo msg
pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
@ -483,7 +482,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ T.pack $ prettyHFError e
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
pure $ ExitFailure 4
@ -517,14 +516,14 @@ install installCommand settings getAppState' runLogger = case installCommand of
runLogger $ logInfo msg
pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
@ -532,6 +531,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ T.pack $ prettyHFError e
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
pure $ ExitFailure 4

3
app/ghcup/GHCup/OptParse/Nuke.hs
View File

@ -26,7 +26,6 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
@ -95,5 +94,5 @@ nuke appState runLogger = do
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 15

3
app/ghcup/GHCup/OptParse/Prefetch.hs
View File

@ -30,7 +30,6 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
@ -216,5 +215,5 @@ prefetch prefetchCommand runAppState runLogger =
VRight _ -> do
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 15

9
app/ghcup/GHCup/OptParse/Rm.hs
View File

@ -34,7 +34,6 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
@ -179,7 +178,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
postRmLog vi
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 7
rmCabal' tv =
@ -194,7 +193,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
postRmLog vi
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 15
rmHLS' tv =
@ -209,7 +208,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
postRmLog vi
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 15
rmStack' tv =
@ -224,7 +223,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
postRmLog vi
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 15
postRmLog vi =

5
app/ghcup/GHCup/OptParse/Run.hs
View File

@ -40,7 +40,6 @@ import Prelude hiding ( appendFile )
import System.FilePath
import System.Environment
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
@ -266,11 +265,11 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
case r' of
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 28
#endif
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 27
where

9
app/ghcup/GHCup/OptParse/Set.hs
View File

@ -35,7 +35,6 @@ import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Data.Bifunctor (second)
@ -286,7 +285,7 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
"GHC " <> prettyVer _tvVersion <> " successfully set as default version" <> maybe "" (" for cross target " <>) _tvTarget
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 5
@ -307,7 +306,7 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
"Cabal " <> prettyVer (_tvVersion v) <> " successfully set as default version"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 14
setHLS' :: SetOptions
@ -327,7 +326,7 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
"HLS " <> prettyVer (_tvVersion v) <> " successfully set as default version"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 14
@ -348,5 +347,5 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
"Stack " <> prettyVer (_tvVersion v) <> " successfully set as default version"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 14

3
app/ghcup/GHCup/OptParse/ToolRequirements.hs
View File

@ -23,7 +23,6 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import qualified Data.Text.IO as T
@ -118,5 +117,5 @@ toolRequirements ToolReqOpts{..} runAppState runLogger = runToolRequirements run
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 12

3
app/ghcup/GHCup/OptParse/UnSet.hs
View File

@ -31,7 +31,6 @@ import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
@ -189,7 +188,7 @@ unset unsetCommand runLeanAppState runLogger = case unsetCommand of
runLogger $ logInfo "GHC successfully unset"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 14
(UnsetCabal (UnsetOptions _)) -> do
void $ runLeanAppState (VRight <$> unsetCabal)

3
app/ghcup/GHCup/OptParse/Upgrade.hs
View File

@ -28,7 +28,6 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
@ -152,5 +151,5 @@ upgrade uOpts force' fatal Dirs{..} runAppState runLogger = do
runLogger $ logWarn "No GHCup update available"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 11

7
app/ghcup/GHCup/OptParse/Whereis.hs
View File

@ -34,7 +34,6 @@ import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Environment
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
@ -288,7 +287,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
liftIO $ putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 30
(WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) ->
runLeanWhereIs leanAppstate (do
@ -302,7 +301,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
liftIO $ putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 30
(WhereisTool tool whereVer, WhereisOptions{..}) -> do
@ -318,7 +317,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
liftIO $ putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 30
(WhereisBaseDir, _) -> do

7
app/ghcup/Main.hs
View File

@ -206,7 +206,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
VRight r -> pure r
VLeft e -> do
runLogger
(logError $ T.pack $ prettyShow e)
(logError $ T.pack $ prettyHFError e)
exitWith (ExitFailure 2)
ghcupInfo <-
@ -218,7 +218,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
VRight r -> pure r
VLeft e -> do
runLogger
(logError $ T.pack $ prettyShow e)
(logError $ T.pack $ prettyHFError e)
exitWith (ExitFailure 2)
let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig
@ -266,7 +266,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
VRight _ -> pure ()
VLeft e -> do
runLogger
(logError $ T.pack $ prettyShow e)
(logError $ T.pack $ prettyHFError e)
exitWith (ExitFailure 30)
pure s'
@ -311,6 +311,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
Prefetch pfCom -> prefetch pfCom runAppState runLogger
GC gcOpts -> gc gcOpts runAppState runLogger
Run runCommand -> run runCommand appState leanAppstate runLogger
PrintAppErrors -> putStrLn allHFError >> pure ExitSuccess
case res of
ExitSuccess -> pure ()

3
lib/GHCup.hs
View File

@ -78,7 +78,6 @@ import Text.Regex.Posix
import qualified Data.Text as T
import qualified Streamly.Prelude as S
import Text.PrettyPrint.HughesPJClass (prettyShow)
@ -328,7 +327,7 @@ upgradeGHCup mtarget force' fatal = do
Just pa
| fatal -> throwE (ToolShadowed GHCup pa destFile latestVer)
| otherwise ->
lift $ logWarn $ T.pack $ prettyShow (ToolShadowed GHCup pa destFile latestVer)
lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed GHCup pa destFile latestVer)
pure latestVer

3
lib/GHCup/Cabal.hs
View File

@ -50,7 +50,6 @@ import System.FilePath
import System.IO.Error
import qualified Data.Text as T
import Text.PrettyPrint.HughesPJClass (prettyShow)
@ -235,7 +234,7 @@ setCabal ver = do
liftIO (isShadowed cabalbin) >>= \case
Nothing -> pure ()
Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed Cabal pa cabalbin ver)
Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed Cabal pa cabalbin ver)
pure ()

10
lib/GHCup/Download.hs
View File

@ -75,7 +75,6 @@ import System.Exit
import System.FilePath
import System.IO.Error
import System.IO.Temp
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString
import qualified Crypto.Hash.SHA256 as SHA256
@ -176,7 +175,7 @@ getBase uri = do
Lax -> lift (warnCache (displayException e) downloader) >> pure Nothing)
. catchE @_ @_ @'[DownloadFailed] (\e@(DownloadFailed _) -> case metaMode of
Strict -> throwE e
Lax -> lift (warnCache (prettyShow e) downloader) >> pure Nothing)
Lax -> lift (warnCache (prettyHFError e) downloader) >> pure Nothing)
. fmap Just
. smartDl
$ uri
@ -392,7 +391,7 @@ download uri gpgUri eDigest eCSize dest mfn etags
liftE $ flip onException
(lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile gpgDestFile))
$ catchAllE @_ @'[GPGError, ProcessError, UnsupportedScheme, DownloadFailed] @'[GPGError]
(\e -> if gpgSetting == GPGStrict then throwE (GPGError e) else lift $ logWarn $ T.pack (prettyShow (GPGError e))
(\e -> if gpgSetting == GPGStrict then throwE (GPGError e) else lift $ logWarn $ T.pack (prettyHFError (GPGError e))
) $ do
o' <- liftIO getGpgOpts
lift $ logDebug $ "downloading: " <> (decUTF8Safe . serializeURIRef') gpgUri' <> " as file " <> T.pack gpgDestFile
@ -486,7 +485,10 @@ download uri gpgUri eDigest eCSize dest mfn etags
, MonadMask m
, MonadIO m
)
=> [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
=> [String]
-> FilePath
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
wgetEtagsDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
let destFileTemp = tmpFile destFile
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do

611
lib/GHCup/Errors.hs
View File

@ -6,6 +6,7 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-|
Module : GHCup.Errors
@ -34,9 +35,139 @@ import URI.ByteString
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import Data.Data (Proxy(..))
allHFError :: String
allHFError = unlines allErrors
where
format p = "GHCup-" <> show (eBase p) <> " " <> eDesc p
format'' e p = "GHCup-" <> show (eNum e) <> " " <> eDesc p
format' e _ = "GHCup-" <> show (eNum e) <> " " <> prettyShow e
format''' e _ str' = "GHCup-" <> show (eNum e) <> " " <> str'
allErrors =
[ "# low level errors (1 to 500)"
, let proxy = Proxy :: Proxy NoCompatiblePlatform in format proxy
, let proxy = Proxy :: Proxy NoDownload in format proxy
, let proxy = Proxy :: Proxy NoUpdate in format proxy
, let proxy = Proxy :: Proxy DistroNotFound in format proxy
, let proxy = Proxy :: Proxy UnknownArchive in format proxy
, let proxy = Proxy :: Proxy UnsupportedScheme in format proxy
, let proxy = Proxy :: Proxy CopyError in format proxy
, let proxy = Proxy :: Proxy MergeFileTreeError in format proxy
, let proxy = Proxy :: Proxy TagNotFound in format proxy
, let proxy = Proxy :: Proxy NextVerNotFound in format proxy
, let proxy = Proxy :: Proxy AlreadyInstalled in format proxy
, let proxy = Proxy :: Proxy DirNotEmpty in format proxy
, let proxy = Proxy :: Proxy NotInstalled in format proxy
, let proxy = Proxy :: Proxy UninstallFailed in format proxy
, let proxy = Proxy :: Proxy NotFoundInPATH in format proxy
, let proxy = Proxy :: Proxy JSONError in format proxy
, let proxy = Proxy :: Proxy FileDoesNotExistError in format proxy
, let proxy = Proxy :: Proxy FileAlreadyExistsError in format proxy
, let proxy = Proxy :: Proxy TarDirDoesNotExist in format proxy
, let proxy = Proxy :: Proxy DigestError in format proxy
, let proxy = Proxy :: Proxy GPGError in format proxy
, let proxy = Proxy :: Proxy HTTPStatusError in format proxy
, let proxy = Proxy :: Proxy MalformedHeaders in format proxy
, let proxy = Proxy :: Proxy HTTPNotModified in format proxy
, let proxy = Proxy :: Proxy NoLocationHeader in format proxy
, let proxy = Proxy :: Proxy TooManyRedirs in format proxy
, let proxy = Proxy :: Proxy PatchFailed in format proxy
, let proxy = Proxy :: Proxy NoToolRequirements in format proxy
, let proxy = Proxy :: Proxy InvalidBuildConfig in format proxy
, let proxy = Proxy :: Proxy NoToolVersionSet in format proxy
, let proxy = Proxy :: Proxy NoNetwork in format proxy
, let proxy = Proxy :: Proxy HadrianNotFound in format proxy
, let proxy = Proxy :: Proxy ToolShadowed in format proxy
, let proxy = Proxy :: Proxy ContentLengthError in format proxy
, ""
, "# high level errors (5000+)"
, let proxy = Proxy :: Proxy DownloadFailed in format proxy
, let proxy = Proxy :: Proxy InstallSetError in format proxy
, let proxy = Proxy :: Proxy BuildFailed in format proxy
, let proxy = Proxy :: Proxy GHCupSetError in format proxy
, ""
, "# true exceptions (500+)"
, let proxy = Proxy :: Proxy ParseError in format proxy
, let proxy = Proxy :: Proxy UnexpectedListLength in format proxy
, let proxy = Proxy :: Proxy NoUrlBase in format proxy
, ""
, "# orphans (800+)"
, let proxy = Proxy :: Proxy URIParseError in format proxy
, let proxy = Proxy :: Proxy URIParseError
e = MalformedScheme MissingColon
in format' e proxy
, let proxy = Proxy :: Proxy URIParseError
e = MalformedUserInfo
in format' e proxy
, let proxy = Proxy :: Proxy URIParseError
e = MalformedQuery
in format' e proxy
, let proxy = Proxy :: Proxy URIParseError
e = MalformedFragment
in format' e proxy
, let proxy = Proxy :: Proxy URIParseError
e = MalformedHost
in format' e proxy
, let proxy = Proxy :: Proxy URIParseError
e = MalformedPort
in format' e proxy
, let proxy = Proxy :: Proxy URIParseError
e = MalformedPath
in format' e proxy
, let proxy = Proxy :: Proxy URIParseError
e = OtherError ""
in format'' e proxy
, let proxy = Proxy :: Proxy ArchiveResult in format proxy
, let proxy = Proxy :: Proxy ArchiveResult
e = ArchiveFatal
in format' e proxy
, let proxy = Proxy :: Proxy ArchiveResult
e = ArchiveFailed
in format' e proxy
, let proxy = Proxy :: Proxy ArchiveResult
e = ArchiveWarn
in format' e proxy
, let proxy = Proxy :: Proxy ArchiveResult
e = ArchiveRetry
in format' e proxy
, let proxy = Proxy :: Proxy ArchiveResult
e = ArchiveOk
in format' e proxy
, let proxy = Proxy :: Proxy ArchiveResult
e = ArchiveEOF
in format' e proxy
, let proxy = Proxy :: Proxy ProcessError in format proxy
, let proxy = Proxy :: Proxy ProcessError
e = NonZeroExit 0 "" []
in format''' e proxy "A process returned a non-zero exit code."
, let proxy = Proxy :: Proxy ProcessError
e = PTerminated "" []
in format''' e proxy "A process terminated prematurely."
, let proxy = Proxy :: Proxy ProcessError
e = PStopped "" []
in format''' e proxy "A process stopped prematurely."
, let proxy = Proxy :: Proxy ProcessError
e = NoSuchPid "" []
in format''' e proxy "Could not find PID for this process."
]
prettyHFError :: (Pretty e, HFErrorProject e) => e -> String
prettyHFError e = ("[GHCup-" <> show (eNum e) <> "] ") <> prettyShow e
class HFErrorProject a where
eNum :: a -> Int
eNum _ = eBase (Proxy :: Proxy a)
eBase :: Proxy a -> Int
eDesc :: Proxy a -> String
------------------------
--[ Low-level errors ]--
------------------------
@ -51,20 +182,32 @@ instance Pretty NoCompatiblePlatform where
pPrint (NoCompatiblePlatform str') =
text ("Could not find a compatible platform. Got: " ++ str')
instance HFErrorProject NoCompatiblePlatform where
eBase _ = 1
eDesc _ = "No compatible platform could be found"
-- | Unable to find a download for the requested version/distro.
data NoDownload = NoDownload
deriving Show
instance Pretty NoDownload where
pPrint NoDownload =
text "Unable to find a download for the requested version/distro."
text (eDesc (Proxy :: Proxy NoDownload))
instance HFErrorProject NoDownload where
eBase _ = 10
eDesc _ = "Unable to find a download for the requested version/distro."
-- | No update available or necessary.
data NoUpdate = NoUpdate
deriving Show
instance Pretty NoUpdate where
pPrint NoUpdate = text "No update available or necessary."
pPrint NoUpdate = text (eDesc (Proxy :: Proxy NoUpdate))
instance HFErrorProject NoUpdate where
eBase _ = 20
eDesc _ = "No update available or necessary."
-- | The Architecture is unknown and unsupported.
data NoCompatibleArch = NoCompatibleArch String
@ -74,13 +217,21 @@ instance Pretty NoCompatibleArch where
pPrint (NoCompatibleArch arch) =
text ("The Architecture is unknown or unsupported. Got: " ++ arch)
instance HFErrorProject NoCompatibleArch where
eBase _ = 30
eDesc _ = "The Architecture is unknown and unsupported"
-- | Unable to figure out the distribution of the host.
data DistroNotFound = DistroNotFound
deriving Show
instance Pretty DistroNotFound where
pPrint DistroNotFound =
text "Unable to figure out the distribution of the host."
text (eDesc (Proxy :: Proxy DistroNotFound))
instance HFErrorProject DistroNotFound where
eBase _ = 40
eDesc _ = "Unable to figure out the distribution of the host"
-- | The archive format is unknown. We don't know how to extract it.
data UnknownArchive = UnknownArchive FilePath
@ -90,12 +241,21 @@ instance Pretty UnknownArchive where
pPrint (UnknownArchive file) =
text $ "The archive format is unknown. We don't know how to extract the file " <> file
instance HFErrorProject UnknownArchive where
eBase _ = 50
eDesc _ = "The archive format is unknown. We don't know how to extract it."
-- | The scheme is not supported (such as ftp).
data UnsupportedScheme = UnsupportedScheme
deriving Show
instance Pretty UnsupportedScheme where
pPrint UnsupportedScheme = text "The scheme is not supported (such as ftp)."
pPrint UnsupportedScheme =
text (eDesc (Proxy :: Proxy UnsupportedScheme))
instance HFErrorProject UnsupportedScheme where
eBase _ = 60
eDesc _ = "The scheme is not supported (such as ftp)."
-- | Unable to copy a file.
data CopyError = CopyError String
@ -105,6 +265,10 @@ instance Pretty CopyError where
pPrint (CopyError reason) =
text ("Unable to copy a file. Reason was: " ++ reason)
instance HFErrorProject CopyError where
eBase _ = 70
eDesc _ = "Unable to copy a file."
-- | Unable to merge file trees.
data MergeFileTreeError = MergeFileTreeError IOException FilePath FilePath
deriving Show
@ -114,6 +278,10 @@ instance Pretty MergeFileTreeError where
text "Failed to merge file tree from" <+> text from <+> text "to" <+> text to <+> text "\nexception was:" <+> text (displayException e)
<+> text "\n...you may need to delete" <+> text to <+> text "manually. Make sure it's gone."
instance HFErrorProject MergeFileTreeError where
eBase _ = 80
eDesc _ = "Unable to merge file trees during installation"
-- | Unable to find a tag of a tool.
data TagNotFound = TagNotFound Tag Tool
deriving Show
@ -122,6 +290,10 @@ instance Pretty TagNotFound where
pPrint (TagNotFound tag tool) =
text "Unable to find tag" <+> pPrint tag <+> text "of tool" <+> pPrint tool
instance HFErrorProject TagNotFound where
eBase _ = 90
eDesc _ = "Unable to find a tag of a tool"
-- | Unable to find the next version of a tool (the one after the currently
-- set one).
data NextVerNotFound = NextVerNotFound Tool
@ -131,6 +303,10 @@ instance Pretty NextVerNotFound where
pPrint (NextVerNotFound tool) =
text "Unable to find next (the one after the currently set one) version of tool" <+> pPrint tool
instance HFErrorProject NextVerNotFound where
eBase _ = 100
eDesc _ = "Unable to find the next version of a tool (the one after the currently set one)"
-- | The tool (such as GHC) is already installed with that version.
data AlreadyInstalled = AlreadyInstalled Tool Version
deriving Show
@ -140,6 +316,9 @@ instance Pretty AlreadyInstalled where
(pPrint tool <> text "-" <> pPrint ver') <+> text "is already installed;"
<+> text "if you really want to reinstall it, you may want to run 'ghcup install" <+> pPrint tool <+> text "--force" <+> (pPrint ver' <> text "'")
instance HFErrorProject AlreadyInstalled where
eBase _ = 110
eDesc _ = "The tool (such as GHC) is already installed with that version"
-- | The Directory is supposed to be empty, but wasn't.
data DirNotEmpty = DirNotEmpty {path :: FilePath}
@ -149,6 +328,10 @@ instance Pretty DirNotEmpty where
pPrint (DirNotEmpty path) = do
text $ "The directory was expected to be empty, but isn't: " <> path
instance HFErrorProject DirNotEmpty where
eBase _ = 120
eDesc _ = "The Directory is supposed to be empty, but wasn't"
-- | The tool is not installed. Some operations rely on a tool
-- to be installed (such as setting the current GHC version).
data NotInstalled = NotInstalled Tool GHCTargetVersion
@ -158,6 +341,10 @@ instance Pretty NotInstalled where
pPrint (NotInstalled tool ver) =
text "The version" <+> pPrint ver <+> text "of the tool" <+> pPrint tool <+> text "is not installed."
instance HFErrorProject NotInstalled where
eBase _ = 130
eDesc _ = "The required tool is not installed"
data UninstallFailed = UninstallFailed FilePath [FilePath]
deriving Show
@ -165,6 +352,10 @@ instance Pretty UninstallFailed where
pPrint (UninstallFailed dir files) =
text "The following files survived uninstallation: " <+> pPrint files <+> text "...consider removing" <+> pPrint dir <+> text "manually."
instance HFErrorProject UninstallFailed where
eBase _ = 140
eDesc _ = "Uninstallation failed with leftover files"
-- | An executable was expected to be in PATH, but was not found.
data NotFoundInPATH = NotFoundInPATH FilePath
deriving Show
@ -175,6 +366,10 @@ instance Pretty NotFoundInPATH where
pPrint (NotFoundInPATH exe) =
text $ "The exe " <> exe <> " was not found in PATH."
instance HFErrorProject NotFoundInPATH where
eBase _ = 150
eDesc _ = "An executable was expected to be in PATH, but was not found"
-- | JSON decoding failed.
data JSONError = JSONDecodeError String
deriving Show
@ -183,6 +378,10 @@ instance Pretty JSONError where
pPrint (JSONDecodeError err) =
text $ "JSON decoding failed with: " <> err
instance HFErrorProject JSONError where
eBase _ = 160
eDesc _ = "JSON decoding failed"
-- | A file that is supposed to exist does not exist
-- (e.g. when we use file scheme to "download" something).
data FileDoesNotExistError = FileDoesNotExistError FilePath
@ -192,6 +391,10 @@ instance Pretty FileDoesNotExistError where
pPrint (FileDoesNotExistError file) =
text $ "File " <> file <> " does not exist."
instance HFErrorProject FileDoesNotExistError where
eBase _ = 170
eDesc _ = "A file that is supposed to exist does not exist (oops)"
-- | The file already exists
-- (e.g. when we use isolated installs with the same path).
-- (e.g. This is done to prevent any overwriting)
@ -202,6 +405,10 @@ instance Pretty FileAlreadyExistsError where
pPrint (FileAlreadyExistsError file) =
text $ "File " <> file <> " Already exists."
instance HFErrorProject FileAlreadyExistsError where
eBase _ = 180
eDesc _ = "A file already exists that wasn't expected to exist"
data TarDirDoesNotExist = TarDirDoesNotExist TarDir
deriving Show
@ -209,6 +416,10 @@ instance Pretty TarDirDoesNotExist where
pPrint (TarDirDoesNotExist dir) =
text "Tar directory does not exist:" <+> pPrint dir
instance HFErrorProject TarDirDoesNotExist where
eBase _ = 190
eDesc _ = "The tar directory (e.g. inside an archive) does not exist"
-- | File digest verification failed.
data DigestError = DigestError FilePath Text Text
deriving Show
@ -219,6 +430,175 @@ instance Pretty DigestError where
<+> text (T.unpack expectedDigest) <+> text "but got" <+> pPrint currentDigest <+> text
"\nConsider removing the file in case it's cached and try again."
instance HFErrorProject DigestError where
eBase _ = 200
eDesc _ = "File digest verification failed"
-- | File PGP verification failed.
data GPGError = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => GPGError (V xs)
deriving instance Show GPGError
instance Pretty GPGError where
pPrint (GPGError reason) = text "GPG verify failed:" <+> pPrint reason
instance HFErrorProject GPGError where
eBase _ = 210
eDesc _ = "File PGP verification failed"
-- | Unexpected HTTP status.
data HTTPStatusError = HTTPStatusError Int (M.Map (CI ByteString) ByteString)
deriving Show
instance Pretty HTTPStatusError where
pPrint (HTTPStatusError status _) =
text "Unexpected HTTP status:" <+> pPrint status
instance HFErrorProject HTTPStatusError where
eBase _ = 220
eDesc _ = "Unexpected HTTP status error (e.g. during downloads)"
-- | Malformed headers.
data MalformedHeaders = MalformedHeaders Text
deriving Show
instance Pretty MalformedHeaders where
pPrint (MalformedHeaders h) =
text "Headers are malformed: " <+> pPrint h
instance HFErrorProject MalformedHeaders where
eBase _ = 230
eDesc _ = "Malformed headers during download"
-- | Unexpected HTTP status.
data HTTPNotModified = HTTPNotModified Text
deriving Show
instance Pretty HTTPNotModified where
pPrint (HTTPNotModified etag) =
text "Remote resource not modifed, etag was:" <+> pPrint etag
instance HFErrorProject HTTPNotModified where
eBase _ = 240
eDesc _ = "Not modified HTTP status error (e.g. during downloads)."
-- | The 'Location' header was expected during a 3xx redirect, but not found.
data NoLocationHeader = NoLocationHeader
deriving Show
instance Pretty NoLocationHeader where
pPrint NoLocationHeader =
text (eDesc (Proxy :: Proxy NoLocationHeader))
instance HFErrorProject NoLocationHeader where
eBase _ = 250
eDesc _ = "The 'Location' header was expected during a 3xx redirect, but not found."
-- | Too many redirects.
data TooManyRedirs = TooManyRedirs
deriving Show
instance Pretty TooManyRedirs where
pPrint TooManyRedirs =
text (eDesc (Proxy :: Proxy TooManyRedirs))
instance HFErrorProject TooManyRedirs where
eBase _ = 260
eDesc _ = "Too many redirections."
-- | A patch could not be applied.
data PatchFailed = PatchFailed
deriving Show
instance Pretty PatchFailed where
pPrint PatchFailed =
text (eDesc (Proxy :: Proxy PatchFailed))
instance HFErrorProject PatchFailed where
eBase _ = 270
eDesc _ = "A patch could not be applied."
-- | The tool requirements could not be found.
data NoToolRequirements = NoToolRequirements
deriving Show
instance Pretty NoToolRequirements where
pPrint NoToolRequirements =
text (eDesc (Proxy :: Proxy NoToolRequirements))
instance HFErrorProject NoToolRequirements where
eBase _ = 280
eDesc _ = "The Tool requirements could not be found."
data InvalidBuildConfig = InvalidBuildConfig Text
deriving Show
instance Pretty InvalidBuildConfig where
pPrint (InvalidBuildConfig reason) =
text "The build config is invalid. Reason was:" <+> pPrint reason
instance HFErrorProject InvalidBuildConfig where
eBase _ = 290
eDesc _ = "The build config is invalid."
data NoToolVersionSet = NoToolVersionSet Tool
deriving Show
instance Pretty NoToolVersionSet where
pPrint (NoToolVersionSet tool) =
text "No version is set for tool" <+> pPrint tool <+> text "."
instance HFErrorProject NoToolVersionSet where
eBase _ = 300
eDesc _ = "No version is set for tool (but was expected)."
data NoNetwork = NoNetwork
deriving Show
instance Pretty NoNetwork where
pPrint NoNetwork =
text (eDesc (Proxy :: Proxy NoNetwork))
instance HFErrorProject NoNetwork where
eBase _ = 310
eDesc _ = "A download was required or requested, but '--offline' was specified."
data HadrianNotFound = HadrianNotFound
deriving Show
instance Pretty HadrianNotFound where
pPrint HadrianNotFound =
text (eDesc (Proxy :: Proxy HadrianNotFound))
instance HFErrorProject HadrianNotFound where
eBase _ = 320
eDesc _ = "Could not find Hadrian build files. Does this GHC version support Hadrian builds?"
data ToolShadowed = ToolShadowed
Tool
FilePath -- shadow binary
FilePath -- upgraded binary
Version -- upgraded version
deriving Show
instance Pretty ToolShadowed where
pPrint (ToolShadowed tool sh up _) =
text (prettyShow tool
<> " is shadowed by "
<> sh
<> ".\nThe upgrade will not be in effect, unless you remove "
<> sh
<> "\nor make sure "
<> takeDirectory up
<> " comes before "
<> takeDirectory sh
<> " in PATH."
)
instance HFErrorProject ToolShadowed where
eBase _ = 330
eDesc _ = "A tool is shadowed in PATH."
-- | File content length verification failed.
data ContentLengthError = ContentLengthError (Maybe FilePath) (Maybe Integer) Integer
deriving Show
@ -242,125 +622,16 @@ instance Pretty ContentLengthError where
instance Exception ContentLengthError
-- | File digest verification failed.
data GPGError = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => GPGError (V xs)
deriving instance Show GPGError
instance Pretty GPGError where
pPrint (GPGError reason) = text "GPG verify failed:" <+> pPrint reason
-- | Unexpected HTTP status.
data HTTPStatusError = HTTPStatusError Int (M.Map (CI ByteString) ByteString)
deriving Show
instance Pretty HTTPStatusError where
pPrint (HTTPStatusError status _) =
text "Unexpected HTTP status:" <+> pPrint status
-- | Malformed headers.
data MalformedHeaders = MalformedHeaders Text
deriving Show
instance Pretty MalformedHeaders where
pPrint (MalformedHeaders h) =
text "Headers are malformed: " <+> pPrint h
-- | Unexpected HTTP status.
data HTTPNotModified = HTTPNotModified Text
deriving Show
instance Pretty HTTPNotModified where
pPrint (HTTPNotModified etag) =
text "Remote resource not modifed, etag was:" <+> pPrint etag
-- | The 'Location' header was expected during a 3xx redirect, but not found.
data NoLocationHeader = NoLocationHeader
deriving Show
instance Pretty NoLocationHeader where
pPrint NoLocationHeader =
text "The 'Location' header was expected during a 3xx redirect, but not found."
-- | Too many redirects.
data TooManyRedirs = TooManyRedirs
deriving Show
instance Pretty TooManyRedirs where
pPrint TooManyRedirs =
text "Too many redirections."
-- | A patch could not be applied.
data PatchFailed = PatchFailed
deriving Show
instance Pretty PatchFailed where
pPrint PatchFailed =
text "A patch could not be applied."
-- | The tool requirements could not be found.
data NoToolRequirements = NoToolRequirements
deriving Show
instance Pretty NoToolRequirements where
pPrint NoToolRequirements =
text "The Tool requirements could not be found."
data InvalidBuildConfig = InvalidBuildConfig Text
deriving Show
instance Pretty InvalidBuildConfig where
pPrint (InvalidBuildConfig reason) =
text "The build config is invalid. Reason was:" <+> pPrint reason
data NoToolVersionSet = NoToolVersionSet Tool
deriving Show
instance Pretty NoToolVersionSet where
pPrint (NoToolVersionSet tool) =
text "No version is set for tool" <+> pPrint tool <+> text "."
data NoNetwork = NoNetwork
deriving Show
instance Pretty NoNetwork where
pPrint NoNetwork =
text "A download was required or requested, but '--offline' was specified."
data HadrianNotFound = HadrianNotFound
deriving Show
instance Pretty HadrianNotFound where
pPrint HadrianNotFound =
text "Could not find Hadrian build files. Does this GHC version support Hadrian builds?"
data ToolShadowed = ToolShadowed
Tool
FilePath -- shadow binary
FilePath -- upgraded binary
Version -- upgraded version
deriving Show
instance Pretty ToolShadowed where
pPrint (ToolShadowed tool sh up _) =
text (prettyShow tool
<> " is shadowed by "
<> sh
<> ".\nThe upgrade will not be in effect, unless you remove "
<> sh
<> "\nor make sure "
<> takeDirectory up
<> " comes before "
<> takeDirectory sh
<> " in PATH."
)
instance HFErrorProject ContentLengthError where
eBase _ = 340
eDesc _ = "File content length verification failed"
-------------------------
--[ High-level errors ]--
-------------------------
-- | A download failed. The underlying error is encapsulated.
data DownloadFailed = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => DownloadFailed (V xs)
data DownloadFailed = forall xs . (HFErrorProject (V xs), ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => DownloadFailed (V xs)
instance Pretty DownloadFailed where
pPrint (DownloadFailed reason) =
@ -370,7 +641,12 @@ instance Pretty DownloadFailed where
deriving instance Show DownloadFailed
data InstallSetError = forall xs1 xs2 . (Show (V xs1), Pretty (V xs1), Show (V xs2), Pretty (V xs2)) => InstallSetError (V xs1) (V xs2)
instance HFErrorProject DownloadFailed where
eBase _ = 5000
eNum (DownloadFailed xs) = 5000 + eNum xs
eDesc _ = "A download failed."
data InstallSetError = forall xs1 xs2 . (Show (V xs1), Pretty (V xs1), HFErrorProject (V xs1), Show (V xs2), Pretty (V xs2), HFErrorProject (V xs2)) => InstallSetError (V xs1) (V xs2)
instance Pretty InstallSetError where
pPrint (InstallSetError reason1 reason2) =
@ -381,9 +657,15 @@ instance Pretty InstallSetError where
deriving instance Show InstallSetError
instance HFErrorProject InstallSetError where
eBase _ = 7000
-- will there be collisions?
eNum (InstallSetError xs1 xs2) = 7000 + eNum xs1 + eNum xs2
eDesc _ = "Installation or setting the tool failed."
-- | A build failed.
data BuildFailed = forall es . (ToVariantMaybe BuildFailed es, PopVariant BuildFailed es, Pretty (V es), Show (V es)) => BuildFailed FilePath (V es)
data BuildFailed = forall es . (ToVariantMaybe BuildFailed es, PopVariant BuildFailed es, Pretty (V es), Show (V es), HFErrorProject (V es)) => BuildFailed FilePath (V es)
instance Pretty BuildFailed where
pPrint (BuildFailed path reason) =
@ -393,18 +675,28 @@ instance Pretty BuildFailed where
deriving instance Show BuildFailed
instance HFErrorProject BuildFailed where
eBase _ = 8000
eNum (BuildFailed _ xs2) = 8000 + eNum xs2
eDesc _ = "The build failed."
-- | Setting the current GHC version failed.
data GHCupSetError = forall es . (ToVariantMaybe GHCupSetError es, PopVariant GHCupSetError es, Show (V es), Pretty (V es)) => GHCupSetError (V es)
data GHCupSetError = forall es . (ToVariantMaybe GHCupSetError es, PopVariant GHCupSetError es, Show (V es), Pretty (V es), HFErrorProject (V es)) => GHCupSetError (V es)
instance Pretty GHCupSetError where
pPrint (GHCupSetError reason) =
case reason of
VMaybe (_ :: GHCupSetError) -> pPrint reason
_ -> text "Setting the current GHC version failed:" <+> pPrint reason
_ -> text "Setting the current version failed:" <+> pPrint reason
deriving instance Show GHCupSetError
instance HFErrorProject GHCupSetError where
eBase _ = 9000
eNum (GHCupSetError xs) = 9000 + eNum xs
eDesc _ = "Setting the current version failed."
---------------------------------------------
--[ True Exceptions (e.g. for MonadThrow) ]--
@ -421,6 +713,10 @@ instance Pretty ParseError where
instance Exception ParseError
instance HFErrorProject ParseError where
eBase _ = 500
eDesc _ = "A parse error occured."
data UnexpectedListLength = UnexpectedListLength String
deriving Show
@ -431,6 +727,10 @@ instance Pretty UnexpectedListLength where
instance Exception UnexpectedListLength
instance HFErrorProject UnexpectedListLength where
eBase _ = 510
eDesc _ = "A list had an unexpected length."
data NoUrlBase = NoUrlBase Text
deriving Show
@ -440,6 +740,10 @@ instance Pretty NoUrlBase where
instance Exception NoUrlBase
instance HFErrorProject NoUrlBase where
eBase _ = 520
eDesc _ = "URL does not have a base filename."
------------------------
@ -459,6 +763,23 @@ instance
Right x -> pPrint x
Left xs -> pPrint xs
instance HFErrorProject (V '[]) where
{-# INLINABLE eBase #-}
eBase _ = undefined
{-# INLINABLE eDesc #-}
eDesc _ = undefined
instance
( HFErrorProject x
, HFErrorProject (V xs)
) => HFErrorProject (V (x ': xs))
where
eNum v = case popVariantHead v of
Right x -> eNum x
Left xs -> eNum xs
eDesc _ = undefined
eBase _ = undefined
instance Pretty URIParseError where
pPrint (MalformedScheme reason) =
text "Failed to parse URI. Malformed scheme:" <+> text (show reason)
@ -477,6 +798,22 @@ instance Pretty URIParseError where
pPrint (OtherError err) =
text "Failed to parse URI:" <+> pPrint err
instance HFErrorProject URIParseError where
eBase _ = 800
eNum (MalformedScheme NonAlphaLeading) = 801
eNum (MalformedScheme InvalidChars) = 802
eNum (MalformedScheme MissingColon) = 803
eNum MalformedUserInfo = 804
eNum MalformedQuery = 805
eNum MalformedFragment = 806
eNum MalformedHost = 807
eNum MalformedPort = 808
eNum MalformedPath = 809
eNum (OtherError _) = 810
eDesc _ = "Failed to parse URI."
instance Pretty ArchiveResult where
pPrint ArchiveFatal = text "Archive result: fatal"
pPrint ArchiveFailed = text "Archive result: failed"
@ -485,5 +822,37 @@ instance Pretty ArchiveResult where
pPrint ArchiveOk = text "Archive result: Ok"
pPrint ArchiveEOF = text "Archive result: EOF"
instance HFErrorProject ArchiveResult where
eBase _ = 820
eNum ArchiveFatal = 821
eNum ArchiveFailed = 822
eNum ArchiveWarn = 823
eNum ArchiveRetry = 824
eNum ArchiveOk = 825
eNum ArchiveEOF = 826
eDesc _ = "Archive extraction result."
instance Pretty T.Text where
pPrint = text . T.unpack
instance Pretty ProcessError where
pPrint (NonZeroExit e exe args) =
text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "failed with exit code" <+> text (show e <> ".")
pPrint (PTerminated exe args) =
text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "terminated."
pPrint (PStopped exe args) =
text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "stopped."
pPrint (NoSuchPid exe args) =
text "Could not find PID for process running " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text "."
instance HFErrorProject ProcessError where
eBase _ = 840
eNum NonZeroExit{} = 841
eNum (PTerminated _ _) = 842
eNum (PStopped _ _) = 843
eNum (NoSuchPid _ _) = 844
eDesc _ = "A process exited prematurely."

2
lib/GHCup/GHC.hs
View File

@ -459,7 +459,7 @@ setGHC ver sghc mBinDir = do
when (targetFile == "ghc") $
liftIO (isShadowed fullF) >>= \case
Nothing -> pure ()
Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed GHC pa fullF (_tvVersion ver))
Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed GHC pa fullF (_tvVersion ver))
when (isNothing mBinDir) $ do
-- create symlink for share dir

3
lib/GHCup/HLS.hs
View File

@ -68,7 +68,6 @@ import qualified Data.List.NonEmpty as NE
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Text.Megaparsec as MP
import Text.PrettyPrint.HughesPJClass (prettyShow)
data HLSVer = SourceDist Version
@ -634,7 +633,7 @@ setHLS ver shls mBinDir = do
liftIO (isShadowed wrapper) >>= \case
Nothing -> pure ()
Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed HLS pa wrapper ver)
Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed HLS pa wrapper ver)
unsetHLS :: ( MonadMask m

6
lib/GHCup/Prelude.hs
View File

@ -41,24 +41,26 @@ import GHCup.Prelude.Posix
import Control.Monad.IO.Class
import Control.Monad.Reader
import Haskus.Utils.Variant.Excepts
import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
import Text.PrettyPrint.HughesPJClass ( Pretty )
import qualified Data.Text as T
-- for some obscure reason... this won't type-check if we move it to a different module
catchWarn :: forall es m env . ( Pretty (V es)
, HFErrorProject (V es)
, MonadReader env m
, HasLog env
, MonadIO m
, Monad m) => Excepts es m () -> Excepts '[] m ()
catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v))
catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyHFError $ v))
runBothE' :: forall e m a b .
( Monad m
, Show (V e)
, Pretty (V e)
, HFErrorProject (V e)
, PopVariant InstallSetError e
, LiftVariant' e (InstallSetError ': e)
, e :<< (InstallSetError ': e)

3
lib/GHCup/Stack.hs
View File

@ -50,7 +50,6 @@ import System.FilePath
import System.IO.Error
import qualified Data.Text as T
import Text.PrettyPrint.HughesPJClass (prettyShow)
@ -234,7 +233,7 @@ setStack ver = do
liftIO (isShadowed stackbin) >>= \case
Nothing -> pure ()
Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed Cabal pa stackbin ver)
Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed Cabal pa stackbin ver)
pure ()

12
lib/GHCup/Types.hs
View File

@ -35,7 +35,7 @@ import Data.Text ( Text )
import Data.Versions
import GHC.IO.Exception ( ExitCode )
import Optics ( makeLenses )
import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text, (<+>))
import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
import URI.ByteString
#if defined(BRICK)
import Graphics.Vty ( Key(..) )
@ -632,15 +632,7 @@ data ProcessError = NonZeroExit Int FilePath [String]
| NoSuchPid FilePath [String]
deriving Show
instance Pretty ProcessError where
pPrint (NonZeroExit e exe args) =
text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "failed with exit code" <+> text (show e <> ".")
pPrint (PTerminated exe args) =
text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "terminated."
pPrint (PStopped exe args) =
text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "stopped."
pPrint (NoSuchPid exe args) =
text "Could not find PID for process running " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text "."
data CapturedProcess = CapturedProcess
{ _exitCode :: ExitCode
, _stdOut :: BL.ByteString

2
lib/GHCup/Utils.hs
View File

@ -1301,7 +1301,7 @@ gitOut args dir = do
ExitSuccess -> pure $ T.pack $ stripNewlineEnd $ T.unpack $ decUTF8Safe' _stdOut
ExitFailure c -> do
let pe = NonZeroExit c "git" args
lift $ logDebug $ T.pack (prettyShow pe)
lift $ logDebug $ T.pack (prettyHFError pe)
throwE pe
processBranches :: T.Text -> [String]