From 009f9211a9ea6887318f0e2a291101ec0f222be4 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Tue, 20 Dec 2022 00:10:19 +0800 Subject: [PATCH 1/2] Integrate with errors.haskell.org Fixes #434 --- app/ghcup/BrickMain.hs | 12 +- app/ghcup/GHCup/OptParse.hs | 8 + app/ghcup/GHCup/OptParse/ChangeLog.hs | 3 +- app/ghcup/GHCup/OptParse/Compile.hs | 13 +- app/ghcup/GHCup/OptParse/DInfo.hs | 2 +- app/ghcup/GHCup/OptParse/GC.hs | 3 +- app/ghcup/GHCup/OptParse/Install.hs | 33 +- app/ghcup/GHCup/OptParse/Nuke.hs | 3 +- app/ghcup/GHCup/OptParse/Prefetch.hs | 3 +- app/ghcup/GHCup/OptParse/Rm.hs | 9 +- app/ghcup/GHCup/OptParse/Run.hs | 5 +- app/ghcup/GHCup/OptParse/Set.hs | 9 +- app/ghcup/GHCup/OptParse/ToolRequirements.hs | 3 +- app/ghcup/GHCup/OptParse/UnSet.hs | 3 +- app/ghcup/GHCup/OptParse/Upgrade.hs | 3 +- app/ghcup/GHCup/OptParse/Whereis.hs | 7 +- app/ghcup/Main.hs | 7 +- lib/GHCup.hs | 3 +- lib/GHCup/Cabal.hs | 3 +- lib/GHCup/Download.hs | 10 +- lib/GHCup/Errors.hs | 611 +++++++++++++++---- lib/GHCup/GHC.hs | 2 +- lib/GHCup/HLS.hs | 3 +- lib/GHCup/Prelude.hs | 6 +- lib/GHCup/Stack.hs | 3 +- lib/GHCup/Types.hs | 12 +- lib/GHCup/Utils.hs | 2 +- 27 files changed, 570 insertions(+), 211 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 11aa051..698a5e9 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -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 diff --git a/app/ghcup/GHCup/OptParse.hs b/app/ghcup/GHCup/OptParse.hs index b36f82c..ab40c7f 100644 --- a/app/ghcup/GHCup/OptParse.hs +++ b/app/ghcup/GHCup/OptParse.hs @@ -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 + ) diff --git a/app/ghcup/GHCup/OptParse/ChangeLog.hs b/app/ghcup/GHCup/OptParse/ChangeLog.hs index 12a7e64..0e6fd08 100644 --- a/app/ghcup/GHCup/OptParse/ChangeLog.hs +++ b/app/ghcup/GHCup/OptParse/ChangeLog.hs @@ -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 diff --git a/app/ghcup/GHCup/OptParse/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs index ed3f99d..f9f114b 100644 --- a/app/ghcup/GHCup/OptParse/Compile.hs +++ b/app/ghcup/GHCup/OptParse/Compile.hs @@ -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 diff --git a/app/ghcup/GHCup/OptParse/DInfo.hs b/app/ghcup/GHCup/OptParse/DInfo.hs index 23ced6e..5d8d0ee 100644 --- a/app/ghcup/GHCup/OptParse/DInfo.hs +++ b/app/ghcup/GHCup/OptParse/DInfo.hs @@ -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 diff --git a/app/ghcup/GHCup/OptParse/GC.hs b/app/ghcup/GHCup/OptParse/GC.hs index d74dd8e..78ea706 100644 --- a/app/ghcup/GHCup/OptParse/GC.hs +++ b/app/ghcup/GHCup/OptParse/GC.hs @@ -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 diff --git a/app/ghcup/GHCup/OptParse/Install.hs b/app/ghcup/GHCup/OptParse/Install.hs index 6827ea4..9e54cbe 100644 --- a/app/ghcup/GHCup/OptParse/Install.hs +++ b/app/ghcup/GHCup/OptParse/Install.hs @@ -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 diff --git a/app/ghcup/GHCup/OptParse/Nuke.hs b/app/ghcup/GHCup/OptParse/Nuke.hs index 84712d4..e9f847a 100644 --- a/app/ghcup/GHCup/OptParse/Nuke.hs +++ b/app/ghcup/GHCup/OptParse/Nuke.hs @@ -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 diff --git a/app/ghcup/GHCup/OptParse/Prefetch.hs b/app/ghcup/GHCup/OptParse/Prefetch.hs index 22e045e..32ba325 100644 --- a/app/ghcup/GHCup/OptParse/Prefetch.hs +++ b/app/ghcup/GHCup/OptParse/Prefetch.hs @@ -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 diff --git a/app/ghcup/GHCup/OptParse/Rm.hs b/app/ghcup/GHCup/OptParse/Rm.hs index 78e513a..fa756f7 100644 --- a/app/ghcup/GHCup/OptParse/Rm.hs +++ b/app/ghcup/GHCup/OptParse/Rm.hs @@ -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 = diff --git a/app/ghcup/GHCup/OptParse/Run.hs b/app/ghcup/GHCup/OptParse/Run.hs index 449da57..e04960b 100644 --- a/app/ghcup/GHCup/OptParse/Run.hs +++ b/app/ghcup/GHCup/OptParse/Run.hs @@ -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 diff --git a/app/ghcup/GHCup/OptParse/Set.hs b/app/ghcup/GHCup/OptParse/Set.hs index baeb4ef..fdc593a 100644 --- a/app/ghcup/GHCup/OptParse/Set.hs +++ b/app/ghcup/GHCup/OptParse/Set.hs @@ -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 diff --git a/app/ghcup/GHCup/OptParse/ToolRequirements.hs b/app/ghcup/GHCup/OptParse/ToolRequirements.hs index f917a05..bb8a366 100644 --- a/app/ghcup/GHCup/OptParse/ToolRequirements.hs +++ b/app/ghcup/GHCup/OptParse/ToolRequirements.hs @@ -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 diff --git a/app/ghcup/GHCup/OptParse/UnSet.hs b/app/ghcup/GHCup/OptParse/UnSet.hs index 08e804d..a3b33b7 100644 --- a/app/ghcup/GHCup/OptParse/UnSet.hs +++ b/app/ghcup/GHCup/OptParse/UnSet.hs @@ -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) diff --git a/app/ghcup/GHCup/OptParse/Upgrade.hs b/app/ghcup/GHCup/OptParse/Upgrade.hs index 2325f46..8849700 100644 --- a/app/ghcup/GHCup/OptParse/Upgrade.hs +++ b/app/ghcup/GHCup/OptParse/Upgrade.hs @@ -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 diff --git a/app/ghcup/GHCup/OptParse/Whereis.hs b/app/ghcup/GHCup/OptParse/Whereis.hs index 4df064f..a4b48f2 100644 --- a/app/ghcup/GHCup/OptParse/Whereis.hs +++ b/app/ghcup/GHCup/OptParse/Whereis.hs @@ -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 diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 5b3f669..142b34a 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -206,7 +206,7 @@ Report bugs at |] 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 |] 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 |] 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 |] 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 () diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 33a2c93..a00550f 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -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 diff --git a/lib/GHCup/Cabal.hs b/lib/GHCup/Cabal.hs index 1709e31..75dbeb0 100644 --- a/lib/GHCup/Cabal.hs +++ b/lib/GHCup/Cabal.hs @@ -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 () diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 65018f3..627ef9c 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -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 diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index b50346d..2df8d0d 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -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." diff --git a/lib/GHCup/GHC.hs b/lib/GHCup/GHC.hs index 82841cc..6661c15 100644 --- a/lib/GHCup/GHC.hs +++ b/lib/GHCup/GHC.hs @@ -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 diff --git a/lib/GHCup/HLS.hs b/lib/GHCup/HLS.hs index 8702ecc..083f558 100644 --- a/lib/GHCup/HLS.hs +++ b/lib/GHCup/HLS.hs @@ -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 diff --git a/lib/GHCup/Prelude.hs b/lib/GHCup/Prelude.hs index b565924..af494ca 100644 --- a/lib/GHCup/Prelude.hs +++ b/lib/GHCup/Prelude.hs @@ -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) diff --git a/lib/GHCup/Stack.hs b/lib/GHCup/Stack.hs index 24a0ab9..98f8a5c 100644 --- a/lib/GHCup/Stack.hs +++ b/lib/GHCup/Stack.hs @@ -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 () diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index f1d5897..b0fa0fd 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -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 diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 81eb98e..c700895 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -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] From 4be97ffd7c60dd6028b3db9e6a4eaa07dc6a62c7 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 2 Jan 2023 19:37:31 +0800 Subject: [PATCH 2/2] Pad and use hyperlinks --- lib/GHCup/Errors.hs | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index 2df8d0d..47a0a1b 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -157,7 +157,18 @@ allHFError = unlines allErrors prettyHFError :: (Pretty e, HFErrorProject e) => e -> String -prettyHFError e = ("[GHCup-" <> show (eNum e) <> "] ") <> prettyShow e +prettyHFError e = + let errorCode = "GHCup-" <> padIntAndShow (eNum e) + in ("[" <> linkEscapeCode errorCode (hfErrorLink errorCode) <> "] ") <> prettyShow e + where + linkEscapeCode linkText link = "\ESC]8;;" <> link <> "\ESC\\" <> linkText <> "\ESC]8;;\ESC\\" + hfErrorLink errorCode = "https://errors.haskell.org/messages/" <> errorCode + padIntAndShow i + | i < 10 = "0000" <> show i + | i < 100 = "000" <> show i + | i < 1000 = "00" <> show i + | i < 10000 = "0" <> show i + | otherwise = show i class HFErrorProject a where eNum :: a -> Int