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

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

Browse Source
This commit is contained in:
Julian Ospald 2023-07-11 23:30:51 +08:00
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" cabal_store_path="$(dirname "$(cabal help user-config | tail -n 1 | xargs)")/store"
fi fi
cabal-cache sync-from-archive \ cabal-cache.sh sync-from-archive \
--host-name-override=${S3_HOST} \ --host-name-override=${S3_HOST} \
--host-port-override=443 \ --host-port-override=443 \
--host-ssl-override=True \ --host-ssl-override=True \
@ -29,7 +29,7 @@ sync_to() {
cabal_store_path="$(dirname "$(cabal help user-config | tail -n 1 | xargs)")/store" cabal_store_path="$(dirname "$(cabal help user-config | tail -n 1 | xargs)")/store"
fi fi
cabal-cache sync-to-archive \ cabal-cache.sh sync-to-archive \
--host-name-override=${S3_HOST} \ --host-name-override=${S3_HOST} \
--host-port-override=443 \ --host-port-override=443 \
--host-ssl-override=True \ --host-ssl-override=True \
@ -115,6 +115,10 @@ download_cabal_cache() {
mv "cabal-cache${exe}" "${dest}${exe}" mv "cabal-cache${exe}" "${dest}${exe}"
chmod +x "${dest}${exe}" chmod +x "${dest}${exe}"
fi 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: schedule:
- cron: '0 2 * * *' - cron: '0 2 * * *'
env:
CABAL_CACHE_DISABLE: ${{ vars.CABAL_CACHE_DISABLE }}
CABAL_CACHE_NONFATAL: yes
jobs: jobs:
build-linux: build-linux:
name: Build linux binary 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 1) (minHSize 25 $ str "Tags")
<+> padLeft (Pad 5) (str "Notes") <+> padLeft (Pad 5) (str "Notes")
renderList' bis@BrickInternalState{..} = renderList' bis@BrickInternalState{..} =
let getMinLength = length . intercalate "," . fmap tagToString let minTagSize = V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) clr
minLength = V.maximum $ V.map (getMinLength . lTag) clr minVerSize = V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (GHCTargetVersion lCross lVer)) clr
in withDefAttr listAttr . drawListElements (renderItem minLength) True $ bis in withDefAttr listAttr . drawListElements (renderItem minTagSize minVerSize) True $ bis
renderItem minTagSize _ b listResult@ListResult{lTag = lTag', ..} = renderItem minTagSize minVerSize _ b listResult@ListResult{lTag = lTag', ..} =
let marks = if let marks = if
| lSet -> (withAttr (attrName "set") $ str "✔✔") | lSet -> (withAttr (attrName "set") $ str "✔✔")
| lInstalled -> (withAttr (attrName "installed") $ str "✓ ") | lInstalled -> (withAttr (attrName "installed") $ str "✓ ")
@ -184,7 +184,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
( minHSize 6 ( minHSize 6
(printTool lTool) (printTool lTool)
) )
<+> minHSize 15 (str ver) <+> minHSize minVerSize (str ver)
<+> (let l = catMaybes . fmap printTag $ sort lTag' <+> (let l = catMaybes . fmap printTag $ sort lTag'
in padLeft (Pad 1) $ minHSize minTagSize $ if null l in padLeft (Pad 1) $ minHSize minTagSize $ if null l
then emptyWidget then emptyWidget
@ -472,19 +472,19 @@ install' _ (_, ListResult {..}) = do
dirs <- lift getDirs dirs <- lift getDirs
case lTool of case lTool of
GHC -> do GHC -> do
let vi = getVersionInfo lVer GHC dls let vi = getVersionInfo (GHCTargetVersion lCross lVer) GHC dls
liftE $ installGHCBin lVer GHCupInternal False [] $> (vi, dirs, ce) liftE $ installGHCBin (GHCTargetVersion lCross lVer) GHCupInternal False [] $> (vi, dirs, ce)
Cabal -> do Cabal -> do
let vi = getVersionInfo lVer Cabal dls let vi = getVersionInfo (GHCTargetVersion lCross lVer) Cabal dls
liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce) liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce)
GHCup -> do GHCup -> do
let vi = snd <$> getLatest dls GHCup let vi = snd <$> getLatest dls GHCup
liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce) liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce)
HLS -> do HLS -> do
let vi = getVersionInfo lVer HLS dls let vi = getVersionInfo (GHCTargetVersion lCross lVer) HLS dls
liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce) liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce)
Stack -> do Stack -> do
let vi = getVersionInfo lVer Stack dls let vi = getVersionInfo (GHCTargetVersion lCross lVer) Stack dls
liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce) liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce)
) )
>>= \case >>= \case
@ -565,7 +565,7 @@ del' _ (_, ListResult {..}) = do
let run = runE @'[NotInstalled, UninstallFailed] let run = runE @'[NotInstalled, UninstallFailed]
run (do run (do
let vi = getVersionInfo lVer lTool dls let vi = getVersionInfo (GHCTargetVersion lCross lVer) lTool dls
case lTool of case lTool of
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi
Cabal -> liftE $ rmCabalVer lVer $> vi Cabal -> liftE $ rmCabalVer lVer $> vi

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

@ -5,6 +5,7 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ViewPatterns #-}
module GHCup.OptParse.Common where module GHCup.OptParse.Common where
@ -693,52 +694,52 @@ fromVersion' :: ( HasLog env
] m (GHCTargetVersion, Maybe VersionInfo) ] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion' SetRecommended tool = do fromVersion' SetRecommended tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getRecommended dls tool second Just <$> getRecommended dls tool
?? TagNotFound Recommended tool ?? TagNotFound Recommended tool
fromVersion' (SetGHCVersion v) tool = do fromVersion' (SetGHCVersion v) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo 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 case pvp $ prettyVer (_tvVersion v) of -- need to be strict here
Left _ -> pure (v, vi) Left _ -> pure (v, vi)
Right pvpIn -> Right pvpIn ->
lift (getLatestToolFor tool pvpIn dls) >>= \case lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case
Just (pvp_, vi') -> do Just (pvp_, vi', mt) -> do
v' <- lift $ pvpToVersion pvp_ "" v' <- lift $ pvpToVersion pvp_ ""
when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') 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) Nothing -> pure (v, vi)
fromVersion' (SetToolVersion v) tool = do fromVersion' (SetToolVersion (mkTVer -> v)) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo v tool dls let vi = getVersionInfo v tool dls
case pvp $ prettyVer v of -- need to be strict here case pvp $ prettyVer (_tvVersion v) of -- need to be strict here
Left _ -> pure (mkTVer v, vi) Left _ -> pure (v, vi)
Right pvpIn -> Right pvpIn ->
lift (getLatestToolFor tool pvpIn dls) >>= \case lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case
Just (pvp_, vi') -> do Just (pvp_, vi', mt) -> do
v' <- lift $ pvpToVersion pvp_ "" v' <- lift $ pvpToVersion pvp_ ""
when (v' /= v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
pure (GHCTargetVersion mempty v', Just vi') pure (GHCTargetVersion mt v', Just vi')
Nothing -> pure (mkTVer v, vi) Nothing -> pure (v, vi)
fromVersion' (SetToolTag Latest) tool = do fromVersion' (SetToolTag Latest) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo 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 fromVersion' (SetToolDay day) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo 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 Left ad -> throwE $ DayNotFound day tool ad
Right v -> pure v Right v -> pure v
fromVersion' (SetToolTag LatestPrerelease) tool = do fromVersion' (SetToolTag LatestPrerelease) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo 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 fromVersion' (SetToolTag LatestNightly) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo 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 fromVersion' (SetToolTag Recommended) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo 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 fromVersion' (SetToolTag (Base pvp'')) GHC = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo 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 fromVersion' SetNext tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
next <- case tool of next <- case tool of
@ -783,7 +784,7 @@ fromVersion' SetNext tool = do
. sort . sort
$ stacks) ?? NoToolVersionSet tool $ stacks) ?? NoToolVersionSet tool
GHCup -> fail "GHCup cannot be set" GHCup -> fail "GHCup cannot be set"
let vi = getVersionInfo (_tvVersion next) tool dls let vi = getVersionInfo next tool dls
pure (next, vi) pure (next, vi)
fromVersion' (SetToolTag t') tool = fromVersion' (SetToolTag t') tool =
throwE $ TagNotFound t' tool throwE $ TagNotFound t' tool
@ -799,15 +800,15 @@ checkForUpdates :: ( MonadReader env m
, MonadIO m , MonadIO m
, MonadFail m , MonadFail m
) )
=> m [(Tool, Version)] => m [(Tool, GHCTargetVersion)]
checkForUpdates = do checkForUpdates = do
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
lInstalled <- listVersions Nothing [ListInstalled True] False False (Nothing, Nothing) 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 (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 -> otherTools <- forM [GHC, Cabal, HLS, Stack] $ \t ->
forMM (getLatest dls t) $ \(l, _) -> do 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 data GHCCompileOptions = GHCCompileOptions
{ targetGhc :: GHC.GHCVer Version { targetGhc :: GHC.GHCVer
, bootstrapGhc :: Either Version FilePath , bootstrapGhc :: Either Version FilePath
, jobs :: Maybe Int , jobs :: Maybe Int
, buildConfig :: Maybe FilePath , buildConfig :: Maybe FilePath
@ -511,7 +511,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
case targetHLS of case targetHLS of
HLS.SourceDist targetVer -> do HLS.SourceDist targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer HLS dls let vi = getVersionInfo (mkTVer targetVer) HLS dls
forM_ (_viPreCompile =<< vi) $ \msg -> do forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ logInfo msg lift $ logInfo msg
lift $ logInfo lift $ logInfo
@ -531,7 +531,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
patches patches
cabalArgs cabalArgs
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer HLS dls let vi = getVersionInfo (mkTVer targetVer) HLS dls
when setCompile $ void $ liftE $ when setCompile $ void $ liftE $
setHLS targetVer SetHLSOnly Nothing setHLS targetVer SetHLSOnly Nothing
pure (vi, targetVer) pure (vi, targetVer)
@ -555,15 +555,12 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
VLeft e -> do VLeft e -> do
runLogger $ logError $ T.pack $ prettyHFError e runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 9 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 {..}) -> (CompileGHC GHCCompileOptions {..}) ->
runCompileGHC runAppState (do runCompileGHC runAppState (do
case targetGhc of case targetGhc of
GHC.SourceDist targetVer -> do GHC.SourceDist targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer GHC dls let vi = getVersionInfo (mkTVer targetVer) GHC dls
forM_ (_viPreCompile =<< vi) $ \msg -> do forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ logInfo msg lift $ logInfo msg
lift $ logInfo 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 liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
_ -> pure () _ -> pure ()
targetVer <- liftE $ compileGHC targetVer <- liftE $ compileGHC
((\case targetGhc
GHC.SourceDist v -> GHC.SourceDist $ GHCTargetVersion crossTarget v crossTarget
GHC.GitDist g -> GHC.GitDist g
GHC.RemoteDist r -> GHC.RemoteDist r) targetGhc)
ovewrwiteVer ovewrwiteVer
bootstrapGhc bootstrapGhc
jobs jobs
@ -585,7 +580,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
hadrian hadrian
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion targetVer) GHC dls let vi = getVersionInfo targetVer GHC dls
when setCompile $ void $ liftE $ when setCompile $ void $ liftE $
setGHC targetVer SetGHCOnly Nothing setGHC targetVer SetGHCOnly Nothing
pure (vi, targetVer) 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 Nothing -> runInstGHC s' $ do
(v, vi) <- liftE $ fromVersion instVer GHC (v, vi) <- liftE $ fromVersion instVer GHC
liftE $ runBothE' (installGHCBin liftE $ runBothE' (installGHCBin
(_tvVersion v) v
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
addConfArgs addConfArgs
@ -336,7 +336,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
(v, vi) <- liftE $ fromVersion instVer GHC (v, vi) <- liftE $ fromVersion instVer GHC
liftE $ runBothE' (installGHCBindist liftE $ runBothE' (installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing) (DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing)
(_tvVersion v) v
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
addConfArgs addConfArgs

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

@ -195,7 +195,7 @@ prefetch prefetchCommand runAppState runLogger =
forM_ pfCacheDir (liftIO . createDirRecursive') forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt GHC (v, _) <- liftE $ fromVersion mt GHC
if pfGHCSrc if pfGHCSrc
then liftE $ fetchGHCSrc (_tvVersion v) pfCacheDir then liftE $ fetchGHCSrc v pfCacheDir
else liftE $ fetchToolBindist (_tvVersion v) GHC pfCacheDir else liftE $ fetchToolBindist (_tvVersion v) GHC pfCacheDir
PrefetchCabal PrefetchOptions {pfCacheDir} mt -> do PrefetchCabal PrefetchOptions {pfCacheDir} mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive') 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 $ liftE $
rmGHCVer ghcVer rmGHCVer ghcVer
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo (_tvVersion ghcVer) GHC dls) pure (getVersionInfo ghcVer GHC dls)
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
@ -186,7 +186,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
liftE $ liftE $
rmCabalVer tv rmCabalVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv Cabal dls) pure (getVersionInfo (mkTVer tv) Cabal dls)
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
@ -201,7 +201,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
liftE $ liftE $
rmHLSVer tv rmHLSVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv HLS dls) pure (getVersionInfo (mkTVer tv) HLS dls)
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
@ -216,7 +216,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
liftE $ liftE $
rmStackVer tv rmStackVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv Stack dls) pure (getVersionInfo (mkTVer tv) Stack dls)
) )
>>= \case >>= \case
VRight vi -> do 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 Just v -> do
isInstalled <- lift $ checkIfToolInstalled' GHC v isInstalled <- lift $ checkIfToolInstalled' GHC v
unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin
(_tvVersion v) v
GHCupInternal GHCupInternal
False 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 (case testBindist of
Nothing -> runTestGHC s' $ do Nothing -> runTestGHC s' $ do
(v, vi) <- liftE $ fromVersion testVer GHC (v, vi) <- liftE $ fromVersion testVer GHC
liftE $ testGHCVer (_tvVersion v) addMakeArgs liftE $ testGHCVer v addMakeArgs
pure vi pure vi
Just uri -> do Just uri -> do
runTestGHC s'{ settings = settings {noVerify = True}} $ do runTestGHC s'{ settings = settings {noVerify = True}} $ do
(v, vi) <- liftE $ fromVersion testVer GHC (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 pure vi
) )
>>= \case >>= \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 case t of
GHCup -> runLogger $ GHCup -> runLogger $
logWarn ("New GHCup version available: " logWarn ("New GHCup version available: "
<> prettyVer l <> tVerToText l
<> ". To upgrade, run 'ghcup upgrade'") <> ". To upgrade, run 'ghcup upgrade'")
_ -> runLogger $ _ -> runLogger $
logWarn ("New " 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 " <> "If you want to install this latest version, run 'ghcup install "
<> T.pack (prettyShow t) <> T.pack (prettyShow t)
<> " " <> " "
<> prettyVer l <> tVerToText l
<> "'") <> "'")
Just _ -> pure () Just _ -> pure ()
@ -332,7 +332,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
, MonadCatch m , MonadCatch m
) )
=> Command => Command
-> (Tool, Version) -> (Tool, GHCTargetVersion)
-> Excepts -> Excepts
'[ TagNotFound '[ TagNotFound
, DayNotFound , DayNotFound
@ -368,7 +368,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
) )
=> Tool => Tool
-> Maybe ToolVersion -> Maybe ToolVersion
-> Version -> GHCTargetVersion
-> Excepts -> Excepts
'[ TagNotFound '[ TagNotFound
, DayNotFound , DayNotFound
@ -377,4 +377,4 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
] m Bool ] m Bool
cmp' tool instVer ver = do cmp' tool instVer ver = do
(v, _) <- liftE $ fromVersion instVer tool (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 GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
lift $ logInfo "Upgrading GHCup..." lift $ logInfo "Upgrading GHCup..."
let latestVer = fst (fromJust (getLatest dls GHCup)) let latestVer = _tvVersion $ fst (fromJust (getLatest dls GHCup))
(Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer "" (Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer ""
when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate
dli <- liftE $ getDownloadInfo GHCup latestVer dli <- liftE $ getDownloadInfo GHCup latestVer
@ -492,7 +492,7 @@ rmOldGHC :: ( MonadReader env m
=> Excepts '[NotInstalled, UninstallFailed] m () => Excepts '[NotInstalled, UninstallFailed] m ()
rmOldGHC = do rmOldGHC = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo 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 ghcs <- lift $ fmap rights getInstalledGHCs
forM_ ghcs $ \ghc -> when (ghc `elem` oldGHCs) $ rmGHCVer ghc 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 pure f
getDownloadInfo :: ( MonadReader env m getDownloadInfo :: ( MonadReader env m
, HasPlatformReq env , HasPlatformReq env
, HasGHCupInfo env , HasGHCupInfo env
@ -283,7 +282,20 @@ getDownloadInfo :: ( MonadReader env m
'[NoDownload] '[NoDownload]
m m
DownloadInfo 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 (PlatformRequest a p mv) <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo 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 import qualified Text.Megaparsec as MP
data GHCVer v = SourceDist v data GHCVer = SourceDist Version
| GitDist GitBranch | GitDist GitBranch
| RemoteDist URI | RemoteDist URI
@ -105,7 +105,7 @@ testGHCVer :: ( MonadFail m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> Version => GHCTargetVersion
-> [T.Text] -> [T.Text]
-> Excepts -> Excepts
'[ DigestError '[ DigestError
@ -145,7 +145,7 @@ testGHCBindist :: ( MonadFail m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> DownloadInfo => DownloadInfo
-> Version -> GHCTargetVersion
-> [T.Text] -> [T.Text]
-> Excepts -> Excepts
'[ DigestError '[ DigestError
@ -182,7 +182,7 @@ testPackedGHC :: ( MonadMask m
) )
=> FilePath -- ^ Path to the packed GHC bindist => FilePath -- ^ Path to the packed GHC bindist
-> Maybe TarDir -- ^ Subdir of the archive -> Maybe TarDir -- ^ Subdir of the archive
-> Version -- ^ The GHC version -> GHCTargetVersion -- ^ The GHC version
-> [T.Text] -- ^ additional make args -> [T.Text] -- ^ additional make args
-> Excepts -> Excepts
'[ ArchiveResult, UnknownArchive, TarDirDoesNotExist, TestFailed ] m () '[ ArchiveResult, UnknownArchive, TarDirDoesNotExist, TestFailed ] m ()
@ -208,19 +208,21 @@ testUnpackedGHC :: ( MonadReader env m
, MonadIO m , MonadIO m
) )
=> GHCupPath -- ^ Path to the unpacked GHC bindist (where the make file resides) => 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 -> [T.Text] -- ^ additional configure args for bindist
-> Excepts '[ProcessError] m () -> Excepts '[ProcessError] m ()
testUnpackedGHC path ver addMakeArgs = do testUnpackedGHC path tver addMakeArgs = do
lift $ logInfo $ "Testing GHC version " <> prettyVer ver <> "!" lift $ logInfo $ "Testing GHC version " <> tVerToText tver <> "!"
ghcDir <- lift $ ghcupGHCDir (mkTVer ver) ghcDir <- lift $ ghcupGHCDir tver
let ghcBinDir = fromGHCupPath ghcDir </> "bin" let ghcBinDir = fromGHCupPath ghcDir </> "bin"
env <- liftIO $ addToPath ghcBinDir False env <- liftIO $ addToPath ghcBinDir False
lEM $ make' (fmap T.unpack addMakeArgs) lEM $ make' (fmap T.unpack addMakeArgs)
(Just $ fromGHCupPath path) (Just $ fromGHCupPath path)
"ghc-test" "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 () pure ()
@ -243,7 +245,7 @@ fetchGHCSrc :: ( MonadFail m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> Version => GHCTargetVersion
-> Maybe FilePath -> Maybe FilePath
-> Excepts -> Excepts
'[ DigestError '[ DigestError
@ -283,7 +285,7 @@ installGHCBindist :: ( MonadFail m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> DownloadInfo -- ^ where/how to download => DownloadInfo -- ^ where/how to download
-> Version -- ^ the version to install -> GHCTargetVersion -- ^ the version to install
-> InstallDir -> InstallDir
-> Bool -- ^ Force install -> Bool -- ^ Force install
-> [T.Text] -- ^ additional configure args for bindist -> [T.Text] -- ^ additional configure args for bindist
@ -306,10 +308,8 @@ installGHCBindist :: ( MonadFail m
] ]
m m
() ()
installGHCBindist dlinfo ver installDir forceInstall addConfArgs = do installGHCBindist dlinfo tver installDir forceInstall addConfArgs = do
let tver = mkTVer ver lift $ logDebug $ "Requested to install GHC with " <> tVerToText tver
lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver
regularGHCInstalled <- lift $ ghcInstalled tver regularGHCInstalled <- lift $ ghcInstalled tver
@ -317,7 +317,7 @@ installGHCBindist dlinfo ver installDir forceInstall addConfArgs = do
| not forceInstall | not forceInstall
, regularGHCInstalled , regularGHCInstalled
, GHCupInternal <- installDir -> do , GHCupInternal <- installDir -> do
throwE $ AlreadyInstalled GHC ver throwE $ AlreadyInstalled GHC (_tvVersion tver)
| forceInstall | forceInstall
, regularGHCInstalled , regularGHCInstalled
@ -336,12 +336,12 @@ installGHCBindist dlinfo ver installDir forceInstall addConfArgs = do
case installDir of case installDir of
IsolateDir isoDir -> do -- isolated install IsolateDir isoDir -> do -- isolated install
lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir 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 GHCupInternal -> do -- regular install
-- prepare paths -- prepare paths
ghcdir <- lift $ ghcupGHCDir tver 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, -- make symlinks & stuff when regular install,
liftE $ postGHCInstall tver liftE $ postGHCInstall tver
@ -375,7 +375,7 @@ installPackedGHC :: ( MonadMask m
=> FilePath -- ^ Path to the packed GHC bindist => FilePath -- ^ Path to the packed GHC bindist
-> Maybe TarDir -- ^ Subdir of the archive -> Maybe TarDir -- ^ Subdir of the archive
-> InstallDirResolved -> InstallDirResolved
-> Version -- ^ The GHC version -> GHCTargetVersion -- ^ The GHC version
-> Bool -- ^ Force install -> Bool -- ^ Force install
-> [T.Text] -- ^ additional configure args for bindist -> [T.Text] -- ^ additional configure args for bindist
-> Excepts -> Excepts
@ -423,17 +423,17 @@ installUnpackedGHC :: ( MonadReader env m
) )
=> GHCupPath -- ^ Path to the unpacked GHC bindist (where the configure script resides) => GHCupPath -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> InstallDirResolved -- ^ Path to install to -> InstallDirResolved -- ^ Path to install to
-> Version -- ^ The GHC version -> GHCTargetVersion -- ^ The GHC version
-> Bool -- ^ Force install -> Bool -- ^ Force install
-> [T.Text] -- ^ additional configure args for bindist -> [T.Text] -- ^ additional configure args for bindist
-> Excepts '[ProcessError, MergeFileTreeError] m () -> Excepts '[ProcessError, MergeFileTreeError] m ()
installUnpackedGHC path inst ver forceInstall addConfArgs installUnpackedGHC path inst tver forceInstall addConfArgs
| isWindows = do | isWindows = do
lift $ logInfo "Installing GHC (this may take a while)" lift $ logInfo "Installing GHC (this may take a while)"
-- Windows bindists are relocatable and don't need -- Windows bindists are relocatable and don't need
-- to run configure. -- to run configure.
-- We also must make sure to preserve mtime to not confuse ghc-pkg. -- 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) mtime <- liftIO $ ifM (pathIsSymbolicLink source) (pure Nothing) (Just <$> getModificationTime source)
when forceInstall $ hideError doesNotExistErrorType $ hideError InappropriateType $ recycleFile dest when forceInstall $ hideError doesNotExistErrorType $ hideError InappropriateType $ recycleFile dest
liftIO $ moveFilePortable source dest liftIO $ moveFilePortable source dest
@ -442,7 +442,7 @@ installUnpackedGHC path inst ver forceInstall addConfArgs
PlatformRequest {..} <- lift getPlatformReq PlatformRequest {..} <- lift getPlatformReq
let ldOverride let ldOverride
| ver >= [vver|8.2.2|] | _tvVersion tver >= [vver|8.2.2|]
, _rPlatform `elem` [Linux Alpine, Darwin] , _rPlatform `elem` [Linux Alpine, Darwin]
= ["--disable-ld-override"] = ["--disable-ld-override"]
| otherwise | otherwise
@ -451,7 +451,7 @@ installUnpackedGHC path inst ver forceInstall addConfArgs
lift $ logInfo "Installing GHC (this may take a while)" lift $ logInfo "Installing GHC (this may take a while)"
lEM $ execLogged "sh" lEM $ execLogged "sh"
("./configure" : ("--prefix=" <> fromInstallDir inst) ("./configure" : ("--prefix=" <> fromInstallDir inst)
: (ldOverride <> (T.unpack <$> addConfArgs)) : (maybe mempty (\x -> ["--target=" <> T.unpack x]) (_tvTarget tver) <> ldOverride <> (T.unpack <$> addConfArgs))
) )
(Just $ fromGHCupPath path) (Just $ fromGHCupPath path)
"ghc-configure" "ghc-configure"
@ -462,7 +462,7 @@ installUnpackedGHC path inst ver forceInstall addConfArgs
liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst))
inst inst
GHC GHC
(mkTVer ver) tver
(\f t -> liftIO $ do (\f t -> liftIO $ do
mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f) mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f)
install f t (not forceInstall) install f t (not forceInstall)
@ -489,7 +489,7 @@ installGHCBin :: ( MonadFail m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> Version -- ^ the version to install => GHCTargetVersion -- ^ the version to install
-> InstallDir -> InstallDir
-> Bool -- ^ force install -> Bool -- ^ force install
-> [T.Text] -- ^ additional configure args for bindist -> [T.Text] -- ^ additional configure args for bindist
@ -512,9 +512,9 @@ installGHCBin :: ( MonadFail m
] ]
m m
() ()
installGHCBin ver installDir forceInstall addConfArgs = do installGHCBin tver installDir forceInstall addConfArgs = do
dlinfo <- liftE $ getDownloadInfo GHC ver dlinfo <- liftE $ getDownloadInfo' GHC tver
liftE $ installGHCBindist dlinfo ver installDir forceInstall addConfArgs liftE $ installGHCBindist dlinfo tver installDir forceInstall addConfArgs
@ -755,7 +755,8 @@ compileGHC :: ( MonadMask m
, MonadUnliftIO m , MonadUnliftIO m
, MonadFail m , MonadFail m
) )
=> GHCVer GHCTargetVersion => GHCVer
-> Maybe Text -- ^ cross target
-> Maybe Version -- ^ overwrite version -> Maybe Version -- ^ overwrite version
-> Either Version FilePath -- ^ version to bootstrap with -> Either Version FilePath -- ^ version to bootstrap with
-> Maybe Int -- ^ jobs -> Maybe Int -- ^ jobs
@ -792,19 +793,19 @@ compileGHC :: ( MonadMask m
] ]
m m
GHCTargetVersion 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 = do
PlatformRequest { .. } <- lift getPlatformReq PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
(workdir, tmpUnpack, tver) <- case targetGhc of (workdir, tmpUnpack, tver) <- case targetGhc of
-- unpack from version tarball -- unpack from version tarball
SourceDist tver -> do SourceDist ver -> do
lift $ logDebug $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap lift $ logDebug $ "Requested to compile: " <> prettyVer ver <> " with " <> either prettyVer T.pack bstrap
-- download source tarball -- download source tarball
dlInfo <- dlInfo <-
preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls preview (ix GHC % ix (mkTVer ver) % viSourceDL % _Just) dls
?? NoDownload ?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing dl <- liftE $ downloadCached dlInfo Nothing
@ -818,7 +819,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
(view dlSubdir dlInfo) (view dlSubdir dlInfo)
liftE $ applyAnyPatch patches (fromGHCupPath workdir) liftE $ applyAnyPatch patches (fromGHCupPath workdir)
pure (workdir, tmpUnpack, Just tver) pure (workdir, tmpUnpack, Just (GHCTargetVersion crossTarget ver))
RemoteDist uri -> do RemoteDist uri -> do
lift $ logDebug $ "Requested to compile (from uri): " <> T.pack (show uri) 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) let workdir = appendGHCupPath tmpUnpack (takeDirectory bf)
pure (workdir, tmpUnpack, mkTVer <$> tver) pure (workdir, tmpUnpack, GHCTargetVersion crossTarget <$> tver)
-- clone from git -- clone from git
GitDist GitBranch{..} -> do GitDist GitBranch{..} -> do
@ -899,10 +900,10 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
pure tver pure tver
pure (tmpUnpack, tmpUnpack, mkTVer <$> tver) pure (tmpUnpack, tmpUnpack, GHCTargetVersion crossTarget <$> tver)
-- the version that's installed may differ from the -- the version that's installed may differ from the
-- compiled version, so the user can overwrite it -- 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' | 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" | 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 liftE $ installPackedGHC bindist
(Just $ RegexDir "ghc-.*") (Just $ RegexDir "ghc-.*")
ghcdir ghcdir
(installVer ^. tvVersion) installVer
False -- not a force install, since we already overwrite when compiling. 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 = defaultConf =
let cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross"))) 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"))) default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default")))
in case targetGhc of in case crossTarget of
SourceDist (GHCTargetVersion (Just _) _) -> cross_mk Just _ -> cross_mk
_ -> default_mk _ -> default_mk
compileHadrianBindist :: ( MonadReader env m compileHadrianBindist :: ( MonadReader env m
, HasDirs env , HasDirs env
@ -1015,8 +1016,6 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
m m
(Maybe FilePath) -- ^ output path of bindist, None for cross (Maybe FilePath) -- ^ output path of bindist, None for cross
compileHadrianBindist tver workdir ghcdir = do compileHadrianBindist tver workdir ghcdir = do
lEM $ execWithGhcEnv "python3" ["./boot"] (Just workdir) "ghc-bootstrap"
liftE $ configureBindist tver workdir ghcdir liftE $ configureBindist tver workdir ghcdir
lift $ logInfo "Building (this may take a while)..." 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 let lines' = fmap T.strip . T.lines $ decUTF8Safe c
-- for cross, we need Stage1Only -- for cross, we need Stage1Only
case targetGhc of case crossTarget of
SourceDist (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE Just _ -> when ("Stage1Only = YES" `notElem` lines') $ throwE
(InvalidBuildConfig (InvalidBuildConfig
[s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|] [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 -- download source tarball
dlInfo <- dlInfo <-
preview (ix HLS % ix tver % viSourceDL % _Just) dls preview (ix HLS % ix (mkTVer tver) % viSourceDL % _Just) dls
?? NoDownload ?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing 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. -- | 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 availableToolVersions av tool = view
(at tool % non Map.empty) (at tool % non Map.empty)
av av
@ -134,13 +134,13 @@ listVersions lt' criteria hideOld showNightly days = do
slr <- strayGHCs avTools slr <- strayGHCs avTools
pure (sort (slr ++ lr)) pure (sort (slr ++ lr))
Cabal -> do Cabal -> do
slr <- strayCabals avTools cSet cabals slr <- strayCabals (Map.mapKeys _tvVersion avTools) cSet cabals
pure (sort (slr ++ lr)) pure (sort (slr ++ lr))
HLS -> do HLS -> do
slr <- strayHLS avTools hlsSet' hlses slr <- strayHLS (Map.mapKeys _tvVersion avTools) hlsSet' hlses
pure (sort (slr ++ lr)) pure (sort (slr ++ lr))
Stack -> do Stack -> do
slr <- strayStacks avTools sSet stacks slr <- strayStacks (Map.mapKeys _tvVersion avTools) sSet stacks
pure (sort (slr ++ lr)) pure (sort (slr ++ lr))
GHCup -> do GHCup -> do
let cg = maybeToList $ currentGHCup avTools let cg = maybeToList $ currentGHCup avTools
@ -159,44 +159,29 @@ listVersions lt' criteria hideOld showNightly days = do
, HasLog env , HasLog env
, MonadIO m , MonadIO m
) )
=> Map.Map Version VersionInfo => Map.Map GHCTargetVersion VersionInfo
-> m [ListResult] -> m [ListResult]
strayGHCs avTools = do strayGHCs avTools = do
ghcs <- getInstalledGHCs ghcs <- getInstalledGHCs
fmap catMaybes $ forM ghcs $ \case fmap catMaybes $ forM ghcs $ \case
Right tver@GHCTargetVersion{ _tvTarget = Nothing, .. } -> do Right tver@GHCTargetVersion{ .. } -> do
case Map.lookup _tvVersion avTools of case Map.lookup tver avTools of
Just _ -> pure Nothing Just _ -> pure Nothing
Nothing -> do 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 fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions
pure $ Just $ ListResult pure $ Just $ ListResult
{ lTool = GHC { lTool = GHC
, lVer = _tvVersion , lVer = _tvVersion
, lCross = Nothing , lCross = _tvTarget
, lTag = [] , lTag = []
, lInstalled = True , lInstalled = True
, lStray = isNothing (Map.lookup _tvVersion avTools) , lStray = isNothing (Map.lookup tver avTools)
, lNoBindist = False , lNoBindist = False
, lReleaseDay = Nothing , 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 Left e -> do
logWarn logWarn
$ "Could not parse version of stray directory" <> T.pack e $ "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 $ "Could not parse version of stray directory" <> T.pack e
pure Nothing pure Nothing
currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult currentGHCup :: Map.Map GHCTargetVersion VersionInfo -> Maybe ListResult
currentGHCup av = currentGHCup av =
let currentVer = fromJust $ pvpToVersion ghcUpVer "" let currentVer = mkTVer $ fromJust $ pvpToVersion ghcUpVer ""
listVer = Map.lookup currentVer av listVer = Map.lookup currentVer av
latestVer = fst <$> headOf (getTagged Latest) av latestVer = fst <$> headOf (getTagged Latest) av
recommendedVer = fst <$> headOf (getTagged Latest) av recommendedVer = fst <$> headOf (getTagged Latest) av
isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer
in if | Map.member currentVer av -> Nothing 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 , lTag = maybe (if isOld then [Old] else []) _viTags listVer
, lCross = Nothing , lCross = Nothing
, lTool = GHCup , lTool = GHCup
@ -346,18 +331,18 @@ listVersions lt' criteria hideOld showNightly days = do
-> [Either FilePath Version] -> [Either FilePath Version]
-> Maybe Version -> Maybe Version
-> [Either FilePath Version] -> [Either FilePath Version]
-> (Version, VersionInfo) -> (GHCTargetVersion, VersionInfo)
-> m ListResult -> 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 case t of
GHC -> do GHC -> do
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo' GHC tver
let tver = mkTVer v lSet <- fmap (== Just tver) $ ghcSet (_tvTarget tver)
lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing
lInstalled <- ghcInstalled tver lInstalled <- ghcInstalled tver
fromSrc <- ghcSrcInstalled tver fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem v) hlsGHCVersions hlsPowered <- fmap (elem tver) (fmap mkTVer <$> hlsGHCVersions)
pure ListResult { lVer = v, lCross = Nothing , lTag = _viTags, lTool = t, lStray = False, lReleaseDay = _viReleaseDay, .. } pure ListResult { lVer = _tvVersion tver , lCross = _tvTarget tver , lTag = _viTags, lTool = t, lStray = False, lReleaseDay = _viReleaseDay, .. }
Cabal -> do Cabal -> do
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v
let lSet = cSet == Just 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 -- | Description of all binary and source downloads. This is a tree
-- of nested maps. -- of nested maps.
type GHCupDownloads = Map Tool ToolVersionSpec type GHCupDownloads = Map Tool ToolVersionSpec
type ToolVersionSpec = Map Version VersionInfo type ToolVersionSpec = Map GHCTargetVersion VersionInfo
type ArchitectureSpec = Map Architecture PlatformSpec type ArchitectureSpec = Map Architecture PlatformSpec
type PlatformSpec = Map Platform PlatformVersionSpec type PlatformSpec = Map Platform PlatformVersionSpec
type PlatformVersionSpec = Map (Maybe VersionRange) DownloadInfo type PlatformVersionSpec = Map (Maybe VersionRange) DownloadInfo
@ -593,7 +593,9 @@ data GHCTargetVersion = GHCTargetVersion
{ _tvTarget :: Maybe Text { _tvTarget :: Maybe Text
, _tvVersion :: Version , _tvVersion :: Version
} }
deriving (Ord, Eq, Show) deriving (Ord, Eq, Show, GHC.Generic)
instance NFData GHCTargetVersion
data GitBranch = GitBranch data GitBranch = GitBranch
{ ref :: String { ref :: String

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

@ -95,13 +95,29 @@ instance FromJSON URI where
Right x -> pure x Right x -> pure x
Left e -> fail . show $ e 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 instance ToJSON Versioning where
toJSON = toJSON . prettyV toJSON = toJSON . prettyV
instance FromJSON Versioning where instance FromJSON Versioning where
parseJSON = withText "Versioning" $ \t -> case versioning t of parseJSON = withText "Versioning" $ \t -> case versioning t of
Right x -> pure x 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 instance ToJSONKey Versioning where
toJSONKey = toJSONKeyText $ \x -> prettyV x toJSONKey = toJSONKeyText $ \x -> prettyV x

36
lib/GHCup/Utils.hs
View File

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

4
test/GHCup/ArbitraryTypes.hs
View File

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