From c4ab59f7bf9238cd55d24d65e46289b6fe84ed15 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 3 Oct 2021 11:38:53 +0200 Subject: [PATCH] Make sure to always ass GHC env var, fixes #258 --- lib/GHCup.hs | 67 +++++++++++++++++++++----------------- lib/GHCup/Errors.hs | 2 ++ lib/GHCup/Utils/Prelude.hs | 10 ++++++ 3 files changed, 50 insertions(+), 29 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 8d25869..89f7338 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -1137,6 +1137,7 @@ setGHC ver sghc = do SetGHCOnly -> do let sharedir = "share" let fullsharedir = ghcdir sharedir + logDebug $ "Checking for sharedir existence: " <> T.pack fullsharedir whenM (liftIO $ doesDirectoryExist fullsharedir) $ do let fullF = destdir sharedir let targetF = "." "ghc" ver' sharedir @@ -2121,10 +2122,6 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had PlatformRequest { .. } <- lift getPlatformReq GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - bghc <- case bstrap of - Right g -> pure $ Right g - Left bver -> pure $ Left ("ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt) - (workdir, tmpUnpack, tver) <- case targetGhc of -- unpack from version tarball Left tver -> do @@ -2173,9 +2170,8 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had lEM $ git [ "checkout", "FETCH_HEAD" ] lEM $ git [ "submodule", "update", "--init", "--depth", "1" ] forM_ patchdir (\dir -> liftE $ applyPatches dir tmpUnpack) - env <- liftE $ ghcEnv bghc - lEM $ execLogged "python3" ["./boot"] (Just tmpUnpack) "ghc-bootstrap" (Just env) - lEM $ execLogged "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap" (Just env) + lEM $ execWithGhcEnv "python3" ["./boot"] (Just tmpUnpack) "ghc-bootstrap" + lEM $ execWithGhcEnv "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap" CapturedProcess {..} <- lift $ makeOut ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just tmpUnpack) case _exitCode of @@ -2212,8 +2208,8 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had Nothing (do b <- if hadrian - then compileHadrianBindist bghc tver workdir ghcdir - else compileMakeBindist bghc tver workdir ghcdir + then compileHadrianBindist tver workdir ghcdir + else compileMakeBindist tver workdir ghcdir bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk workdir) pure (b, bmk) ) @@ -2265,8 +2261,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had , MonadIO m , MonadFail m ) - => Either FilePath FilePath - -> GHCTargetVersion + => GHCTargetVersion -> FilePath -> FilePath -> Excepts @@ -2279,19 +2274,19 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had , CopyError] m (Maybe FilePath) -- ^ output path of bindist, None for cross - compileHadrianBindist bghc tver workdir ghcdir = do - lEM $ execLogged "python3" ["./boot"] (Just workdir) "ghc-bootstrap" Nothing + compileHadrianBindist tver workdir ghcdir = do + lEM $ execWithGhcEnv "python3" ["./boot"] (Just workdir) "ghc-bootstrap" - liftE $ configureBindist bghc tver workdir ghcdir + liftE $ configureBindist tver workdir ghcdir lift $ logInfo "Building (this may take a while)..." hadrian_build <- liftE $ findHadrianFile workdir - lEM $ execLogged hadrian_build + lEM $ execWithGhcEnv hadrian_build ( maybe [] (\j -> ["-j" <> show j] ) jobs ++ maybe [] (\bf -> ["--flavour=" <> bf]) buildFlavour ++ ["binary-dist"] ) - (Just workdir) "ghc-make" Nothing + (Just workdir) "ghc-make" [tar] <- liftIO $ findFiles (workdir "_build" "bindist") (makeRegexOpts compExtended @@ -2327,8 +2322,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had , MonadIO m , MonadFail m ) - => Either FilePath FilePath - -> GHCTargetVersion + => GHCTargetVersion -> FilePath -> FilePath -> Excepts @@ -2341,8 +2335,8 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had , CopyError] m (Maybe FilePath) -- ^ output path of bindist, None for cross - compileMakeBindist bghc tver workdir ghcdir = do - liftE $ configureBindist bghc tver workdir ghcdir + compileMakeBindist tver workdir ghcdir = do + liftE $ configureBindist tver workdir ghcdir case mbuildConfig of Just bc -> liftIOException @@ -2463,8 +2457,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had , MonadIO m , MonadFail m ) - => Either FilePath FilePath - -> GHCTargetVersion + => GHCTargetVersion -> FilePath -> FilePath -> Excepts @@ -2477,12 +2470,11 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had ] m () - configureBindist bghc tver workdir ghcdir = do + configureBindist tver workdir ghcdir = do lift $ logInfo [s|configuring build|] if | _tvVersion tver >= [vver|8.8.0|] -> do - env <- liftE $ ghcEnv bghc - lEM $ execLogged + lEM $ execWithGhcEnv "sh" ("./configure" : maybe mempty (\x -> ["--target=" <> T.unpack x]) @@ -2495,7 +2487,6 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had ) (Just workdir) "ghc-conf" - (Just env) | otherwise -> do lEM $ execLogged "sh" @@ -2515,14 +2506,32 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had Nothing pure () - ghcEnv :: MonadIO m => Either FilePath FilePath -> Excepts '[NotFoundInPATH] m [(String, String)] - ghcEnv bghc = do + execWithGhcEnv :: ( MonadReader env m + , HasSettings env + , HasDirs env + , MonadIO m + , MonadThrow m) + => FilePath -- ^ thing to execute + -> [String] -- ^ args for the thing + -> Maybe FilePath -- ^ optionally chdir into this + -> FilePath -- ^ log filename (opened in append mode) + -> m (Either ProcessError ()) + execWithGhcEnv fp args dir logf = do + env <- ghcEnv + execLogged fp args dir logf (Just env) + + bghc = case bstrap of + Right g -> Right g + Left bver -> Left ("ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt) + + ghcEnv :: (MonadThrow m, MonadIO m) => m [(String, String)] + ghcEnv = do cEnv <- liftIO getEnvironment bghcPath <- case bghc of Right ghc' -> pure ghc' Left bver -> do spaths <- liftIO getSearchPath - liftIO (searchPath spaths bver) !? NotFoundInPATH bver + throwMaybeM (NotFoundInPATH bver) $ liftIO (searchPath spaths bver) pure (("GHC", bghcPath) : cEnv) diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index ee840a0..4d8b183 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -149,6 +149,8 @@ instance Pretty NotInstalled where data NotFoundInPATH = NotFoundInPATH FilePath deriving Show +instance Exception NotFoundInPATH + instance Pretty NotFoundInPATH where pPrint (NotFoundInPATH exe) = text $ "The exe " <> exe <> " was not found in PATH." diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index 764a9e9..0d085af 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -283,6 +283,16 @@ throwEither' e eth = case eth of Left _ -> throwM e Right r -> pure r +throwMaybe :: (Exception a, MonadThrow m) => a -> Maybe b -> m b +throwMaybe a m = case m of + Nothing -> throwM a + Just r -> pure r + +throwMaybeM :: (Exception a, MonadThrow m) => a -> m (Maybe b) -> m b +throwMaybeM a am = do + m <- am + throwMaybe a m + verToBS :: Version -> ByteString verToBS = E.encodeUtf8 . prettyVer