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

Implement support for nightlies, wrt #824

Browse Source
This commit is contained in:
Julian Ospald 2023-05-01 17:46:27 +08:00
parent 1ba2361fea
commit 4b34cddcda
No known key found for this signature in database
GPG Key ID: CCC85C0E40C06A8C
26 changed files with 11395 additions and 10427 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.github/workflows/bootstrap.yaml vendored
View File

@ -25,7 +25,7 @@ jobs:
include:
- os: ubuntu-latest
DISTRO: Ubuntu
- os: macOS-10.15
- os: macOS-11
DISTRO: na
- os: windows-latest
DISTRO: na

4
.github/workflows/release.yaml vendored
View File

@ -168,7 +168,7 @@ jobs:
ARTIFACT: "aarch64-apple-darwin-ghcup"
GHC_VER: 9.2.6
ARCH: ARM64
- os: macOS-10.15
- os: macOS-11
ARTIFACT: "x86_64-apple-darwin-ghcup"
GHC_VER: 9.2.6
ARCH: 64
@ -403,7 +403,7 @@ jobs:
GHC_VER: 9.2.6
ARCH: ARM64
DISTRO: na
- os: macOS-10.15
- os: macOS-11
ARTIFACT: "x86_64-apple-darwin-ghcup"
GHC_VER: 9.2.6
ARCH: 64

48
app/ghcup/BrickMain.hs
View File

@ -73,8 +73,8 @@ data BrickData = BrickData
deriving Show
data BrickSettings = BrickSettings
{ showAllVersions :: Bool
, showAllTools :: Bool
{ showAllVersions :: Bool
, showAllTools :: Bool
}
deriving Show
@ -202,9 +202,11 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
printTag Recommended = Just $ withAttr (attrName "recommended") $ str "recommended"
printTag Latest = Just $ withAttr (attrName "latest") $ str "latest"
printTag Prerelease = Just $ withAttr (attrName "prerelease") $ str "prerelease"
printTag Nightly = Just $ withAttr (attrName "nightly") $ str "nightly"
printTag (Base pvp'') = Just $ str ("base-" ++ T.unpack (prettyPVP pvp''))
printTag Old = Nothing
printTag LatestPrerelease = Just $ withAttr (attrName "latest-prerelease") $ str "latest-prerelease"
printTag LatestNightly = Just $ withAttr (attrName "latest-nightly") $ str "latest-nightly"
printTag (UnknownTag t) = Just $ str t
printTool Cabal = str "cabal"
@ -218,6 +220,9 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
)
++ (if fromSrc then [withAttr (attrName "compiled") $ str "compiled"] else mempty)
++ (if lStray then [withAttr (attrName "stray") $ str "stray"] else mempty)
++ (case lReleaseDay of
Nothing -> mempty
Just d -> [withAttr (attrName "day") $ str (show d)])
-- | Draws the list elements.
--
@ -272,19 +277,22 @@ app attrs dimAttrs =
defaultAttributes :: Bool -> AttrMap
defaultAttributes no_color = attrMap
Vty.defAttr
[ (attrName "active" , Vty.defAttr `withBackColor` Vty.blue)
, (attrName "not-installed", Vty.defAttr `withForeColor` Vty.red)
, (attrName "set" , Vty.defAttr `withForeColor` Vty.green)
, (attrName "installed" , Vty.defAttr `withForeColor` Vty.green)
, (attrName "recommended" , Vty.defAttr `withForeColor` Vty.green)
, (attrName "hls-powered" , Vty.defAttr `withForeColor` Vty.green)
, (attrName "latest" , Vty.defAttr `withForeColor` Vty.yellow)
[ (attrName "active" , Vty.defAttr `withBackColor` Vty.blue)
, (attrName "not-installed" , Vty.defAttr `withForeColor` Vty.red)
, (attrName "set" , Vty.defAttr `withForeColor` Vty.green)
, (attrName "installed" , Vty.defAttr `withForeColor` Vty.green)
, (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)
, (attrName "help" , Vty.defAttr `withStyle` Vty.italic)
, (attrName "hooray" , Vty.defAttr `withForeColor` Vty.brightWhite)
, (attrName "latest-nightly" , Vty.defAttr `withForeColor` Vty.red)
, (attrName "prerelease" , Vty.defAttr `withForeColor` Vty.red)
, (attrName "nightly" , Vty.defAttr `withForeColor` Vty.red)
, (attrName "compiled" , Vty.defAttr `withForeColor` Vty.blue)
, (attrName "stray" , Vty.defAttr `withForeColor` Vty.blue)
, (attrName "day" , Vty.defAttr `withForeColor` Vty.blue)
, (attrName "help" , Vty.defAttr `withStyle` Vty.italic)
, (attrName "hooray" , Vty.defAttr `withForeColor` Vty.brightWhite)
]
where
withForeColor | no_color = const
@ -411,13 +419,17 @@ filterVisible :: Bool -> Bool -> ListResult -> Bool
filterVisible v t e | lInstalled e = True
| v
, not t
, Nightly `notElem` lTag e
, lTool e `notElem` hiddenTools = True
| not v
, t
, Old `notElem` lTag e = True
, Old `notElem` lTag e
, Nightly `notElem` lTag e = True
| v
, Nightly `notElem` lTag e
, t = True
| otherwise = (Old `notElem` lTag e) &&
| otherwise = (Old `notElem` lTag e) &&
(Nightly `notElem` lTag e) &&
(lTool e `notElem` hiddenTools)
@ -576,7 +588,7 @@ changelog' :: (MonadReader AppState m, MonadIO m)
-> m (Either String ())
changelog' _ (_, ListResult {..}) = do
AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
case getChangeLog dls lTool (Left lVer) of
case getChangeLog dls lTool (ToolVersion lVer) of
Nothing -> pure $ Left $
"Could not find ChangeLog for " <> prettyShow lTool <> ", version " <> T.unpack (prettyVer lVer)
Just uri -> do
@ -656,5 +668,5 @@ getAppData mgi = runExceptT $ do
settings <- liftIO $ readIORef settings'
flip runReaderT settings $ do
lV <- listVersions Nothing Nothing
lV <- listVersions Nothing [] False True (Nothing, Nothing)
pure $ BrickData (reverse lV)

3
app/ghcup/GHCup/OptParse.hs
View File

@ -244,7 +244,8 @@ com =
<> command
"list"
(info (List <$> listOpts <**> helper)
(progDesc "Show available GHCs and other tools")
(progDesc "Show available GHCs and other tools"
<> footerDoc (Just $ text listToolFooter))
)
<> command
"upgrade"

14
app/ghcup/GHCup/OptParse/ChangeLog.hs
View File

@ -35,7 +35,6 @@ import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
import GHCup.Types.Optics
import GHCup.Utils
import Data.Versions
import URI.ByteString (serializeURIRef')
import Data.Char (toLower)
@ -81,7 +80,7 @@ changelogP =
<> completer toolCompleter
)
)
<*> optional (toolVersionTagArgument Nothing Nothing)
<*> optional (toolVersionTagArgument [] Nothing)
@ -115,20 +114,15 @@ changelog :: ( Monad m
changelog ChangeLogOptions{..} runAppState runLogger = do
GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
let tool = fromMaybe GHC clTool
ver' = maybe
(Right Latest)
(\case
GHCVersion tv -> Left (_tvVersion tv)
ToolVersion tv -> Left tv
ToolTag t -> Right t
)
ver' = fromMaybe
(ToolTag Latest)
clToolVer
muri = getChangeLog dls tool ver'
case muri of
Nothing -> do
runLogger
(logWarn $
"Could not find ChangeLog for " <> T.pack (prettyShow tool) <> ", version " <> either prettyVer (T.pack . show) ver'
"Could not find ChangeLog for " <> T.pack (prettyShow tool) <> ", version " <> T.pack (prettyShow ver')
)
pure ExitSuccess
Just uri -> do

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

@ -45,6 +45,8 @@ import Data.Functor
import Data.List ( nub, sort, sortBy, isPrefixOf, stripPrefix )
import Data.Maybe
import Data.Text ( Text )
import Data.Time.Calendar ( Day )
import Data.Time.Format ( parseTimeM, defaultTimeLocale )
import Data.Versions hiding ( str )
import Data.Void
import qualified Data.Vector as V
@ -72,26 +74,26 @@ import qualified Cabal.Config as CC
--[ Types ]--
-------------
data ToolVersion = GHCVersion GHCTargetVersion
| ToolVersion Version
| ToolTag Tag
-- a superset of ToolVersion
data SetToolVersion = SetGHCVersion GHCTargetVersion
| SetToolVersion Version
| SetToolTag Tag
| SetToolDay Day
| SetRecommended
| SetNext
prettyToolVer :: ToolVersion -> String
prettyToolVer (GHCVersion v') = T.unpack $ tVerToText v'
prettyToolVer (GHCVersion v') = T.unpack $ tVerToText v'
prettyToolVer (ToolVersion v') = T.unpack $ prettyVer v'
prettyToolVer (ToolTag t) = show t
prettyToolVer (ToolTag t) = show t
prettyToolVer (ToolDay day) = show day
toSetToolVer :: Maybe ToolVersion -> SetToolVersion
toSetToolVer (Just (GHCVersion v')) = SetGHCVersion v'
toSetToolVer (Just (ToolVersion v')) = SetToolVersion v'
toSetToolVer (Just (ToolTag t')) = SetToolTag t'
toSetToolVer (Just (ToolDay d')) = SetToolDay d'
toSetToolVer Nothing = SetRecommended
@ -102,28 +104,28 @@ toSetToolVer Nothing = SetRecommended
--------------
toolVersionTagArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion
toolVersionTagArgument :: [ListCriteria] -> Maybe Tool -> Parser ToolVersion
toolVersionTagArgument criteria tool =
argument (eitherReader (parser tool))
(metavar (mv tool)
<> completer (tagCompleter (fromMaybe GHC tool) [])
<> foldMap (completer . versionCompleter criteria) tool)
where
mv (Just GHC) = "GHC_VERSION|TAG"
mv (Just HLS) = "HLS_VERSION|TAG"
mv _ = "VERSION|TAG"
mv (Just GHC) = "GHC_VERSION|TAG|RELEASE_DATE"
mv (Just HLS) = "HLS_VERSION|TAG|RELEASE_DATE"
mv _ = "VERSION|TAG|RELEASE_DATE"
parser (Just GHC) = ghcVersionTagEither
parser Nothing = ghcVersionTagEither
parser _ = toolVersionTagEither
versionParser' :: Maybe ListCriteria -> Maybe Tool -> Parser Version
versionParser' :: [ListCriteria] -> Maybe Tool -> Parser Version
versionParser' criteria tool = argument
(eitherReader (first show . version . T.pack))
(metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)
ghcVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion
ghcVersionArgument :: [ListCriteria] -> Maybe Tool -> Parser GHCTargetVersion
ghcVersionArgument criteria tool = argument (eitherReader ghcVersionEither)
(metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)
@ -237,22 +239,23 @@ isolateParser f = case isValid f && isAbsolute f of
-- this accepts cross prefix
ghcVersionTagEither :: String -> Either String ToolVersion
ghcVersionTagEither s' =
second ToolTag (tagEither s') <|> second GHCVersion (ghcVersionEither s')
second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second GHCVersion (ghcVersionEither s')
-- this ignores cross prefix
toolVersionTagEither :: String -> Either String ToolVersion
toolVersionTagEither s' =
second ToolTag (tagEither s') <|> second ToolVersion (toolVersionEither s')
second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second ToolVersion (toolVersionEither s')
tagEither :: String -> Either String Tag
tagEither s' = case fmap toLower s' of
"recommended" -> Right Recommended
"latest" -> Right Latest
"latest-prerelease" -> Right LatestPrerelease
"latest-nightly" -> Right LatestNightly
('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of
Right x -> Right (Base x)
Left _ -> Left $ "Invalid PVP version for base " <> ver'
other -> Left $ "Unknown tag " <> other
other -> Left $ "Unknown tag " <> other
ghcVersionEither :: String -> Either String GHCTargetVersion
@ -261,7 +264,7 @@ ghcVersionEither =
toolVersionEither :: String -> Either String Version
toolVersionEither =
first (const "Not a valid version") . MP.parse version' "" . T.pack
first (const "Not a valid version") . MP.parse (version' <* MP.eof) "" . T.pack
toolParser :: String -> Either String Tool
@ -272,12 +275,22 @@ toolParser s' | t == T.pack "ghc" = Right GHC
| otherwise = Left ("Unknown tool: " <> s')
where t = T.toLower (T.pack s')
dayParser :: String -> Either String Day
dayParser s = maybe (Left $ "Could not parse \"" <> s <> "\". Expected format is: YYYY-MM-DD") Right
$ parseTimeM True defaultTimeLocale "%Y-%-m-%-d" s
criteriaParser :: String -> Either String ListCriteria
criteriaParser s' | t == T.pack "installed" = Right ListInstalled
| t == T.pack "set" = Right ListSet
| t == T.pack "available" = Right ListAvailable
| otherwise = Left ("Unknown criteria: " <> s')
criteriaParser s' | t == T.pack "installed" = Right $ ListInstalled True
| t == T.pack "set" = Right $ ListSet True
| t == T.pack "available" = Right $ ListAvailable True
| t == T.pack "+installed" = Right $ ListInstalled True
| t == T.pack "+set" = Right $ ListSet True
| t == T.pack "+available" = Right $ ListAvailable True
| t == T.pack "-installed" = Right $ ListInstalled False
| t == T.pack "-set" = Right $ ListSet False
| t == T.pack "-available" = Right $ ListAvailable False
| otherwise = Left ("Unknown criteria: " <> s')
where t = T.toLower (T.pack s')
@ -455,10 +468,10 @@ tagCompleter tool add = listIOCompleter $ do
pure $ nub $ (add ++) $ fmap tagToString allTags
VLeft _ -> pure (nub $ ["recommended", "latest", "latest-prerelease"] ++ add)
versionCompleter :: Maybe ListCriteria -> Tool -> Completer
versionCompleter :: [ListCriteria] -> Tool -> Completer
versionCompleter criteria tool = versionCompleter' criteria tool (const True)
versionCompleter' :: Maybe ListCriteria -> Tool -> (Version -> Bool) -> Completer
versionCompleter' :: [ListCriteria] -> Tool -> (Version -> Bool) -> Completer
versionCompleter' criteria tool filter' = listIOCompleter $ do
dirs' <- liftIO getAllDirs
let loggerConfig = LoggerConfig
@ -487,7 +500,7 @@ versionCompleter' criteria tool filter' = listIOCompleter $ do
runEnv = flip runReaderT appState
installedVersions <- runEnv $ listVersions (Just tool) criteria
installedVersions <- runEnv $ listVersions (Just tool) criteria False False (Nothing, Nothing)
return $ fmap (T.unpack . prettyVer) . filter filter' . fmap lVer $ installedVersions
@ -655,6 +668,7 @@ fromVersion :: ( HasLog env
-> Tool
-> Excepts
'[ TagNotFound
, DayNotFound
, NextVerNotFound
, NoToolVersionSet
] m (GHCTargetVersion, Maybe VersionInfo)
@ -673,6 +687,7 @@ fromVersion' :: ( HasLog env
-> Tool
-> Excepts
'[ TagNotFound
, DayNotFound
, NextVerNotFound
, NoToolVersionSet
] m (GHCTargetVersion, Maybe VersionInfo)
@ -707,9 +722,15 @@ 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' (SetToolDay day) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getByReleaseDay dls tool day ?? DayNotFound day tool
fromVersion' (SetToolTag LatestPrerelease) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getLatestPrerelease dls tool ?? TagNotFound LatestPrerelease tool
fromVersion' (SetToolTag LatestNightly) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getLatestNightly dls tool ?? TagNotFound LatestNightly tool
fromVersion' (SetToolTag Recommended) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getRecommended dls tool ?? TagNotFound Recommended tool
@ -779,7 +800,7 @@ checkForUpdates :: ( MonadReader env m
=> m [(Tool, Version)]
checkForUpdates = do
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
lInstalled <- listVersions Nothing (Just ListInstalled)
lInstalled <- listVersions Nothing [ListInstalled True] False False (Nothing, Nothing)
let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled
ghcup <- forMM (getLatest dls GHCup) $ \(l, _) -> do

15
app/ghcup/GHCup/OptParse/Compile.hs
View File

@ -170,7 +170,7 @@ ghcCompileOpts =
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The tool version to compile"
<> (completer $ versionCompleter Nothing GHC)
<> (completer $ versionCompleter [] GHC)
)
) <|>
(GHC.GitDist <$> (GitBranch <$> option
@ -205,7 +205,7 @@ ghcCompileOpts =
<> metavar "BOOTSTRAP_GHC"
<> help
"The GHC version (or full path) to bootstrap with (must be installed)"
<> (completer $ versionCompleter Nothing GHC)
<> (completer $ versionCompleter [] GHC)
)
<*> optional
(option
@ -258,7 +258,7 @@ ghcCompileOpts =
)
(short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help
"Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
<> (completer $ versionCompleter Nothing GHC)
<> (completer $ versionCompleter [] GHC)
)
)
<*> optional
@ -291,7 +291,7 @@ hlsCompileOpts =
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The version to compile (pulled from hackage)"
<> (completer $ versionCompleter' Nothing HLS (either (const False) (const True) . V.pvp . V.prettyVer))
<> (completer $ versionCompleter' [] HLS (either (const False) (const True) . V.pvp . V.prettyVer))
)
)
<|>
@ -311,7 +311,7 @@ hlsCompileOpts =
)
(long "source-dist" <> metavar "VERSION" <> help
"The version to compile (pulled from packaged git sources)"
<> (completer $ versionCompleter Nothing HLS)
<> (completer $ versionCompleter [] HLS)
)
))
<|>
@ -343,7 +343,7 @@ hlsCompileOpts =
)
(short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help
"Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
<> (completer $ versionCompleter Nothing HLS)
<> (completer $ versionCompleter [] HLS)
)
)
<|>
@ -403,7 +403,7 @@ hlsCompileOpts =
option (eitherReader ghcVersionTagEither)
( long "ghc" <> metavar "GHC_VERSION|TAG" <> help "For which GHC version to compile for (can be specified multiple times)"
<> completer (tagCompleter GHC [])
<> completer (versionCompleter Nothing GHC))
<> completer (versionCompleter [] GHC))
)
<*> many (argument str (metavar "CABAL_ARGS" <> help "Additional arguments to cabal install, prefix with '-- ' (longopts)"))
@ -453,6 +453,7 @@ type HLSEffects = '[ AlreadyInstalled
, UnknownArchive
, TarDirDoesNotExist
, TagNotFound
, DayNotFound
, NextVerNotFound
, NoToolVersionSet
, NotInstalled

4
app/ghcup/GHCup/OptParse/Install.hs
View File

@ -184,7 +184,7 @@ installOpts tool =
<> completer (toolDlCompleter (fromMaybe GHC tool))
)
)
<*> (Just <$> toolVersionTagArgument Nothing tool)
<*> (Just <$> toolVersionTagArgument [] tool)
)
<|> pure (Nothing, Nothing)
)
@ -241,6 +241,7 @@ type InstallEffects = '[ AlreadyInstalled
, NotInstalled
, BuildFailed
, TagNotFound
, DayNotFound
, DigestError
, ContentLengthError
, GPGError
@ -284,6 +285,7 @@ type InstallGHCEffects = '[ AlreadyInstalled
, NotInstalled
, ProcessError
, TagNotFound
, DayNotFound
, TarDirDoesNotExist
, UninstallFailed
, UnknownArchive

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

@ -2,6 +2,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
@ -14,6 +15,7 @@ import GHCup
import GHCup.Prelude
import GHCup.Types
import GHCup.OptParse.Common
import GHCup.Prelude.String.QQ
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
@ -24,6 +26,7 @@ import Data.Char
import Data.List ( intercalate, sort )
import Data.Functor
import Data.Maybe
import Data.Time.Calendar ( Day )
import Data.Versions hiding ( str )
import Data.Void
import Options.Applicative hiding ( style )
@ -50,6 +53,10 @@ import qualified Text.Megaparsec.Char as MPC
data ListOptions = ListOptions
{ loTool :: Maybe Tool
, lCriteria :: Maybe ListCriteria
, lFrom :: Maybe Day
, lTo :: Maybe Day
, lHideOld :: Bool
, lShowNightly :: Bool
, lRawFormat :: Bool
}
@ -60,7 +67,6 @@ data ListOptions = ListOptions
--[ Parsers ]--
---------------
listOpts :: Parser ListOptions
listOpts =
ListOptions
@ -69,7 +75,7 @@ listOpts =
(eitherReader toolParser)
(short 't' <> long "tool" <> metavar "<ghc|cabal|hls|stack>" <> help
"Tool to list versions for. Default is all"
<> completer (toolCompleter)
<> completer toolCompleter
)
)
<*> optional
@ -78,15 +84,53 @@ listOpts =
( short 'c'
<> long "show-criteria"
<> metavar "<installed|set|available>"
<> help "Show only installed/set/available tool versions"
<> completer (listCompleter ["installed", "set", "available"])
<> help "Apply filtering criteria, prefix with + or -"
<> completer (listCompleter
[ "+installed", "+set", "+available", "-installed", "-set", "-available"])
)
)
<*> optional
(option
(eitherReader dayParser)
(short 's' <> long "since" <> metavar "YYYY-MM-DD" <> help
"List only tools with release date starting at YYYY-MM-DD or later"
<> completer toolCompleter
)
)
<*> optional
(option
(eitherReader dayParser)
(short 'u' <> long "until" <> metavar "YYYY-MM-DD" <> help
"List only tools with release date earlier than YYYY-MM-DD"
<> completer toolCompleter
)
)
<*> switch
(short 'o' <> long "hide-old" <> help "Hide 'old' GHC versions (installed ones are always shown)"
)
<*> switch
(short 'n' <> long "show-nightly" <> help "Show nightlies (installed ones are always shown)"
)
<*> switch
(short 'r' <> long "raw-format" <> help "More machine-parsable format"
)
--------------
--[ Footer ]--
--------------
listToolFooter :: String
listToolFooter = [s|Discussion:
Lists tool versions with optional criteria.
Nightlies are by default hidden.
Examples:
# query nightlies in a specific range
ghcup list --show-nightly --since 2022-12-07 --until 2022-12-31
# show all installed GHC versions
ghcup list -t ghc -c installed|]
-----------------
@ -105,9 +149,11 @@ printListResult no_color raw lr = do
printTag Recommended = color Green "recommended"
printTag Latest = color Yellow "latest"
printTag Prerelease = color Red "prerelease"
printTag Nightly = color Red "nightly"
printTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
printTag (UnknownTag t ) = t
printTag LatestPrerelease = color Red "latest-prerelease"
printTag LatestNightly = color Red "latest-nightly"
printTag Old = ""
let
@ -136,6 +182,9 @@ printListResult no_color raw lr = do
)
++ (if fromSrc then [color Blue "compiled"] else mempty)
++ (if lStray then [color Yellow "stray"] else mempty)
++ (case lReleaseDay of
Nothing -> mempty
Just d -> [color Blue (show d)])
++ (if lNoBindist
then [color Red "no-bindist"]
else mempty
@ -260,7 +309,7 @@ list :: ( Monad m
-> m ExitCode
list ListOptions{..} no_color runAppState =
runAppState (do
l <- listVersions loTool lCriteria
l <- listVersions loTool (maybeToList lCriteria) lHideOld lShowNightly (lFrom, lTo)
liftIO $ printListResult no_color lRawFormat l
pure ExitSuccess
)

4
app/ghcup/GHCup/OptParse/Nuke.hs
View File

@ -76,8 +76,8 @@ nuke appState runLogger = do
lift $ logInfo "Initiating Nuclear Sequence 🚀🚀🚀"
lift $ logInfo "Nuking in 3...2...1"
lInstalled <- lift $ listVersions Nothing (Just ListInstalled)
lInstalled <- lift $ listVersions Nothing [ListInstalled True] False True (Nothing, Nothing)
forM_ lInstalled (liftE . rmTool)

9
app/ghcup/GHCup/OptParse/Prefetch.hs
View File

@ -83,7 +83,7 @@ prefetchP = subparser
<$> (PrefetchGHCOptions
<$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper )
<*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
<*> optional (toolVersionTagArgument Nothing (Just GHC)) )
<*> optional (toolVersionTagArgument [] (Just GHC)) )
( progDesc "Download GHC assets for installation")
)
<>
@ -92,7 +92,7 @@ prefetchP = subparser
(info
(PrefetchCabal
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
<*> ( optional (toolVersionTagArgument Nothing (Just Cabal)) <**> helper ))
<*> ( optional (toolVersionTagArgument [] (Just Cabal)) <**> helper ))
( progDesc "Download cabal assets for installation")
)
<>
@ -101,7 +101,7 @@ prefetchP = subparser
(info
(PrefetchHLS
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
<*> ( optional (toolVersionTagArgument Nothing (Just HLS)) <**> helper ))
<*> ( optional (toolVersionTagArgument [] (Just HLS)) <**> helper ))
( progDesc "Download HLS assets for installation")
)
<>
@ -110,7 +110,7 @@ prefetchP = subparser
(info
(PrefetchStack
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
<*> ( optional (toolVersionTagArgument Nothing (Just Stack)) <**> helper ))
<*> ( optional (toolVersionTagArgument [] (Just Stack)) <**> helper ))
( progDesc "Download stack assets for installation")
)
<>
@ -148,6 +148,7 @@ Examples:
type PrefetchEffects = '[ TagNotFound
, DayNotFound
, NextVerNotFound
, NoToolVersionSet
, NoDownload

8
app/ghcup/GHCup/OptParse/Rm.hs
View File

@ -80,19 +80,19 @@ rmParser =
<> command
"cabal"
( RmCabal
<$> info (versionParser' (Just ListInstalled) (Just Cabal) <**> helper)
<$> info (versionParser' [ListInstalled True] (Just Cabal) <**> helper)
(progDesc "Remove Cabal version")
)
<> command
"hls"
( RmHLS
<$> info (versionParser' (Just ListInstalled) (Just HLS) <**> helper)
<$> info (versionParser' [ListInstalled True] (Just HLS) <**> helper)
(progDesc "Remove haskell-language-server version")
)
<> command
"stack"
( RmStack
<$> info (versionParser' (Just ListInstalled) (Just Stack) <**> helper)
<$> info (versionParser' [ListInstalled True] (Just Stack) <**> helper)
(progDesc "Remove stack version")
)
)
@ -102,7 +102,7 @@ rmParser =
rmOpts :: Maybe Tool -> Parser RmOptions
rmOpts tool = RmOptions <$> ghcVersionArgument (Just ListInstalled) tool
rmOpts tool = RmOptions <$> ghcVersionArgument [ListInstalled True] tool

13
app/ghcup/GHCup/OptParse/Run.hs
View File

@ -92,7 +92,7 @@ runOpts =
(eitherReader ghcVersionTagEither)
(metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version"
<> completer (tagCompleter GHC [])
<> (completer $ versionCompleter Nothing GHC)
<> (completer $ versionCompleter [] GHC)
)
)
<*> optional
@ -100,7 +100,7 @@ runOpts =
(eitherReader toolVersionTagEither)
(metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version"
<> completer (tagCompleter Cabal [])
<> (completer $ versionCompleter Nothing Cabal)
<> (completer $ versionCompleter [] Cabal)
)
)
<*> optional
@ -108,7 +108,7 @@ runOpts =
(eitherReader toolVersionTagEither)
(metavar "HLS_VERSION" <> long "hls" <> help "The HLS version"
<> completer (tagCompleter HLS [])
<> (completer $ versionCompleter Nothing HLS)
<> (completer $ versionCompleter [] HLS)
)
)
<*> optional
@ -116,7 +116,7 @@ runOpts =
(eitherReader toolVersionTagEither)
(metavar "STACK_VERSION" <> long "stack" <> help "The stack version"
<> completer (tagCompleter Stack [])
<> (completer $ versionCompleter Nothing Stack)
<> (completer $ versionCompleter [] Stack)
)
)
<*> optional
@ -132,7 +132,7 @@ runOpts =
<*> switch
(short 'q' <> long "quick" <> help "Avoid any expensive work (such as downloads, version/tag resolution etc.). Disables --install.")
<*> many (argument str (metavar "COMMAND" <> help "The command to run, with arguments (use longopts --). If omitted, just prints the created bin/ dir to stdout and exits."))
@ -175,6 +175,7 @@ type RunEffects = '[ AlreadyInstalled
, NotInstalled
, BuildFailed
, TagNotFound
, DayNotFound
, DigestError
, ContentLengthError
, GPGError
@ -282,6 +283,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
)
=> Excepts
'[ TagNotFound
, DayNotFound
, NextVerNotFound
, NoToolVersionSet
] (ResourceT (ReaderT AppState m)) Toolchain
@ -332,6 +334,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
-> FilePath
-> Excepts
'[ TagNotFound
, DayNotFound
, NextVerNotFound
, NoToolVersionSet
, UnknownArchive

8
app/ghcup/GHCup/OptParse/Set.hs
View File

@ -139,9 +139,9 @@ setParser =
setOpts :: Tool -> Parser SetOptions
setOpts tool = SetOptions <$>
(fromMaybe SetRecommended <$>
optional (setVersionArgument (Just ListInstalled) tool))
optional (setVersionArgument [ListInstalled True] tool))
setVersionArgument :: Maybe ListCriteria -> Tool -> Parser SetToolVersion
setVersionArgument :: [ListCriteria] -> Tool -> Parser SetToolVersion
setVersionArgument criteria tool =
argument (eitherReader setEither)
(metavar "VERSION|TAG|next"
@ -184,6 +184,7 @@ setFooter = [s|Discussion:
type SetGHCEffects = '[ FileDoesNotExistError
, NotInstalled
, TagNotFound
, DayNotFound
, NextVerNotFound
, NoToolVersionSet]
@ -198,6 +199,7 @@ runSetGHC runAppState =
type SetCabalEffects = '[ NotInstalled
, TagNotFound
, DayNotFound
, NextVerNotFound
, NoToolVersionSet]
@ -212,6 +214,7 @@ runSetCabal runAppState =
type SetHLSEffects = '[ NotInstalled
, TagNotFound
, DayNotFound
, NextVerNotFound
, NoToolVersionSet]
@ -226,6 +229,7 @@ runSetHLS runAppState =
type SetStackEffects = '[ NotInstalled
, TagNotFound
, DayNotFound
, NextVerNotFound
, NoToolVersionSet]

3
app/ghcup/GHCup/OptParse/Test.hs
View File

@ -112,7 +112,7 @@ testOpts tool =
<> completer (toolDlCompleter (fromMaybe GHC tool))
)
)
<*> (Just <$> toolVersionTagArgument Nothing tool)
<*> (Just <$> toolVersionTagArgument [] tool)
)
<|> pure (Nothing, Nothing)
)
@ -140,6 +140,7 @@ type TestGHCEffects = [ DigestError
, TestFailed
, NextVerNotFound
, TagNotFound
, DayNotFound
, NoToolVersionSet
]

9
app/ghcup/GHCup/OptParse/Whereis.hs
View File

@ -82,7 +82,7 @@ whereisP = subparser
command
"ghc"
(WhereisTool GHC <$> info
( optional (toolVersionTagArgument Nothing (Just GHC)) <**> helper )
( optional (toolVersionTagArgument [] (Just GHC)) <**> helper )
( progDesc "Get GHC location"
<> footerDoc (Just $ text whereisGHCFooter ))
)
@ -90,7 +90,7 @@ whereisP = subparser
command
"cabal"
(WhereisTool Cabal <$> info
( optional (toolVersionTagArgument Nothing (Just Cabal)) <**> helper )
( optional (toolVersionTagArgument [] (Just Cabal)) <**> helper )
( progDesc "Get cabal location"
<> footerDoc (Just $ text whereisCabalFooter ))
)
@ -98,7 +98,7 @@ whereisP = subparser
command
"hls"
(WhereisTool HLS <$> info
( optional (toolVersionTagArgument Nothing (Just HLS)) <**> helper )
( optional (toolVersionTagArgument [] (Just HLS)) <**> helper )
( progDesc "Get HLS location"
<> footerDoc (Just $ text whereisHLSFooter ))
)
@ -106,7 +106,7 @@ whereisP = subparser
command
"stack"
(WhereisTool Stack <$> info
( optional (toolVersionTagArgument Nothing (Just Stack)) <**> helper )
( optional (toolVersionTagArgument [] (Just Stack)) <**> helper )
( progDesc "Get stack location"
<> footerDoc (Just $ text whereisStackFooter ))
)
@ -222,6 +222,7 @@ type WhereisEffects = '[ NotInstalled
, NoToolVersionSet
, NextVerNotFound
, TagNotFound
, DayNotFound
]

4
app/ghcup/Main.hs
View File

@ -240,7 +240,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
_
| Just False <- optVerbose -> pure ()
| otherwise -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
Nothing -> void . flip runReaderT s' . runE @'[TagNotFound, NextVerNotFound, NoToolVersionSet] $ do
Nothing -> void . flip runReaderT s' . runE @'[TagNotFound, DayNotFound, NextVerNotFound, NoToolVersionSet] $ do
newTools <- lift checkForUpdates
forM_ newTools $ \newTool@(t, l) -> do
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/283
@ -335,6 +335,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
-> (Tool, Version)
-> Excepts
'[ TagNotFound
, DayNotFound
, NextVerNotFound
, NoToolVersionSet
] m Bool
@ -370,6 +371,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
-> Version
-> Excepts
'[ TagNotFound
, DayNotFound
, NextVerNotFound
, NoToolVersionSet
] m Bool

2
ghcup.cabal
View File

@ -269,6 +269,7 @@ executable ghcup
, template-haskell >=2.7 && <2.20
, temporary ^>=1.3
, text ^>=2.0
, time ^>=1.9.3
, unordered-containers ^>=0.2
, uri-bytestring ^>=0.3.2.2
, utf8-string ^>=1.0
@ -335,6 +336,7 @@ test-suite ghcup-test
, QuickCheck ^>=2.14.1
, quickcheck-arbitrary-adt ^>=0.3.1.0
, streamly ^>=0.8.2
, time ^>=1.9.3
, text ^>=2.0
, uri-bytestring ^>=0.3.2.2
, versions >=4.0.1 && <5.1

14
lib/GHCup/Errors.hs
View File

@ -38,6 +38,7 @@ import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.Encoding.Error as E
import Data.Data (Proxy(..))
import Data.Time (Day)
@ -59,6 +60,7 @@ allHFError = unlines allErrors
, let proxy = Proxy :: Proxy CopyError in format proxy
, let proxy = Proxy :: Proxy MergeFileTreeError in format proxy
, let proxy = Proxy :: Proxy TagNotFound in format proxy
, let proxy = Proxy :: Proxy DayNotFound in format proxy
, let proxy = Proxy :: Proxy NextVerNotFound in format proxy
, let proxy = Proxy :: Proxy AlreadyInstalled in format proxy
, let proxy = Proxy :: Proxy DirNotEmpty in format proxy
@ -311,6 +313,18 @@ instance HFErrorProject TagNotFound where
eBase _ = 90
eDesc _ = "Unable to find a tag of a tool"
-- | Unable to find a release day of a tool
data DayNotFound = DayNotFound Day Tool
deriving Show
instance Pretty DayNotFound where
pPrint (DayNotFound day tool) =
text "Unable to find release date" <+> text (show day) <+> text "of tool" <+> pPrint tool
instance HFErrorProject DayNotFound where
eBase _ = 95
eDesc _ = "Unable to find a release date of a tool"
-- | Unable to find the next version of a tool (the one after the currently
-- set one).
data NextVerNotFound = NextVerNotFound Tool

94
lib/GHCup/List.hs
View File

@ -36,6 +36,7 @@ import Data.Either
import Data.List
import Data.Maybe
import Data.Text ( Text )
import Data.Time.Calendar ( Day )
import Data.Versions hiding ( patch )
import Haskus.Utils.Variant.Excepts
import Optics
@ -61,9 +62,9 @@ import qualified Data.Text as T
-- | Filter data type for 'listVersions'.
data ListCriteria = ListInstalled
| ListSet
| ListAvailable
data ListCriteria = ListInstalled Bool
| ListSet Bool
| ListAvailable Bool
deriving Show
-- | A list result describes a single tool version
@ -79,6 +80,7 @@ data ListResult = ListResult
, lStray :: Bool -- ^ not in download info
, lNoBindist :: Bool -- ^ whether the version is available for this platform/arch
, hlsPowered :: Bool
, lReleaseDay :: Maybe Day
}
deriving (Eq, Ord, Show)
@ -93,19 +95,22 @@ availableToolVersions av tool = view
-- | List all versions from the download info, as well as stray
-- versions.
listVersions :: ( MonadCatch m
, HasLog env
, MonadThrow m
, HasLog env
, MonadIO m
, MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasGHCupInfo env
)
=> Maybe Tool
-> Maybe ListCriteria
-> m [ListResult]
listVersions lt' criteria = do
, HasLog env
, MonadThrow m
, HasLog env
, MonadIO m
, MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasGHCupInfo env
)
=> Maybe Tool
-> [ListCriteria]
-> Bool
-> Bool
-> (Maybe Day, Maybe Day)
-> m [ListResult]
listVersions lt' criteria hideOld showNightly days = do
-- some annoying work to avoid too much repeated IO
cSet <- cabalSet
cabals <- getInstalledCabals
@ -172,8 +177,9 @@ listVersions lt' criteria = do
, lCross = Nothing
, lTag = []
, lInstalled = True
, lStray = isNothing (Map.lookup _tvVersion avTools)
, lStray = isNothing (Map.lookup _tvVersion avTools)
, lNoBindist = False
, lReleaseDay = Nothing
, ..
}
Right tver@GHCTargetVersion{ .. } -> do
@ -188,6 +194,7 @@ listVersions lt' criteria = do
, lInstalled = True
, lStray = True -- NOTE: cross currently cannot be installed via bindist
, lNoBindist = False
, lReleaseDay = Nothing
, ..
}
Left e -> do
@ -223,6 +230,7 @@ listVersions lt' criteria = do
, lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False
, lReleaseDay = Nothing
, ..
}
Left e -> do
@ -257,6 +265,7 @@ listVersions lt' criteria = do
, lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False
, lReleaseDay = Nothing
, ..
}
Left e -> do
@ -292,6 +301,7 @@ listVersions lt' criteria = do
, lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False
, lReleaseDay = Nothing
, ..
}
Left e -> do
@ -317,6 +327,7 @@ listVersions lt' criteria = do
, lInstalled = True
, lNoBindist = False
, hlsPowered = False
, lReleaseDay = Nothing
}
-- NOTE: this are not cross ones, because no bindists
@ -337,7 +348,7 @@ listVersions lt' criteria = do
-> [Either FilePath Version]
-> (Version, VersionInfo)
-> m ListResult
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, _viTags -> tags) = do
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, VersionInfo{..}) = do
case t of
GHC -> do
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v
@ -346,31 +357,33 @@ listVersions lt' criteria = do
lInstalled <- ghcInstalled tver
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem v) hlsGHCVersions
pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. }
pure ListResult { lVer = v, lCross = Nothing , lTag = _viTags, lTool = t, lStray = False, lReleaseDay = _viReleaseDay, .. }
Cabal -> do
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v
let lSet = cSet == Just v
let lInstalled = elem v $ rights cabals
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags
, lTag = _viTags
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, lReleaseDay = _viReleaseDay
, ..
}
GHCup -> do
let lSet = prettyPVP ghcUpVer == prettyVer v
let lInstalled = lSet
pure ListResult { lVer = v
, lTag = tags
, lTag = _viTags
, lCross = Nothing
, lTool = t
, fromSrc = False
, lStray = False
, lNoBindist = False
, hlsPowered = False
, lReleaseDay = _viReleaseDay
, ..
}
HLS -> do
@ -379,11 +392,12 @@ listVersions lt' criteria = do
let lInstalled = elem v $ rights hlses
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags
, lTag = _viTags
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, lReleaseDay = _viReleaseDay
, ..
}
Stack -> do
@ -392,19 +406,43 @@ listVersions lt' criteria = do
let lInstalled = elem v $ rights stacks
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags
, lTag = _viTags
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, lReleaseDay = _viReleaseDay
, ..
}
filter' :: [ListResult] -> [ListResult]
filter' lr = case criteria of
Nothing -> lr
Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr
Just ListSet -> filter (\ListResult {..} -> lSet) lr
Just ListAvailable -> filter (\ListResult {..} -> not lNoBindist) lr
filter' = filterNightly . filterOld . filter (\lr -> foldr (\a b -> fromCriteria a lr && b) True criteria) . filterDays
filterDays :: [ListResult] -> [ListResult]
filterDays lrs = case days of
(Nothing, Nothing) -> lrs
(Just from, Just to') -> filter (\ListResult{..} -> maybe False (\d -> d >= from && d <= to') lReleaseDay) lrs
(Nothing, Just to') -> filter (\ListResult{..} -> maybe False (<= to') lReleaseDay) lrs
(Just from, Nothing) -> filter (\ListResult{..} -> maybe False (>= from) lReleaseDay) lrs
fromCriteria :: ListCriteria -> ListResult -> Bool
fromCriteria lc ListResult{..} = case lc of
ListInstalled b -> f b lInstalled
ListSet b -> f b lSet
ListAvailable b -> f b $ not lNoBindist
where
f b
| b = id
| otherwise = not
filterOld :: [ListResult] -> [ListResult]
filterOld lr
| hideOld = filter (\ListResult {..} -> lInstalled || Old `notElem` lTag) lr
| otherwise = lr
filterNightly :: [ListResult] -> [ListResult]
filterNightly lr
| showNightly = lr
| otherwise = filter (\ListResult {..} -> lInstalled || (Nightly `notElem` lTag && LatestNightly `notElem` lTag)) lr

23
lib/GHCup/Types.hs
View File

@ -31,6 +31,7 @@ import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath, GHCupPath )
import Control.DeepSeq ( NFData, rnf )
import Data.Map.Strict ( Map )
import Data.List.NonEmpty ( NonEmpty (..) )
import Data.Time.Calendar ( Day )
import Data.Text ( Text )
import Data.Versions
import GHC.IO.Exception ( ExitCode )
@ -136,6 +137,7 @@ instance NFData GlobalTool
-- source download and per-architecture downloads.
data VersionInfo = VersionInfo
{ _viTags :: [Tag] -- ^ version specific tag
, _viReleaseDay :: Maybe Day
, _viChangeLog :: Maybe URI
, _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
, _viTestDL :: Maybe DownloadInfo -- ^ test tarball
@ -155,6 +157,8 @@ data Tag = Latest
| Recommended
| Prerelease
| LatestPrerelease
| Nightly
| LatestNightly
| Base PVP
| Old -- ^ old versions are hidden by default in TUI
| UnknownTag String -- ^ used for upwardscompat
@ -166,18 +170,22 @@ tagToString :: Tag -> String
tagToString Recommended = "recommended"
tagToString Latest = "latest"
tagToString Prerelease = "prerelease"
tagToString Nightly = "nightly"
tagToString (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
tagToString (UnknownTag t ) = t
tagToString LatestPrerelease = "latest-prerelease"
tagToString LatestNightly = "latest-nightly"
tagToString Old = ""
instance Pretty Tag where
pPrint Recommended = text "recommended"
pPrint Latest = text "latest"
pPrint Prerelease = text "prerelease"
pPrint Nightly = text "nightly"
pPrint (Base pvp'') = text ("base-" ++ T.unpack (prettyPVP pvp''))
pPrint (UnknownTag t ) = text t
pPrint LatestPrerelease = text "latest-prerelease"
pPrint LatestNightly = text "latest-prerelease"
pPrint Old = mempty
data Architecture = A_64
@ -694,3 +702,18 @@ type PromptQuestion = Text
data PromptResponse = PromptYes | PromptNo
deriving (Show, Eq)
data ToolVersion = GHCVersion GHCTargetVersion
| ToolVersion Version
| ToolTag Tag
| ToolDay Day
instance Pretty ToolVersion where
pPrint (GHCVersion v) = pPrint v
pPrint (ToolVersion v) = pPrint v
pPrint (ToolTag t) = pPrint t
pPrint (ToolDay d) = text (show d)

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

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

20
lib/GHCup/Utils.hs
View File

@ -94,6 +94,7 @@ import qualified Streamly.Prelude as S
import Control.DeepSeq (force)
import GHC.IO (evaluate)
import System.Environment (getEnvironment, setEnv)
import Data.Time (Day)
-- $setup
@ -889,12 +890,21 @@ getTagged tag =
to (Map.toDescList . Map.filter (\VersionInfo {..} -> tag `elem` _viTags))
% folding id
getByReleaseDay :: GHCupDownloads -> Tool -> Day -> Maybe (Version, VersionInfo)
getByReleaseDay av tool day = headOf (ix tool % getByReleaseDayFold day) av
getByReleaseDayFold :: Day -> Fold (Map.Map Version VersionInfo) (Version, VersionInfo)
getByReleaseDayFold day = to (Map.toDescList . Map.filter (\VersionInfo {..} -> Just day == _viReleaseDay)) % folding id
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
getLatestNightly :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getLatestNightly av tool = headOf (ix tool % getTagged LatestNightly) av
getRecommended :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getRecommended av tool = headOf (ix tool % getTagged Recommended) av
@ -1081,11 +1091,15 @@ darwinNotarization _ _ = pure $ Right ()
getChangeLog :: GHCupDownloads -> Tool -> Either Version Tag -> Maybe URI
getChangeLog dls tool (Left v') =
getChangeLog :: GHCupDownloads -> Tool -> ToolVersion -> Maybe URI
getChangeLog dls tool (GHCVersion (_tvVersion -> v')) =
preview (ix tool % ix v' % viChangeLog % _Just) dls
getChangeLog dls tool (Right tag) =
getChangeLog dls tool (ToolVersion v') =
preview (ix tool % ix v' % viChangeLog % _Just) dls
getChangeLog dls tool (ToolTag tag) =
preview (ix tool % pre (getTagged tag) % to snd % viChangeLog % _Just) dls
getChangeLog dls tool (ToolDay day) =
preview (ix tool % pre (getByReleaseDayFold day) % to snd % viChangeLog % _Just) dls
-- | Execute a build action while potentially cleaning up:

4
test/GHCup/ArbitraryTypes.hs
View File

@ -11,6 +11,7 @@ import GHCup.Types
import Data.ByteString ( ByteString )
import Data.Versions
import Data.List.NonEmpty
import Data.Time.Calendar ( Day(..) )
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.ADT ( ToADTArbitrary )
import Test.QuickCheck.Arbitrary.Generic
@ -76,6 +77,9 @@ instance Arbitrary Port where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Day where
arbitrary = ModifiedJulianDay . fromIntegral <$> (chooseAny :: Gen Int)
instance Arbitrary (URIRef Absolute) where
arbitrary =
URI <$> arbitrary <*> pure Nothing <*> arbitrary <*> pure (Query []) <*> pure Nothing

52
test/golden/unix/GHCupInfo.json
View File

@ -274,6 +274,7 @@
"viPostInstall": "voj",
"viPostRemove": null,
"viPreCompile": "yma",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "wv",
@ -377,6 +378,7 @@
"viPostInstall": "drbiff",
"viPostRemove": "lk",
"viPreCompile": "thzbtj",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "jpouxbme",
@ -500,6 +502,7 @@
"viPostInstall": "uogkghr",
"viPostRemove": null,
"viPreCompile": "nmkj",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "d",
@ -816,6 +819,7 @@
"viPostInstall": "pvhnmsmi",
"viPostRemove": "jkc",
"viPreCompile": "y",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "edqa",
@ -1081,6 +1085,7 @@
"viPostInstall": "",
"viPostRemove": null,
"viPreCompile": "hnakh",
"viReleaseDay": null,
"viSourceDL": null,
"viTags": [
"base-7.3.6",
@ -1236,6 +1241,7 @@
"viPostInstall": "dwizoud",
"viPostRemove": "foi",
"viPreCompile": "ma",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "lpc",
@ -1668,6 +1674,7 @@
"viPostInstall": "anwu",
"viPostRemove": null,
"viPreCompile": "uavccmoo",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "wp",
@ -1965,6 +1972,7 @@
"viPostInstall": "mddazr",
"viPostRemove": "bltge",
"viPreCompile": "khe",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "ovmjwp",
@ -2302,6 +2310,7 @@
"viPostInstall": "egwp",
"viPostRemove": "vn",
"viPreCompile": "crsegnwv",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "gizfs",
@ -2426,6 +2435,7 @@
"viPostInstall": "hqpy",
"viPostRemove": "vbupaa",
"viPreCompile": "lu",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "l",
@ -2882,6 +2892,7 @@
"viPostInstall": null,
"viPostRemove": "jpehk",
"viPreCompile": "ucz",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "nryawf",
@ -3097,6 +3108,7 @@
"viPostInstall": "nvs",
"viPostRemove": null,
"viPreCompile": null,
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "n",
@ -3329,6 +3341,7 @@
"viPostInstall": "vouuw",
"viPostRemove": "widnqidl",
"viPreCompile": "hdykow",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "in",
@ -3688,6 +3701,7 @@
"viPostInstall": null,
"viPostRemove": "vhzr",
"viPreCompile": null,
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "ooajpjt",
@ -3755,6 +3769,7 @@
"viPostInstall": "z",
"viPostRemove": null,
"viPreCompile": null,
"viReleaseDay": null,
"viSourceDL": null,
"viTags": [
"base-2.6.5",
@ -3886,6 +3901,7 @@
"viPostInstall": "",
"viPostRemove": "o",
"viPreCompile": "vfij",
"viReleaseDay": null,
"viSourceDL": null,
"viTags": [
"base-5.4.2",
@ -4006,6 +4022,7 @@
"viPostInstall": "ezahxgy",
"viPostRemove": "",
"viPreCompile": null,
"viReleaseDay": null,
"viSourceDL": null,
"viTags": [
"old"
@ -4192,6 +4209,7 @@
"viPostInstall": "qrvyqt",
"viPostRemove": null,
"viPreCompile": null,
"viReleaseDay": null,
"viSourceDL": null,
"viTags": [
"Latest",
@ -4471,6 +4489,7 @@
"viPostInstall": "rialloi",
"viPostRemove": "hsul",
"viPreCompile": null,
"viReleaseDay": null,
"viSourceDL": null,
"viTags": [
"鲤"
@ -4832,6 +4851,7 @@
"viPostInstall": "nr",
"viPostRemove": null,
"viPreCompile": null,
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "pd",
@ -4948,6 +4968,7 @@
"viPostInstall": "avh",
"viPostRemove": "eegqaxeq",
"viPreCompile": "cyrqrsay",
"viReleaseDay": null,
"viSourceDL": null,
"viTags": [
"Latest",
@ -5036,6 +5057,7 @@
"viPostInstall": null,
"viPostRemove": null,
"viPreCompile": null,
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "p",
@ -5131,6 +5153,7 @@
"viPostInstall": "k",
"viPostRemove": "dxqp",
"viPreCompile": "fzrbyso",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "sx",
@ -5483,6 +5506,7 @@
"viPostInstall": "m",
"viPostRemove": "nwnzw",
"viPreCompile": "s",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "dinptoca",
@ -5566,6 +5590,7 @@
"viPostInstall": "bquxgn",
"viPostRemove": null,
"viPreCompile": "rtzhvw",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "xs",
@ -5678,6 +5703,7 @@
"viPostInstall": "bxdutem",
"viPostRemove": null,
"viPreCompile": "dl",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "uvy",
@ -6083,6 +6109,7 @@
"viPostInstall": "ocvjmosz",
"viPostRemove": "b",
"viPreCompile": null,
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "jo",
@ -7368,6 +7395,7 @@
"viPostInstall": null,
"viPostRemove": null,
"viPreCompile": "rkmaobn",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "gbhvafgn",
@ -8066,6 +8094,7 @@
"viPostInstall": null,
"viPostRemove": "hdst",
"viPreCompile": "lssslq",
"viReleaseDay": null,
"viSourceDL": null,
"viTags": [
"",
@ -8345,6 +8374,7 @@
"viPostInstall": null,
"viPostRemove": "lp",
"viPreCompile": "orlne",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "wehnncsi",
@ -8542,6 +8572,7 @@
"viPostInstall": "izvcv",
"viPostRemove": "byey",
"viPreCompile": "lbl",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "jqlydnm",
@ -8568,6 +8599,7 @@
"viPostInstall": "oyil",
"viPostRemove": "sirzxo",
"viPreCompile": "hecmex",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "n",
@ -8915,6 +8947,7 @@
"viPostInstall": null,
"viPostRemove": "pdwctmw",
"viPreCompile": "apqewk",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "xgebbvvt",
@ -9056,6 +9089,7 @@
"viPostInstall": "qecgd",
"viPostRemove": "zzuiq",
"viPreCompile": "jwqv",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "uhqdcf",
@ -10431,6 +10465,7 @@
"viPostInstall": null,
"viPostRemove": "inqxrwxs",
"viPreCompile": "deajwn",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "xhkk",
@ -10754,6 +10789,7 @@
"viPostInstall": "rvzk",
"viPostRemove": "r",
"viPreCompile": "",
"viReleaseDay": null,
"viSourceDL": null,
"viTags": [
"base-5.1.7",
@ -11130,6 +11166,7 @@
"viPostInstall": "jrkzdq",
"viPostRemove": "p",
"viPreCompile": "",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "fi",
@ -11376,6 +11413,7 @@
"viPostInstall": null,
"viPostRemove": "hcftjbb",
"viPreCompile": "qy",
"viReleaseDay": null,
"viSourceDL": null,
"viTags": [
"\u000c󴶑\u0001E\u0012\u0015",
@ -11394,6 +11432,7 @@
"viPostInstall": "",
"viPostRemove": null,
"viPreCompile": "hr",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "pd",
@ -11414,6 +11453,7 @@
"viPostInstall": null,
"viPostRemove": "nhlcatpc",
"viPreCompile": "wjakrdnl",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "rx",
@ -11796,6 +11836,7 @@
"viPostInstall": "cey",
"viPostRemove": "bbuscyjp",
"viPreCompile": "fvw",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "zeqioqpo",
@ -13572,6 +13613,7 @@
"viPostInstall": "jdjwlz",
"viPostRemove": "fbzect",
"viPreCompile": null,
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "woix",
@ -13624,6 +13666,7 @@
"viPostInstall": null,
"viPostRemove": null,
"viPreCompile": "dxw",
"viReleaseDay": null,
"viSourceDL": null,
"viTags": [
"Latest"
@ -13638,6 +13681,7 @@
"viPostInstall": "ly",
"viPostRemove": null,
"viPreCompile": "unrj",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "h",
@ -14092,6 +14136,7 @@
"viPostInstall": "ytr",
"viPostRemove": null,
"viPreCompile": null,
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "",
@ -14281,6 +14326,7 @@
"viPostInstall": "qvm",
"viPostRemove": "sgvk",
"viPreCompile": "nvecnkvu",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "dzydyxg",
@ -14346,6 +14392,7 @@
"viPostInstall": "segjmze",
"viPostRemove": "",
"viPreCompile": null,
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "nu",
@ -14495,6 +14542,7 @@
"viPostInstall": "kvdlwtq",
"viPostRemove": "qyvxvztp",
"viPreCompile": "hpjrxowq",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "uvyqgeiy",
@ -14667,6 +14715,7 @@
"viPostInstall": "hqxhqabh",
"viPostRemove": "h",
"viPreCompile": "",
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "mpfno",
@ -14864,6 +14913,7 @@
"viPostInstall": null,
"viPostRemove": "h",
"viPreCompile": null,
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "pazpsu",
@ -15204,6 +15254,7 @@
"viPostInstall": "uvftr",
"viPostRemove": "",
"viPreCompile": null,
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "orhgsp",
@ -15565,6 +15616,7 @@
"viPostInstall": "js",
"viPostRemove": "mjwcdv",
"viPreCompile": null,
"viReleaseDay": null,
"viSourceDL": {
"dlCSize": null,
"dlHash": "poxbrll",

21335
test/golden/windows/GHCupInfo.json
View File

File diff suppressed because it is too large Load Diff