diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index 8de86b1..7dcc1b0 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -85,7 +85,7 @@ validate dls = do [i|FreeBSD missing for #{t} #{v'} #{arch}|] checkUniqueTags tool = do - let allTags = join $ fmap snd $ availableToolVersions dls tool + let allTags = join $ M.elems $ availableToolVersions dls tool let nonUnique = fmap fst . filter (\(_, b) -> not b) @@ -118,7 +118,7 @@ validate dls = do -- a tool must have at least one of each mandatory tags 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 False -> do lift $ $(logError) [i|Tag #{t} missing from #{tool}|] diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 786a010..3ded405 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -684,10 +684,7 @@ Report bugs at |] , TagNotFound ] - let runListGHC = - runLogger - . flip runReaderT settings - . runE @'[FileDoesNotExistError] + let runListGHC = runE @'[] . runLogger let runRmGHC = 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 {..}) -> (runListGHC $ do - liftIO $ listVersions dls lTool lCriteria + l <- listVersions dls lTool lCriteria + pure l ) >>= \case VRight r -> do @@ -1024,14 +1022,16 @@ printListResult lr = do , fmap toLower . show $ lTool , T.unpack . prettyVer $ lVer , 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 putStrLn $ formatted -checkForUpdates :: (MonadIO m, MonadFail m, MonadLogger m) +checkForUpdates :: (MonadThrow m, MonadIO m, MonadFail m, MonadLogger m) => GHCupDownloads -> m () checkForUpdates dls = do @@ -1057,7 +1057,7 @@ checkForUpdates dls = do where latestInstalled tool = (fmap lVer . lastMay) - <$> liftIO (listVersions dls (Just tool) (Just ListInstalled)) + <$> (listVersions dls (Just tool) (Just ListInstalled)) prettyDebugInfo :: DebugInfo -> String diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 307e030..0150580 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -9,6 +9,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module GHCup where @@ -305,25 +306,38 @@ data ListResult = ListResult , lVer :: Version , lTag :: [Tag] , lInstalled :: Bool - , lSet :: Bool - , fromSrc :: Bool + , lSet :: Bool -- ^ currently active version + , fromSrc :: Bool -- ^ compiled from source + , lStray :: Bool -- ^ not in download info } - deriving Show + deriving (Eq, Ord, Show) -availableToolVersions :: GHCupDownloads -> Tool -> [(Version, [Tag])] -availableToolVersions av tool = toListOf - (ix tool % to (fmap (\(v, vi) -> (v, (_viTags vi))) . Map.toList) % folded) +availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version [Tag] +availableToolVersions av tool = view + (at tool % non Map.empty % to (fmap (_viTags))) av -listVersions :: GHCupDownloads +-- | List all versions from the download info, as well as stray +-- versions. +listVersions :: (MonadLogger m, MonadIO m) + => GHCupDownloads -> Maybe Tool -> Maybe ListCriteria - -> IO [ListResult] + -> m [ListResult] listVersions av lt criteria = case lt of 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 ghcvers <- listVersions av (Just GHC) criteria cabalvers <- listVersions av (Just Cabal) criteria @@ -331,21 +345,60 @@ listVersions av lt criteria = case lt of pure (ghcvers <> cabalvers <> ghcupvers) 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 t (v, tags) = case t of GHC -> do lSet <- fmap (maybe False (== v)) $ ghcSet lInstalled <- ghcInstalled v fromSrc <- ghcSrcInstalled v - pure ListResult { lVer = v, lTag = tags, lTool = t, .. } + pure ListResult { lVer = v, lTag = tags, lTool = t, lStray = False, .. } Cabal -> do lSet <- fmap (== v) $ cabalSet 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 let lSet = prettyPVP ghcUpVer == prettyVer v 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] diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 22a9ad8..e103ad7 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -162,7 +162,7 @@ ghcSrcInstalled ver = do doesFileExist (ghcdir ghcUpSrcBuiltFile) -ghcSet :: (MonadIO m, MonadThrow m) => m (Maybe Version) +ghcSet :: (MonadIO m) => m (Maybe Version) ghcSet = do ghcBin <- ( [rel|ghc|]) <$> liftIO ghcupBinDir