Don't install stack by default in CI

Add support for mirrors wrt #357
2023-01-04 00:58:05 +08:00 · 2023-01-04 00:36:07 +08:00
31 changed files with 299 additions and 591 deletions
--- a/.github/scripts/common.sh
+++ b/.github/scripts/common.sh
@@ -151,7 +151,7 @@ install_ghcup() {
 		chmod +x ghcup
 		mv ghcup "$HOME/.local/bin/ghcup"
 	else
-		curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_MINIMAL=1 sh
+		curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_MINIMAL=1 BOOTSTRAP_HASKELL_INSTALL_NO_STACK=yes sh
 	fi
 }

--- 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 $ prettyHFError e <> "\n"
+          VLeft e -> pure $ Left $ prettyShow 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 (prettyHFError e)
+                PromptNo -> pure $ Left (prettyShow 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 (prettyHFError e)
+            _ -> pure $ Left (prettyShow e)



@@ -560,7 +560,7 @@ del' _ (_, ListResult {..}) = do
            forM_ (_viPostRemove =<< vi) $ \msg ->
              logInfo msg
            pure $ Right ()
-          VLeft  e -> pure $ Left (prettyHFError e)
+          VLeft  e -> pure $ Left (prettyShow 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 $ prettyHFError e
+        Left  e -> pure $ Left $ prettyShow e


 settings' :: IORef AppState
@@ -638,7 +638,7 @@ getGHCupInfo = do

  case r of
    VRight a -> pure $ Right a
-    VLeft  e -> pure $ Left (prettyHFError e)
+    VLeft  e -> pure $ Left (prettyShow e)


 getAppData :: Maybe GHCupInfo
--- a/app/ghcup/GHCup/OptParse.hs
+++ b/app/ghcup/GHCup/OptParse.hs
@@ -108,7 +108,6 @@ data Command
  | Prefetch PrefetchCommand
  | GC GCOptions
  | Run RunOptions
-  | PrintAppErrors



@@ -342,10 +341,3 @@ com =
           <> commandGroup "Nuclear Commands:"
           <> hidden
          )
-     <|> subparser
-          (command
-              "print-app-errors"
-               (info (pure PrintAppErrors <**> helper)
-                     (progDesc ""))
-           <> internal
-          )
--- a/app/ghcup/GHCup/OptParse/ChangeLog.hs
+++ b/app/ghcup/GHCup/OptParse/ChangeLog.hs
@@ -12,7 +12,6 @@ module GHCup.OptParse.ChangeLog where


 import           GHCup.Types
-import           GHCup.Errors
 import           GHCup.OptParse.Common
 import           GHCup.Prelude
 import           GHCup.Prelude.Logger
@@ -149,6 +148,6 @@ changelog ChangeLogOptions{..} runAppState runLogger = do
                 Nothing
              >>= \case
                    Right _ -> pure ExitSuccess
-                    Left  e -> logError (T.pack $ prettyHFError e)
+                    Left  e -> logError (T.pack $ prettyShow e)
                      >> pure (ExitFailure 13)
        else liftIO $ putStrLn uri' >> pure ExitSuccess
--- a/app/ghcup/GHCup/OptParse/Compile.hs
+++ b/app/ghcup/GHCup/OptParse/Compile.hs
@@ -40,6 +40,7 @@ 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
@@ -545,14 +546,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 $ prettyHFError err
-                  _ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
+                  Never -> runLogger $ logError $ T.pack $ prettyShow err
+                  _ -> runLogger (logError $ T.pack (prettyShow 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 $ prettyHFError e
+                runLogger $ logError $ T.pack $ prettyShow e
                pure $ ExitFailure 9
    (CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do
      runLogger $ logError "Hadrian cross compile support is not yet implemented!"
@@ -607,12 +608,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 $ prettyHFError err
-                  _ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
+                  Never -> runLogger $ logError $ T.pack $ prettyShow err
+                  _ -> runLogger (logError $ T.pack (prettyShow 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 $ prettyHFError e
+                runLogger $ logError $ T.pack $ prettyShow e
                pure $ ExitFailure 9
--- a/app/ghcup/GHCup/OptParse/Config.hs
+++ b/app/ghcup/GHCup/OptParse/Config.hs
@@ -59,7 +59,7 @@ data ConfigCommand
    --[ Parsers ]--
    ---------------

-
+          
 configP :: Parser ConfigCommand
 configP = subparser
      (  command "init" initP
@@ -133,7 +133,8 @@ updateSettings UserSettings{..} Settings{..} =
       noNetwork'  = fromMaybe noNetwork uNoNetwork
       gpgSetting' = fromMaybe gpgSetting uGPGSetting
       platformOverride' = uPlatformOverride <|> platformOverride
-   in Settings cache' metaCache' metaMode' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor platformOverride'
+       mirrors' = fromMaybe mirrors uMirrors
+   in Settings cache' metaCache' metaMode' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor platformOverride' mirrors'



--- 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 $ prettyHFError e
+            runLogger $ logError $ T.pack $ prettyShow e
            pure $ ExitFailure 8
--- a/app/ghcup/GHCup/OptParse/GC.hs
+++ b/app/ghcup/GHCup/OptParse/GC.hs
@@ -27,6 +27,7 @@ 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)
@@ -138,5 +139,5 @@ gc GCOptions{..} runAppState runLogger = runGC runAppState (do
            VRight _ -> do
                  pure ExitSuccess
            VLeft e -> do
-              runLogger $ logError $ T.pack $ prettyHFError e
+              runLogger $ logError $ T.pack $ prettyShow e
              pure $ ExitFailure 27
--- a/app/ghcup/GHCup/OptParse/Install.hs
+++ b/app/ghcup/GHCup/OptParse/Install.hs
@@ -38,6 +38,7 @@ 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
@@ -350,10 +351,10 @@ install installCommand settings getAppState' runLogger = case installCommand of
                pure ExitSuccess

              VLeft e@(V (AlreadyInstalled _ _)) -> do
-                runLogger $ logWarn $ T.pack $ prettyHFError e
+                runLogger $ logWarn $ T.pack $ prettyShow e
                pure ExitSuccess
              VLeft e@(V (AlreadyInstalled _ _)) -> do
-                runLogger $ logWarn $ T.pack $ prettyHFError e
+                runLogger $ logWarn $ T.pack $ prettyShow e
                pure ExitSuccess

              VLeft (V (DirNotEmpty fp)) -> do
@@ -367,22 +368,22 @@ install installCommand settings getAppState' runLogger = case installCommand of

              VLeft err@(V (BuildFailed tmpdir _)) -> do
                case keepDirs settings of
-                  Never -> runLogger (logError $ T.pack $ prettyHFError err)
-                  _ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
+                  Never -> runLogger (logError $ T.pack $ prettyShow err)
+                  _ -> runLogger (logError $ T.pack (prettyShow 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 $ prettyHFError err)
-                  _ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
+                  Never -> runLogger (logError $ T.pack $ prettyShow err)
+                  _ -> runLogger (logError $ T.pack (prettyShow 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 $ prettyHFError e
+                  logError $ T.pack $ prettyShow e
                  logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
                pure $ ExitFailure 3

@@ -417,14 +418,14 @@ install installCommand settings getAppState' runLogger = case installCommand of
                runLogger $ logInfo msg
              pure ExitSuccess
            VLeft e@(V (AlreadyInstalled _ _)) -> do
-              runLogger $ logWarn $ T.pack $ prettyHFError e
+              runLogger $ logWarn $ T.pack $ prettyShow 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 $ prettyHFError e
+              runLogger $ logWarn $ T.pack $ prettyShow e
              pure ExitSuccess
            VLeft (V (FileAlreadyExistsError fp)) -> do
              runLogger $ logWarn $
@@ -432,7 +433,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
              pure $ ExitFailure 3
            VLeft e -> do
              runLogger $ do
-                logError $ T.pack $ prettyHFError e
+                logError $ T.pack $ prettyShow e
                logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
              pure $ ExitFailure 4

@@ -467,14 +468,14 @@ install installCommand settings getAppState' runLogger = case installCommand of
                runLogger $ logInfo msg
              pure ExitSuccess
            VLeft e@(V (AlreadyInstalled _ _)) -> do
-              runLogger $ logWarn $ T.pack $ prettyHFError e
+              runLogger $ logWarn $ T.pack $ prettyShow 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 $ prettyHFError e
+              runLogger $ logWarn $ T.pack $ prettyShow e
              pure ExitSuccess
            VLeft (V (FileAlreadyExistsError fp)) -> do
              runLogger $ logWarn $
@@ -482,7 +483,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
              pure $ ExitFailure 3
            VLeft e -> do
              runLogger $ do
-                logError $ T.pack $ prettyHFError e
+                logError $ T.pack $ prettyShow e
                logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
              pure $ ExitFailure 4

@@ -516,14 +517,14 @@ install installCommand settings getAppState' runLogger = case installCommand of
                runLogger $ logInfo msg
              pure ExitSuccess
            VLeft e@(V (AlreadyInstalled _ _)) -> do
-              runLogger $ logWarn $ T.pack $ prettyHFError e
+              runLogger $ logWarn $ T.pack $ prettyShow 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 $ prettyHFError e
+              runLogger $ logWarn $ T.pack $ prettyShow e
              pure ExitSuccess
            VLeft (V (FileAlreadyExistsError fp)) -> do
              runLogger $ logWarn $
@@ -531,6 +532,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
              pure $ ExitFailure 3
            VLeft e -> do
              runLogger $ do
-                logError $ T.pack $ prettyHFError e
+                logError $ T.pack $ prettyShow e
                logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
              pure $ ExitFailure 4
--- a/app/ghcup/GHCup/OptParse/Nuke.hs
+++ b/app/ghcup/GHCup/OptParse/Nuke.hs
@@ -26,6 +26,7 @@ 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)
@@ -94,5 +95,5 @@ nuke appState runLogger = do
                      pure ExitSuccess

                VLeft e -> do
-                  runLogger $ logError $ T.pack $ prettyHFError e
+                  runLogger $ logError $ T.pack $ prettyShow e
                  pure $ ExitFailure 15
--- a/app/ghcup/GHCup/OptParse/Prefetch.hs
+++ b/app/ghcup/GHCup/OptParse/Prefetch.hs
@@ -30,6 +30,7 @@ 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)
@@ -215,5 +216,5 @@ prefetch prefetchCommand runAppState runLogger =
                VRight _ -> do
                      pure ExitSuccess
                VLeft e -> do
-                  runLogger $ logError $ T.pack $ prettyHFError e
+                  runLogger $ logError $ T.pack $ prettyShow e
                  pure $ ExitFailure 15
--- a/app/ghcup/GHCup/OptParse/Rm.hs
+++ b/app/ghcup/GHCup/OptParse/Rm.hs
@@ -34,6 +34,7 @@ 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)
@@ -178,7 +179,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
              postRmLog vi
              pure ExitSuccess
            VLeft  e -> do
-              runLogger $ logError $ T.pack $ prettyHFError e
+              runLogger $ logError $ T.pack $ prettyShow e
              pure $ ExitFailure 7

  rmCabal' tv =
@@ -193,7 +194,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
              postRmLog vi
              pure ExitSuccess
            VLeft  e -> do
-              runLogger $ logError $ T.pack $ prettyHFError e
+              runLogger $ logError $ T.pack $ prettyShow e
              pure $ ExitFailure 15

  rmHLS' tv =
@@ -208,7 +209,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
              postRmLog vi
              pure ExitSuccess
            VLeft  e -> do
-              runLogger $ logError $ T.pack $ prettyHFError e
+              runLogger $ logError $ T.pack $ prettyShow e
              pure $ ExitFailure 15

  rmStack' tv =
@@ -223,7 +224,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
              postRmLog vi
              pure ExitSuccess
            VLeft  e -> do
-              runLogger $ logError $ T.pack $ prettyHFError e
+              runLogger $ logError $ T.pack $ prettyShow e
              pure $ ExitFailure 15

  postRmLog vi =
--- a/app/ghcup/GHCup/OptParse/Run.hs
+++ b/app/ghcup/GHCup/OptParse/Run.hs
@@ -40,6 +40,7 @@ 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
@@ -265,11 +266,11 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
               case r' of
                 VRight _ -> pure ExitSuccess
                 VLeft e -> do
-                   runLogger $ logError $ T.pack $ prettyHFError e
+                   runLogger $ logError $ T.pack $ prettyShow e
                   pure $ ExitFailure 28
 #endif
         VLeft e -> do
-           runLogger $ logError $ T.pack $ prettyHFError e
+           runLogger $ logError $ T.pack $ prettyShow e
           pure $ ExitFailure 27

  where
--- a/app/ghcup/GHCup/OptParse/Set.hs
+++ b/app/ghcup/GHCup/OptParse/Set.hs
@@ -35,6 +35,7 @@ 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)
@@ -285,7 +286,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 $ prettyHFError e
+              runLogger $ logError $ T.pack $ prettyShow e
              pure $ ExitFailure 5


@@ -306,7 +307,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 $ prettyHFError e
+              runLogger $ logError $ T.pack $ prettyShow e
              pure $ ExitFailure 14

  setHLS' :: SetOptions
@@ -326,7 +327,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 $ prettyHFError e
+              runLogger $ logError $ T.pack $ prettyShow e
              pure $ ExitFailure 14


@@ -347,5 +348,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 $ prettyHFError e
+              runLogger $ logError $ T.pack $ prettyShow e
              pure $ ExitFailure 14
--- a/app/ghcup/GHCup/OptParse/ToolRequirements.hs
+++ b/app/ghcup/GHCup/OptParse/ToolRequirements.hs
@@ -23,6 +23,7 @@ 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
@@ -117,5 +118,5 @@ toolRequirements ToolReqOpts{..} runAppState runLogger = runToolRequirements run
    >>= \case
          VRight _ -> pure ExitSuccess
          VLeft  e -> do
-            runLogger $ logError $ T.pack $ prettyHFError e
+            runLogger $ logError $ T.pack $ prettyShow e
            pure $ ExitFailure 12
--- a/app/ghcup/GHCup/OptParse/UnSet.hs
+++ b/app/ghcup/GHCup/OptParse/UnSet.hs
@@ -31,6 +31,7 @@ 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)
@@ -188,7 +189,7 @@ unset unsetCommand runLeanAppState runLogger = case unsetCommand of
                runLogger $ logInfo "GHC successfully unset"
                pure ExitSuccess
              VLeft  e -> do
-                runLogger $ logError $ T.pack $ prettyHFError e
+                runLogger $ logError $ T.pack $ prettyShow e
                pure $ ExitFailure 14
  (UnsetCabal (UnsetOptions _)) -> do
    void $ runLeanAppState (VRight <$> unsetCabal)
--- a/app/ghcup/GHCup/OptParse/Upgrade.hs
+++ b/app/ghcup/GHCup/OptParse/Upgrade.hs
@@ -28,6 +28,7 @@ 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)
@@ -151,5 +152,5 @@ upgrade uOpts force' fatal Dirs{..} runAppState runLogger = do
        runLogger $ logWarn "No GHCup update available"
        pure ExitSuccess
      VLeft e -> do
-        runLogger $ logError $ T.pack $ prettyHFError e
+        runLogger $ logError $ T.pack $ prettyShow e
        pure $ ExitFailure 11
--- a/app/ghcup/GHCup/OptParse/Whereis.hs
+++ b/app/ghcup/GHCup/OptParse/Whereis.hs
@@ -34,6 +34,7 @@ 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)
@@ -287,7 +288,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
                liftIO $ putStr r
                pure ExitSuccess
              VLeft e -> do
-                runLogger $ logError $ T.pack $ prettyHFError e
+                runLogger $ logError $ T.pack $ prettyShow e
                pure $ ExitFailure 30
    (WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) ->
      runLeanWhereIs leanAppstate (do
@@ -301,7 +302,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
                liftIO $ putStr r
                pure ExitSuccess
              VLeft e -> do
-                runLogger $ logError $ T.pack $ prettyHFError e
+                runLogger $ logError $ T.pack $ prettyShow e
                pure $ ExitFailure 30

    (WhereisTool tool whereVer, WhereisOptions{..}) -> do
@@ -317,7 +318,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
                liftIO $ putStr r
                pure ExitSuccess
              VLeft e -> do
-                runLogger $ logError $ T.pack $ prettyHFError e
+                runLogger $ logError $ T.pack $ prettyShow e
                pure $ ExitFailure 30

    (WhereisBaseDir, _) -> do
--- a/app/ghcup/Main.hs
+++ b/app/ghcup/Main.hs
@@ -89,6 +89,7 @@ toSettings options = do
         noNetwork   = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork
         gpgSetting  = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg
         platformOverride = optPlatform <|> (uPlatformOverride <|> Types.platformOverride defaultSettings)
+         mirrors  = fromMaybe (Types.mirrors defaultSettings) uMirrors
     in (Settings {..}, keyBindings)
 #if defined(INTERNAL_DOWNLOADER)
   defaultDownloader = Internal
@@ -206,7 +207,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
                                          VRight r -> pure r
                                          VLeft e -> do
                                            runLogger
-                                              (logError $ T.pack $ prettyHFError e)
+                                              (logError $ T.pack $ prettyShow e)
                                            exitWith (ExitFailure 2)

                ghcupInfo <-
@@ -218,7 +219,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
                          VRight r -> pure r
                          VLeft  e -> do
                            runLogger
-                              (logError $ T.pack $ prettyHFError e)
+                              (logError $ T.pack $ prettyShow e)
                            exitWith (ExitFailure 2)
                let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig

@@ -266,7 +267,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
                  VRight _ -> pure ()
                  VLeft e -> do
                    runLogger
-                      (logError $ T.pack $ prettyHFError e)
+                      (logError $ T.pack $ prettyShow e)
                    exitWith (ExitFailure 30)
                pure s'

@@ -311,7 +312,6 @@ 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 ()
--- a/data/config.yaml
+++ b/data/config.yaml
@@ -92,3 +92,30 @@ url-source:
 #     tag: Linux
 #   version: '18.04'
 platform-override: null
+
+# Support for mirrors. Currently there are 3 hosts you can mirror:
+#   - github.com (for stack and some older HLS versions)
+#   - raw.githubusercontent.com (for the yaml metadata)
+#   - downloads.haskell.org (for everything else)
+#
+# E.g. when we have 'https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-0.0.7.yaml'
+# and the following mirror config
+#
+#  "raw.githubusercontent.com":
+#    authority:
+#      host: "mirror.sjtu.edu.cn"
+#    pathPrefix: "ghcup/yaml"
+#
+# Then the resulting url will be 'https://mirror.sjtu.edu.cn/ghcup/yaml/haskell/ghcup-metadata/master/ghcup-0.0.7.yaml'
+mirrors:
+  "github.com":
+    authority:
+      host: "mirror.sjtu.edu.cn"
+  "raw.githubusercontent.com":
+    authority:
+      host: "mirror.sjtu.edu.cn"
+    pathPrefix: "ghcup/yaml"
+  "downloads.haskell.org":
+    authority:
+      host: "mirror.sjtu.edu.cn"
+
--- a/lib/GHCup.hs
+++ b/lib/GHCup.hs
@@ -78,6 +78,7 @@ import           Text.Regex.Posix

 import qualified Data.Text                     as T
 import qualified Streamly.Prelude              as S
+import Text.PrettyPrint.HughesPJClass (prettyShow)



@@ -327,7 +328,7 @@ upgradeGHCup mtarget force' fatal = do
    Just pa
      | fatal -> throwE (ToolShadowed GHCup pa destFile latestVer)
      | otherwise ->
-        lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed GHCup pa destFile latestVer)
+        lift $ logWarn $ T.pack $ prettyShow (ToolShadowed GHCup pa destFile latestVer)

  pure latestVer

--- a/lib/GHCup/Cabal.hs
+++ b/lib/GHCup/Cabal.hs
@@ -50,6 +50,7 @@ import           System.FilePath
 import           System.IO.Error

 import qualified Data.Text                     as T
+import Text.PrettyPrint.HughesPJClass (prettyShow)



@@ -234,7 +235,7 @@ setCabal ver = do

  liftIO (isShadowed cabalbin) >>= \case
    Nothing -> pure ()
-    Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed Cabal pa cabalbin ver)
+    Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed Cabal pa cabalbin ver)

  pure ()

--- a/lib/GHCup/Download.hs
+++ b/lib/GHCup/Download.hs
@@ -75,6 +75,7 @@ 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
@@ -175,7 +176,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 (prettyHFError e) downloader) >> pure Nothing)
+                   Lax -> lift (warnCache (prettyShow e) downloader) >> pure Nothing)
               . fmap Just
               . smartDl
               $ uri
@@ -333,19 +334,21 @@ download :: ( MonadReader env m
         -> Maybe FilePath    -- ^ optional filename
         -> Bool              -- ^ whether to read an write etags
         -> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath
-download uri gpgUri eDigest eCSize dest mfn etags
+download rawUri gpgUri eDigest eCSize dest mfn etags
  | scheme == "https" = liftE dl
  | scheme == "http"  = liftE dl
  | scheme == "file"  = do
-      let destFile' = T.unpack . decUTF8Safe $ view pathL' uri
+      let destFile' = T.unpack . decUTF8Safe $ view pathL' rawUri
      lift $ logDebug $ "using local file: " <> T.pack destFile'
      forM_ eDigest (liftE . flip checkDigest destFile')
      pure destFile'
  | otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)

 where
-  scheme = view (uriSchemeL' % schemeBSL') uri
+  scheme = view (uriSchemeL' % schemeBSL') rawUri
  dl = do
+    Settings{ mirrors } <- lift getSettings
+    let uri = applyMirrors mirrors rawUri
    baseDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile uri mfn
    lift $ logInfo $ "downloading: " <> (decUTF8Safe . serializeURIRef') uri <> " as file " <> T.pack baseDestFile

@@ -391,7 +394,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 (prettyHFError (GPGError e))
+                        (\e -> if gpgSetting == GPGStrict then throwE (GPGError e) else lift $ logWarn $ T.pack (prettyShow (GPGError e))
                        ) $ do
                      o' <- liftIO getGpgOpts
                      lift $ logDebug $ "downloading: " <> (decUTF8Safe . serializeURIRef') gpgUri' <> " as file " <> T.pack gpgDestFile
@@ -485,10 +488,7 @@ 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
@@ -751,3 +751,17 @@ getLastHeader = T.unlines . lastDef [] . filter (\x -> not (null x)) . splitOn [

 tmpFile :: FilePath -> FilePath
 tmpFile = (<.> "tmp")
+
+
+applyMirrors :: DownloadMirrors -> URI -> URI
+applyMirrors (DM ms) uri@(URI { uriAuthority = Just (Authority { authorityHost = Host host }) }) =
+  case M.lookup (decUTF8Safe host) ms of
+    Nothing -> uri
+    Just (DownloadMirror auth (Just prefix)) ->
+      uri { uriAuthority = Just auth
+          , uriPath = E.encodeUtf8 $ T.pack ("/" <> T.unpack prefix <> (T.unpack . decUTF8Safe . uriPath $ uri))
+          }
+    Just (DownloadMirror auth Nothing) ->
+      uri { uriAuthority = Just auth }
+applyMirrors _ uri = uri
+
--- a/lib/GHCup/Errors.hs
+++ b/lib/GHCup/Errors.hs
@@ -6,7 +6,6 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeOperators           #-}
 {-# LANGUAGE FlexibleInstances           #-}
-{-# LANGUAGE RankNTypes           #-}

 {-|
 Module      : GHCup.Errors
@@ -35,150 +34,9 @@ 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 =
-  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
-  eNum _ = eBase (Proxy :: Proxy a)
-
-  eBase :: Proxy a -> Int
-
-  eDesc :: Proxy a -> String
-
-
    ------------------------
    --[ Low-level errors ]--
    ------------------------
@@ -193,32 +51,20 @@ 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 (eDesc (Proxy :: Proxy NoDownload))
-
-instance HFErrorProject NoDownload where
-  eBase _ = 10
-  eDesc _ = "Unable to find a download for the requested version/distro."
+    text "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 (eDesc (Proxy :: Proxy NoUpdate))
-
-instance HFErrorProject NoUpdate where
-  eBase _ = 20
-  eDesc _ = "No update available or necessary."
+  pPrint NoUpdate = text "No update available or necessary."

 -- | The Architecture is unknown and unsupported.
 data NoCompatibleArch = NoCompatibleArch String
@@ -228,21 +74,13 @@ 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 (eDesc (Proxy :: Proxy DistroNotFound))
-
-instance HFErrorProject DistroNotFound where
-  eBase _ = 40
-  eDesc _ = "Unable to figure out the distribution of the host"
+    text "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
@@ -252,21 +90,12 @@ 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 (eDesc (Proxy :: Proxy UnsupportedScheme))
-
-instance HFErrorProject UnsupportedScheme where
-  eBase _ = 60
-  eDesc _ = "The scheme is not supported (such as ftp)."
+  pPrint UnsupportedScheme = text "The scheme is not supported (such as ftp)."

 -- | Unable to copy a file.
 data CopyError = CopyError String
@@ -276,10 +105,6 @@ 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
@@ -289,10 +114,6 @@ 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
@@ -301,10 +122,6 @@ 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
@@ -314,10 +131,6 @@ 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
@@ -327,9 +140,6 @@ 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}
@@ -339,10 +149,6 @@ 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
@@ -352,10 +158,6 @@ 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

@@ -363,10 +165,6 @@ 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
@@ -377,10 +175,6 @@ 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
@@ -389,10 +183,6 @@ 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
@@ -402,10 +192,6 @@ 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)
@@ -416,10 +202,6 @@ 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

@@ -427,10 +209,6 @@ 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
@@ -441,175 +219,6 @@ 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
@@ -633,16 +242,125 @@ instance Pretty ContentLengthError where

 instance Exception ContentLengthError

-instance HFErrorProject ContentLengthError where
-  eBase _ = 340
-  eDesc _ = "File content length verification failed"
+-- | 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."
+         )

    -------------------------
    --[ High-level errors ]--
    -------------------------

 -- | A download failed. The underlying error is encapsulated.
-data DownloadFailed = forall xs . (HFErrorProject (V xs), ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => DownloadFailed (V xs)
+data DownloadFailed = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => DownloadFailed (V xs)

 instance Pretty DownloadFailed where
  pPrint (DownloadFailed reason) =
@@ -652,12 +370,7 @@ instance Pretty DownloadFailed where

 deriving instance Show DownloadFailed

-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)
+data InstallSetError = forall xs1 xs2 . (Show (V xs1), Pretty (V xs1), Show (V xs2), Pretty (V xs2)) => InstallSetError (V xs1) (V xs2)

 instance Pretty InstallSetError where
  pPrint (InstallSetError reason1 reason2) =
@@ -668,15 +381,9 @@ 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), HFErrorProject (V es)) => BuildFailed FilePath (V es)
+data BuildFailed = forall es . (ToVariantMaybe BuildFailed es, PopVariant BuildFailed es, Pretty (V es), Show (V es)) => BuildFailed FilePath (V es)

 instance Pretty BuildFailed where
  pPrint (BuildFailed path reason) =
@@ -686,28 +393,18 @@ 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), HFErrorProject (V es)) => GHCupSetError (V es)
+data GHCupSetError = forall es . (ToVariantMaybe GHCupSetError es, PopVariant GHCupSetError es, Show (V es), Pretty (V es)) => GHCupSetError (V es)

 instance Pretty GHCupSetError where
  pPrint (GHCupSetError reason) =
    case reason of
      VMaybe (_ :: GHCupSetError) -> pPrint reason
-      _ -> text "Setting the current version failed:" <+> pPrint reason
+      _ -> text "Setting the current GHC 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) ]--
@@ -724,10 +421,6 @@ instance Pretty ParseError where

 instance Exception ParseError

-instance HFErrorProject ParseError where
-  eBase _ = 500
-  eDesc _ = "A parse error occured."
-

 data UnexpectedListLength = UnexpectedListLength String
  deriving Show
@@ -738,10 +431,6 @@ 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

@@ -751,10 +440,6 @@ instance Pretty NoUrlBase where

 instance Exception NoUrlBase

-instance HFErrorProject NoUrlBase where
-  eBase _ = 520
-  eDesc _ = "URL does not have a base filename."
-


    ------------------------
@@ -774,23 +459,6 @@ 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)
@@ -809,22 +477,6 @@ 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"
@@ -833,37 +485,5 @@ 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."
--- 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 $ prettyHFError (ToolShadowed GHC pa fullF (_tvVersion ver))
+          Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed GHC pa fullF (_tvVersion ver))

  when (isNothing mBinDir) $ do
    -- create symlink for share dir
--- a/lib/GHCup/HLS.hs
+++ b/lib/GHCup/HLS.hs
@@ -68,6 +68,7 @@ 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
@@ -633,7 +634,7 @@ setHLS ver shls mBinDir = do

      liftIO (isShadowed wrapper) >>= \case
        Nothing -> pure ()
-        Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed HLS pa wrapper ver)
+        Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed HLS pa wrapper ver)


 unsetHLS :: ( MonadMask m
--- a/lib/GHCup/Prelude.hs
+++ b/lib/GHCup/Prelude.hs
@@ -41,26 +41,24 @@ import GHCup.Prelude.Posix
 import           Control.Monad.IO.Class
 import           Control.Monad.Reader
 import           Haskus.Utils.Variant.Excepts
-import           Text.PrettyPrint.HughesPJClass ( Pretty )
+import           Text.PrettyPrint.HughesPJClass ( prettyShow, 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 . prettyHFError $ v))
+catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ 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)
--- a/lib/GHCup/Stack.hs
+++ b/lib/GHCup/Stack.hs
@@ -50,6 +50,7 @@ import           System.FilePath
 import           System.IO.Error

 import qualified Data.Text                     as T
+import Text.PrettyPrint.HughesPJClass (prettyShow)



@@ -233,7 +234,7 @@ setStack ver = do

  liftIO (isShadowed stackbin) >>= \case
    Nothing -> pure ()
-    Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed Cabal pa stackbin ver)
+    Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed Cabal pa stackbin ver)

  pure ()

--- 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(..) )
@@ -274,6 +274,23 @@ instance NFData DownloadInfo
    --[ Others ]--
    --------------

+data DownloadMirror = DownloadMirror {
+     authority :: Authority
+   , pathPrefix :: Maybe Text
+} deriving (Eq, Ord, GHC.Generic, Show)
+
+instance NFData DownloadMirror
+
+newtype DownloadMirrors = DM (Map Text DownloadMirror)
+  deriving (Eq, Ord, GHC.Generic, Show)
+
+instance NFData DownloadMirrors
+
+instance NFData UserInfo
+instance NFData Host
+instance NFData Port
+instance NFData Authority
+

 -- | How to descend into a tar archive.
 data TarDir = RealDir FilePath
@@ -316,12 +333,13 @@ data UserSettings = UserSettings
  , uUrlSource   :: Maybe URLSource
  , uNoNetwork   :: Maybe Bool
  , uGPGSetting  :: Maybe GPGSetting
-  , uPlatformOverride    :: Maybe PlatformRequest
+  , uPlatformOverride :: Maybe PlatformRequest
+  , uMirrors     :: Maybe DownloadMirrors
  }
  deriving (Show, GHC.Generic)

 defaultUserSettings :: UserSettings
-defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing

 fromSettings :: Settings -> Maybe KeyBindings -> UserSettings
 fromSettings Settings{..} Nothing =
@@ -338,6 +356,7 @@ fromSettings Settings{..} Nothing =
    , uUrlSource = Just urlSource
    , uGPGSetting = Just gpgSetting
    , uPlatformOverride = platformOverride
+    , uMirrors = Just mirrors
  }
 fromSettings Settings{..} (Just KeyBindings{..}) =
  let ukb = UserKeyBindings
@@ -364,6 +383,7 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
    , uUrlSource = Just urlSource
    , uGPGSetting = Just gpgSetting
    , uPlatformOverride = platformOverride
+    , uMirrors = Just mirrors
  }

 data UserKeyBindings = UserKeyBindings
@@ -445,6 +465,7 @@ data Settings = Settings
  , gpgSetting       :: GPGSetting
  , noColor          :: Bool -- this also exists in LoggerConfig
  , platformOverride :: Maybe PlatformRequest
+  , mirrors          :: DownloadMirrors
  }
  deriving (Show, GHC.Generic)

@@ -452,7 +473,7 @@ defaultMetaCache :: Integer
 defaultMetaCache = 300 -- 5 minutes

 defaultSettings :: Settings
-defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing
+defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing (DM mempty)

 instance NFData Settings

@@ -632,7 +653,15 @@ 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
--- a/lib/GHCup/Types/JSON.hs
+++ b/lib/GHCup/Types/JSON.hs
@@ -29,6 +29,7 @@ import           Control.Applicative            ( (<|>) )
 import           Data.Aeson              hiding (Key)
 import           Data.Aeson.TH
 import           Data.Aeson.Types        hiding (Key)
+import           Data.ByteString                ( ByteString )
 import           Data.List.NonEmpty             ( NonEmpty(..) )
 import           Data.Text.Encoding            as E
 import           Data.Versions
@@ -225,6 +226,12 @@ instance FromJSON VersionCmp where
      Right r -> pure r
      Left  e -> fail (MP.errorBundlePretty e)

+instance ToJSON ByteString where
+  toJSON = toJSON . E.decodeUtf8With E.lenientDecode
+
+instance FromJSON ByteString where
+  parseJSON = withText "ByteString" $ \t -> pure $ E.encodeUtf8 t
+
 versionCmpToText :: VersionCmp -> T.Text
 versionCmpToText (VR_gt   ver') = "> " <> prettyV ver'
 versionCmpToText (VR_gteq ver') = ">= " <> prettyV ver'
@@ -320,6 +327,12 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupI
 deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
 deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
 deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Port
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Host
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''UserInfo
+deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' (T.unpack . T.toLower) . T.stripPrefix (T.pack "authority") . T.pack $ str' } ''Authority
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadMirror
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadMirrors
 deriveToJSON defaultOptions { fieldLabelModifier = kebab } ''Settings
 deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key

@@ -356,4 +369,3 @@ instance FromJSON URLSource where
      pure (AddSource r)

 deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings
-
--- 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 (prettyHFError pe)
+      lift $ logDebug $ T.pack (prettyShow pe)
      throwE pe

 processBranches :: T.Text -> [String]
Author	SHA1	Message	Date
Julian Ospald	fffaa65b7f	Don't install stack by default in CI	2023-01-04 00:58:05 +08:00
Julian Ospald	703be0a706	Add support for mirrors wrt #357	2023-01-04 00:36:07 +08:00