From 57c34a07f2565b3d6b64a9fe8e4a585df7e1b527 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 9 Oct 2020 22:55:33 +0200 Subject: [PATCH] Allow to hide old versions of tools in TUI --- app/ghcup-gen/Validate.hs | 1 + app/ghcup/BrickMain.hs | 184 ++++++++++++++++++++++++++++---------- app/ghcup/Main.hs | 3 +- ghcup-0.0.3.yaml | 20 ++++- lib/GHCup/Types.hs | 1 + lib/GHCup/Types/JSON.hs | 2 + 6 files changed, 159 insertions(+), 52 deletions(-) diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index e67096c..f54eb97 100644 --- a/app/ghcup-gen/Validate.hs +++ b/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 diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index fdc2835..e8531eb 100644 --- a/app/ghcup/BrickMain.hs +++ b/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) - , ('i', "Install" , withIOAction install') - , ('u', "Uninstall", withIOAction del') - , ('s', "Set" , withIOAction set') - , ('c', "ChangeLog", withIOAction changelog') + [ ('q', const "Quit" , halt) + , ('i', const "Install" , withIOAction install') + , ('u', const "Uninstall", withIOAction del') + , ('s', const "Set" , withIOAction set') + , ('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 - then emptyWidget - else - foldr1 (\x y -> x <+> str "," <+> y) - $ (fmap printTag $ sort lTag) + <+> (let l = catMaybes . fmap printTag $ sort lTag + in padLeft (Pad 1) $ minHSize 25 $ + if null l + then emptyWidget + 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 Latest = withAttr "latest" $ str "latest" - printTag Prerelease = withAttr "prerelease" $ str "prerelease" - printTag (Base pvp'') = str ("base-" ++ T.unpack (prettyPVP pvp'')) - printTag (UnknownTag t ) = str t + printTag Recommended = Just $ withAttr "recommended" $ str "recommended" + printTag Latest = Just $ withAttr "latest" $ str "latest" + printTag Prerelease = Just $ withAttr "prerelease" $ str "prerelease" + printTag (Base pvp'') = Just $ str ("base-" ++ T.unpack (prettyPVP pvp'')) + 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) _)) = - continue (AppState (listMoveUp lr) dls pfreq) -eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) = - continue (AppState (listMoveDown lr) dls pfreq) -eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) = +eventHandler AppState { appData = AppData {..}, ..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) + = continue (AppState (AppData (listMoveUp lr) dls pfreq) appSettings) +eventHandler AppState { appData = AppData {..}, ..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) + = continue (AppState (AppData (listMoveDown lr) dls pfreq) appSettings) +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) - (\AppState {..} -> AppState { lr = listMoveTo ix lr, .. }) - $ getAppState Nothing (pfreq as) + apps <- + (fmap . fmap) + (\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' - case eApps of - Right as -> defaultMain app (selectLatest as) $> () + eAppData <- getAppData (Just av) pfreq' + case eAppData of + 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) -getAppState mg pfreq' = do +selectLatest :: AppData -> AppData +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 - 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') + $ fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri) 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}|] diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 24e60e1..ec67ce1 100644 --- a/app/ghcup/Main.hs +++ b/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 diff --git a/ghcup-0.0.3.yaml b/ghcup-0.0.3.yaml index 4a3cca0..75a68a0 100644 --- a/ghcup-0.0.3.yaml +++ b/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: diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 6c1a014..9857cf3 100644 --- a/lib/GHCup/Types.hs +++ b/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 diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index c271a08..8904b91 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/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