diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index d7f3a88..34d8995 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -23,6 +23,7 @@ import GHCup.Utils.MegaParsec import GHCup.Utils.Prelude import GHCup.Version +import Control.Exception.Safe #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif @@ -53,7 +54,7 @@ import System.Console.Pretty import System.Environment import System.Exit import System.IO hiding ( appendFile ) -import Text.Read +import Text.Read hiding ( lift ) import Text.Layout.Table import URI.ByteString @@ -917,7 +918,7 @@ Report bugs at |] , TagNotFound ] - let runListGHC = runE @'[] . runLogger + let runListGHC = runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] let runRmGHC = runLogger . flip runReaderT settings . runE @'[NotInstalled] @@ -1000,7 +1001,14 @@ Report bugs at |] runLogger ($(logError) [i|Error fetching download info: #{e}|]) exitWith (ExitFailure 2) - runLogger $ checkForUpdates dls + (runLogger + . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ checkForUpdates dls + ) + >>= \case + VRight _ -> pure () + VLeft e -> do + runLogger + ($(logError) [i|Error checking for upgrades: #{e}|]) ----------------------- @@ -1353,7 +1361,8 @@ printListResult raw lr = do , intercalate "," $ (fmap printTag $ sort lTag) , intercalate "," $ (if fromSrc then [color' Blue "compiled"] else mempty) - ++ (if lStray then [color' Blue "stray"] else mempty) + ++ (if lStray then [color' Yellow "stray"] else mempty) + ++ (if lNoBindist then [color' Red "no-bindist"] else mempty) ] ) lr @@ -1367,28 +1376,34 @@ printListResult raw lr = do True -> flip const False -> color -checkForUpdates :: (MonadThrow m, MonadIO m, MonadFail m, MonadLogger m) +checkForUpdates :: (MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m) => GHCupDownloads - -> m () + -> Excepts + '[ NoCompatiblePlatform + , NoCompatibleArch + , DistroNotFound + ] + m + () checkForUpdates dls = do forM_ (getLatest dls GHCup) $ \l -> do (Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer when (l > ghc_ver) - $ $(logWarn) + $ lift $ $(logWarn) [i|New GHCup version available: #{prettyVer l}. To upgrade, run 'ghcup upgrade'|] forM_ (getLatest dls GHC) $ \l -> do mghc_ver <- latestInstalled GHC forM mghc_ver $ \ghc_ver -> when (l > ghc_ver) - $ $(logWarn) + $ lift $ $(logWarn) [i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install ghc #{prettyVer l}'|] forM_ (getLatest dls Cabal) $ \l -> do mcabal_ver <- latestInstalled Cabal forM mcabal_ver $ \cabal_ver -> when (l > cabal_ver) - $ $(logWarn) + $ lift $ $(logWarn) [i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|] where diff --git a/ghcup.cabal b/ghcup.cabal index 619e5ba..85ec8c8 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -327,6 +327,7 @@ executable ghcup , pretty-terminal , resourcet , safe + , safe-exceptions , string-interpolate , table-layout , template-haskell diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 8ac1679..fe75673 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -357,6 +357,7 @@ data ListResult = ListResult , lSet :: Bool -- ^ currently active version , fromSrc :: Bool -- ^ compiled from source , lStray :: Bool -- ^ not in download info + , lNoBindist :: Bool -- ^ whether the version is available for this platform/arch } deriving (Eq, Ord, Show) @@ -369,28 +370,41 @@ availableToolVersions av tool = view -- | List all versions from the download info, as well as stray -- versions. -listVersions :: (MonadThrow m, MonadLogger m, MonadIO m) +listVersions :: ( MonadCatch m + , MonadLogger m + , MonadThrow m + , MonadLogger m + , MonadIO m + ) => GHCupDownloads -> Maybe Tool -> Maybe ListCriteria - -> m [ListResult] -listVersions av lt criteria = case lt of - Just t -> do - -- get versions from GHCupDownloads - let avTools = availableToolVersions av t - lr <- filter' <$> forM (Map.toList avTools) (liftIO . toListResult t) + -> Excepts + '[ NoCompatiblePlatform + , NoCompatibleArch + , DistroNotFound + ] + m + [ListResult] +listVersions av lt criteria = do + pfreq <- platformRequest + case lt of + Just t -> do + -- get versions from GHCupDownloads + let avTools = availableToolVersions av t + lr <- filter' <$> forM (Map.toList avTools) (liftIO . toListResult pfreq t) - case t of - -- append stray GHCs - GHC -> do - slr <- strayGHCs avTools - pure $ (sort (slr ++ lr)) - _ -> pure lr - Nothing -> do - ghcvers <- listVersions av (Just GHC) criteria - cabalvers <- listVersions av (Just Cabal) criteria - ghcupvers <- listVersions av (Just GHCup) criteria - pure (ghcvers <> cabalvers <> ghcupvers) + case t of + -- append stray GHCs + GHC -> do + slr <- lift $ strayGHCs avTools + pure $ (sort (slr ++ lr)) + _ -> pure lr + Nothing -> do + ghcvers <- listVersions av (Just GHC) criteria + cabalvers <- listVersions av (Just Cabal) criteria + ghcupvers <- listVersions av (Just GHCup) criteria + pure (ghcvers <> cabalvers <> ghcupvers) where strayGHCs :: (MonadThrow m, MonadLogger m, MonadIO m) @@ -412,6 +426,7 @@ listVersions av lt criteria = case lt of , lTag = [] , lInstalled = True , lStray = maybe True (const False) (Map.lookup _tvVersion avTools) + , lNoBindist = False , .. } Right tver@GHCTargetVersion{ .. } -> do @@ -424,6 +439,7 @@ listVersions av lt criteria = case lt of , lTag = [] , lInstalled = True , lStray = True -- NOTE: cross currently cannot be installed via bindist + , lNoBindist = False , .. } Left e -> do @@ -432,15 +448,17 @@ listVersions av lt criteria = case lt of pure Nothing -- NOTE: this are not cross ones, because no bindists - toListResult :: Tool -> (Version, [Tag]) -> IO ListResult - toListResult t (v, tags) = case t of + toListResult :: PlatformRequest -> Tool -> (Version, [Tag]) -> IO ListResult + toListResult pfreq t (v, tags) = case t of GHC -> do + let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av let tver = mkTVer v lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing lInstalled <- ghcInstalled tver fromSrc <- ghcSrcInstalled tver pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. } Cabal -> do + let lNoBindist = isLeft $ getDownloadInfo Cabal v pfreq av lSet <- fmap (maybe False (== v)) $ cabalSet lInstalled <- cabalInstalled v pure ListResult { lVer = v @@ -460,6 +478,7 @@ listVersions av lt criteria = case lt of , lTool = t , fromSrc = False , lStray = False + , lNoBindist = False , .. }