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

Merge branch 'fix-list-tools'

Browse Source
This commit is contained in:
Julian Ospald 2021-07-27 23:16:18 +02:00
commit 00caeba067
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
5 changed files with 59 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -126,7 +126,7 @@ validate dls _ = do
_ -> lift $ $(logWarn) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|]
checkUniqueTags tool = do
let allTags = join $ M.elems $ availableToolVersions dls tool
let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
let nonUnique =
fmap fst
. filter (\(_, b) -> not b)
@ -164,7 +164,7 @@ validate dls _ = do
-- a tool must have at least one of each mandatory tags
checkMandatoryTags tool = do
let allTags = join $ M.elems $ availableToolVersions dls tool
let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
forM_ [Latest, Recommended] $ \t -> case elem t allTags of
False -> do
lift $ $(logError) [i|Tag #{t} missing from #{tool}|]
@ -174,7 +174,7 @@ validate dls _ = do
-- all GHC versions must have a base tag
checkGHCHasBaseVersion = do
let allTags = M.toList $ availableToolVersions dls GHC
forM allTags $ \(ver, tags) -> case any isBase tags of
forM allTags $ \(ver, _viTags -> tags) -> case any isBase tags of
False -> do
lift $ $(logError) [i|Base tag missing from GHC ver #{ver}|]
addError

36
app/ghcup/Main.hs
View File

@ -1061,6 +1061,7 @@ tagCompleter tool add = listIOCompleter $ do
VRight ghcupInfo -> do
let allTags = filter (\t -> t /= Old)
$ join
$ fmap _viTags
$ M.elems
$ availableToolVersions (_ghcupDownloads ghcupInfo) tool
pure $ nub $ (add ++) $ fmap tagToString allTags
@ -2026,22 +2027,25 @@ Make sure to clean up #{tmpdir} afterwards.|])
(UpgradeAt p) -> pure $ Just p
UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt))
runUpgrade (liftE $ upgradeGHCup target force') >>= \case
VRight v' -> do
GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
let pretty_v = prettyVer v'
let vi = fromJust $ snd <$> getLatest dls GHCup
runLogger $ $(logInfo)
[i|Successfully upgraded GHCup to version #{pretty_v}|]
forM_ (_viPostInstall vi) $ \msg ->
runLogger $ $(logInfo) msg
pure ExitSuccess
VLeft (V NoUpdate) -> do
runLogger $ $(logWarn) [i|No GHCup update available|]
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 11
runUpgrade (do
v' <- liftE $ upgradeGHCup target force'
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (v', dls)
) >>= \case
VRight (v', dls) -> do
let pretty_v = prettyVer v'
let vi = fromJust $ snd <$> getLatest dls GHCup
runLogger $ $(logInfo)
[i|Successfully upgraded GHCup to version #{pretty_v}|]
forM_ (_viPostInstall vi) $ \msg ->
runLogger $ $(logInfo) msg
pure ExitSuccess
VLeft (V NoUpdate) -> do
runLogger $ $(logWarn) [i|No GHCup update available|]
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 11
ToolRequirements -> do
s' <- appState

7
ghcup-0.0.5.yaml
View File

@ -2076,7 +2076,10 @@ ghcupDownloads:
1.1.0:
viTags: []
viChangeLog: https://github.com/haskell/haskell-language-server/blob/master/ChangeLog.md#110
viPostInstall: "This is just the server part of your LSP configuration. Consult the README on how to configure HLS, your project and your LSP client in your editor: https://github.com/haskell/haskell-language-server/blob/master/README.md"
viPostInstall: &hls-post-install |
This is just the server part of your LSP configuration. Consult the README on how to
configure HLS, your project and your LSP client in your editor:
https://github.com/haskell/haskell-language-server/blob/master/README.md
viArch:
A_64:
Linux_UnknownLinux:
@ -2098,7 +2101,7 @@ ghcupDownloads:
- Recommended
- Latest
viChangeLog: https://github.com/haskell/haskell-language-server/blob/master/ChangeLog.md#120
viPostInstall: "This is just the server part of your LSP configuration. Consult the README on how to configure HLS, your project and your LSP client in your editor: https://github.com/haskell/haskell-language-server/blob/master/README.md"
viPostInstall: *hls-post-install
viArch:
A_64:
Linux_UnknownLinux:

2
ghcup.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 3.0
name: ghcup
version: 0.1.15.2
version: 0.1.16
license: LGPL-3.0-only
license-file: LICENSE
copyright: Julian Ospald 2020

39
lib/GHCup.hs
View File

@ -965,9 +965,9 @@ data ListResult = ListResult
-- | Extract all available tool versions and their tags.
availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version [Tag]
availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version VersionInfo
availableToolVersions av tool = view
(at tool % non Map.empty % to (fmap _viTags))
(at tool % non Map.empty)
av
@ -1018,7 +1018,9 @@ listVersions lt' criteria = do
Stack -> do
slr <- strayStacks avTools sSet stacks
pure (sort (slr ++ lr))
GHCup -> pure lr
GHCup -> do
let cg = currentGHCup avTools
pure (sort (cg : lr))
Nothing -> do
ghcvers <- go (Just GHC) cSet cabals hlsSet' hlses sSet stacks
cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses sSet stacks
@ -1033,7 +1035,7 @@ listVersions lt' criteria = do
, MonadLogger m
, MonadIO m
)
=> Map.Map Version [Tag]
=> Map.Map Version VersionInfo
-> m [ListResult]
strayGHCs avTools = do
ghcs <- getInstalledGHCs
@ -1081,7 +1083,7 @@ listVersions lt' criteria = do
, MonadLogger m
, MonadIO m
)
=> Map.Map Version [Tag]
=> Map.Map Version VersionInfo
-> Maybe Version
-> [Either FilePath Version]
-> m [ListResult]
@ -1115,7 +1117,7 @@ listVersions lt' criteria = do
, MonadThrow m
, MonadLogger m
, MonadIO m)
=> Map.Map Version [Tag]
=> Map.Map Version VersionInfo
-> Maybe Version
-> [Either FilePath Version]
-> m [ListResult]
@ -1150,7 +1152,7 @@ listVersions lt' criteria = do
, MonadLogger m
, MonadIO m
)
=> Map.Map Version [Tag]
=> Map.Map Version VersionInfo
-> Maybe Version
-> [Either FilePath Version]
-> m [ListResult]
@ -1178,6 +1180,25 @@ listVersions lt' criteria = do
[i|Could not parse version of stray directory #{e}|]
pure Nothing
currentGHCup :: Map.Map Version VersionInfo -> ListResult
currentGHCup av =
let currentVer = pvpToVersion ghcUpVer
listVer = Map.lookup currentVer av
latestVer = fst <$> headOf (getTagged Latest) av
recommendedVer = fst <$> headOf (getTagged Latest) av
isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer
in ListResult { lVer = currentVer
, lTag = maybe (if isOld then [Old] else []) _viTags listVer
, lCross = Nothing
, lTool = GHCup
, fromSrc = False
, lStray = isNothing listVer
, lSet = True
, lInstalled = True
, lNoBindist = False
, hlsPowered = False
}
-- NOTE: this are not cross ones, because no bindists
toListResult :: ( MonadLogger m
, MonadReader env m
@ -1194,9 +1215,9 @@ listVersions lt' criteria = do
-> [Either FilePath Version]
-> Maybe Version
-> [Either FilePath Version]
-> (Version, [Tag])
-> (Version, VersionInfo)
-> m ListResult
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, tags) = do
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, _viTags -> tags) = do
case t of
GHC -> do
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v