List stray tools

This commit is contained in:
Julian Ospald 2020-04-21 23:37:48 +02:00
parent 5b33c3f491
commit e637f90fae
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
4 changed files with 76 additions and 23 deletions

View File

@ -85,7 +85,7 @@ validate dls = do
[i|FreeBSD missing for #{t} #{v'} #{arch}|] [i|FreeBSD missing for #{t} #{v'} #{arch}|]
checkUniqueTags tool = do checkUniqueTags tool = do
let allTags = join $ fmap snd $ availableToolVersions dls tool let allTags = join $ M.elems $ availableToolVersions dls tool
let nonUnique = let nonUnique =
fmap fst fmap fst
. filter (\(_, b) -> not b) . filter (\(_, b) -> not b)
@ -118,7 +118,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 $ fmap snd $ availableToolVersions dls tool let allTags = join $ 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}|]

View File

@ -684,10 +684,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, TagNotFound , TagNotFound
] ]
let runListGHC = let runListGHC = runE @'[] . runLogger
runLogger
. flip runReaderT settings
. runE @'[FileDoesNotExistError]
let runRmGHC = let runRmGHC =
runLogger . flip runReaderT settings . runE @'[NotInstalled] runLogger . flip runReaderT settings . runE @'[NotInstalled]
@ -825,7 +822,8 @@ Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues
List (ListOptions {..}) -> List (ListOptions {..}) ->
(runListGHC $ do (runListGHC $ do
liftIO $ listVersions dls lTool lCriteria l <- listVersions dls lTool lCriteria
pure l
) )
>>= \case >>= \case
VRight r -> do VRight r -> do
@ -1024,14 +1022,16 @@ printListResult lr = do
, fmap toLower . show $ lTool , fmap toLower . show $ lTool
, T.unpack . prettyVer $ lVer , T.unpack . prettyVer $ lVer
, intercalate "," $ ((fmap . fmap) toLower . fmap show $ lTag) , intercalate "," $ ((fmap . fmap) toLower . fmap show $ lTag)
, if fromSrc then (color Blue "compiled") else mempty , intercalate "," $
(if fromSrc then [color Blue "compiled"] else mempty)
++ (if lStray then [color Blue "stray"] else mempty)
] ]
) )
lr lr
putStrLn $ formatted putStrLn $ formatted
checkForUpdates :: (MonadIO m, MonadFail m, MonadLogger m) checkForUpdates :: (MonadThrow m, MonadIO m, MonadFail m, MonadLogger m)
=> GHCupDownloads => GHCupDownloads
-> m () -> m ()
checkForUpdates dls = do checkForUpdates dls = do
@ -1057,7 +1057,7 @@ checkForUpdates dls = do
where where
latestInstalled tool = (fmap lVer . lastMay) latestInstalled tool = (fmap lVer . lastMay)
<$> liftIO (listVersions dls (Just tool) (Just ListInstalled)) <$> (listVersions dls (Just tool) (Just ListInstalled))
prettyDebugInfo :: DebugInfo -> String prettyDebugInfo :: DebugInfo -> String

View File

@ -9,6 +9,7 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module GHCup where module GHCup where
@ -305,25 +306,38 @@ data ListResult = ListResult
, lVer :: Version , lVer :: Version
, lTag :: [Tag] , lTag :: [Tag]
, lInstalled :: Bool , lInstalled :: Bool
, lSet :: Bool , lSet :: Bool -- ^ currently active version
, fromSrc :: Bool , fromSrc :: Bool -- ^ compiled from source
, lStray :: Bool -- ^ not in download info
} }
deriving Show deriving (Eq, Ord, Show)
availableToolVersions :: GHCupDownloads -> Tool -> [(Version, [Tag])] availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version [Tag]
availableToolVersions av tool = toListOf availableToolVersions av tool = view
(ix tool % to (fmap (\(v, vi) -> (v, (_viTags vi))) . Map.toList) % folded) (at tool % non Map.empty % to (fmap (_viTags)))
av av
listVersions :: GHCupDownloads -- | List all versions from the download info, as well as stray
-- versions.
listVersions :: (MonadLogger m, MonadIO m)
=> GHCupDownloads
-> Maybe Tool -> Maybe Tool
-> Maybe ListCriteria -> Maybe ListCriteria
-> IO [ListResult] -> m [ListResult]
listVersions av lt criteria = case lt of listVersions av lt criteria = case lt of
Just t -> do Just t -> do
filter' <$> forM (availableToolVersions av t) (toListResult t) -- get versions from GHCupDownloads
let avTools = availableToolVersions av t
lr <- filter' <$> forM (Map.toList avTools) (liftIO . toListResult t)
case t of
-- append stray GHCs
GHC -> do
slr <- strayGHCs avTools
pure $ (sort (slr ++ lr))
_ -> pure lr
Nothing -> do Nothing -> do
ghcvers <- listVersions av (Just GHC) criteria ghcvers <- listVersions av (Just GHC) criteria
cabalvers <- listVersions av (Just Cabal) criteria cabalvers <- listVersions av (Just Cabal) criteria
@ -331,21 +345,60 @@ listVersions av lt criteria = case lt of
pure (ghcvers <> cabalvers <> ghcupvers) pure (ghcvers <> cabalvers <> ghcupvers)
where where
strayGHCs :: (MonadLogger m, MonadIO m)
=> Map.Map Version [Tag]
-> m [ListResult]
strayGHCs avTools = do
ghcdir <- liftIO $ ghcupGHCBaseDir
fs <- liftIO $ getDirsFiles' ghcdir
fmap catMaybes $ forM fs $ \(toFilePath -> f) -> do
case version . decUTF8Safe $ f of
Right v' -> do
case Map.lookup v' avTools of
Just _ -> pure Nothing
Nothing -> do
lSet <- fmap (maybe False (== v')) $ ghcSet
fromSrc <- liftIO $ ghcSrcInstalled v'
pure $ Just $ ListResult
{ lTool = GHC
, lVer = v'
, lTag = []
, lInstalled = True
, lStray = maybe True (const False) (Map.lookup v' avTools)
, ..
}
Left e -> do
$(logWarn)
[i|Could not parse version of stray directory #{toFilePath ghcdir}/#{f}: #{e}|]
pure Nothing
toListResult :: Tool -> (Version, [Tag]) -> IO ListResult toListResult :: Tool -> (Version, [Tag]) -> IO ListResult
toListResult t (v, tags) = case t of toListResult t (v, tags) = case t of
GHC -> do GHC -> do
lSet <- fmap (maybe False (== v)) $ ghcSet lSet <- fmap (maybe False (== v)) $ ghcSet
lInstalled <- ghcInstalled v lInstalled <- ghcInstalled v
fromSrc <- ghcSrcInstalled v fromSrc <- ghcSrcInstalled v
pure ListResult { lVer = v, lTag = tags, lTool = t, .. } pure ListResult { lVer = v, lTag = tags, lTool = t, lStray = False, .. }
Cabal -> do Cabal -> do
lSet <- fmap (== v) $ cabalSet lSet <- fmap (== v) $ cabalSet
let lInstalled = lSet let lInstalled = lSet
pure ListResult { lVer = v, lTag = tags, lTool = t, fromSrc = False, .. } pure ListResult { lVer = v
, lTag = tags
, lTool = t
, fromSrc = False
, lStray = False
, ..
}
GHCup -> do GHCup -> do
let lSet = prettyPVP ghcUpVer == prettyVer v let lSet = prettyPVP ghcUpVer == prettyVer v
let lInstalled = lSet let lInstalled = lSet
pure ListResult { lVer = v, lTag = tags, lTool = t, fromSrc = False, .. } pure ListResult { lVer = v
, lTag = tags
, lTool = t
, fromSrc = False
, lStray = False
, ..
}
filter' :: [ListResult] -> [ListResult] filter' :: [ListResult] -> [ListResult]

View File

@ -162,7 +162,7 @@ ghcSrcInstalled ver = do
doesFileExist (ghcdir </> ghcUpSrcBuiltFile) doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
ghcSet :: (MonadIO m, MonadThrow m) => m (Maybe Version) ghcSet :: (MonadIO m) => m (Maybe Version)
ghcSet = do ghcSet = do
ghcBin <- (</> [rel|ghc|]) <$> liftIO ghcupBinDir ghcBin <- (</> [rel|ghc|]) <$> liftIO ghcupBinDir