Update ghcup-gen

This commit is contained in:
Julian Ospald 2023-11-17 22:24:19 +08:00
parent 174ff702a5
commit dc6d43ddba
No known key found for this signature in database
GPG Key ID: 4275CDA6A29BED43
4 changed files with 16 additions and 26 deletions

View File

@ -7,7 +7,7 @@ package ghcup
source-repository-package
type: git
location: https://github.com/haskell/ghcup-hs.git
tag: e27fed09f3eb4b0b72ce7825c65f16a4202a2399
tag: b1106985ec1173a0122f2781719e9bb1a85de257
constraints: http-io-streams -brotli,
any.aeson >= 2.0.1.0

View File

@ -135,15 +135,13 @@ tarballFilterP = option readm $
long "tarball-filter" <> short 'u' <> metavar "<tool>-<version>" <> value def
<> help "Only check certain tarballs (format: <tool>-<version>)"
where
def = TarballFilter (Right Nothing) (makeRegex ("" :: String))
def = TarballFilter Nothing (makeRegex ("" :: String))
readm = do
s <- str
case span (/= '-') s of
(_, []) -> fail "invalid format, missing '-' after the tool name"
(t, v) | [tool] <- [ tool | tool <- [minBound..maxBound], low (show tool) == low t ] ->
pure (TarballFilter $ Right $ Just tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
(t, v) | [tool] <- [ tool | tool <- [minBound..maxBound], low (show tool) == low t ] ->
pure (TarballFilter $ Left tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
pure (TarballFilter $ Just tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
_ -> fail "invalid tool"
low = fmap toLower
@ -206,7 +204,7 @@ main = do
flip runReaderT leanAppstate $ logError $ T.pack $ prettyShow e
liftIO $ exitWith (ExitFailure 2)
let appstate = AppState (Settings True 0 Lax False Never Curl True GHCupURL False GPGNone True Nothing (DM mempty)) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq loggerConfig
let appstate = AppState (Settings True 0 Lax False Never Curl True GHCupURL False GPGNone True Nothing (DM mempty)) dirs defaultKeyBindings (GHCupInfo mempty mempty Nothing) pfreq loggerConfig
let withValidateYamlOpts vopts f = case vopts of
ValidateYAMLOpts { vInput = Nothing } ->

View File

@ -207,7 +207,7 @@ validate distroChannel = do
isBase _ = False
data TarballFilter = TarballFilter
{ tfTool :: Either GlobalTool (Maybe Tool)
{ tfTool :: Maybe Tool
, tfVersion :: Regex
}
@ -226,20 +226,16 @@ validateTarballs :: ( Monad m
)
=> TarballFilter
-> m ExitCode
validateTarballs (TarballFilter etool versionRegex) = do
GHCupInfo { _ghcupDownloads = dls, _globalTools = gt } <- getGHCupInfo
validateTarballs (TarballFilter mtool versionRegex) = do
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
ref <- liftIO $ newIORef 0
-- download/verify all tarballs
let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool)
%> each %& indices (matchTest versionRegex . T.unpack . prettyVer . _tvVersion)
% (viTestDL % _Just `summing` viSourceDL % _Just `summing` viArch % each % each % each)
)
etool
let gdlis = nubOrd $ gt ^.. each
let allDls = either (const gdlis) (const dlis) etool
when (null allDls) $ logError "no tarballs selected by filter" *> runReaderT addError ref
forM_ allDls (downloadAll ref)
let dlis = nubOrd $ dls ^.. each %& indices (maybe (const True) (==) mtool)
%> each %& indices (matchTest versionRegex . T.unpack . prettyVer . _tvVersion)
% (viTestDL % _Just `summing` viSourceDL % _Just `summing` viArch % each % each % each)
when (null dlis) $ logError "no tarballs selected by filter" *> runReaderT addError ref
forM_ dlis (downloadAll ref)
-- exit
e <- liftIO $ readIORef ref
@ -273,20 +269,16 @@ validateTarballs (TarballFilter etool versionRegex) = do
, ContentLengthError
]
$ do
case etool of
Right (Just GHCup) -> do
case mtool of
(Just GHCup) -> do
tmpUnpack <- lift mkGhcupTmpDir
_ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) Nothing (fromGHCupPath tmpUnpack) Nothing False
pure Nothing
Right _ -> do
_ -> do
p <- liftE $ downloadCached dli Nothing
fmap Just $ liftE
. getArchiveFiles
$ p
Left ShimGen -> do
tmpUnpack <- lift mkGhcupTmpDir
_ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) Nothing (fromGHCupPath tmpUnpack) Nothing False
pure Nothing
case r of
VRight (Just entries) -> do
case _dlSubdir dli of

View File

@ -65,5 +65,5 @@ executable ghcup-gen
, safe-exceptions ^>=0.1
, text ^>=2.0
, transformers ^>=0.5
, versions >=4.0.1 && <5.1
, versions >=6.0.0
, yaml-streamly ^>=0.12.0