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

Merge remote-tracking branch 'origin/pr/844'

This commit is contained in:
Julian Ospald 2023-07-11 23:30:51 +08:00
parent 7b1f591cc4 07dfb1e94b
commit a05f272b58
No known key found for this signature in database
GPG Key ID: CCC85C0E40C06A8C
21 changed files with 209 additions and 172 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
.github/scripts/cabal-cache.sh vendored Normal file
View File

@ -0,0 +1,13 @@
#!/usr/bin/env bash
case "$(uname -s)" in
MSYS_*|MINGW*)
ext=".exe"
;;
*)
ext=""
;;
esac
echo "cabal-cache disabled (CABAL_CACHE_DISABLE set)"

8
.github/scripts/common.sh vendored
View File

@ -15,7 +15,7 @@ sync_from() {
cabal_store_path="$(dirname "$(cabal help user-config | tail -n 1 | xargs)")/store"
fi
cabal-cache sync-from-archive \
cabal-cache.sh sync-from-archive \
--host-name-override=${S3_HOST} \
--host-port-override=443 \
--host-ssl-override=True \
@ -29,7 +29,7 @@ sync_to() {
cabal_store_path="$(dirname "$(cabal help user-config | tail -n 1 | xargs)")/store"
fi
cabal-cache sync-to-archive \
cabal-cache.sh sync-to-archive \
--host-name-override=${S3_HOST} \
--host-port-override=443 \
--host-ssl-override=True \
@ -115,6 +115,10 @@ download_cabal_cache() {
mv "cabal-cache${exe}" "${dest}${exe}"
chmod +x "${dest}${exe}"
fi
# install shell wrapper
cp "${CI_PROJECT_DIR}"/.github/scripts/cabal-cache.sh "$HOME"/.local/bin/
chmod +x "$HOME"/.local/bin/cabal-cache.sh
)
}

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

@ -12,6 +12,10 @@ on:
schedule:
- cron: '0 2 * * *'
env:
CABAL_CACHE_DISABLE: ${{ vars.CABAL_CACHE_DISABLE }}
CABAL_CACHE_NONFATAL: yes
jobs:
build-linux:
name: Build linux binary

22
app/ghcup/BrickMain.hs
View File

@ -156,10 +156,10 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
<+> padLeft (Pad 1) (minHSize 25 $ str "Tags")
<+> padLeft (Pad 5) (str "Notes")
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 minTagSize = V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) clr
minVerSize = V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (GHCTargetVersion lCross lVer)) clr
in withDefAttr listAttr . drawListElements (renderItem minTagSize minVerSize) True $ bis
renderItem minTagSize minVerSize _ b listResult@ListResult{lTag = lTag', ..} =
let marks = if
| lSet -> (withAttr (attrName "set") $ str "✔✔")
| lInstalled -> (withAttr (attrName "installed") $ str "✓ ")
@ -184,7 +184,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
( minHSize 6
(printTool lTool)
)
<+> minHSize 15 (str ver)
<+> minHSize minVerSize (str ver)
<+> (let l = catMaybes . fmap printTag $ sort lTag'
in padLeft (Pad 1) $ minHSize minTagSize $ if null l
then emptyWidget
@ -472,19 +472,19 @@ install' _ (_, ListResult {..}) = do
dirs <- lift getDirs
case lTool of
GHC -> do
let vi = getVersionInfo lVer GHC dls
liftE $ installGHCBin lVer GHCupInternal False [] $> (vi, dirs, ce)
let vi = getVersionInfo (GHCTargetVersion lCross lVer) GHC dls
liftE $ installGHCBin (GHCTargetVersion lCross lVer) GHCupInternal False [] $> (vi, dirs, ce)
Cabal -> do
let vi = getVersionInfo lVer Cabal dls
let vi = getVersionInfo (GHCTargetVersion lCross lVer) Cabal dls
liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce)
GHCup -> do
let vi = snd <$> getLatest dls GHCup
liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce)
HLS -> do
let vi = getVersionInfo lVer HLS dls
let vi = getVersionInfo (GHCTargetVersion lCross lVer) HLS dls
liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce)
Stack -> do
let vi = getVersionInfo lVer Stack dls
let vi = getVersionInfo (GHCTargetVersion lCross lVer) Stack dls
liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce)
)
>>= \case
@ -565,7 +565,7 @@ del' _ (_, ListResult {..}) = do
let run = runE @'[NotInstalled, UninstallFailed]
run (do
let vi = getVersionInfo lVer lTool dls
let vi = getVersionInfo (GHCTargetVersion lCross lVer) lTool dls
case lTool of
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi
Cabal -> liftE $ rmCabalVer lVer $> vi

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

@ -5,6 +5,7 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ViewPatterns #-}
module GHCup.OptParse.Common where
@ -693,52 +694,52 @@ fromVersion' :: ( HasLog env
] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion' SetRecommended tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getRecommended dls tool
second Just <$> getRecommended dls tool
?? TagNotFound Recommended tool
fromVersion' (SetGHCVersion v) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion v) tool dls
let vi = getVersionInfo v tool dls
case pvp $ prettyVer (_tvVersion v) of -- need to be strict here
Left _ -> pure (v, vi)
Right pvpIn ->
lift (getLatestToolFor tool pvpIn dls) >>= \case
Just (pvp_, vi') -> do
lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case
Just (pvp_, vi', mt) -> do
v' <- lift $ pvpToVersion pvp_ ""
when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
pure (GHCTargetVersion (_tvTarget v) v', Just vi')
pure (GHCTargetVersion mt v', Just vi')
Nothing -> pure (v, vi)
fromVersion' (SetToolVersion v) tool = do
fromVersion' (SetToolVersion (mkTVer -> v)) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo v tool dls
case pvp $ prettyVer v of -- need to be strict here
Left _ -> pure (mkTVer v, vi)
case pvp $ prettyVer (_tvVersion v) of -- need to be strict here
Left _ -> pure (v, vi)
Right pvpIn ->
lift (getLatestToolFor tool pvpIn dls) >>= \case
Just (pvp_, vi') -> do
lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case
Just (pvp_, vi', mt) -> do
v' <- lift $ pvpToVersion pvp_ ""
when (v' /= v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
pure (GHCTargetVersion mempty v', Just vi')
Nothing -> pure (mkTVer v, vi)
when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
pure (GHCTargetVersion mt v', Just vi')
Nothing -> pure (v, vi)
fromVersion' (SetToolTag Latest) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getLatest dls tool ?? TagNotFound Latest tool
bimap id Just <$> getLatest dls tool ?? TagNotFound Latest tool
fromVersion' (SetToolDay day) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> case getByReleaseDay dls tool day of
bimap id Just <$> case getByReleaseDay dls tool day of
Left ad -> throwE $ DayNotFound day tool ad
Right v -> pure v
fromVersion' (SetToolTag LatestPrerelease) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getLatestPrerelease dls tool ?? TagNotFound LatestPrerelease tool
bimap id 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
bimap id 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
bimap id Just <$> getRecommended dls tool ?? TagNotFound Recommended tool
fromVersion' (SetToolTag (Base pvp'')) GHC = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
bimap id Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
fromVersion' SetNext tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
next <- case tool of
@ -783,7 +784,7 @@ fromVersion' SetNext tool = do
. sort
$ stacks) ?? NoToolVersionSet tool
GHCup -> fail "GHCup cannot be set"
let vi = getVersionInfo (_tvVersion next) tool dls
let vi = getVersionInfo next tool dls
pure (next, vi)
fromVersion' (SetToolTag t') tool =
throwE $ TagNotFound t' tool
@ -799,15 +800,15 @@ checkForUpdates :: ( MonadReader env m
, MonadIO m
, MonadFail m
)
=> m [(Tool, Version)]
=> m [(Tool, GHCTargetVersion)]
checkForUpdates = do
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
lInstalled <- listVersions Nothing [ListInstalled True] False False (Nothing, Nothing)
let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled
let latestInstalled tool = (fmap (\lr -> GHCTargetVersion (lCross lr) (lVer lr)) . lastMay . filter (\lr -> lTool lr == tool)) lInstalled
ghcup <- forMM (getLatest dls GHCup) $ \(l, _) -> do
ghcup <- forMM (getLatest dls GHCup) $ \(GHCTargetVersion _ l, _) -> do
(Right ghcup_ver) <- pure $ version $ prettyPVP ghcUpVer
if (l > ghcup_ver) then pure $ Just (GHCup, l) else pure Nothing
if (l > ghcup_ver) then pure $ Just (GHCup, mkTVer l) else pure Nothing
otherTools <- forM [GHC, Cabal, HLS, Stack] $ \t ->
forMM (getLatest dls t) $ \(l, _) -> do

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

@ -66,7 +66,7 @@ data CompileCommand = CompileGHC GHCCompileOptions
data GHCCompileOptions = GHCCompileOptions
{ targetGhc :: GHC.GHCVer Version
{ targetGhc :: GHC.GHCVer
, bootstrapGhc :: Either Version FilePath
, jobs :: Maybe Int
, buildConfig :: Maybe FilePath
@ -511,7 +511,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
case targetHLS of
HLS.SourceDist targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer HLS dls
let vi = getVersionInfo (mkTVer targetVer) HLS dls
forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ logInfo msg
lift $ logInfo
@ -531,7 +531,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
patches
cabalArgs
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer HLS dls
let vi = getVersionInfo (mkTVer targetVer) HLS dls
when setCompile $ void $ liftE $
setHLS targetVer SetHLSOnly Nothing
pure (vi, targetVer)
@ -555,15 +555,12 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
VLeft e -> do
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 9
(CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do
runLogger $ logError "Hadrian cross compile support is not yet implemented!"
pure $ ExitFailure 9
(CompileGHC GHCCompileOptions {..}) ->
runCompileGHC runAppState (do
case targetGhc of
GHC.SourceDist targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer GHC dls
let vi = getVersionInfo (mkTVer targetVer) GHC dls
forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ logInfo msg
lift $ logInfo
@ -571,10 +568,8 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
_ -> pure ()
targetVer <- liftE $ compileGHC
((\case
GHC.SourceDist v -> GHC.SourceDist $ GHCTargetVersion crossTarget v
GHC.GitDist g -> GHC.GitDist g
GHC.RemoteDist r -> GHC.RemoteDist r) targetGhc)
targetGhc
crossTarget
ovewrwiteVer
bootstrapGhc
jobs
@ -585,7 +580,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
hadrian
(maybe GHCupInternal IsolateDir isolateDir)
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion targetVer) GHC dls
let vi = getVersionInfo targetVer GHC dls
when setCompile $ void $ liftE $
setGHC targetVer SetGHCOnly Nothing
pure (vi, targetVer)

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

@ -324,7 +324,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
Nothing -> runInstGHC s' $ do
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ runBothE' (installGHCBin
(_tvVersion v)
v
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
addConfArgs
@ -336,7 +336,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ runBothE' (installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing)
(_tvVersion v)
v
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
addConfArgs

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

@ -195,7 +195,7 @@ prefetch prefetchCommand runAppState runLogger =
forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt GHC
if pfGHCSrc
then liftE $ fetchGHCSrc (_tvVersion v) pfCacheDir
then liftE $ fetchGHCSrc v pfCacheDir
else liftE $ fetchToolBindist (_tvVersion v) GHC pfCacheDir
PrefetchCabal PrefetchOptions {pfCacheDir} mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive')

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

@ -170,7 +170,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
liftE $
rmGHCVer ghcVer
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo (_tvVersion ghcVer) GHC dls)
pure (getVersionInfo ghcVer GHC dls)
)
>>= \case
VRight vi -> do
@ -186,7 +186,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
liftE $
rmCabalVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv Cabal dls)
pure (getVersionInfo (mkTVer tv) Cabal dls)
)
>>= \case
VRight vi -> do
@ -201,7 +201,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
liftE $
rmHLSVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv HLS dls)
pure (getVersionInfo (mkTVer tv) HLS dls)
)
>>= \case
VRight vi -> do
@ -216,7 +216,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
liftE $
rmStackVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv Stack dls)
pure (getVersionInfo (mkTVer tv) Stack dls)
)
>>= \case
VRight vi -> do

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

@ -360,7 +360,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
Just v -> do
isInstalled <- lift $ checkIfToolInstalled' GHC v
unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin
(_tvVersion v)
v
GHCupInternal
False
[]

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

@ -169,12 +169,12 @@ test testCommand settings getAppState' runLogger = case testCommand of
(case testBindist of
Nothing -> runTestGHC s' $ do
(v, vi) <- liftE $ fromVersion testVer GHC
liftE $ testGHCVer (_tvVersion v) addMakeArgs
liftE $ testGHCVer v addMakeArgs
pure vi
Just uri -> do
runTestGHC s'{ settings = settings {noVerify = True}} $ do
(v, vi) <- liftE $ fromVersion testVer GHC
liftE $ testGHCBindist (DownloadInfo uri (Just $ RegexDir ".*/.*") "" Nothing Nothing) (_tvVersion v) addMakeArgs
liftE $ testGHCBindist (DownloadInfo uri (Just $ RegexDir ".*/.*") "" Nothing Nothing) v addMakeArgs
pure vi
)
>>= \case

10
app/ghcup/Main.hs
View File

@ -249,7 +249,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
case t of
GHCup -> runLogger $
logWarn ("New GHCup version available: "
<> prettyVer l
<> tVerToText l
<> ". To upgrade, run 'ghcup upgrade'")
_ -> runLogger $
logWarn ("New "
@ -258,7 +258,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
<> "If you want to install this latest version, run 'ghcup install "
<> T.pack (prettyShow t)
<> " "
<> prettyVer l
<> tVerToText l
<> "'")
Just _ -> pure ()
@ -332,7 +332,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
, MonadCatch m
)
=> Command
-> (Tool, Version)
-> (Tool, GHCTargetVersion)
-> Excepts
'[ TagNotFound
, DayNotFound
@ -368,7 +368,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
)
=> Tool
-> Maybe ToolVersion
-> Version
-> GHCTargetVersion
-> Excepts
'[ TagNotFound
, DayNotFound
@ -377,4 +377,4 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
] m Bool
cmp' tool instVer ver = do
(v, _) <- liftE $ fromVersion instVer tool
pure (v == mkTVer ver)
pure (v == ver)

4
lib/GHCup.hs
View File

@ -303,7 +303,7 @@ upgradeGHCup mtarget force' fatal = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
lift $ logInfo "Upgrading GHCup..."
let latestVer = fst (fromJust (getLatest dls GHCup))
let latestVer = _tvVersion $ fst (fromJust (getLatest dls GHCup))
(Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer ""
when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate
dli <- liftE $ getDownloadInfo GHCup latestVer
@ -492,7 +492,7 @@ rmOldGHC :: ( MonadReader env m
=> Excepts '[NotInstalled, UninstallFailed] m ()
rmOldGHC = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let oldGHCs = mkTVer <$> toListOf (ix GHC % getTagged Old % to fst) dls
let oldGHCs = toListOf (ix GHC % getTagged Old % to fst) dls
ghcs <- lift $ fmap rights getInstalledGHCs
forM_ ghcs $ \ghc -> when (ghc `elem` oldGHCs) $ rmGHCVer ghc

16
lib/GHCup/Download.hs
View File

@ -271,7 +271,6 @@ getBase uri = do
pure f
getDownloadInfo :: ( MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
@ -283,7 +282,20 @@ getDownloadInfo :: ( MonadReader env m
'[NoDownload]
m
DownloadInfo
getDownloadInfo t v = do
getDownloadInfo t v = getDownloadInfo' t (mkTVer v)
getDownloadInfo' :: ( MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
)
=> Tool
-> GHCTargetVersion
-- ^ tool version
-> Excepts
'[NoDownload]
m
DownloadInfo
getDownloadInfo' t v = do
(PlatformRequest a p mv) <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo

95
lib/GHCup/GHC.hs
View File

@ -80,9 +80,9 @@ import qualified Data.Text.Encoding as E
import qualified Text.Megaparsec as MP
data GHCVer v = SourceDist v
| GitDist GitBranch
| RemoteDist URI
data GHCVer = SourceDist Version
| GitDist GitBranch
| RemoteDist URI
@ -105,7 +105,7 @@ testGHCVer :: ( MonadFail m
, MonadIO m
, MonadUnliftIO m
)
=> Version
=> GHCTargetVersion
-> [T.Text]
-> Excepts
'[ DigestError
@ -145,7 +145,7 @@ testGHCBindist :: ( MonadFail m
, MonadUnliftIO m
)
=> DownloadInfo
-> Version
-> GHCTargetVersion
-> [T.Text]
-> Excepts
'[ DigestError
@ -182,7 +182,7 @@ testPackedGHC :: ( MonadMask m
)
=> FilePath -- ^ Path to the packed GHC bindist
-> Maybe TarDir -- ^ Subdir of the archive
-> Version -- ^ The GHC version
-> GHCTargetVersion -- ^ The GHC version
-> [T.Text] -- ^ additional make args
-> Excepts
'[ ArchiveResult, UnknownArchive, TarDirDoesNotExist, TestFailed ] m ()
@ -208,19 +208,21 @@ testUnpackedGHC :: ( MonadReader env m
, MonadIO m
)
=> GHCupPath -- ^ Path to the unpacked GHC bindist (where the make file resides)
-> Version -- ^ The GHC version
-> GHCTargetVersion -- ^ The GHC version
-> [T.Text] -- ^ additional configure args for bindist
-> Excepts '[ProcessError] m ()
testUnpackedGHC path ver addMakeArgs = do
lift $ logInfo $ "Testing GHC version " <> prettyVer ver <> "!"
ghcDir <- lift $ ghcupGHCDir (mkTVer ver)
testUnpackedGHC path tver addMakeArgs = do
lift $ logInfo $ "Testing GHC version " <> tVerToText tver <> "!"
ghcDir <- lift $ ghcupGHCDir tver
let ghcBinDir = fromGHCupPath ghcDir </> "bin"
env <- liftIO $ addToPath ghcBinDir False
lEM $ make' (fmap T.unpack addMakeArgs)
(Just $ fromGHCupPath path)
"ghc-test"
(Just $ ("STAGE1_GHC", "ghc-" <> T.unpack (prettyVer ver)) : env)
(Just $ ("STAGE1_GHC", maybe "" (T.unpack . (<> "-")) (_tvTarget tver)
<> "ghc-"
<> T.unpack (prettyVer $ _tvVersion tver)) : env)
pure ()
@ -243,7 +245,7 @@ fetchGHCSrc :: ( MonadFail m
, MonadIO m
, MonadUnliftIO m
)
=> Version
=> GHCTargetVersion
-> Maybe FilePath
-> Excepts
'[ DigestError
@ -283,7 +285,7 @@ installGHCBindist :: ( MonadFail m
, MonadUnliftIO m
)
=> DownloadInfo -- ^ where/how to download
-> Version -- ^ the version to install
-> GHCTargetVersion -- ^ the version to install
-> InstallDir
-> Bool -- ^ Force install
-> [T.Text] -- ^ additional configure args for bindist
@ -306,10 +308,8 @@ installGHCBindist :: ( MonadFail m
]
m
()
installGHCBindist dlinfo ver installDir forceInstall addConfArgs = do
let tver = mkTVer ver
lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver
installGHCBindist dlinfo tver installDir forceInstall addConfArgs = do
lift $ logDebug $ "Requested to install GHC with " <> tVerToText tver
regularGHCInstalled <- lift $ ghcInstalled tver
@ -317,7 +317,7 @@ installGHCBindist dlinfo ver installDir forceInstall addConfArgs = do
| not forceInstall
, regularGHCInstalled
, GHCupInternal <- installDir -> do
throwE $ AlreadyInstalled GHC ver
throwE $ AlreadyInstalled GHC (_tvVersion tver)
| forceInstall
, regularGHCInstalled
@ -336,12 +336,12 @@ installGHCBindist dlinfo ver installDir forceInstall addConfArgs = do
case installDir of
IsolateDir isoDir -> do -- isolated install
lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir
liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) ver forceInstall addConfArgs
liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) tver forceInstall addConfArgs
GHCupInternal -> do -- regular install
-- prepare paths
ghcdir <- lift $ ghcupGHCDir tver
liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) ver forceInstall addConfArgs
liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) tver forceInstall addConfArgs
-- make symlinks & stuff when regular install,
liftE $ postGHCInstall tver
@ -375,7 +375,7 @@ installPackedGHC :: ( MonadMask m
=> FilePath -- ^ Path to the packed GHC bindist
-> Maybe TarDir -- ^ Subdir of the archive
-> InstallDirResolved
-> Version -- ^ The GHC version
-> GHCTargetVersion -- ^ The GHC version
-> Bool -- ^ Force install
-> [T.Text] -- ^ additional configure args for bindist
-> Excepts
@ -423,17 +423,17 @@ installUnpackedGHC :: ( MonadReader env m
)
=> GHCupPath -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> InstallDirResolved -- ^ Path to install to
-> Version -- ^ The GHC version
-> GHCTargetVersion -- ^ The GHC version
-> Bool -- ^ Force install
-> [T.Text] -- ^ additional configure args for bindist
-> Excepts '[ProcessError, MergeFileTreeError] m ()
installUnpackedGHC path inst ver forceInstall addConfArgs
installUnpackedGHC path inst tver forceInstall addConfArgs
| isWindows = do
lift $ logInfo "Installing GHC (this may take a while)"
-- Windows bindists are relocatable and don't need
-- to run configure.
-- We also must make sure to preserve mtime to not confuse ghc-pkg.
liftE $ mergeFileTree path inst GHC (mkTVer ver) $ \source dest -> do
liftE $ mergeFileTree path inst GHC tver $ \source dest -> do
mtime <- liftIO $ ifM (pathIsSymbolicLink source) (pure Nothing) (Just <$> getModificationTime source)
when forceInstall $ hideError doesNotExistErrorType $ hideError InappropriateType $ recycleFile dest
liftIO $ moveFilePortable source dest
@ -442,7 +442,7 @@ installUnpackedGHC path inst ver forceInstall addConfArgs
PlatformRequest {..} <- lift getPlatformReq
let ldOverride
| ver >= [vver|8.2.2|]
| _tvVersion tver >= [vver|8.2.2|]
, _rPlatform `elem` [Linux Alpine, Darwin]
= ["--disable-ld-override"]
| otherwise
@ -451,7 +451,7 @@ installUnpackedGHC path inst ver forceInstall addConfArgs
lift $ logInfo "Installing GHC (this may take a while)"
lEM $ execLogged "sh"
("./configure" : ("--prefix=" <> fromInstallDir inst)
: (ldOverride <> (T.unpack <$> addConfArgs))
: (maybe mempty (\x -> ["--target=" <> T.unpack x]) (_tvTarget tver) <> ldOverride <> (T.unpack <$> addConfArgs))
)
(Just $ fromGHCupPath path)
"ghc-configure"
@ -462,7 +462,7 @@ installUnpackedGHC path inst ver forceInstall addConfArgs
liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst))
inst
GHC
(mkTVer ver)
tver
(\f t -> liftIO $ do
mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f)
install f t (not forceInstall)
@ -489,7 +489,7 @@ installGHCBin :: ( MonadFail m
, MonadIO m
, MonadUnliftIO m
)
=> Version -- ^ the version to install
=> GHCTargetVersion -- ^ the version to install
-> InstallDir
-> Bool -- ^ force install
-> [T.Text] -- ^ additional configure args for bindist
@ -512,9 +512,9 @@ installGHCBin :: ( MonadFail m
]
m
()
installGHCBin ver installDir forceInstall addConfArgs = do
dlinfo <- liftE $ getDownloadInfo GHC ver
liftE $ installGHCBindist dlinfo ver installDir forceInstall addConfArgs
installGHCBin tver installDir forceInstall addConfArgs = do
dlinfo <- liftE $ getDownloadInfo' GHC tver
liftE $ installGHCBindist dlinfo tver installDir forceInstall addConfArgs
@ -755,7 +755,8 @@ compileGHC :: ( MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> GHCVer GHCTargetVersion
=> GHCVer
-> Maybe Text -- ^ cross target
-> Maybe Version -- ^ overwrite version
-> Either Version FilePath -- ^ version to bootstrap with
-> Maybe Int -- ^ jobs
@ -792,19 +793,19 @@ compileGHC :: ( MonadMask m
]
m
GHCTargetVersion
compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian installDir
compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian installDir
= do
PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
(workdir, tmpUnpack, tver) <- case targetGhc of
-- unpack from version tarball
SourceDist tver -> do
lift $ logDebug $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap
SourceDist ver -> do
lift $ logDebug $ "Requested to compile: " <> prettyVer ver <> " with " <> either prettyVer T.pack bstrap
-- download source tarball
dlInfo <-
preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls
preview (ix GHC % ix (mkTVer ver) % viSourceDL % _Just) dls
?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing
@ -818,7 +819,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
(view dlSubdir dlInfo)
liftE $ applyAnyPatch patches (fromGHCupPath workdir)
pure (workdir, tmpUnpack, Just tver)
pure (workdir, tmpUnpack, Just (GHCTargetVersion crossTarget ver))
RemoteDist uri -> do
lift $ logDebug $ "Requested to compile (from uri): " <> T.pack (show uri)
@ -842,7 +843,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
let workdir = appendGHCupPath tmpUnpack (takeDirectory bf)
pure (workdir, tmpUnpack, mkTVer <$> tver)
pure (workdir, tmpUnpack, GHCTargetVersion crossTarget <$> tver)
-- clone from git
GitDist GitBranch{..} -> do
@ -899,10 +900,10 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
pure tver
pure (tmpUnpack, tmpUnpack, mkTVer <$> tver)
pure (tmpUnpack, tmpUnpack, GHCTargetVersion crossTarget <$> tver)
-- the version that's installed may differ from the
-- compiled version, so the user can overwrite it
installVer <- if | Just ov' <- ov -> pure (mkTVer ov')
installVer <- if | Just ov' <- ov -> pure (GHCTargetVersion crossTarget ov')
| Just tver' <- tver -> pure tver'
| otherwise -> fail "Newer GHCs don't support discovering the version in git. Complain to GHC devs: https://gitlab.haskell.org/ghc/ghc/-/issues/22322"
@ -948,7 +949,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
liftE $ installPackedGHC bindist
(Just $ RegexDir "ghc-.*")
ghcdir
(installVer ^. tvVersion)
installVer
False -- not a force install, since we already overwrite when compiling.
[]
@ -987,9 +988,9 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
defaultConf =
let cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross")))
default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default")))
in case targetGhc of
SourceDist (GHCTargetVersion (Just _) _) -> cross_mk
_ -> default_mk
in case crossTarget of
Just _ -> cross_mk
_ -> default_mk
compileHadrianBindist :: ( MonadReader env m
, HasDirs env
@ -1015,8 +1016,6 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
m
(Maybe FilePath) -- ^ output path of bindist, None for cross
compileHadrianBindist tver workdir ghcdir = do
lEM $ execWithGhcEnv "python3" ["./boot"] (Just workdir) "ghc-bootstrap"
liftE $ configureBindist tver workdir ghcdir
lift $ logInfo "Building (this may take a while)..."
@ -1164,8 +1163,8 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
let lines' = fmap T.strip . T.lines $ decUTF8Safe c
-- for cross, we need Stage1Only
case targetGhc of
SourceDist (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE
case crossTarget of
Just _ -> when ("Stage1Only = YES" `notElem` lines') $ throwE
(InvalidBuildConfig
[s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|]
)

2
lib/GHCup/HLS.hs
View File

@ -369,7 +369,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
-- download source tarball
dlInfo <-
preview (ix HLS % ix tver % viSourceDL % _Just) dls
preview (ix HLS % ix (mkTVer tver) % viSourceDL % _Just) dls
?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing

55
lib/GHCup/List.hs
View File

@ -86,7 +86,7 @@ data ListResult = ListResult
-- | Extract all available tool versions and their tags.
availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version VersionInfo
availableToolVersions :: GHCupDownloads -> Tool -> Map.Map GHCTargetVersion VersionInfo
availableToolVersions av tool = view
(at tool % non Map.empty)
av
@ -134,13 +134,13 @@ listVersions lt' criteria hideOld showNightly days = do
slr <- strayGHCs avTools
pure (sort (slr ++ lr))
Cabal -> do
slr <- strayCabals avTools cSet cabals
slr <- strayCabals (Map.mapKeys _tvVersion avTools) cSet cabals
pure (sort (slr ++ lr))
HLS -> do
slr <- strayHLS avTools hlsSet' hlses
slr <- strayHLS (Map.mapKeys _tvVersion avTools) hlsSet' hlses
pure (sort (slr ++ lr))
Stack -> do
slr <- strayStacks avTools sSet stacks
slr <- strayStacks (Map.mapKeys _tvVersion avTools) sSet stacks
pure (sort (slr ++ lr))
GHCup -> do
let cg = maybeToList $ currentGHCup avTools
@ -159,44 +159,29 @@ listVersions lt' criteria hideOld showNightly days = do
, HasLog env
, MonadIO m
)
=> Map.Map Version VersionInfo
=> Map.Map GHCTargetVersion VersionInfo
-> m [ListResult]
strayGHCs avTools = do
ghcs <- getInstalledGHCs
fmap catMaybes $ forM ghcs $ \case
Right tver@GHCTargetVersion{ _tvTarget = Nothing, .. } -> do
case Map.lookup _tvVersion avTools of
Right tver@GHCTargetVersion{ .. } -> do
case Map.lookup tver avTools of
Just _ -> pure Nothing
Nothing -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions
pure $ Just $ ListResult
{ lTool = GHC
, lVer = _tvVersion
, lCross = Nothing
, lCross = _tvTarget
, lTag = []
, lInstalled = True
, lStray = isNothing (Map.lookup _tvVersion avTools)
, lStray = isNothing (Map.lookup tver avTools)
, lNoBindist = False
, lReleaseDay = Nothing
, ..
}
Right tver@GHCTargetVersion{ .. } -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions
pure $ Just $ ListResult
{ lTool = GHC
, lVer = _tvVersion
, lCross = _tvTarget
, lTag = []
, lInstalled = True
, lStray = True -- NOTE: cross currently cannot be installed via bindist
, lNoBindist = False
, lReleaseDay = Nothing
, ..
}
Left e -> do
logWarn
$ "Could not parse version of stray directory" <> T.pack e
@ -309,15 +294,15 @@ listVersions lt' criteria hideOld showNightly days = do
$ "Could not parse version of stray directory" <> T.pack e
pure Nothing
currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult
currentGHCup :: Map.Map GHCTargetVersion VersionInfo -> Maybe ListResult
currentGHCup av =
let currentVer = fromJust $ pvpToVersion ghcUpVer ""
let currentVer = mkTVer $ fromJust $ 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 if | Map.member currentVer av -> Nothing
| otherwise -> Just $ ListResult { lVer = currentVer
| otherwise -> Just $ ListResult { lVer = _tvVersion currentVer
, lTag = maybe (if isOld then [Old] else []) _viTags listVer
, lCross = Nothing
, lTool = GHCup
@ -346,18 +331,18 @@ listVersions lt' criteria hideOld showNightly days = do
-> [Either FilePath Version]
-> Maybe Version
-> [Either FilePath Version]
-> (Version, VersionInfo)
-> (GHCTargetVersion, VersionInfo)
-> m ListResult
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, VersionInfo{..}) = do
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (tver, VersionInfo{..}) = do
let v = _tvVersion tver
case t of
GHC -> do
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v
let tver = mkTVer v
lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo' GHC tver
lSet <- fmap (== Just tver) $ ghcSet (_tvTarget tver)
lInstalled <- ghcInstalled tver
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem v) hlsGHCVersions
pure ListResult { lVer = v, lCross = Nothing , lTag = _viTags, lTool = t, lStray = False, lReleaseDay = _viReleaseDay, .. }
hlsPowered <- fmap (elem tver) (fmap mkTVer <$> hlsGHCVersions)
pure ListResult { lVer = _tvVersion tver , lCross = _tvTarget tver , lTag = _viTags, lTool = t, lStray = False, lReleaseDay = _viReleaseDay, .. }
Cabal -> do
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v
let lSet = cSet == Just v

6
lib/GHCup/Types.hs
View File

@ -104,7 +104,7 @@ instance NFData Requirements
-- | Description of all binary and source downloads. This is a tree
-- of nested maps.
type GHCupDownloads = Map Tool ToolVersionSpec
type ToolVersionSpec = Map Version VersionInfo
type ToolVersionSpec = Map GHCTargetVersion VersionInfo
type ArchitectureSpec = Map Architecture PlatformSpec
type PlatformSpec = Map Platform PlatformVersionSpec
type PlatformVersionSpec = Map (Maybe VersionRange) DownloadInfo
@ -593,7 +593,9 @@ data GHCTargetVersion = GHCTargetVersion
{ _tvTarget :: Maybe Text
, _tvVersion :: Version
}
deriving (Ord, Eq, Show)
deriving (Ord, Eq, Show, GHC.Generic)
instance NFData GHCTargetVersion
data GitBranch = GitBranch
{ ref :: String

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

@ -95,13 +95,29 @@ instance FromJSON URI where
Right x -> pure x
Left e -> fail . show $ e
instance ToJSON GHCTargetVersion where
toJSON = toJSON . tVerToText
instance FromJSON GHCTargetVersion where
parseJSON = withText "GHCTargetVersion" $ \t -> case MP.parse ghcTargetVerP "" t of
Right x -> pure x
Left e -> fail $ "Failure in GHCTargetVersion (FromJSON)" <> show e
instance ToJSONKey GHCTargetVersion where
toJSONKey = toJSONKeyText $ \x -> tVerToText x
instance FromJSONKey GHCTargetVersion where
fromJSONKey = FromJSONKeyTextParser $ \t -> case MP.parse ghcTargetVerP "" t of
Right x -> pure x
Left e -> fail $ "Failure in GHCTargetVersion (FromJSONKey)" <> show e
instance ToJSON Versioning where
toJSON = toJSON . prettyV
instance FromJSON Versioning where
parseJSON = withText "Versioning" $ \t -> case versioning t of
Right x -> pure x
Left e -> fail $ "Failure in Version (FromJSON)" <> show e
Left e -> fail $ "Failure in GHCTargetVersion (FromJSON)" <> show e
instance ToJSONKey Versioning where
toJSONKey = toJSONKeyText $ \x -> prettyV x

36
lib/GHCup/Utils.hs
View File

@ -62,7 +62,6 @@ import Control.Monad.Trans.Resource
hiding ( throwM )
import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
import Data.Char ( isHexDigit )
import Data.Bifunctor ( first )
import Data.ByteString ( ByteString )
import Data.Either
import Data.Foldable
@ -774,13 +773,16 @@ getGHCForPVP' pvpIn ghcs' mt = do
-- Just (PVP {_pComponents = 8 :| [8,4]})
getLatestToolFor :: MonadThrow m
=> Tool
-> Maybe Text
-> PVP
-> GHCupDownloads
-> m (Maybe (PVP, VersionInfo))
getLatestToolFor tool pvpIn dls = do
let ls = fromMaybe [] $ preview (ix tool % to Map.toDescList) dls
let ps = catMaybes $ fmap (\(v, vi) -> (,vi) <$> versionToPVP v) ls
pure . fmap (first fst) . headMay . filter (\((v, _), _) -> matchPVPrefix pvpIn v) $ ps
-> m (Maybe (PVP, VersionInfo, Maybe Text))
getLatestToolFor tool target pvpIn dls = do
let ls :: [(GHCTargetVersion, VersionInfo)]
ls = fromMaybe [] $ preview (ix tool % to Map.toDescList) dls
let ps :: [((PVP, Text), VersionInfo, Maybe Text)]
ps = catMaybes $ fmap (\(v, vi) -> (,vi, _tvTarget v) <$> versionToPVP (_tvVersion v)) ls
pure . fmap (\((pv', _), vi, mt) -> (pv', vi, mt)) . headMay . filter (\((v, _), _, t) -> matchPVPrefix pvpIn v && t == target) $ ps
@ -885,12 +887,12 @@ intoSubdir bdir tardir = case tardir of
-- | Get the tool version that has this tag. If multiple have it,
-- picks the greatest version.
getTagged :: Tag
-> Fold (Map.Map Version VersionInfo) (Version, VersionInfo)
-> Fold (Map.Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getTagged tag =
to (Map.toDescList . Map.filter (\VersionInfo {..} -> tag `elem` _viTags))
% folding id
getByReleaseDay :: GHCupDownloads -> Tool -> Day -> Either (Maybe Day) (Version, VersionInfo)
getByReleaseDay :: GHCupDownloads -> Tool -> Day -> Either (Maybe Day) (GHCTargetVersion, VersionInfo)
getByReleaseDay av tool day = let mvv = fromMaybe mempty $ headOf (ix tool) av
mdv = Map.foldrWithKey (\k vi@VersionInfo{..} m ->
maybe m (\d -> let diff = diffDays d day
@ -902,24 +904,24 @@ getByReleaseDay av tool day = let mvv = fromMaybe mempty $ headOf (ix tool) av
| absDiff == 0 -> Right (k, vi)
| otherwise -> Left (Just (addDays diff day))
getByReleaseDayFold :: Day -> Fold (Map.Map Version VersionInfo) (Version, VersionInfo)
getByReleaseDayFold :: Day -> Fold (Map.Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getByReleaseDayFold day = to (Map.toDescList . Map.filter (\VersionInfo {..} -> Just day == _viReleaseDay)) % folding id
getLatest :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getLatest :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatest av tool = headOf (ix tool % getTagged Latest) av
getLatestPrerelease :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getLatestPrerelease :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatestPrerelease av tool = headOf (ix tool % getTagged LatestPrerelease) av
getLatestNightly :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getLatestNightly :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatestNightly av tool = headOf (ix tool % getTagged LatestNightly) av
getRecommended :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getRecommended :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getRecommended av tool = headOf (ix tool % getTagged Recommended) av
-- | Gets the latest GHC with a given base version.
getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe (Version, VersionInfo)
getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe (GHCTargetVersion, VersionInfo)
getLatestBaseVersion av pvpVer =
headOf (ix GHC % getTagged (Base pvpVer)) av
@ -1101,9 +1103,9 @@ darwinNotarization _ _ = pure $ Right ()
getChangeLog :: GHCupDownloads -> Tool -> ToolVersion -> Maybe URI
getChangeLog dls tool (GHCVersion (_tvVersion -> v')) =
getChangeLog dls tool (GHCVersion v') =
preview (ix tool % ix v' % viChangeLog % _Just) dls
getChangeLog dls tool (ToolVersion v') =
getChangeLog dls tool (ToolVersion (mkTVer -> 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
@ -1192,7 +1194,7 @@ rmBDir dir = withRunInIO (\run -> run $
$ rmPathForcibly dir)
getVersionInfo :: Version
getVersionInfo :: GHCTargetVersion
-> Tool
-> GHCupDownloads
-> Maybe VersionInfo

4
test/GHCup/ArbitraryTypes.hs
View File

@ -183,6 +183,10 @@ instance Arbitrary GHCupInfo where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary GHCTargetVersion where
arbitrary = GHCTargetVersion Nothing <$> arbitrary
shrink = genericShrink
-- our maps are nested... the default size easily blows up most ppls ram