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

Allow building newer GHCs from git

Browse Source 
The user will have to pass --overwrite-version=<ver> because
we can't discover the GHC version from git anymore.

https://gitlab.haskell.org/ghc/ghc/-/issues/22322
This commit is contained in:
Julian Ospald 2022-12-20 23:18:44 +08:00
parent cb0d8b80c3
commit 6ad9963889
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
1 changed files with 17 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
lib/GHCup/GHC.hs
View File

@ -676,7 +676,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, tver) pure (workdir, tmpUnpack, Just tver)
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)
@ -694,12 +694,13 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
execBlank execBlank
regex regex
) )
tver <- liftE $ getGHCVer (appendGHCupPath tmpUnpack (takeDirectory bootFile)) tver <- liftE $ catchAllE @_ @'[ProcessError, ParseError] @'[] (\_ -> pure Nothing) $ fmap Just $ getGHCVer
(appendGHCupPath tmpUnpack (takeDirectory bootFile))
pure (bootFile, tver) pure (bootFile, tver)
let workdir = appendGHCupPath tmpUnpack (takeDirectory bf) let workdir = appendGHCupPath tmpUnpack (takeDirectory bf)
pure (workdir, tmpUnpack, mkTVer tver) pure (workdir, tmpUnpack, mkTVer <$> tver)
-- clone from git -- clone from git
GitDist GitBranch{..} -> do GitDist GitBranch{..} -> do
@ -745,20 +746,23 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack) liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack)
-- bootstrap -- bootstrap
tver <- liftE $ getGHCVer tmpUnpack tver <- liftE $ catchAllE @_ @'[ProcessError, ParseError] @'[] (\_ -> pure Nothing) $ fmap Just $ getGHCVer
tmpUnpack
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
lift $ logInfo $ "Examining git ref " <> T.pack ref <> "\n " <> lift $ logInfo $ "Examining git ref " <> T.pack ref <> "\n " <>
"GHC version (from Makefile): " <> prettyVer tver <> "GHC version (from Makefile): " <> T.pack (show (prettyVer <$> tver)) <>
(if not shallow_clone then "\n " <> "'git describe' output: " <> fromJust git_describe else mempty) <> (if not shallow_clone then "\n " <> "'git describe' output: " <> fromJust git_describe else mempty) <>
(if isCommitHash ref then mempty else "\n " <> "commit hash: " <> chash) (if isCommitHash ref then mempty else "\n " <> "commit hash: " <> chash)
liftIO $ threadDelay 5000000 -- give the user a sec to intervene liftIO $ threadDelay 5000000 -- give the user a sec to intervene
pure tver pure tver
pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver) pure (tmpUnpack, tmpUnpack, mkTVer <$> 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
let installVer = maybe tver (\ov' -> tver { _tvVersion = ov' }) ov installVer <- if | Just ov' <- ov -> pure (mkTVer 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"
alreadyInstalled <- lift $ ghcInstalled installVer alreadyInstalled <- lift $ ghcInstalled installVer
alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer) alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer)
@ -781,8 +785,10 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
tmpUnpack tmpUnpack
(do (do
b <- if hadrian b <- if hadrian
then compileHadrianBindist tver (fromGHCupPath workdir) ghcdir -- prefer 'tver', because the real version carries out compatibility checks
else compileMakeBindist tver (fromGHCupPath workdir) ghcdir -- we don't want the user to do funny things with it
then compileHadrianBindist (fromMaybe installVer tver) (fromGHCupPath workdir) ghcdir
else compileMakeBindist (fromMaybe installVer tver) (fromGHCupPath workdir) ghcdir
bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk $ fromGHCupPath workdir) bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk $ fromGHCupPath workdir)
pure (b, bmk) pure (b, bmk)
) )
@ -826,14 +832,14 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
, MonadThrow m , MonadThrow m
) )
=> GHCupPath => GHCupPath
-> Excepts '[ProcessError] m Version -> Excepts '[ProcessError, ParseError] m Version
getGHCVer tmpUnpack = do getGHCVer tmpUnpack = do
lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
CapturedProcess {..} <- lift $ makeOut CapturedProcess {..} <- lift $ makeOut
["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack) ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack)
case _exitCode of case _exitCode of
ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut ExitSuccess -> either (throwE . ParseError . show) pure . MP.parse ghcProjectVersion "" . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut
ExitFailure c -> throwE $ NonZeroExit c "make" ["show!", "--quiet", "VALUE=ProjectVersion" ] ExitFailure c -> throwE $ NonZeroExit c "make" ["show!", "--quiet", "VALUE=ProjectVersion" ]
defaultConf = defaultConf =