Improve AlreadyInstalled

CHANGELOG.md

@@ -1,5 +1,13 @@
 # Revision history for ghcup
 
+## 0.1.17.10 -- 2022-05-12
+
+* windows hotfix (hackage-only release)
+
+## 0.1.17.9 -- 2022-05-12
+
+* broken sdist (hackage-only release)
+
 ## 0.1.17.8 -- 2022-05-11
 
 * Fix a serious (but hard to trigger) bug when combining `--isolate <DIR>` with `--force`, please make sure to upgrade or avoid `--force`

app/ghcup/BrickMain.hs

@@ -437,7 +437,7 @@ install' _ (_, ListResult {..}) = do
               , TarDirDoesNotExist
               , FileAlreadyExistsError
               , ProcessError
-              , GHCupShadowed
+              , ToolShadowed
               , UninstallFailed
               , MergeFileTreeError
               ]

app/ghcup/GHCup/OptParse/Install.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE ViewPatterns      #-}
+{-# LANGUAGE TypeOperators     #-}
 
 module GHCup.OptParse.Install where
 
@@ -19,6 +20,7 @@ import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Utils.Dirs
+import           GHCup.Prelude
 import           GHCup.Prelude.Logger
 import           GHCup.Prelude.String.QQ
 
@@ -260,51 +262,7 @@ type InstallEffects = '[ AlreadyInstalled
                        , ProcessError
                        , UninstallFailed
                        , MergeFileTreeError
-
-                       , (AlreadyInstalled, ())
-                       , (UnknownArchive, ())
-                       , (ArchiveResult, ())
-                       , (FileDoesNotExistError, ())
-                       , (CopyError, ())
-                       , (NotInstalled, ())
-                       , (UninstallFailed, ())
-                       , (MergeFileTreeError, ())
-                       , (DirNotEmpty, ())
-                       , (NoDownload, ())
-                       , (BuildFailed, ())
-                       , (TagNotFound, ())
-                       , (DigestError, ())
-                       , (GPGError, ())
-                       , (DownloadFailed, ())
-                       , (TarDirDoesNotExist, ())
-                       , (NextVerNotFound, ())
-                       , (NoToolVersionSet, ())
-                       , (FileAlreadyExistsError, ())
-                       , (ProcessError, ())
-
-                       , (AlreadyInstalled, NotInstalled)
-                       , (UnknownArchive, NotInstalled)
-                       , (ArchiveResult, NotInstalled)
-                       , (FileDoesNotExistError, NotInstalled)
-                       , (CopyError, NotInstalled)
-                       , (NotInstalled, NotInstalled)
-                       , (DirNotEmpty, NotInstalled)
-                       , (NoDownload, NotInstalled)
-                       , (NotInstalled, NotInstalled)
-                       , (UninstallFailed, NotInstalled)
-                       , (MergeFileTreeError, NotInstalled)
-                       , (BuildFailed, NotInstalled)
-                       , (TagNotFound, NotInstalled)
-                       , (DigestError, NotInstalled)
-                       , (GPGError, NotInstalled)
-                       , (DownloadFailed, NotInstalled)
-                       , (TarDirDoesNotExist, NotInstalled)
-                       , (NextVerNotFound, NotInstalled)
-                       , (NoToolVersionSet, NotInstalled)
-                       , (FileAlreadyExistsError, NotInstalled)
-                       , (ProcessError, NotInstalled)
-
-                       , ((), NotInstalled)
+                       , InstallSetError
                        ]
 
 
@@ -319,58 +277,27 @@ runInstTool appstate' mInstPlatform =
     @InstallEffects
 
 
-type InstallGHCEffects = '[ TagNotFound
-                          , NextVerNotFound
-                          , NoToolVersionSet
+type InstallGHCEffects = '[ AlreadyInstalled
+                          , ArchiveResult
                           , BuildFailed
+                          , CopyError
+                          , DigestError
                           , DirNotEmpty
-                          , AlreadyInstalled
-                          , UninstallFailed
+                          , DownloadFailed
+                          , FileAlreadyExistsError
+                          , FileDoesNotExistError
+                          , GPGError
                           , MergeFileTreeError
-
-                          , (AlreadyInstalled, NotInstalled)
-                          , (UnknownArchive, NotInstalled)
-                          , (ArchiveResult, NotInstalled)
-                          , (FileDoesNotExistError, NotInstalled)
-                          , (CopyError, NotInstalled)
-                          , (NotInstalled, NotInstalled)
-                          , (DirNotEmpty, NotInstalled)
-                          , (NoDownload, NotInstalled)
-                          , (UninstallFailed, NotInstalled)
-                          , (MergeFileTreeError, NotInstalled)
-                          , (BuildFailed, NotInstalled)
-                          , (TagNotFound, NotInstalled)
-                          , (DigestError, NotInstalled)
-                          , (GPGError, NotInstalled)
-                          , (DownloadFailed, NotInstalled)
-                          , (TarDirDoesNotExist, NotInstalled)
-                          , (NextVerNotFound, NotInstalled)
-                          , (NoToolVersionSet, NotInstalled)
-                          , (FileAlreadyExistsError, NotInstalled)
-                          , (ProcessError, NotInstalled)
-
-                          , (AlreadyInstalled, ())
-                          , (UnknownArchive, ())
-                          , (ArchiveResult, ())
-                          , (FileDoesNotExistError, ())
-                          , (CopyError, ())
-                          , (NotInstalled, ())
-                          , (DirNotEmpty, ())
-                          , (NoDownload, ())
-                          , (UninstallFailed, ())
-                          , (MergeFileTreeError, ())
-                          , (BuildFailed, ())
-                          , (TagNotFound, ())
-                          , (DigestError, ())
-                          , (GPGError, ())
-                          , (DownloadFailed, ())
-                          , (TarDirDoesNotExist, ())
-                          , (NextVerNotFound, ())
-                          , (NoToolVersionSet, ())
-                          , (FileAlreadyExistsError, ())
-                          , (ProcessError, ())
-
-                          , ((), NotInstalled)
+                          , NextVerNotFound
+                          , NoDownload
+                          , NoToolVersionSet
+                          , NotInstalled
+                          , ProcessError
+                          , TagNotFound
+                          , TarDirDoesNotExist
+                          , UninstallFailed
+                          , UnknownArchive
+                          , InstallSetError
                           ]
 
 runInstGHC :: AppState
@@ -405,23 +332,23 @@ install installCommand settings getAppState' runLogger = case installCommand of
     (case instBindist of
        Nothing -> runInstGHC s' instPlatform $ do
          (v, vi) <- liftE $ fromVersion instVer GHC
-         void $ liftE $ sequenceE (installGHCBin
+         liftE $ runBothE' (installGHCBin
                      (_tvVersion v)
                      (maybe GHCupInternal IsolateDir isolateDir)
                      forceInstall
                    )
-                   $ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing
+                   $ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing
          pure vi
        Just uri -> do
          runInstGHC s'{ settings = settings {noVerify = True}} instPlatform $ do
            (v, vi) <- liftE $ fromVersion instVer GHC
-           void $ liftE $ sequenceE (installGHCBindist
+           liftE $ runBothE' (installGHCBindist
                        (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
                        (_tvVersion v)
                        (maybe GHCupInternal IsolateDir isolateDir)
                        forceInstall
                      )
-                     $ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing
+                     $ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing
            pure vi
       )
         >>= \case
@@ -431,20 +358,18 @@ install installCommand settings getAppState' runLogger = case installCommand of
                   runLogger $ logInfo msg
                 pure ExitSuccess
 
-              VLeft (V (AlreadyInstalled _ v, ())) -> do
-                runLogger $ logWarn $
-                  "GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"
+              VLeft e@(V (AlreadyInstalled _ _)) -> do
+                runLogger $ logWarn $ T.pack $ prettyShow e
                 pure ExitSuccess
-              VLeft (V (AlreadyInstalled _ v)) -> do
-                runLogger $ logWarn $
-                  "GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"
+              VLeft e@(V (AlreadyInstalled _ _)) -> do
+                runLogger $ logWarn $ T.pack $ prettyShow e
                 pure ExitSuccess
 
               VLeft (V (DirNotEmpty fp)) -> do
                 runLogger $ logError $
                   "Install directory " <> T.pack fp <> " is not empty."
                 pure $ ExitFailure 3
-              VLeft (V (DirNotEmpty fp, ())) -> do
+              VLeft (V (DirNotEmpty fp)) -> do
                 runLogger $ logError $
                   "Install directory " <> T.pack fp <> " is not empty."
                 pure $ ExitFailure 3
@@ -456,7 +381,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
                     "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
+              VLeft err@(V (BuildFailed tmpdir _)) -> do
                 case keepDirs settings of
                   Never -> runLogger (logError $ T.pack $ prettyShow err)
                   _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
@@ -477,21 +402,21 @@ install installCommand settings getAppState' runLogger = case installCommand of
     (case instBindist of
        Nothing -> runInstTool s' instPlatform $ do
          (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
-         void $ liftE $ sequenceE (installCabalBin
+         liftE $ runBothE' (installCabalBin
                                     v
                                     (maybe GHCupInternal IsolateDir isolateDir)
                                     forceInstall
-                                  ) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v
+                                  ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v
          pure vi
        Just uri -> do
          runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
            (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
-           void $ liftE $ sequenceE (installCabalBindist
+           liftE $ runBothE' (installCabalBindist
                                       (DownloadInfo uri Nothing "")
                                       v
                                       (maybe GHCupInternal IsolateDir isolateDir)
                                       forceInstall
-                                    ) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v
+                                    ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v
            pure vi
       )
       >>= \case
@@ -500,19 +425,17 @@ install installCommand settings getAppState' runLogger = case installCommand of
               forM_ (_viPostInstall =<< vi) $ \msg ->
                 runLogger $ logInfo msg
               pure ExitSuccess
-            VLeft (V (AlreadyInstalled _ v)) -> do
-              runLogger $ logWarn $
-                "Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'"
+            VLeft e@(V (AlreadyInstalled _ _)) -> do
+              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 (V (AlreadyInstalled _ v, ())) -> do
-              runLogger $ logWarn $
-                "Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'"
+            VLeft e@(V (AlreadyInstalled _ _)) -> do
+              runLogger $ logWarn $ T.pack $ prettyShow e
               pure ExitSuccess
-            VLeft (V (FileAlreadyExistsError fp, ())) -> do
+            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
@@ -528,22 +451,22 @@ install installCommand settings getAppState' runLogger = case installCommand of
      (case instBindist of
        Nothing -> runInstTool s' instPlatform $ do
          (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
-         void $ liftE $ sequenceE (installHLSBin
+         liftE $ runBothE' (installHLSBin
                                     v
                                     (maybe GHCupInternal IsolateDir isolateDir)
                                     forceInstall
-                                  ) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing
+                                  ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing
          pure vi
        Just uri -> do
          runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
            (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
            -- TODO: support legacy
-           void $ liftE $ sequenceE (installHLSBindist
+           liftE $ runBothE' (installHLSBindist
                                       (DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "")
                                       v
                                       (maybe GHCupInternal IsolateDir isolateDir)
                                       forceInstall
-                                    ) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing
+                                    ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing
            pure vi
       )
       >>= \case
@@ -552,27 +475,17 @@ install installCommand settings getAppState' runLogger = case installCommand of
               forM_ (_viPostInstall =<< vi) $ \msg ->
                 runLogger $ logInfo msg
               pure ExitSuccess
-            VLeft (V (AlreadyInstalled _ v)) -> do
-              runLogger $ logWarn $
-                  "HLS ver "
-                <> prettyVer v
-                <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force "
-                <> prettyVer v
-                <> "'"
+            VLeft e@(V (AlreadyInstalled _ _)) -> do
+              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 (V (AlreadyInstalled _ v, ())) -> do
-              runLogger $ logWarn $
-                  "HLS ver "
-                <> prettyVer v
-                <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force "
-                <> prettyVer v
-                <> "'"
+            VLeft e@(V (AlreadyInstalled _ _)) -> do
+              runLogger $ logWarn $ T.pack $ prettyShow e
               pure ExitSuccess
-            VLeft (V (FileAlreadyExistsError fp, ())) -> do
+            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
@@ -588,21 +501,21 @@ install installCommand settings getAppState' runLogger = case installCommand of
      (case instBindist of
         Nothing -> runInstTool s' instPlatform $ do
           (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
-          void $ liftE $ sequenceE (installStackBin
+          liftE $ runBothE' (installStackBin
                                      v
                                      (maybe GHCupInternal IsolateDir isolateDir)
                                      forceInstall
-                                   ) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v
+                                   ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v
           pure vi
         Just uri -> do
           runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
             (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
-            void $ liftE $ sequenceE (installStackBindist
+            liftE $ runBothE' (installStackBindist
                                        (DownloadInfo uri Nothing "")
                                        v
                                        (maybe GHCupInternal IsolateDir isolateDir)
                                        forceInstall
-                                     ) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v
+                                     ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v
             pure vi
       )
       >>= \case
@@ -611,19 +524,17 @@ install installCommand settings getAppState' runLogger = case installCommand of
               forM_ (_viPostInstall =<< vi) $ \msg ->
                 runLogger $ logInfo msg
               pure ExitSuccess
-            VLeft (V (AlreadyInstalled _ v)) -> do
-              runLogger $ logWarn $
-                "Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'"
+            VLeft e@(V (AlreadyInstalled _ _)) -> do
+              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 (V (AlreadyInstalled _ v, ())) -> do
-              runLogger $ logWarn $
-                "Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'"
+            VLeft e@(V (AlreadyInstalled _ _)) -> do
+              runLogger $ logWarn $ T.pack $ prettyShow e
               pure ExitSuccess
-            VLeft (V (FileAlreadyExistsError fp, ())) -> do
+            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

app/ghcup/GHCup/OptParse/Upgrade.hs

@@ -94,7 +94,7 @@ type UpgradeEffects = '[ DigestError
                        , FileDoesNotExistError
                        , CopyError
                        , DownloadFailed
-                       , GHCupShadowed
+                       , ToolShadowed
                        ]
 
 

docs/guide.md

@@ -287,10 +287,11 @@ GHCup itself is also pre-installed on all platforms, but may use non-standard in
 GHCup supports verifying the GPG signature of the metadata file. The metadata file then contains SHA256 hashes of all downloads, so
 this is cryptographically secure.
 
-First, obtain the gpg key:
+First, obtain the gpg keys:
 
 ```sh
-gpg --batch --keyserver keys.openpgp.org --recv-keys 7784930957807690A66EBDBE3786C5262ECB4A3F
+gpg --batch --keyserver keys.openpgp.org     --recv-keys 7784930957807690A66EBDBE3786C5262ECB4A3F
+gpg --batch --keyserver keyserver.ubuntu.com --recv-keys FE5AB6C91FEA597C3B31180B73EDE9E8CFBAEF01
 ```
 
 Then verify the gpg key in one of these ways:

docs/install.md

@@ -187,7 +187,7 @@ Lower availability of bindists. Stack and HLS binaries are experimental.
 Download the binary for your platform at [https://downloads.haskell.org/~ghcup/](https://downloads.haskell.org/~ghcup/)
 and place it into your `PATH` anywhere.
 
-If you want to GPG verify the binaries, import the following key first: `7784930957807690A66EBDBE3786C5262ECB4A3F`.
+If you want to GPG verify the binaries, import the following keys first: `7784930957807690A66EBDBE3786C5262ECB4A3F` and `FE5AB6C91FEA597C3B31180B73EDE9E8CFBAEF01`.
 
 Then adjust your `PATH` in `~/.bashrc` (or similar, depending on your shell) like so:
 

ghcup.cabal

@@ -241,6 +241,7 @@ executable ghcup
     , directory             ^>=1.3.6.0
     , filepath              ^>=1.4.2.1
     , ghcup
+    , haskus-utils-types    ^>=1.5
     , haskus-utils-variant  ^>=3.2.1
     , libarchive            ^>=3.0.3.0
     , megaparsec            >=8.0.0    && <9.3

lib/GHCup.hs

@@ -77,6 +77,7 @@ import           Text.Regex.Posix
 
 import qualified Data.Text                     as T
 import qualified Streamly.Prelude              as S
+import Text.PrettyPrint.HughesPJClass (prettyShow)
 
 
 
@@ -291,7 +292,7 @@ upgradeGHCup :: ( MonadMask m
                    , DownloadFailed
                    , NoDownload
                    , NoUpdate
-                   , GHCupShadowed
+                   , ToolShadowed
                    ]
                   m
                   Version
@@ -322,17 +323,9 @@ upgradeGHCup mtarget force' fatal = do
   liftIO (isShadowed destFile) >>= \case
     Nothing -> pure ()
     Just pa
-      | fatal -> throwE (GHCupShadowed pa destFile latestVer)
+      | fatal -> throwE (ToolShadowed GHCup pa destFile latestVer)
       | otherwise ->
-        lift $ logWarn $ "ghcup is shadowed by "
-          <> T.pack pa
-          <> ". The upgrade will not be in effect, unless you remove "
-          <> T.pack pa
-          <> " or make sure "
-          <> T.pack destDir
-          <> " comes before "
-          <> T.pack (takeDirectory pa)
-          <> " in PATH."
+        lift $ logWarn $ T.pack $ prettyShow (ToolShadowed GHCup pa destFile latestVer)
 
   pure latestVer
 

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)
 
 
 
@@ -230,6 +231,10 @@ setCabal ver = do
   let destL = targetFile
   lift $ createLink destL cabalbin
 
+  liftIO (isShadowed cabalbin) >>= \case
+    Nothing -> pure ()
+    Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed Cabal pa cabalbin ver)
+
   pure ()
 
 unsetCabal :: ( MonadMask m

lib/GHCup/Errors.hs

@@ -137,10 +137,13 @@ data AlreadyInstalled = AlreadyInstalled Tool Version
 
 instance Pretty AlreadyInstalled where
   pPrint (AlreadyInstalled tool ver') =
-    pPrint tool <+> text "-" <+> pPrint ver' <+> text "is already installed"
+    pPrint tool <+> text "-" <+> pPrint ver' <+> text "is already installed;"
+    <+> text "if you really want to reinstall it, you may want to run 'ghcup install cabal --force" <+> (pPrint ver' <> text "'")
+
 
 -- | The Directory is supposed to be empty, but wasn't.
 data DirNotEmpty = DirNotEmpty {path :: FilePath}
+  deriving Show
 
 instance Pretty DirNotEmpty where
   pPrint (DirNotEmpty path) = do
@@ -308,19 +311,21 @@ instance Pretty HadrianNotFound where
   pPrint HadrianNotFound =
     text "Could not find Hadrian build files. Does this GHC version support Hadrian builds?"
 
-data GHCupShadowed = GHCupShadowed
+data ToolShadowed = ToolShadowed
+                       Tool
                        FilePath  -- shadow binary
                        FilePath  -- upgraded binary
                        Version   -- upgraded version
   deriving Show
 
-instance Pretty GHCupShadowed where
-  pPrint (GHCupShadowed sh up _) =
-    text ("ghcup is shadowed by "
+instance Pretty ToolShadowed where
+  pPrint (ToolShadowed tool sh up _) =
+    text (prettyShow tool
+         <> " is shadowed by "
          <> sh
-         <> ". The upgrade will not be in effect, unless you remove "
+         <> ".\nThe upgrade will not be in effect, unless you remove "
          <> sh
-         <> " or make sure "
+         <> "\nor make sure "
          <> takeDirectory up
          <> " comes before "
          <> takeDirectory sh
@@ -342,6 +347,17 @@ 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 Pretty InstallSetError where
+  pPrint (InstallSetError reason1 reason2) =
+     text "Both installation and setting the tool failed. Install error was:"
+      <+> pPrint reason1
+      <+> text "\nSet error was:"
+      <+> pPrint reason2
+
+deriving instance Show InstallSetError
+
 
 -- | A build failed.
 data BuildFailed = forall es . (ToVariantMaybe BuildFailed es, PopVariant BuildFailed es, Pretty (V es), Show (V es)) => BuildFailed FilePath (V es)

lib/GHCup/GHC.hs

@@ -442,6 +442,11 @@ setGHC ver sghc mBinDir = do
       destL <- binarySymLinkDestination binDir fileWithExt
       lift $ createLink destL fullF
 
+      when (targetFile == "ghc") $
+        liftIO (isShadowed fullF) >>= \case
+          Nothing -> pure ()
+          Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed GHC pa fullF (_tvVersion ver))
+
   when (isNothing mBinDir) $ do
     -- create symlink for share dir
     when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir (fromGHCupPath ghcdir) verS

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)
 
 
 
@@ -549,6 +550,10 @@ setHLS ver shls mBinDir = do
       when (isNothing mBinDir) $
         lift warnAboutHlsCompatibility
 
+      liftIO (isShadowed wrapper) >>= \case
+        Nothing -> pure ()
+        Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed HLS pa wrapper ver)
+
 
 unsetHLS :: ( MonadMask m
             , MonadReader env m

lib/GHCup/Prelude.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleInstances   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
 
 {-|
 Module      : GHCup.Prelude
@@ -27,6 +28,7 @@ module GHCup.Prelude
   )
 where
 
+import           GHCup.Errors
 import           GHCup.Prelude.Internal
 import           GHCup.Types.Optics   (HasLog)
 import           GHCup.Prelude.Logger (logWarn)
@@ -52,3 +54,29 @@ catchWarn :: forall es m env . ( Pretty (V es)
                              , Monad m) => Excepts es m () -> Excepts '[] m ()
 catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v))
 
+
+runBothE' :: forall e m a b .
+             ( Monad m
+             , Show (V e)
+             , Pretty (V e)
+             , PopVariant InstallSetError e
+             , LiftVariant' e (InstallSetError ': e)
+             , e :<< (InstallSetError ': e)
+             )
+          => Excepts e m a
+          -> Excepts e m b
+          -> Excepts (InstallSetError ': e) m ()
+runBothE' a1 a2 = do
+   r1 <- lift $ runE @e a1
+   r2 <- lift $ runE @e a2
+   case (r1, r2) of
+      (VLeft e1, VLeft e2) -> throwE (InstallSetError e1 e2)
+      (VLeft e , _       ) -> throwSomeE e
+      (_       , VLeft e ) -> throwSomeE e
+      (VRight _, VRight _) -> pure ()
+
+
+-- | Throw some exception
+throwSomeE :: forall es' es a m. (Monad m, LiftVariant es' es) => V es' -> Excepts es m a
+{-# INLINABLE throwSomeE #-}
+throwSomeE = Excepts . pure . VLeft . liftVariant

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)
 
 
 
@@ -229,6 +230,10 @@ setStack ver = do
 
   lift $ createLink targetFile stackbin
 
+  liftIO (isShadowed stackbin) >>= \case
+    Nothing -> pure ()
+    Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed Cabal pa stackbin ver)
+
   pure ()
 
 

scripts/bootstrap/bootstrap-haskell

@@ -763,7 +763,7 @@ if [ -z "${BOOTSTRAP_HASKELL_MINIMAL}" ] ; then
 
 	do_cabal_config_init $ask_cabal_config_init_answer
 
-	edo cabal new-update --ignore-project
+	edo cabal update --ignore-project
 else # don't install ghc and cabal
 	case "${plat}" in
 			MSYS*|MINGW*)