From 2e03b075f8f1a4cea07285e2cbbd61bc2198a89d Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 13 Nov 2021 22:50:15 +0100 Subject: [PATCH] Avoid redundant warnings when installing tools, fixes #283 --- app/ghcup/GHCup/OptParse/Common.hs | 44 +++++----------- app/ghcup/GHCup/OptParse/Compile.hs | 4 +- app/ghcup/Main.hs | 79 +++++++++++++++++++++++++++-- 3 files changed, 90 insertions(+), 37 deletions(-) diff --git a/app/ghcup/GHCup/OptParse/Common.hs b/app/ghcup/GHCup/OptParse/Common.hs index 0bc9d4a..64e2d6a 100644 --- a/app/ghcup/GHCup/OptParse/Common.hs +++ b/app/ghcup/GHCup/OptParse/Common.hs @@ -472,42 +472,22 @@ checkForUpdates :: ( MonadReader env m , MonadIO m , MonadFail m ) - => m () + => m [(Tool, Version)] checkForUpdates = do GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo lInstalled <- listVersions Nothing (Just ListInstalled) let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled - forM_ (getLatest dls GHCup) $ \(l, _) -> do - (Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer - when (l > ghc_ver) - $ logWarn $ - "New GHCup version available: " <> prettyVer l <> ". To upgrade, run 'ghcup upgrade'" + ghcup <- forMM (getLatest dls GHCup) $ \(l, _) -> do + (Right ghcup_ver) <- pure $ version $ prettyPVP ghcUpVer + if (l > ghcup_ver) then pure $ Just (GHCup, l) else pure Nothing - forM_ (getLatest dls GHC) $ \(l, _) -> do - let mghc_ver = latestInstalled GHC - forM mghc_ver $ \ghc_ver -> - when (l > ghc_ver) - $ logWarn $ - "New GHC version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install ghc " <> prettyVer l <> "'" + otherTools <- forM [GHC, Cabal, HLS, Stack] $ \t -> + forMM (getLatest dls t) $ \(l, _) -> do + let mver = latestInstalled t + forMM mver $ \ver -> + if (l > ver) then pure $ Just (t, l) else pure Nothing - forM_ (getLatest dls Cabal) $ \(l, _) -> do - let mcabal_ver = latestInstalled Cabal - forM mcabal_ver $ \cabal_ver -> - when (l > cabal_ver) - $ logWarn $ - "New Cabal version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install cabal " <> prettyVer l <> "'" - - forM_ (getLatest dls HLS) $ \(l, _) -> do - let mhls_ver = latestInstalled HLS - forM mhls_ver $ \hls_ver -> - when (l > hls_ver) - $ logWarn $ - "New HLS version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install hls " <> prettyVer l <> "'" - - forM_ (getLatest dls Stack) $ \(l, _) -> do - let mstack_ver = latestInstalled Stack - forM mstack_ver $ \stack_ver -> - when (l > stack_ver) - $ logWarn $ - "New Stack version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install stack " <> prettyVer l <> "'" + pure $ catMaybes (ghcup:otherTools) + where + forMM a f = fmap join $ forM a f diff --git a/app/ghcup/GHCup/OptParse/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs index 2d2f6aa..28e1506 100644 --- a/app/ghcup/GHCup/OptParse/Compile.hs +++ b/app/ghcup/GHCup/OptParse/Compile.hs @@ -429,11 +429,11 @@ compile :: ( Monad m ) => CompileCommand -> Settings + -> Dirs -> (forall eff a . ReaderT AppState m (VEither eff a) -> m (VEither eff a)) -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode -compile compileCommand settings runAppState runLogger = do - VRight Dirs{ .. } <- runAppState (VRight <$> getDirs) +compile compileCommand settings Dirs{..} runAppState runLogger = do case compileCommand of (CompileHLS HLSCompileOptions { .. }) -> do runCompileHLS runAppState (do diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index d550316..d8d05d6 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -20,6 +20,7 @@ import GHCup.Download import GHCup.Errors import GHCup.Platform import GHCup.Types +import GHCup.Types.Optics hiding ( toolRequirements ) import GHCup.Utils import GHCup.Utils.Logger import GHCup.Utils.Prelude @@ -39,6 +40,7 @@ import Data.Aeson.Encode.Pretty ( encodePretty ) import Data.Either import Data.Functor import Data.Maybe +import Data.Versions import GHC.IO.Encoding import Haskus.Utils.Variant.Excepts import Language.Haskell.TH @@ -191,7 +193,7 @@ Report bugs at |] ------------------------- - appState = do + let appState = do pfreq <- ( runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest ) >>= \case @@ -227,8 +229,28 @@ Report bugs at |] #if defined(BRICK) Interactive -> pure () #endif + -- check for new tools _ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case - Nothing -> runReaderT checkForUpdates s' + Nothing -> void . flip runReaderT s' . runE @'[TagNotFound, NextVerNotFound, NoToolVersionSet] $ do + newTools <- lift checkForUpdates + forM_ newTools $ \newTool@(t, l) -> do + -- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/283 + alreadyInstalling' <- alreadyInstalling optCommand newTool + when (not alreadyInstalling') $ + case t of + GHCup -> runLogger $ + logWarn ("New GHCup version available: " + <> prettyVer l + <> ". To upgrade, run 'ghcup upgrade'") + _ -> runLogger $ + logWarn ("New " + <> T.pack (prettyShow t) + <> " version available. " + <> "To upgrade, run 'ghcup install " + <> T.pack (prettyShow t) + <> " " + <> prettyVer l + <> "'") Just _ -> pure () -- TODO: always run for windows @@ -270,7 +292,7 @@ Report bugs at |] List lo -> list lo no_color runAppState Rm rmCommand -> rm rmCommand runAppState runLogger DInfo -> dinfo runAppState runLogger - Compile compileCommand -> compile compileCommand settings runAppState runLogger + Compile compileCommand -> compile compileCommand settings dirs runAppState runLogger Config configCommand -> config configCommand settings keybindings runLogger Whereis whereisOptions whereisCommand -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger @@ -287,4 +309,55 @@ Report bugs at |] pure () + where + alreadyInstalling :: ( HasLog env + , MonadFail m + , MonadReader env m + , HasGHCupInfo env + , HasDirs env + , MonadThrow m + , MonadIO m + , MonadCatch m + ) + => Command + -> (Tool, Version) + -> Excepts + '[ TagNotFound + , NextVerNotFound + , NoToolVersionSet + ] m Bool + alreadyInstalling (Install (Right InstallOptions{..})) (GHC, ver) = cmp' GHC instVer ver + alreadyInstalling (Install (Left (InstallGHC InstallOptions{..}))) (GHC, ver) = cmp' GHC instVer ver + alreadyInstalling (Install (Left (InstallCabal InstallOptions{..}))) (Cabal, ver) = cmp' Cabal instVer ver + alreadyInstalling (Install (Left (InstallHLS InstallOptions{..}))) (HLS, ver) = cmp' HLS instVer ver + alreadyInstalling (Install (Left (InstallStack InstallOptions{..}))) (Stack, ver) = cmp' Stack instVer ver + alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ ovewrwiteVer = Just over })) + (GHC, ver) = cmp' GHC (Just $ ToolVersion (mkTVer over)) ver + alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = Left tver })) + (GHC, ver) = cmp' GHC (Just $ ToolVersion (mkTVer tver)) ver + alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Just over })) + (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer over)) ver + alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = Left tver })) + (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver + alreadyInstalling _ _ = pure False + cmp' :: ( HasLog env + , MonadFail m + , MonadReader env m + , HasGHCupInfo env + , HasDirs env + , MonadThrow m + , MonadIO m + , MonadCatch m + ) + => Tool + -> Maybe ToolVersion + -> Version + -> Excepts + '[ TagNotFound + , NextVerNotFound + , NoToolVersionSet + ] m Bool + cmp' tool instVer ver = do + (v, _) <- liftE $ fromVersion instVer tool + pure (v == mkTVer ver)