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

Implement 'latest-prerelease' tag wrt #788

Browse Source
This commit is contained in:
Julian Ospald 2023-02-21 22:22:11 +08:00
parent 75e801e9e6
commit 785fb895b4
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
6 changed files with 27 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
app/ghcup/BrickMain.hs
View File

@ -4,6 +4,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
module BrickMain where
@ -154,8 +155,11 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
<+> minHSize 15 (str "Version")
<+> padLeft (Pad 1) (minHSize 25 $ str "Tags")
<+> padLeft (Pad 5) (str "Notes")
renderList' = withDefAttr listAttr . drawListElements renderItem True
renderItem _ b listResult@ListResult{..} =
renderList' bis@BrickInternalState{..} =
let getMinLength = length . intercalate "," . fmap tagToString
minLength = V.maximum $ V.map (getMinLength . lTag) clr
in withDefAttr listAttr . drawListElements (renderItem minLength) True $ bis
renderItem minTagSize _ b listResult@ListResult{lTag = lTag', ..} =
let marks = if
| lSet -> (withAttr (attrName "set") $ str "✔✔")
| lInstalled -> (withAttr (attrName "installed") $ str "✓ ")
@ -170,7 +174,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
= updateAttrMap (const dimAttrs) . withAttr (attrName "no-bindist")
| otherwise = id
hooray
| elem Latest lTag && not lInstalled =
| elem Latest lTag' && not lInstalled =
withAttr (attrName "hooray")
| otherwise = id
active = if b then putCursor "GHCup" (Location (0,0)) . forceAttr (attrName "active") else id
@ -181,8 +185,8 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
(printTool lTool)
)
<+> minHSize 15 (str ver)
<+> (let l = catMaybes . fmap printTag $ sort lTag
in padLeft (Pad 1) $ minHSize 25 $ if null l
<+> (let l = catMaybes . fmap printTag $ sort lTag'
in padLeft (Pad 1) $ minHSize minTagSize $ if null l
then emptyWidget
else foldr1 (\x y -> x <+> str "," <+> y) l
)
@ -200,6 +204,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
printTag Prerelease = Just $ withAttr (attrName "prerelease") $ str "prerelease"
printTag (Base pvp'') = Just $ str ("base-" ++ T.unpack (prettyPVP pvp''))
printTag Old = Nothing
printTag LatestPrerelease = Just $ withAttr (attrName "latest-prerelease") $ str "latest-prerelease"
printTag (UnknownTag t) = Just $ str t
printTool Cabal = str "cabal"
@ -274,6 +279,7 @@ defaultAttributes no_color = attrMap
, (attrName "recommended" , Vty.defAttr `withForeColor` Vty.green)
, (attrName "hls-powered" , Vty.defAttr `withForeColor` Vty.green)
, (attrName "latest" , Vty.defAttr `withForeColor` Vty.yellow)
, (attrName "latest-prerelease" , Vty.defAttr `withForeColor` Vty.red)
, (attrName "prerelease" , Vty.defAttr `withForeColor` Vty.red)
, (attrName "compiled" , Vty.defAttr `withForeColor` Vty.blue)
, (attrName "stray" , Vty.defAttr `withForeColor` Vty.blue)

10
app/ghcup/GHCup/OptParse/Common.hs
View File

@ -246,8 +246,9 @@ toolVersionTagEither s' =
tagEither :: String -> Either String Tag
tagEither s' = case fmap toLower s' of
"recommended" -> Right Recommended
"latest" -> Right Latest
"recommended" -> Right Recommended
"latest" -> Right Latest
"latest-prerelease" -> Right LatestPrerelease
('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of
Right x -> Right (Base x)
Left _ -> Left $ "Invalid PVP version for base " <> ver'
@ -452,7 +453,7 @@ tagCompleter tool add = listIOCompleter $ do
let allTags = filter (/= Old)
$ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
pure $ nub $ (add ++) $ fmap tagToString allTags
VLeft _ -> pure (nub $ ["recommended", "latest"] ++ add)
VLeft _ -> pure (nub $ ["recommended", "latest", "latest-prerelease"] ++ add)
versionCompleter :: Maybe ListCriteria -> Tool -> Completer
versionCompleter criteria tool = versionCompleter' criteria tool (const True)
@ -706,6 +707,9 @@ fromVersion' (SetToolVersion v) tool = do
fromVersion' (SetToolTag Latest) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getLatest dls tool ?? TagNotFound Latest tool
fromVersion' (SetToolTag LatestPrerelease) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getLatestPrerelease dls tool ?? TagNotFound LatestPrerelease tool
fromVersion' (SetToolTag Recommended) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getRecommended dls tool ?? TagNotFound Recommended tool

1
app/ghcup/GHCup/OptParse/List.hs
View File

@ -107,6 +107,7 @@ printListResult no_color raw lr = do
printTag Prerelease = color Red "prerelease"
printTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
printTag (UnknownTag t ) = t
printTag LatestPrerelease = color Red "latest-prerelease"
printTag Old = ""
let

3
lib/GHCup/Types.hs
View File

@ -154,6 +154,7 @@ instance NFData VersionInfo
data Tag = Latest
| Recommended
| Prerelease
| LatestPrerelease
| Base PVP
| Old -- ^ old versions are hidden by default in TUI
| UnknownTag String -- ^ used for upwardscompat
@ -167,6 +168,7 @@ tagToString Latest = "latest"
tagToString Prerelease = "prerelease"
tagToString (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
tagToString (UnknownTag t ) = t
tagToString LatestPrerelease = "latest-prerelease"
tagToString Old = ""
instance Pretty Tag where
@ -175,6 +177,7 @@ instance Pretty Tag where
pPrint Prerelease = text "prerelease"
pPrint (Base pvp'') = text ("base-" ++ T.unpack (prettyPVP pvp''))
pPrint (UnknownTag t ) = text t
pPrint LatestPrerelease = text "latest-prerelease"
pPrint Old = mempty
data Architecture = A_64

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

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

3
lib/GHCup/Utils.hs
View File

@ -892,6 +892,9 @@ getTagged tag =
getLatest :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getLatest av tool = headOf (ix tool % getTagged Latest) av
getLatestPrerelease :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getLatestPrerelease av tool = headOf (ix tool % getTagged LatestPrerelease) av
getRecommended :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getRecommended av tool = headOf (ix tool % getTagged Recommended) av