Fix listTools to always show currently installed GHCup

This commit is contained in:
Julian Ospald 2021-07-27 22:13:22 +02:00
parent 85003900d7
commit 5a34191b88
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
3 changed files with 34 additions and 12 deletions

View File

@ -126,7 +126,7 @@ validate dls _ = do
_ -> lift $ $(logWarn) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|] _ -> lift $ $(logWarn) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|]
checkUniqueTags tool = do checkUniqueTags tool = do
let allTags = join $ M.elems $ availableToolVersions dls tool let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
let nonUnique = let nonUnique =
fmap fst fmap fst
. filter (\(_, b) -> not b) . filter (\(_, b) -> not b)
@ -164,7 +164,7 @@ validate dls _ = do
-- a tool must have at least one of each mandatory tags -- a tool must have at least one of each mandatory tags
checkMandatoryTags tool = do checkMandatoryTags tool = do
let allTags = join $ M.elems $ availableToolVersions dls tool let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
forM_ [Latest, Recommended] $ \t -> case elem t allTags of forM_ [Latest, Recommended] $ \t -> case elem t allTags of
False -> do False -> do
lift $ $(logError) [i|Tag #{t} missing from #{tool}|] lift $ $(logError) [i|Tag #{t} missing from #{tool}|]
@ -174,7 +174,7 @@ validate dls _ = do
-- all GHC versions must have a base tag -- all GHC versions must have a base tag
checkGHCHasBaseVersion = do checkGHCHasBaseVersion = do
let allTags = M.toList $ availableToolVersions dls GHC let allTags = M.toList $ availableToolVersions dls GHC
forM allTags $ \(ver, tags) -> case any isBase tags of forM allTags $ \(ver, _viTags -> tags) -> case any isBase tags of
False -> do False -> do
lift $ $(logError) [i|Base tag missing from GHC ver #{ver}|] lift $ $(logError) [i|Base tag missing from GHC ver #{ver}|]
addError addError

View File

@ -1061,6 +1061,7 @@ tagCompleter tool add = listIOCompleter $ do
VRight ghcupInfo -> do VRight ghcupInfo -> do
let allTags = filter (\t -> t /= Old) let allTags = filter (\t -> t /= Old)
$ join $ join
$ fmap _viTags
$ M.elems $ M.elems
$ availableToolVersions (_ghcupDownloads ghcupInfo) tool $ availableToolVersions (_ghcupDownloads ghcupInfo) tool
pure $ nub $ (add ++) $ fmap tagToString allTags pure $ nub $ (add ++) $ fmap tagToString allTags

View File

@ -965,9 +965,9 @@ data ListResult = ListResult
-- | Extract all available tool versions and their tags. -- | Extract all available tool versions and their tags.
availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version [Tag] availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version VersionInfo
availableToolVersions av tool = view availableToolVersions av tool = view
(at tool % non Map.empty % to (fmap _viTags)) (at tool % non Map.empty)
av av
@ -1018,7 +1018,9 @@ listVersions lt' criteria = do
Stack -> do Stack -> do
slr <- strayStacks avTools sSet stacks slr <- strayStacks avTools sSet stacks
pure (sort (slr ++ lr)) pure (sort (slr ++ lr))
GHCup -> pure lr GHCup -> do
let cg = currentGHCup avTools
pure (sort (cg : lr))
Nothing -> do Nothing -> do
ghcvers <- go (Just GHC) cSet cabals hlsSet' hlses sSet stacks ghcvers <- go (Just GHC) cSet cabals hlsSet' hlses sSet stacks
cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses sSet stacks cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses sSet stacks
@ -1033,7 +1035,7 @@ listVersions lt' criteria = do
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
) )
=> Map.Map Version [Tag] => Map.Map Version VersionInfo
-> m [ListResult] -> m [ListResult]
strayGHCs avTools = do strayGHCs avTools = do
ghcs <- getInstalledGHCs ghcs <- getInstalledGHCs
@ -1081,7 +1083,7 @@ listVersions lt' criteria = do
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
) )
=> Map.Map Version [Tag] => Map.Map Version VersionInfo
-> Maybe Version -> Maybe Version
-> [Either FilePath Version] -> [Either FilePath Version]
-> m [ListResult] -> m [ListResult]
@ -1115,7 +1117,7 @@ listVersions lt' criteria = do
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m) , MonadIO m)
=> Map.Map Version [Tag] => Map.Map Version VersionInfo
-> Maybe Version -> Maybe Version
-> [Either FilePath Version] -> [Either FilePath Version]
-> m [ListResult] -> m [ListResult]
@ -1150,7 +1152,7 @@ listVersions lt' criteria = do
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
) )
=> Map.Map Version [Tag] => Map.Map Version VersionInfo
-> Maybe Version -> Maybe Version
-> [Either FilePath Version] -> [Either FilePath Version]
-> m [ListResult] -> m [ListResult]
@ -1178,6 +1180,25 @@ listVersions lt' criteria = do
[i|Could not parse version of stray directory #{e}|] [i|Could not parse version of stray directory #{e}|]
pure Nothing pure Nothing
currentGHCup :: Map.Map Version VersionInfo -> ListResult
currentGHCup av =
let currentVer = pvpToVersion ghcUpVer
listVer = Map.lookup currentVer av
latestVer = fst <$> headOf (getTagged Latest) av
recommendedVer = fst <$> headOf (getTagged Latest) av
isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer
in ListResult { lVer = currentVer
, lTag = maybe (if isOld then [Old] else []) _viTags listVer
, lCross = Nothing
, lTool = GHCup
, fromSrc = False
, lStray = isNothing listVer
, lSet = True
, lInstalled = True
, lNoBindist = False
, hlsPowered = False
}
-- NOTE: this are not cross ones, because no bindists -- NOTE: this are not cross ones, because no bindists
toListResult :: ( MonadLogger m toListResult :: ( MonadLogger m
, MonadReader env m , MonadReader env m
@ -1194,9 +1215,9 @@ listVersions lt' criteria = do
-> [Either FilePath Version] -> [Either FilePath Version]
-> Maybe Version -> Maybe Version
-> [Either FilePath Version] -> [Either FilePath Version]
-> (Version, [Tag]) -> (Version, VersionInfo)
-> m ListResult -> m ListResult
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, tags) = do toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, _viTags -> tags) = do
case t of case t of
GHC -> do GHC -> do
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v