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

Merge branch 'master' into optparse-test-suite

This commit is contained in:
Lei Zhu 2023-08-05 13:08:41 +08:00
parent 69d311f0b4 a2a605ad89
commit bcb498de20
15 changed files with 399 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
.github/scripts/cross.sh vendored Normal file
View File

@ -0,0 +1,74 @@
#!/usr/bin/env bash
set -ex
. .github/scripts/common.sh
run() {
"$@"
}
if [ "${OS}" = "Windows" ] ; then
GHCUP_DIR="${GHCUP_INSTALL_BASE_PREFIX}"/ghcup
else
GHCUP_DIR="${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
fi
git_describe
rm -rf "${GHCUP_DIR}"
mkdir -p "${GHCUP_BIN}"
cp "out/${ARTIFACT}"-* "$GHCUP_BIN/ghcup${ext}"
cp "out/test-${ARTIFACT}"-* "ghcup-test${ext}"
chmod +x "$GHCUP_BIN/ghcup${ext}"
chmod +x "ghcup-test${ext}"
"$GHCUP_BIN/ghcup${ext}" --version
eghcup --version
sha_sum "$GHCUP_BIN/ghcup${ext}"
sha_sum "$(raw_eghcup --offline whereis ghcup)"
### cross build
eghcup --numeric-version
eghcup install ghc "${GHC_VER}"
eghcup set ghc "${GHC_VER}"
eghcup install cabal "${CABAL_VER}"
cabal --version
eghcup debug-info
ecabal update
"${WRAPPER}" "$GHCUP_BIN/ghcup${ext}" -c -s "file://$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml" -v \
compile ghc \
$(if [ -n "${HADRIAN_FLAVOUR}" ] ; then printf "%s" "--flavour=${HADRIAN_FLAVOUR}" ; else true ; fi) \
-j "$(nproc)" \
-v "${GHC_TARGET_VERSION}" \
-b "${GHC_VER}" \
-x "${CROSS}" \
-- ${BUILD_CONF_ARGS}
eghcup set ghc "${CROSS}-${GHC_TARGET_VERSION}"
[ "$($(eghcup whereis ghc "${CROSS}-${GHC_TARGET_VERSION}") --numeric-version)" = "${GHC_TARGET_VERSION}" ]
# test that doing fishy symlinks into GHCup dir doesn't cause weird stuff on 'ghcup nuke'
mkdir no_nuke/
mkdir no_nuke/bar
echo 'foo' > no_nuke/file
echo 'bar' > no_nuke/bar/file
ln -s "$CI_PROJECT_DIR"/no_nuke/ "${GHCUP_DIR}"/cache/no_nuke
ln -s "$CI_PROJECT_DIR"/no_nuke/ "${GHCUP_DIR}"/logs/no_nuke
# nuke
eghcup nuke
[ ! -e "${GHCUP_DIR}" ]
# make sure nuke doesn't resolve symlinks
[ -e "$CI_PROJECT_DIR"/no_nuke/file ]
[ -e "$CI_PROJECT_DIR"/no_nuke/bar/file ]

140
.github/workflows/cross.yaml vendored Normal file
View File

@ -0,0 +1,140 @@
name: Test cross bindists
on:
push:
branches:
- master
tags:
- 'v*'
pull_request:
branches:
- master
schedule:
- cron: '0 2 * * *'
env:
CABAL_CACHE_DISABLE: ${{ vars.CABAL_CACHE_DISABLE }}
CABAL_CACHE_NONFATAL: yes
jobs:
build:
name: Build linux binary
runs-on: ubuntu-latest
env:
CABAL_VER: 3.10.1.0
JSON_VERSION: "0.0.7"
AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }}
AWS_ACCESS_KEY_ID: ${{ secrets.AWS_ACCESS_KEY_ID }}
S3_HOST: ${{ secrets.S3_HOST }}
ARTIFACT: "x86_64-linux-ghcup"
GHC_VER: 8.10.7
ARCH: 64
steps:
- name: Checkout code
uses: actions/checkout@v3
with:
submodules: 'true'
- name: Run build
uses: docker://hasufell/alpine-haskell:3.12
with:
args: sh .github/scripts/build.sh
env:
ARTIFACT: ${{ env.ARTIFACT }}
ARCH: ${{ env.ARCH }}
GHC_VER: ${{ env.GHC_VER }}
DISTRO: Alpine
AWS_SECRET_ACCESS_KEY: ${{ env.AWS_SECRET_ACCESS_KEY }}
AWS_ACCESS_KEY_ID: ${{ env.AWS_ACCESS_KEY_ID }}
S3_HOST: ${{ env.S3_HOST }}
- if: always()
name: Upload artifact
uses: actions/upload-artifact@v3
with:
name: artifacts
path: |
./out/*
test-cross-linux:
name: Test linux cross
needs: "build"
runs-on: [self-hosted, Linux, X64]
container:
image: registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb10:8d0224e6b2a08157649651e69302380b2bd24e11
options: --user root
env:
CABAL_VER: 3.6.2.0
BUILD_CONF_ARGS: "--enable-unregisterised"
HADRIAN_FLAVOUR: ""
JSON_VERSION: "0.0.7"
GHC_VER: 8.10.6
GHC_TARGET_VERSION: "8.10.7"
ARCH: 64
DISTRO: Debian
ARTIFACT: "x86_64-linux-ghcup"
CROSS: "arm-linux-gnueabihf"
WRAPPER: "run"
steps:
- name: Checkout code
uses: actions/checkout@v3
with:
submodules: 'true'
- uses: actions/download-artifact@v3
with:
name: artifacts
path: ./out
- name: Run test (64 bit linux)
run: |
sudo apt-get update -y
sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget lsb-release software-properties-common gnupg2 apt-transport-https gcc autoconf automake build-essential curl gzip
sudo apt-get install -y gcc-arm-linux-gnueabihf
sudo dpkg --add-architecture armhf
sudo apt-get update -y
sudo apt-get install -y libncurses-dev:armhf
sh .github/scripts/cross.sh
test-cross-js:
name: Test GHC JS cross
needs: "build"
runs-on: [self-hosted, Linux, X64]
container:
image: registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb10:8d0224e6b2a08157649651e69302380b2bd24e11
options: --user root
env:
CABAL_VER: 3.6.2.0
BUILD_CONF_ARGS: ""
HADRIAN_FLAVOUR: "default+native_bignum"
JSON_VERSION: "0.0.7"
GHC_VER: 9.6.2
GHC_TARGET_VERSION: "9.6.2"
ARCH: 64
DISTRO: Debian
ARTIFACT: "x86_64-linux-ghcup"
CROSS: "javascript-unknown-ghcjs"
WRAPPER: "emconfigure"
steps:
- name: Checkout code
uses: actions/checkout@v3
with:
submodules: 'true'
- uses: actions/download-artifact@v3
with:
name: artifacts
path: ./out
- name: Run test (64 bit linux)
run: |
sudo apt-get update -y
sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget lsb-release software-properties-common gnupg2 apt-transport-https gcc autoconf automake build-essential curl gzip
git clone https://github.com/emscripten-core/emsdk.git
cd emsdk
./emsdk install latest
./emsdk activate latest
. ./emsdk_env.sh
cd ..
bash .github/scripts/cross.sh

1
app/ghcup/BrickMain.hs
View File

@ -218,7 +218,6 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
printNotes ListResult {..} = printNotes ListResult {..} =
(if hlsPowered then [withAttr (attrName "hls-powered") $ str "hls-powered"] else mempty (if hlsPowered then [withAttr (attrName "hls-powered") $ str "hls-powered"] else mempty
) )
++ (if fromSrc then [withAttr (attrName "compiled") $ str "compiled"] else mempty)
++ (if lStray then [withAttr (attrName "stray") $ str "stray"] else mempty) ++ (if lStray then [withAttr (attrName "stray") $ str "stray"] else mempty)
++ (case lReleaseDay of ++ (case lReleaseDay of
Nothing -> mempty Nothing -> mempty

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

@ -77,7 +77,7 @@ data GHCCompileOptions = GHCCompileOptions
, setCompile :: Bool , setCompile :: Bool
, ovewrwiteVer :: Maybe Version , ovewrwiteVer :: Maybe Version
, buildFlavour :: Maybe String , buildFlavour :: Maybe String
, hadrian :: Bool , buildSystem :: Maybe BuildSystem
, isolateDir :: Maybe FilePath , isolateDir :: Maybe FilePath
} deriving (Eq, Show) } deriving (Eq, Show)
@ -269,9 +269,15 @@ ghcCompileOpts =
"Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')" "Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')"
) )
) )
<*> switch <*> (
(long "hadrian" <> help "Use the hadrian build system instead of make (only git versions seem to be properly supported atm)" (\b -> if b then Just Hadrian else Nothing) <$> switch
(long "hadrian" <> help "Use the hadrian build system instead of make. Tries to detect by default."
) )
<|>
(\b -> if b then Just Make else Nothing) <$> switch
(long "make" <> help "Use the make build system instead of hadrian. Tries to detect by default."
)
)
<*> optional <*> optional
(option (option
(eitherReader isolateParser) (eitherReader isolateParser)
@ -578,7 +584,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
patches patches
addConfArgs addConfArgs
buildFlavour buildFlavour
hadrian buildSystem
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer GHC dls let vi = getVersionInfo targetVer GHC dls

1
app/ghcup/GHCup/OptParse/List.hs
View File

@ -180,7 +180,6 @@ printListResult no_color raw lr = do
then [color Green "hls-powered"] then [color Green "hls-powered"]
else mempty else mempty
) )
++ (if fromSrc then [color Blue "compiled"] else mempty)
++ (if lStray then [color Yellow "stray"] else mempty) ++ (if lStray then [color Yellow "stray"] else mempty)
++ (case lReleaseDay of ++ (case lReleaseDay of
Nothing -> mempty Nothing -> mempty

2
docs/guide.md
View File

@ -205,7 +205,7 @@ url-source:
### Nightlies ### Nightlies
Nightlies are just a nother release channel. Currently, only GHC supports nightlies, which are binary releases Nightlies are just another release channel. Currently, only GHC supports nightlies, which are binary releases
that are built every night from `master`. that are built every night from `master`.
To add the nightly channel, run: To add the nightly channel, run:

23
lib/GHCup.hs
View File

@ -134,15 +134,24 @@ rmTool :: ( MonadReader env m
=> ListResult => ListResult
-> Excepts '[NotInstalled, UninstallFailed] m () -> Excepts '[NotInstalled, UninstallFailed] m ()
rmTool ListResult {lVer, lTool, lCross} = do rmTool ListResult {lVer, lTool, lCross} = do
logInfo $ "removing " <> T.pack (show lTool) <> " version " <> prettyVer lVer let printRmTool = logInfo $ "removing " <> T.pack (show lTool) <> " version " <> prettyVer lVer
case lTool of case lTool of
GHC -> GHC -> do
let ghcTargetVersion = GHCTargetVersion lCross lVer let ghcTargetVersion = GHCTargetVersion lCross lVer
in rmGHCVer ghcTargetVersion logInfo $ "removing " <> T.pack (show lTool) <> " version " <> tVerToText ghcTargetVersion
HLS -> rmHLSVer lVer rmGHCVer ghcTargetVersion
Cabal -> liftE $ rmCabalVer lVer HLS -> do
Stack -> liftE $ rmStackVer lVer printRmTool
GHCup -> lift rmGhcup rmHLSVer lVer
Cabal -> do
printRmTool
liftE $ rmCabalVer lVer
Stack -> do
printRmTool
liftE $ rmStackVer lVer
GHCup -> do
printRmTool
lift rmGhcup
rmGhcupDirs :: ( MonadReader env m rmGhcupDirs :: ( MonadReader env m

4
lib/GHCup/Download.hs
View File

@ -296,7 +296,7 @@ getDownloadInfo' :: ( MonadReader env m
m m
DownloadInfo DownloadInfo
getDownloadInfo' t v = do getDownloadInfo' t v = do
(PlatformRequest a p mv) <- lift getPlatformReq pfreq@(PlatformRequest a p mv) <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let distro_preview f g = let distro_preview f g =
@ -317,7 +317,7 @@ getDownloadInfo' t v = do
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing) without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
maybe maybe
(throwE NoDownload) (throwE $ NoDownload v t (Just pfreq))
pure pure
(case p of (case p of
-- non-musl won't work on alpine -- non-musl won't work on alpine

20
lib/GHCup/Errors.hs
View File

@ -206,12 +206,26 @@ instance HFErrorProject NoCompatiblePlatform where
eDesc _ = "No compatible platform could be found" eDesc _ = "No compatible platform could be found"
-- | Unable to find a download for the requested version/distro. -- | Unable to find a download for the requested version/distro.
data NoDownload = NoDownload data NoDownload = NoDownload GHCTargetVersion Tool (Maybe PlatformRequest)
| NoDownload' GlobalTool
deriving Show deriving Show
instance Pretty NoDownload where instance Pretty NoDownload where
pPrint NoDownload = pPrint (NoDownload tver@(GHCTargetVersion mtarget vv) tool mpfreq)
text (eDesc (Proxy :: Proxy NoDownload)) | (Just target) <- mtarget
, target `elem` (T.pack . prettyShow <$> enumFromTo (minBound :: Tool) (maxBound :: Tool))
= text $ "Unable to find a download for "
<> show tool
<> " version '"
<> T.unpack (tVerToText tver)
<> maybe "'\n" (\pfreq -> "' on detected platform " <> pfReqToString pfreq <> "\n") mpfreq
<> "Perhaps you meant: 'ghcup <command> "
<> T.unpack target
<> " "
<> T.unpack (prettyVer vv)
<> "'"
| otherwise = text $ "Unable to find a download for " <> T.unpack (tVerToText tver)
pPrint (NoDownload' globalTool) = text $ "Unable to find a download for " <> prettyShow globalTool
instance HFErrorProject NoDownload where instance HFErrorProject NoDownload where
eBase _ = 10 eBase _ = 10

219
lib/GHCup/GHC.hs
View File

@ -126,7 +126,7 @@ testGHCVer ver addMakeArgs = do
dlInfo <- dlInfo <-
preview (ix GHC % ix ver % viTestDL % _Just) dls preview (ix GHC % ix ver % viTestDL % _Just) dls
?? NoDownload ?? NoDownload ver GHC Nothing
liftE $ testGHCBindist dlInfo ver addMakeArgs liftE $ testGHCBindist dlInfo ver addMakeArgs
@ -261,7 +261,7 @@ fetchGHCSrc v mfp = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
dlInfo <- dlInfo <-
preview (ix GHC % ix v % viSourceDL % _Just) dls preview (ix GHC % ix v % viSourceDL % _Just) dls
?? NoDownload ?? NoDownload v GHC Nothing
liftE $ downloadCached' dlInfo Nothing mfp liftE $ downloadCached' dlInfo Nothing mfp
@ -434,11 +434,7 @@ installUnpackedGHC path inst tver forceInstall addConfArgs
-- 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 tver $ \source dest -> do liftE $ mergeGHCFileTree path inst tver forceInstall
mtime <- liftIO $ ifM (pathIsSymbolicLink source) (pure Nothing) (Just <$> getModificationTime source)
when forceInstall $ hideError doesNotExistErrorType $ hideError InappropriateType $ recycleFile dest
liftIO $ moveFilePortable source dest
forM_ mtime $ liftIO . setModificationTime dest
| otherwise = do | otherwise = do
PlatformRequest {..} <- lift getPlatformReq PlatformRequest {..} <- lift getPlatformReq
@ -460,7 +456,36 @@ installUnpackedGHC path inst tver forceInstall addConfArgs
tmpInstallDest <- lift withGHCupTmpDir tmpInstallDest <- lift withGHCupTmpDir
lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "install"] (Just $ fromGHCupPath path) lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "install"] (Just $ fromGHCupPath path)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest) liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest)
liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) liftE $ mergeGHCFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) inst tver forceInstall
pure ()
mergeGHCFileTree :: ( MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadThrow m
, HasLog env
, MonadIO m
, MonadUnliftIO m
, MonadMask m
, MonadResource m
, MonadFail m
)
=> GHCupPath -- ^ Path to the root of the tree
-> InstallDirResolved -- ^ Path to install to
-> GHCTargetVersion -- ^ The GHC version
-> Bool -- ^ Force install
-> Excepts '[MergeFileTreeError] m ()
mergeGHCFileTree root inst tver forceInstall
| isWindows = do
liftE $ mergeFileTree root 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
forM_ mtime $ liftIO . setModificationTime dest
| otherwise = do
liftE $ mergeFileTree root
inst inst
GHC GHC
tver tver
@ -469,8 +494,6 @@ installUnpackedGHC path inst tver forceInstall addConfArgs
install f t (not forceInstall) install f t (not forceInstall)
forM_ mtime $ setModificationTime t) forM_ mtime $ setModificationTime t)
pure ()
-- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the -- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
-- following symlinks in @~\/.ghcup\/bin@: -- following symlinks in @~\/.ghcup\/bin@:
@ -709,7 +732,7 @@ rmGHCVer ver = do
Just files -> do Just files -> do
lift $ logInfo $ "Removing files safely from: " <> T.pack dir lift $ logInfo $ "Removing files safely from: " <> T.pack dir
forM_ files (lift . hideError NoSuchThing . recycleFile . (\f -> dir </> dropDrive f)) forM_ files (lift . hideError NoSuchThing . recycleFile . (\f -> dir </> dropDrive f))
removeEmptyDirsRecursive dir hideError UnsatisfiedConstraints $ removeEmptyDirsRecursive dir
survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir
f <- recordedInstallationFile GHC ver f <- recordedInstallationFile GHC ver
lift $ recycleFile f lift $ recycleFile f
@ -765,7 +788,7 @@ compileGHC :: ( MonadMask m
-> Maybe (Either FilePath [URI]) -- ^ patches -> Maybe (Either FilePath [URI]) -- ^ patches
-> [Text] -- ^ additional args to ./configure -> [Text] -- ^ additional args to ./configure
-> Maybe String -- ^ build flavour -> Maybe String -- ^ build flavour
-> Bool -> Maybe BuildSystem
-> InstallDir -> InstallDir
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
@ -794,9 +817,9 @@ compileGHC :: ( MonadMask m
] ]
m m
GHCTargetVersion GHCTargetVersion
compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian installDir compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs buildFlavour buildSystem installDir
= do = do
PlatformRequest { .. } <- lift getPlatformReq pfreq@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
@ -805,9 +828,10 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
lift $ logDebug $ "Requested to compile: " <> prettyVer ver <> " 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
let tver = mkTVer ver
dlInfo <- dlInfo <-
preview (ix GHC % ix (mkTVer ver) % viSourceDL % _Just) dls preview (ix GHC % ix tver % viSourceDL % _Just) dls
?? NoDownload ?? NoDownload tver GHC (Just pfreq)
dl <- liftE $ downloadCached dlInfo Nothing dl <- liftE $ downloadCached dlInfo Nothing
-- unpack -- unpack
@ -906,7 +930,7 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
-- compiled version, so the user can overwrite it -- compiled version, so the user can overwrite it
installVer <- if | Just ov' <- ov -> pure (GHCTargetVersion crossTarget 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 "No GHC version given and couldn't detect version. Giving up..."
alreadyInstalled <- lift $ ghcInstalled installVer alreadyInstalled <- lift $ ghcInstalled installVer
alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer) alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer)
@ -925,16 +949,31 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
IsolateDir isoDir -> pure $ IsolateDirResolved isoDir IsolateDir isoDir -> pure $ IsolateDirResolved isoDir
GHCupInternal -> GHCupDir <$> lift (ghcupGHCDir installVer) GHCupInternal -> GHCupDir <$> lift (ghcupGHCDir installVer)
(mBindist, bmk) <- liftE $ runBuildAction mBindist <- liftE $ runBuildAction
tmpUnpack tmpUnpack
(do (do
b <- if hadrian -- prefer 'tver', because the real version carries out compatibility checks
-- prefer 'tver', because the real version carries out compatibility checks -- we don't want the user to do funny things with it
-- we don't want the user to do funny things with it let doHadrian = compileHadrianBindist (fromMaybe installVer tver) (fromGHCupPath workdir) ghcdir
then compileHadrianBindist (fromMaybe installVer tver) (fromGHCupPath workdir) ghcdir doMake = compileMakeBindist (fromMaybe installVer tver) (fromGHCupPath workdir) ghcdir
else compileMakeBindist (fromMaybe installVer tver) (fromGHCupPath workdir) ghcdir case buildSystem of
bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk $ fromGHCupPath workdir) Just Hadrian -> do
pure (b, bmk) lift $ logInfo "Requested to use Hadrian"
liftE doHadrian
Just Make -> do
lift $ logInfo "Requested to use Make"
doMake
Nothing -> do
supportsHadrian <- liftE $ catchE @HadrianNotFound @'[HadrianNotFound] @'[] (\_ -> return False)
$ fmap (const True)
$ findHadrianFile (fromGHCupPath workdir)
if supportsHadrian
then do
lift $ logInfo "Detected Hadrian"
liftE doHadrian
else do
lift $ logInfo "Detected Make"
doMake
) )
case installDir of case installDir of
@ -954,8 +993,6 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
False -- not a force install, since we already overwrite when compiling. False -- not a force install, since we already overwrite when compiling.
[] []
liftIO $ B.writeFile (fromInstallDir ghcdir </> ghcUpSrcBuiltFile) bmk
case installDir of case installDir of
-- set and make symlinks for regular (non-isolated) installs -- set and make symlinks for regular (non-isolated) installs
GHCupInternal -> do GHCupInternal -> do
@ -978,13 +1015,22 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
=> GHCupPath => GHCupPath
-> Excepts '[ProcessError, ParseError] m Version -> Excepts '[ProcessError, ParseError] m Version
getGHCVer tmpUnpack = do getGHCVer tmpUnpack = do
lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" lEM $ execLogged "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" Nothing
lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" lEM $ configureWithGhcBoot Nothing [] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
CapturedProcess {..} <- lift $ makeOut let versionFile = fromGHCupPath tmpUnpack </> "VERSION"
["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack) hasVersionFile <- liftIO $ doesFileExist versionFile
case _exitCode of if hasVersionFile
ExitSuccess -> either (throwE . ParseError . show) pure . MP.parse ghcProjectVersion "" . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut then do
ExitFailure c -> throwE $ NonZeroExit c "make" ["show!", "--quiet", "VALUE=ProjectVersion" ] lift $ logDebug "Detected VERSION file, trying to extract"
contents <- liftIO $ readFile versionFile
either (throwE . ParseError . show) pure . MP.parse version' "" . T.pack . stripNewlineEnd $ contents
else do
lift $ logDebug "Didn't detect VERSION file, trying to extract via legacy 'make'"
CapturedProcess {..} <- lift $ makeOut
["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack)
case _exitCode of
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" ]
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")))
@ -1021,12 +1067,13 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
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 $ execWithGhcEnv hadrian_build lEM $ execLogged 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" (Just workdir) "ghc-make"
Nothing
[tar] <- liftIO $ findFiles [tar] <- liftIO $ findFiles
(workdir </> "_build" </> "bindist") (workdir </> "_build" </> "bindist")
(makeRegexOpts compExtended (makeRegexOpts compExtended
@ -1059,6 +1106,9 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
, HasLog env , HasLog env
, MonadIO m , MonadIO m
, MonadFail m , MonadFail m
, MonadMask m
, MonadUnliftIO m
, MonadResource m
) )
=> GHCTargetVersion => GHCTargetVersion
-> FilePath -> FilePath
@ -1070,6 +1120,7 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
, PatchFailed , PatchFailed
, ProcessError , ProcessError
, NotFoundInPATH , NotFoundInPATH
, MergeFileTreeError
, CopyError] , CopyError]
m m
(Maybe FilePath) -- ^ output path of bindist, None for cross (Maybe FilePath) -- ^ output path of bindist, None for cross
@ -1091,7 +1142,9 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
if | isCross tver -> do if | isCross tver -> do
lift $ logInfo "Installing cross toolchain..." lift $ logInfo "Installing cross toolchain..."
lEM $ make ["install"] (Just workdir) tmpInstallDest <- lift withGHCupTmpDir
lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "install"] (Just workdir)
liftE $ mergeGHCFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir ghcdir)) ghcdir tver True
pure Nothing pure Nothing
| otherwise -> do | otherwise -> do
lift $ logInfo "Creating bindist..." lift $ logInfo "Creating bindist..."
@ -1209,64 +1262,50 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
() ()
configureBindist tver workdir (fromInstallDir -> ghcdir) = do configureBindist tver workdir (fromInstallDir -> ghcdir) = do
lift $ logInfo [s|configuring build|] lift $ logInfo [s|configuring build|]
lEM $ configureWithGhcBoot (Just tver)
if | _tvVersion tver >= [vver|8.8.0|] -> do (maybe mempty
lEM $ execWithGhcEnv (\x -> ["--target=" <> T.unpack x])
"sh" (_tvTarget tver)
("./configure" : maybe mempty ++ ["--prefix=" <> ghcdir]
(\x -> ["--target=" <> T.unpack x]) ++ (if isWindows then ["--enable-tarballs-autodownload"] else [])
(_tvTarget tver) ++ fmap T.unpack aargs
++ ["--prefix=" <> ghcdir] )
++ (if isWindows then ["--enable-tarballs-autodownload"] else []) (Just workdir)
++ fmap T.unpack aargs "ghc-conf"
)
(Just workdir)
"ghc-conf"
| otherwise -> do
lEM $ execLogged
"sh"
( [ "./configure", "--with-ghc=" <> either id id bghc
]
++ maybe mempty
(\x -> ["--target=" <> T.unpack x])
(_tvTarget tver)
++ ["--prefix=" <> ghcdir]
++ (if isWindows then ["--enable-tarballs-autodownload"] else [])
++ fmap T.unpack aargs
)
(Just workdir)
"ghc-conf"
Nothing
pure () pure ()
execWithGhcEnv :: ( MonadReader env m configureWithGhcBoot :: ( MonadReader env m
, HasSettings env , HasSettings env
, HasDirs env , HasDirs env
, HasLog env , HasLog env
, MonadIO m , MonadIO m
, MonadThrow m) , MonadThrow m)
=> FilePath -- ^ thing to execute => Maybe GHCTargetVersion
-> [String] -- ^ args for the thing -> [String] -- ^ args for configure
-> Maybe FilePath -- ^ optionally chdir into this -> Maybe FilePath -- ^ optionally chdir into this
-> FilePath -- ^ log filename (opened in append mode) -> FilePath -- ^ log filename (opened in append mode)
-> m (Either ProcessError ()) -> m (Either ProcessError ())
execWithGhcEnv fp args dir logf = do configureWithGhcBoot mtver args dir logf = do
env <- ghcEnv let execNew = execLogged
execLogged fp args dir logf (Just env) "sh"
("./configure" : ("GHC=" <> bghc) : args)
dir
logf
Nothing
execOld = execLogged
"sh"
("./configure" : ("--with-ghc=" <> bghc) : args)
dir
logf
Nothing
if | Just tver <- mtver
, _tvVersion tver >= [vver|8.8.0|] -> execNew
| Nothing <- mtver -> execNew -- need some default for git checkouts where we don't know yet
| otherwise -> execOld
bghc = case bstrap of bghc = case bstrap of
Right g -> Right g Right g -> g
Left bver -> Left ("ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt) Left bver -> "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
throwMaybeM (NotFoundInPATH bver) $ liftIO (searchPath spaths bver)
pure (("GHC", bghcPath) : cEnv)

4
lib/GHCup/HLS.hs
View File

@ -355,7 +355,7 @@ compileHLS :: ( MonadMask m
, NotInstalled , NotInstalled
] m Version ] m Version
compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal updateCabal patches cabalArgs = do compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal updateCabal patches cabalArgs = do
PlatformRequest { .. } <- lift getPlatformReq pfreq@PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
Dirs { .. } <- lift getDirs Dirs { .. } <- lift getDirs
@ -371,7 +371,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
-- download source tarball -- download source tarball
dlInfo <- dlInfo <-
preview (ix HLS % ix (mkTVer tver) % viSourceDL % _Just) dls preview (ix HLS % ix (mkTVer tver) % viSourceDL % _Just) dls
?? NoDownload ?? NoDownload (mkTVer tver) HLS (Just pfreq)
dl <- liftE $ downloadCached dlInfo Nothing dl <- liftE $ downloadCached dlInfo Nothing
-- unpack -- unpack

11
lib/GHCup/List.hs
View File

@ -76,7 +76,6 @@ data ListResult = ListResult
, lTag :: [Tag] , lTag :: [Tag]
, lInstalled :: Bool , lInstalled :: Bool
, lSet :: Bool -- ^ currently active version , lSet :: Bool -- ^ currently active version
, fromSrc :: Bool -- ^ compiled from source
, lStray :: Bool -- ^ not in download info , lStray :: Bool -- ^ not in download info
, lNoBindist :: Bool -- ^ whether the version is available for this platform/arch , lNoBindist :: Bool -- ^ whether the version is available for this platform/arch
, hlsPowered :: Bool , hlsPowered :: Bool
@ -169,7 +168,6 @@ listVersions lt' criteria hideOld showNightly days = do
Just _ -> pure Nothing Just _ -> pure Nothing
Nothing -> do Nothing -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions
pure $ Just $ ListResult pure $ Just $ ListResult
{ lTool = GHC { lTool = GHC
@ -213,7 +211,6 @@ listVersions lt' criteria hideOld showNightly days = do
, lInstalled = True , lInstalled = True
, lStray = isNothing (Map.lookup ver avTools) , lStray = isNothing (Map.lookup ver avTools)
, lNoBindist = False , lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False , hlsPowered = False
, lReleaseDay = Nothing , lReleaseDay = Nothing
, .. , ..
@ -248,7 +245,6 @@ listVersions lt' criteria hideOld showNightly days = do
, lInstalled = True , lInstalled = True
, lStray = isNothing (Map.lookup ver avTools) , lStray = isNothing (Map.lookup ver avTools)
, lNoBindist = False , lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False , hlsPowered = False
, lReleaseDay = Nothing , lReleaseDay = Nothing
, .. , ..
@ -284,7 +280,6 @@ listVersions lt' criteria hideOld showNightly days = do
, lInstalled = True , lInstalled = True
, lStray = isNothing (Map.lookup ver avTools) , lStray = isNothing (Map.lookup ver avTools)
, lNoBindist = False , lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False , hlsPowered = False
, lReleaseDay = Nothing , lReleaseDay = Nothing
, .. , ..
@ -306,7 +301,6 @@ listVersions lt' criteria hideOld showNightly days = do
, 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
, fromSrc = False
, lStray = isNothing listVer , lStray = isNothing listVer
, lSet = True , lSet = True
, lInstalled = True , lInstalled = True
@ -340,7 +334,6 @@ listVersions lt' criteria hideOld showNightly days = do
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo' GHC tver lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo' GHC tver
lSet <- fmap (== Just tver) $ ghcSet (_tvTarget tver) lSet <- fmap (== Just tver) $ ghcSet (_tvTarget tver)
lInstalled <- ghcInstalled tver lInstalled <- ghcInstalled tver
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem tver) (fmap mkTVer <$> hlsGHCVersions) hlsPowered <- fmap (elem tver) (fmap mkTVer <$> hlsGHCVersions)
pure ListResult { lVer = _tvVersion tver , lCross = _tvTarget tver , 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
@ -351,7 +344,6 @@ listVersions lt' criteria hideOld showNightly days = do
, lCross = Nothing , lCross = Nothing
, lTag = _viTags , lTag = _viTags
, lTool = t , lTool = t
, fromSrc = False
, lStray = False , lStray = False
, hlsPowered = False , hlsPowered = False
, lReleaseDay = _viReleaseDay , lReleaseDay = _viReleaseDay
@ -364,7 +356,6 @@ listVersions lt' criteria hideOld showNightly days = do
, lTag = _viTags , lTag = _viTags
, lCross = Nothing , lCross = Nothing
, lTool = t , lTool = t
, fromSrc = False
, lStray = False , lStray = False
, lNoBindist = False , lNoBindist = False
, hlsPowered = False , hlsPowered = False
@ -379,7 +370,6 @@ listVersions lt' criteria hideOld showNightly days = do
, lCross = Nothing , lCross = Nothing
, lTag = _viTags , lTag = _viTags
, lTool = t , lTool = t
, fromSrc = False
, lStray = False , lStray = False
, hlsPowered = False , hlsPowered = False
, lReleaseDay = _viReleaseDay , lReleaseDay = _viReleaseDay
@ -393,7 +383,6 @@ listVersions lt' criteria hideOld showNightly days = do
, lCross = Nothing , lCross = Nothing
, lTag = _viTags , lTag = _viTags
, lTool = t , lTool = t
, fromSrc = False
, lStray = False , lStray = False
, hlsPowered = False , hlsPowered = False
, lReleaseDay = _viReleaseDay , lReleaseDay = _viReleaseDay

7
lib/GHCup/Types.hs
View File

@ -132,6 +132,9 @@ data GlobalTool = ShimGen
instance NFData GlobalTool instance NFData GlobalTool
instance Pretty GlobalTool where
pPrint ShimGen = text "shimgen"
-- | All necessary information of a tool version, including -- | All necessary information of a tool version, including
-- source download and per-architecture downloads. -- source download and per-architecture downloads.
@ -720,4 +723,6 @@ instance Pretty ToolVersion where
data BuildSystem = Hadrian
| Make
deriving (Show, Eq)

14
lib/GHCup/Utils.hs
View File

@ -288,13 +288,6 @@ ghcInstalled ver = do
liftIO $ doesDirectoryExist (fromGHCupPath ghcdir) liftIO $ doesDirectoryExist (fromGHCupPath ghcdir)
-- | Whether the given GHC version is installed from source.
ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
ghcSrcInstalled ver = do
ghcdir <- ghcupGHCDir ver
liftIO $ doesFileExist (fromGHCupPath ghcdir </> ghcUpSrcBuiltFile)
-- | Whether the given GHC version is set as the current. -- | Whether the given GHC version is set as the current.
ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
=> Maybe Text -- ^ the target of the GHC version, if any => Maybe Text -- ^ the target of the GHC version, if any
@ -975,11 +968,6 @@ ghcToolFiles ver = do
isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs
-- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
-- this GHC was built from source. It contains the build config.
ghcUpSrcBuiltFile :: FilePath
ghcUpSrcBuiltFile = ".ghcup_src_built"
-- | Calls gmake if it exists in PATH, otherwise make. -- | Calls gmake if it exists in PATH, otherwise make.
make :: ( MonadThrow m make :: ( MonadThrow m
@ -1224,7 +1212,7 @@ ensureGlobalTools
(GHCupInfo _ _ gTools) <- lift getGHCupInfo (GHCupInfo _ _ gTools) <- lift getGHCupInfo
dirs <- lift getDirs dirs <- lift getDirs
shimDownload <- liftE $ lE @_ @'[NoDownload] shimDownload <- liftE $ lE @_ @'[NoDownload]
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools $ maybe (Left (NoDownload' ShimGen)) Right $ Map.lookup ShimGen gTools
let dl = downloadCached' shimDownload (Just "gs.exe") Nothing let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
void $ (\DigestError{} -> do void $ (\DigestError{} -> do
lift $ logWarn "Digest doesn't match, redownloading gs.exe..." lift $ logWarn "Digest doesn't match, redownloading gs.exe..."

2
scripts/bootstrap/bootstrap-haskell.ps1
View File

@ -459,7 +459,7 @@ if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
Print-Msg -msg 'Processing MSYS2 bash for first time use...' Print-Msg -msg 'Processing MSYS2 bash for first time use...'
Exec "$Bash" '-lc' 'exit' Exec "$Bash" '-lc' 'exit'
Exec "$env:windir\system32\taskkill.exe" /F /FI `"MODULES eq msys-2.0.dll`" Exec "$env:windir\system32\taskkill.exe" /F /FI "MODULES eq msys-2.0.dll"
Print-Msg -msg 'Upgrading full system...' Print-Msg -msg 'Upgrading full system...'
Exec "$Bash" '-lc' 'pacman --noconfirm -Syuu' Exec "$Bash" '-lc' 'pacman --noconfirm -Syuu'