hasufell
/
ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Allow to hide old versions of tools in TUI

This commit is contained in:
Julian Ospald 2020-10-09 22:55:33 +02:00
parent 73d1d97f1f
commit 57c34a07f2
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
6 changed files with 159 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
app/ghcup-gen/Validate.hs
View File

@ -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

184
app/ghcup/BrickMain.hs
View File

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

3
app/ghcup/Main.hs
View File

@ -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

20
ghcup-0.0.3.yaml
View File

@ -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:

1
lib/GHCup/Types.hs
View File

@ -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

2
lib/GHCup/Types/JSON.hs
View File

@ -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