diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 46c9d53..f257e2f 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -80,7 +80,7 @@ data Command | Rm RmOptions | DInfo | Compile CompileCommand - | Upgrade UpgradeOpts + | Upgrade UpgradeOpts Bool | NumericVersion | ToolRequirements @@ -194,9 +194,12 @@ com = ) <> command "upgrade" - ( Upgrade - <$> (info (upgradeOptsP <**> helper) (progDesc "Upgrade ghcup")) - ) + (info ((Upgrade <$> upgradeOptsP <*> + switch + (short 'f' <> long "force" <> help + "Force update" + ) + ) <**> helper) (progDesc "Upgrade ghcup")) <> command "compile" ( Compile @@ -626,6 +629,7 @@ main = do , NoCompatiblePlatform , NoCompatibleArch , NoDownload + , NoUpdate , FileDoesNotExistError , CopyError , DownloadFailed @@ -770,7 +774,7 @@ Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues VLeft e -> runLogger ($(logError) [i|#{e}|]) >> exitFailure - Upgrade (uOpts) -> do + Upgrade (uOpts) force -> do target <- case uOpts of UpgradeInplace -> do efp <- liftIO $ getExecutablePath @@ -783,7 +787,7 @@ Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues void $ (runUpgrade $ do - liftE $ upgradeGHCup dls target + liftE $ upgradeGHCup dls target force ) >>= \case VRight v' -> do @@ -791,6 +795,9 @@ Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues runLogger $ $(logInfo) [i|Successfully upgraded GHCup to version #{pretty_v}|] + VLeft (V NoUpdate) -> + runLogger $ $(logWarn) + [i|No GHCup update available|] VLeft e -> runLogger ($(logError) [i|#{e}|]) >> exitFailure diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 00d4339..f33ca53 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -675,6 +675,8 @@ upgradeGHCup :: ( MonadMask m ) => GHCupDownloads -> Maybe (Path Abs) -- ^ full file destination to write ghcup into + -> Bool -- ^ whether to force update regardless + -- of currently installed version -> Excepts '[ CopyError , DigestError @@ -683,12 +685,14 @@ upgradeGHCup :: ( MonadMask m , NoCompatibleArch , NoCompatiblePlatform , NoDownload + , NoUpdate ] m Version -upgradeGHCup dls mtarget = do +upgradeGHCup dls mtarget force = do lift $ $(logInfo) [i|Upgrading GHCup...|] let latestVer = fromJust $ getLatest dls GHCup + when (not force && (latestVer < pvpToVersion ghcUpVer)) $ throwE NoUpdate pfreq <- liftE platformRequest dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls tmp <- lift withGHCupTmpDir diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index d8ea801..9046c1c 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -30,6 +30,10 @@ data NoCompatiblePlatform = NoCompatiblePlatform String -- the platform we got data NoDownload = NoDownload deriving Show +-- | No update available or necessary. +data NoUpdate = NoUpdate + deriving Show + -- | The Architecture is unknown and unsupported. data NoCompatibleArch = NoCompatibleArch String deriving Show diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index dee954c..07acf14 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -240,3 +240,7 @@ addToCurrentEnv :: MonadIO m addToCurrentEnv adds = do cEnv <- liftIO $ getEnvironment pure (adds ++ cEnv) + + +pvpToVersion :: PVP -> Version +pvpToVersion = either (\_ -> error "Couldn't convert PVP to Version") id . version . prettyPVP