List stray tools

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}|]

app/ghcup/Main.hs

@@ -684,10 +684,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                     , TagNotFound
                     ]
 
-          let runListGHC =
+          let runListGHC = runE @'[] . runLogger
-                runLogger
-                  . flip runReaderT settings
-                  . runE @'[FileDoesNotExistError]
 
           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

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
+  , 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
 
 
-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]

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