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

Merge branch 'issue-258'

Browse Source
This commit is contained in:
Julian Ospald 2021-10-03 12:40:27 +02:00
commit 6459af419e
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
4 changed files with 51 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
ghcup.cabal
View File

@ -20,9 +20,7 @@ extra-doc-files:
data/metadata/ghcup-0.0.4.yaml data/metadata/ghcup-0.0.4.yaml
data/metadata/ghcup-0.0.5.yaml data/metadata/ghcup-0.0.5.yaml
data/metadata/ghcup-0.0.6.yaml data/metadata/ghcup-0.0.6.yaml
docs/CHANGELOG.md CHANGELOG.md
docs/HACKING.md
docs/RELEASING.md
README.md README.md
extra-source-files: extra-source-files:

67
lib/GHCup.hs
View File

@ -1137,6 +1137,7 @@ setGHC ver sghc = do
SetGHCOnly -> do SetGHCOnly -> do
let sharedir = "share" let sharedir = "share"
let fullsharedir = ghcdir </> sharedir let fullsharedir = ghcdir </> sharedir
logDebug $ "Checking for sharedir existence: " <> T.pack fullsharedir
whenM (liftIO $ doesDirectoryExist fullsharedir) $ do whenM (liftIO $ doesDirectoryExist fullsharedir) $ do
let fullF = destdir </> sharedir let fullF = destdir </> sharedir
let targetF = "." </> "ghc" </> ver' </> sharedir let targetF = "." </> "ghc" </> ver' </> sharedir
@ -2121,10 +2122,6 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
PlatformRequest { .. } <- lift getPlatformReq PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo 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 (workdir, tmpUnpack, tver) <- case targetGhc of
-- unpack from version tarball -- unpack from version tarball
Left tver -> do Left tver -> do
@ -2173,9 +2170,8 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
lEM $ git [ "checkout", "FETCH_HEAD" ] lEM $ git [ "checkout", "FETCH_HEAD" ]
lEM $ git [ "submodule", "update", "--init", "--depth", "1" ] lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
forM_ patchdir (\dir -> liftE $ applyPatches dir tmpUnpack) forM_ patchdir (\dir -> liftE $ applyPatches dir tmpUnpack)
env <- liftE $ ghcEnv bghc lEM $ execWithGhcEnv "python3" ["./boot"] (Just tmpUnpack) "ghc-bootstrap"
lEM $ execLogged "python3" ["./boot"] (Just tmpUnpack) "ghc-bootstrap" (Just env) lEM $ execWithGhcEnv "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap"
lEM $ execLogged "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap" (Just env)
CapturedProcess {..} <- lift $ makeOut CapturedProcess {..} <- lift $ makeOut
["show!", "--quiet", "VALUE=ProjectVersion" ] (Just tmpUnpack) ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just tmpUnpack)
case _exitCode of case _exitCode of
@ -2212,8 +2208,8 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
Nothing Nothing
(do (do
b <- if hadrian b <- if hadrian
then compileHadrianBindist bghc tver workdir ghcdir then compileHadrianBindist tver workdir ghcdir
else compileMakeBindist bghc tver workdir ghcdir else compileMakeBindist tver workdir ghcdir
bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk workdir) bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk workdir)
pure (b, bmk) pure (b, bmk)
) )
@ -2265,8 +2261,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
, MonadIO m , MonadIO m
, MonadFail m , MonadFail m
) )
=> Either FilePath FilePath => GHCTargetVersion
-> GHCTargetVersion
-> FilePath -> FilePath
-> FilePath -> FilePath
-> Excepts -> Excepts
@ -2279,19 +2274,19 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
, CopyError] , CopyError]
m m
(Maybe FilePath) -- ^ output path of bindist, None for cross (Maybe FilePath) -- ^ output path of bindist, None for cross
compileHadrianBindist bghc tver workdir ghcdir = do compileHadrianBindist tver workdir ghcdir = do
lEM $ execLogged "python3" ["./boot"] (Just workdir) "ghc-bootstrap" Nothing 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)..." lift $ logInfo "Building (this may take a while)..."
hadrian_build <- liftE $ findHadrianFile workdir hadrian_build <- liftE $ findHadrianFile workdir
lEM $ execLogged hadrian_build lEM $ execWithGhcEnv hadrian_build
( maybe [] (\j -> ["-j" <> show j] ) jobs ( maybe [] (\j -> ["-j" <> show j] ) jobs
++ maybe [] (\bf -> ["--flavour=" <> bf]) buildFlavour ++ maybe [] (\bf -> ["--flavour=" <> bf]) buildFlavour
++ ["binary-dist"] ++ ["binary-dist"]
) )
(Just workdir) "ghc-make" Nothing (Just workdir) "ghc-make"
[tar] <- liftIO $ findFiles [tar] <- liftIO $ findFiles
(workdir </> "_build" </> "bindist") (workdir </> "_build" </> "bindist")
(makeRegexOpts compExtended (makeRegexOpts compExtended
@ -2327,8 +2322,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
, MonadIO m , MonadIO m
, MonadFail m , MonadFail m
) )
=> Either FilePath FilePath => GHCTargetVersion
-> GHCTargetVersion
-> FilePath -> FilePath
-> FilePath -> FilePath
-> Excepts -> Excepts
@ -2341,8 +2335,8 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
, CopyError] , CopyError]
m m
(Maybe FilePath) -- ^ output path of bindist, None for cross (Maybe FilePath) -- ^ output path of bindist, None for cross
compileMakeBindist bghc tver workdir ghcdir = do compileMakeBindist tver workdir ghcdir = do
liftE $ configureBindist bghc tver workdir ghcdir liftE $ configureBindist tver workdir ghcdir
case mbuildConfig of case mbuildConfig of
Just bc -> liftIOException Just bc -> liftIOException
@ -2463,8 +2457,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
, MonadIO m , MonadIO m
, MonadFail m , MonadFail m
) )
=> Either FilePath FilePath => GHCTargetVersion
-> GHCTargetVersion
-> FilePath -> FilePath
-> FilePath -> FilePath
-> Excepts -> Excepts
@ -2477,12 +2470,11 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
] ]
m m
() ()
configureBindist bghc tver workdir ghcdir = do configureBindist tver workdir ghcdir = do
lift $ logInfo [s|configuring build|] lift $ logInfo [s|configuring build|]
if | _tvVersion tver >= [vver|8.8.0|] -> do if | _tvVersion tver >= [vver|8.8.0|] -> do
env <- liftE $ ghcEnv bghc lEM $ execWithGhcEnv
lEM $ execLogged
"sh" "sh"
("./configure" : maybe mempty ("./configure" : maybe mempty
(\x -> ["--target=" <> T.unpack x]) (\x -> ["--target=" <> T.unpack x])
@ -2495,7 +2487,6 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
) )
(Just workdir) (Just workdir)
"ghc-conf" "ghc-conf"
(Just env)
| otherwise -> do | otherwise -> do
lEM $ execLogged lEM $ execLogged
"sh" "sh"
@ -2515,14 +2506,32 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
Nothing Nothing
pure () pure ()
ghcEnv :: MonadIO m => Either FilePath FilePath -> Excepts '[NotFoundInPATH] m [(String, String)] execWithGhcEnv :: ( MonadReader env m
ghcEnv bghc = do , 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 cEnv <- liftIO getEnvironment
bghcPath <- case bghc of bghcPath <- case bghc of
Right ghc' -> pure ghc' Right ghc' -> pure ghc'
Left bver -> do Left bver -> do
spaths <- liftIO getSearchPath spaths <- liftIO getSearchPath
liftIO (searchPath spaths bver) !? NotFoundInPATH bver throwMaybeM (NotFoundInPATH bver) $ liftIO (searchPath spaths bver)
pure (("GHC", bghcPath) : cEnv) pure (("GHC", bghcPath) : cEnv)

2
lib/GHCup/Errors.hs
View File

@ -149,6 +149,8 @@ instance Pretty NotInstalled where
data NotFoundInPATH = NotFoundInPATH FilePath data NotFoundInPATH = NotFoundInPATH FilePath
deriving Show deriving Show
instance Exception NotFoundInPATH
instance Pretty NotFoundInPATH where instance Pretty NotFoundInPATH where
pPrint (NotFoundInPATH exe) = pPrint (NotFoundInPATH exe) =
text $ "The exe " <> exe <> " was not found in PATH." text $ "The exe " <> exe <> " was not found in PATH."

10
lib/GHCup/Utils/Prelude.hs
View File

@ -283,6 +283,16 @@ throwEither' e eth = case eth of
Left _ -> throwM e Left _ -> throwM e
Right r -> pure r 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 :: Version -> ByteString
verToBS = E.encodeUtf8 . prettyVer verToBS = E.encodeUtf8 . prettyVer