Allow to hide old versions of tools in TUI

app/ghcup-gen/Validate.hs

@@ -122,6 +122,7 @@ validate dls = do
    where
     isUniqueTag Latest         = True
     isUniqueTag Recommended    = True
+    isUniqueTag Old            = False
     isUniqueTag Prerelease     = False
     isUniqueTag (Base       _) = False
     isUniqueTag (UnknownTag _) = False

app/ghcup/BrickMain.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts  #-}
 
 module BrickMain where
 
@@ -48,31 +49,60 @@ import qualified Data.Vector                   as V
 import qualified Brick.Widgets.List            as L
 
 
-data AppState = AppState {
+data AppData = AppData {
     lr :: LR
   , dls :: GHCupDownloads
   , pfreq :: PlatformRequest
-}
+} deriving Show
+
+data AppSettings = AppSettings {
+    showAll :: Bool
+} deriving Show
+
+data AppState = AppState {
+    appData :: AppData
+  , appSettings :: AppSettings
+} deriving Show
 
 type LR = GenericList String Vector ListResult
 
 
-keyHandlers :: [(Char, String, AppState -> EventM n (Next AppState))]
+keyHandlers :: [ ( Char
+                 , AppSettings -> String
+                 , AppState -> EventM n (Next AppState)
+                 )
+               ]
 keyHandlers =
-  [ ('q', "Quit"     , halt)
+  [ ('q', const "Quit"     , halt)
-  , ('i', "Install"  , withIOAction install')
+  , ('i', const "Install"  , withIOAction install')
-  , ('u', "Uninstall", withIOAction del')
+  , ('u', const "Uninstall", withIOAction del')
-  , ('s', "Set"      , withIOAction set')
+  , ('s', const "Set"      , withIOAction set')
-  , ('c', "ChangeLog", withIOAction changelog')
+  , ('c', const "ChangeLog", withIOAction changelog')
+  , ( 'a'
+    , (\AppSettings {..} ->
+        if showAll then "Hide old versions" else "Show all versions"
+      )
+    , (\AppState {..} ->
+        let newAppSettings =
+                appSettings { showAll = not . showAll $ appSettings }
+        in  continue (AppState appData newAppSettings)
+      )
+    )
   ]
 
 
 ui :: AppState -> Widget String
-ui AppState {..} =
+ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}) } =
   ( padBottom Max
     $ ( withBorderStyle unicode
       $ borderWithLabel (str "GHCup")
-      $ (center $ (header <=> hBorder <=> renderList renderItem True (L.listReverse lr)))
+      $ ( center
+        $ (header <=> hBorder <=> renderList
+            renderItem
+            True
+            (L.listReverse lr)
+          )
+        )
       )
     )
     <=> footer
@@ -84,7 +114,7 @@ ui AppState {..} =
       . T.pack
       . foldr1 (\x y -> x <> "  " <> y)
       . (++ ["↑↓:Navigation"])
-      $ (fmap (\(c, s, _) -> (c : ':' : s)) keyHandlers)
+      $ (fmap (\(c, s, _) -> (c : ':' : s as)) keyHandlers)
   header =
     (minHSize 2 $ emptyWidget)
       <+> (padLeft (Pad 2) $ minHSize 6 $ str "Tool")
@@ -112,11 +142,11 @@ ui AppState {..} =
                )
               )
           <+> (minHSize 15 $ active $ (str ver))
-          <+> (padLeft (Pad 1) $ minHSize 25 $ if null lTag
+          <+> (let l = catMaybes . fmap printTag $ sort lTag
-                then emptyWidget
+               in padLeft (Pad 1) $ minHSize 25 $
-                else
+                  if null l
-                  foldr1 (\x y -> x <+> str "," <+> y)
+                  then emptyWidget
-                    $ (fmap printTag $ sort lTag)
+                  else foldr1 (\x y -> x <+> str "," <+> y) l
               )
           <+> ( padLeft (Pad 5)
               $ let notes = printNotes listResult
@@ -126,11 +156,12 @@ ui AppState {..} =
               )
           )
 
-  printTag Recommended        = withAttr "recommended" $ str "recommended"
+  printTag Recommended        = Just $ withAttr "recommended" $ str "recommended"
-  printTag Latest             = withAttr "latest" $ str "latest"
+  printTag Latest             = Just $ withAttr "latest" $ str "latest"
-  printTag Prerelease         = withAttr "prerelease" $ str "prerelease"
+  printTag Prerelease         = Just $ withAttr "prerelease" $ str "prerelease"
-  printTag (Base       pvp'') = str ("base-" ++ T.unpack (prettyPVP pvp''))
+  printTag (Base       pvp'') = Just $ str ("base-" ++ T.unpack (prettyPVP pvp''))
-  printTag (UnknownTag t    ) = str t
+  printTag Old                = Nothing
+  printTag (UnknownTag t    ) = Just $ str t
 
   printNotes ListResult {..} =
     (if hlsPowered then [withAttr "hls-powered" $ str "hls-powered"] else mempty
@@ -182,31 +213,64 @@ eventHandler :: AppState -> BrickEvent n e -> EventM n (Next AppState)
 eventHandler st (VtyEvent (Vty.EvResize _               _)) = continue st
 eventHandler st (VtyEvent (Vty.EvKey    (Vty.KChar 'q') _)) = halt st
 eventHandler st (VtyEvent (Vty.EvKey    Vty.KEsc        _)) = halt st
-eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) =
+eventHandler AppState { appData = AppData {..}, ..} (VtyEvent (Vty.EvKey (Vty.KUp) _))
-  continue (AppState (listMoveUp lr) dls pfreq)
+  = continue (AppState (AppData (listMoveUp lr) dls pfreq) appSettings)
-eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) =
+eventHandler AppState { appData = AppData {..}, ..} (VtyEvent (Vty.EvKey (Vty.KDown) _))
-  continue (AppState (listMoveDown lr) dls pfreq)
+  = continue (AppState (AppData (listMoveDown lr) dls pfreq) appSettings)
-eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
+eventHandler as@(AppState appD appS) (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
   case find (\(c', _, _) -> c' == c) keyHandlers of
     Nothing              -> continue as
+    Just ('a', _, handler) ->
+      if (not $ showAll appS) -- it's not swapped to `showAll` yet, but it will in the handler
+      then do
+        newAppData <- liftIO $ replaceLR (\_ -> True) appD
+        handler (AppState (selectLatest newAppData) appS)
+      else do -- hide old versions
+        newAppData <- liftIO $ replaceLR (filterVisible (not $ showAll appS)) appD
+        handler (AppState (selectLatest newAppData) appS)
     Just (_, _, handler) -> handler as
 eventHandler st _ = continue st
 
 
+replaceLR :: (ListResult -> Bool) -> AppData -> IO AppData
+replaceLR filterF (AppData {..}) = do
+  settings <- liftIO $ readIORef settings'
+  l        <- liftIO $ readIORef logger'
+  let runLogger = myLoggerT l
+  lV <- runLogger
+    . flip runReaderT settings
+    . fmap (V.fromList . filter filterF)
+    . listVersions dls Nothing Nothing
+    $ pfreq
+  pure $ AppData { lr = L.listReplace lV Nothing $ lr, .. }
+
+
+filterVisible :: Bool -> ListResult -> Bool
+filterVisible showAll e
+  | lInstalled e = True
+  | showAll      = True
+  | otherwise    = not (elem Old (lTag e))
+
+
 -- | Suspend the current UI and run an IO action in terminal. If the
 -- IO action returns a Left value, then it's thrown as userError.
 withIOAction :: (AppState -> (Int, ListResult) -> IO (Either String a))
              -> AppState
              -> EventM n (Next AppState)
-withIOAction action as = case listSelectedElement (lr as) of
+withIOAction action as = case listSelectedElement (lr . appData $ as) of
   Nothing      -> continue as
   Just (ix, e) -> suspendAndResume $ do
     action as (ix, e) >>= \case
       Left  err -> putStrLn $ ("Error: " <> err)
       Right _   -> putStrLn "Success"
-    apps <- (fmap . fmap)
+    apps <-
-      (\AppState {..} -> AppState { lr = listMoveTo ix lr, .. })
+      (fmap . fmap)
-      $ getAppState Nothing (pfreq as)
+          (\AppData {..} -> AppState
+            { appData     = AppData { lr = listMoveTo ix lr, .. }
+            , appSettings = (appSettings as)
+            }
+          )
+        $ getAppData Nothing (pfreq . appData $ as)
     case apps of
       Right nas -> do
         putStrLn "Press enter to continue"
@@ -216,7 +280,7 @@ withIOAction action as = case listSelectedElement (lr as) of
 
 
 install' :: AppState -> (Int, ListResult) -> IO (Either String ())
-install' AppState {..} (_, ListResult {..}) = do
+install' AppState { appData = AppData {..}} (_, ListResult {..}) = do
   settings <- readIORef settings'
   l        <- readIORef logger'
   let runLogger = myLoggerT l
@@ -307,7 +371,7 @@ del' _ (_, ListResult {..}) = do
 
 
 changelog' :: AppState -> (Int, ListResult) -> IO (Either String ())
-changelog' AppState {..} (_, ListResult {..}) = do
+changelog' AppState { appData = AppData {..}} (_, ListResult {..}) = do
   case getChangeLog dls lTool (Left lVer) of
     Nothing -> pure $ Left
       [i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|]
@@ -357,23 +421,30 @@ brickMain s muri l av pfreq' = do
   writeIORef logger'   l
   let runLogger = myLoggerT l
 
-  eApps <- getAppState (Just av) pfreq'
+  eAppData <- getAppData (Just av) pfreq'
-  case eApps of
+  case eAppData of
-    Right as -> defaultMain app (selectLatest as) $> ()
+    Right ad -> defaultMain app (AppState (selectLatest ad) defaultAppSettings) $> ()
     Left  e  -> do
       runLogger ($(logError) [i|Error building app state: #{show e}|])
       exitWith $ ExitFailure 2
- where
-  selectLatest :: AppState -> AppState
-  selectLatest AppState {..} =
-    (\ix -> AppState { lr = listMoveTo ix lr, .. })
-      . fromJust
-      . V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
-      $ (listElements lr)
 
 
-getAppState :: Maybe GHCupDownloads -> PlatformRequest -> IO (Either String AppState)
+selectLatest :: AppData -> AppData
-getAppState mg pfreq' = do
+selectLatest (AppData {..}) =
+  (\ix -> AppData { lr = listMoveTo ix lr, .. } )
+    . fromJust
+    . V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
+    $ (listElements lr)
+
+
+defaultAppSettings :: AppSettings
+defaultAppSettings = AppSettings {
+    showAll = False
+  }
+
+
+getDownloads' :: IO (Either String GHCupDownloads)
+getDownloads' = do
   muri     <- readIORef uri'
   settings <- readIORef settings'
   l        <- readIORef logger'
@@ -384,12 +455,27 @@ getAppState mg pfreq' = do
     . flip runReaderT settings
     . runE
       @'[JSONError, DownloadFailed, FileDoesNotExistError]
-    $ do
+    $ fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri)
-        dls <- maybe (fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri)) pure mg
-
-        lV <- lift $ listVersions dls Nothing Nothing pfreq'
-        pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls pfreq')
 
   case r of
     VRight a -> pure $ Right a
     VLeft  e -> pure $ Left [i|#{e}|]
+
+
+getAppData :: Maybe GHCupDownloads -> PlatformRequest -> IO (Either String AppData)
+getAppData mg pfreq' = do
+  settings <- readIORef settings'
+  l        <- readIORef logger'
+  let runLogger = myLoggerT l
+
+  r <- maybe getDownloads' (pure . Right) mg
+
+  runLogger
+    . flip runReaderT settings
+    $ do
+      case r of
+        Right dls -> do
+          lV <- listVersions dls Nothing Nothing pfreq'
+          pure $ Right $ (AppData (list "Tool versions"
+                (V.fromList . filter (filterVisible (showAll defaultAppSettings)) $ lV) 1) dls pfreq')
+        Left  e -> pure $ Left [i|#{e}|]

app/ghcup/Main.hs

@@ -1480,7 +1480,7 @@ printListResult raw lr = do
                      , case lCross of
                        Nothing -> T.unpack . prettyVer $ lVer
                        Just c  -> T.unpack (c <> "-" <> prettyVer lVer)
-                     , intercalate "," $ (fmap printTag $ sort lTag)
+                     , intercalate "," $ (filter (/= "") . fmap printTag $ sort lTag)
                      , intercalate ","
                      $  (if hlsPowered
                           then [color' Green "hls-powered"]
@@ -1507,6 +1507,7 @@ printListResult raw lr = do
   printTag Prerelease         = color' Red "prerelease"
   printTag (Base       pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
   printTag (UnknownTag t    ) = t
+  printTag Old                = ""
 
   color' = case raw of
     True  -> flip const

ghcup-0.0.3.yaml

@@ -95,6 +95,7 @@ ghcupDownloads:
     7.10.3:
       viTags:
       - base-4.8.2.0
+      - old
       viChangeLog: https://downloads.haskell.org/~ghc/7.10.3/docs/html/users_guide/release-7-10-1.html
       viSourceDL:
         dlUri: https://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-src.tar.xz
@@ -157,6 +158,7 @@ ghcupDownloads:
     8.0.2:
       viTags:
       - base-4.9.1.0
+      - old
       viChangeLog: https://downloads.haskell.org/~ghc/8.0.2/docs/html/users_guide/8.0.1-notes.html
       viSourceDL:
         dlUri: https://downloads.haskell.org/~ghc/8.0.2/ghc-8.0.2-src.tar.xz
@@ -214,6 +216,7 @@ ghcupDownloads:
     8.2.2:
       viTags:
       - base-4.10.1.0
+      - old
       viChangeLog: https://downloads.haskell.org/~ghc/8.2.2/docs/html/users_guide/8.2.2-notes.html
       viSourceDL:
         dlUri: https://downloads.haskell.org/~ghc/8.2.2/ghc-8.2.2-src.tar.xz
@@ -280,6 +283,7 @@ ghcupDownloads:
     8.4.1:
       viTags:
       - base-4.11.0.0
+      - old
       viChangeLog: https://downloads.haskell.org/~ghc/8.4.1/docs/html/users_guide/8.4.1-notes.html
       viSourceDL:
         dlUri: https://downloads.haskell.org/~ghc/8.4.1/ghc-8.4.1-src.tar.xz
@@ -328,6 +332,7 @@ ghcupDownloads:
     8.4.2:
       viTags:
       - base-4.11.1.0
+      - old
       viChangeLog: https://downloads.haskell.org/~ghc/8.4.2/docs/html/users_guide/8.4.2-notes.html
       viSourceDL:
         dlUri: https://downloads.haskell.org/~ghc/8.4.2/ghc-8.4.2-src.tar.xz
@@ -382,6 +387,7 @@ ghcupDownloads:
     8.4.3:
       viTags:
       - base-4.11.1.0
+      - old
       viChangeLog: https://downloads.haskell.org/~ghc/8.4.3/docs/html/users_guide/8.4.3-notes.html
       viSourceDL:
         dlUri: https://downloads.haskell.org/~ghc/8.4.3/ghc-8.4.3-src.tar.xz
@@ -504,6 +510,7 @@ ghcupDownloads:
     8.6.1:
       viTags:
       - base-4.12.0.0
+      - old
       viChangeLog: https://downloads.haskell.org/~ghc/8.6.1/docs/html/users_guide/8.6.1-notes.html
       viSourceDL:
         dlUri: https://downloads.haskell.org/~ghc/8.6.1/ghc-8.6.1-src.tar.xz
@@ -558,6 +565,7 @@ ghcupDownloads:
     8.6.2:
       viTags:
       - base-4.12.0.0
+      - old
       viChangeLog: https://downloads.haskell.org/~ghc/8.6.2/docs/html/users_guide/8.6.2-notes.html
       viSourceDL:
         dlUri: https://downloads.haskell.org/~ghc/8.6.2/ghc-8.6.2-src.tar.xz
@@ -603,6 +611,7 @@ ghcupDownloads:
     8.6.3:
       viTags:
       - base-4.12.0.0
+      - old
       viChangeLog: https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/8.6.3-notes.html
       viSourceDL:
         dlUri: https://downloads.haskell.org/~ghc/8.6.3/ghc-8.6.3-src.tar.xz
@@ -666,6 +675,7 @@ ghcupDownloads:
     8.6.4:
       viTags:
       - base-4.12.0.0
+      - old
       viChangeLog: https://downloads.haskell.org/~ghc/8.6.4/docs/html/users_guide/8.6.4-notes.html
       viSourceDL:
         dlUri: https://downloads.haskell.org/~ghc/8.6.4/ghc-8.6.4-src.tar.xz
@@ -788,6 +798,7 @@ ghcupDownloads:
     8.8.1:
       viTags:
       - base-4.13.0.0
+      - old
       viChangeLog: https://downloads.haskell.org/~ghc/8.8.1/docs/html/users_guide/8.8.1-notes.html
       viSourceDL:
         dlUri: https://downloads.haskell.org/~ghc/8.8.1/ghc-8.8.1-src.tar.xz
@@ -846,6 +857,7 @@ ghcupDownloads:
     8.8.2:
       viTags:
       - base-4.13.0.0
+      - old
       viChangeLog: https://downloads.haskell.org/~ghc/8.8.2/docs/html/users_guide/8.8.2-notes.html
       viSourceDL:
         dlUri: https://downloads.haskell.org/~ghc/8.8.2/ghc-8.8.2-src.tar.xz
@@ -904,6 +916,7 @@ ghcupDownloads:
     8.8.3:
       viTags:
       - base-4.13.0.0
+      - old
       viChangeLog: https://downloads.haskell.org/~ghc/8.8.3/docs/html/users_guide/8.8.3-notes.html
       viSourceDL:
         dlUri: https://downloads.haskell.org/~ghc/8.8.3/ghc-8.8.3-src.tar.xz
@@ -1041,6 +1054,7 @@ ghcupDownloads:
     8.10.1:
       viTags:
       - base-4.14.0.0
+      - old
       viChangeLog: https://downloads.haskell.org/~ghc/8.10.1/docs/html/users_guide/8.10.1-notes.html
       viSourceDL:
         dlUri: https://downloads.haskell.org/~ghc/8.10.1/ghc-8.10.1-src.tar.xz
@@ -1267,7 +1281,8 @@ ghcupDownloads:
             unknown_versioning: *ghc-901a1-32-deb9
   Cabal:
     2.4.1.0:
-      viTags: []
+      viTags:
+        - old
       viChangeLog: https://downloads.haskell.org/~cabal/cabal-install-2.4.1.0/changelog
       viArch:
         A_64:
@@ -1298,7 +1313,8 @@ ghcupDownloads:
               dlSubdir:
               dlHash: b2da736cc27609442b10f77fc1a687aba603a7a33045b722dbf1a0066fade198
     3.0.0.0:
-      viTags: []
+      viTags:
+        - old
       viChangeLog: https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/changelog
       viArch:
         A_64:

lib/GHCup/Types.hs

@@ -96,6 +96,7 @@ data Tag = Latest
          | Recommended
          | Prerelease
          | Base PVP
+         | Old                -- ^ old version are hidden by default in TUI
          | UnknownTag String  -- ^ used for upwardscompat
          deriving (Ord, Eq, GHC.Generic, Show) -- FIXME: manual JSON instance
 

lib/GHCup/Types/JSON.hs

@@ -55,6 +55,7 @@ instance ToJSON Tag where
   toJSON Latest             = String "Latest"
   toJSON Recommended        = String "Recommended"
   toJSON Prerelease         = String "Prerelease"
+  toJSON Old                = String "old"
   toJSON (Base       pvp'') = String ("base-" <> prettyPVP pvp'')
   toJSON (UnknownTag x    ) = String (T.pack x)
 
@@ -63,6 +64,7 @@ instance FromJSON Tag where
     "Latest"                             -> pure Latest
     "Recommended"                        -> pure Recommended
     "Prerelease"                         -> pure Prerelease
+    "old"                                -> pure Old
     ('b' : 'a' : 's' : 'e' : '-' : ver') -> case pvp (T.pack ver') of
       Right x -> pure $ Base x
       Left  e -> fail . show $ e