WIP
This commit is contained in:
parent
7f542646dd
commit
e9db8f9895
GPG Key ID:
3786C5262ECB4A3F
@ -182,12 +182,12 @@ variables:
|
|||||||
- export HOMEBREW_CHANGE_ARCH_TO_ARM=1
|
- export HOMEBREW_CHANGE_ARCH_TO_ARM=1
|
||||||
|
|
||||||
# make sure to not pollute the machine with temp files etc
|
# make sure to not pollute the machine with temp files etc
|
||||||
- mkdir -p $CI_PROJECT_DIR/.brew_cache
|
- mkdir -p $CI_PROJECT_DIR/.bc
|
||||||
- export HOMEBREW_CACHE=$CI_PROJECT_DIR/.brew_cache
|
- export HOMEBREW_CACHE=$CI_PROJECT_DIR/.bc
|
||||||
- mkdir -p $CI_PROJECT_DIR/.brew_logs
|
- mkdir -p $CI_PROJECT_DIR/.bl
|
||||||
- export HOMEBREW_LOGS=$CI_PROJECT_DIR/.brew_logs
|
- export HOMEBREW_LOGS=$CI_PROJECT_DIR/.bl
|
||||||
- mkdir -p $CI_PROJECT_DIR/.brew_tmp
|
- mkdir -p $CI_PROJECT_DIR/.bt
|
||||||
- export HOMEBREW_TEMP=$CI_PROJECT_DIR/.brew_tmp
|
- export HOMEBREW_TEMP=$CI_PROJECT_DIR/.bt
|
||||||
|
|
||||||
# update and install packages
|
# update and install packages
|
||||||
- brew update
|
- brew update
|
||||||
@ -541,12 +541,12 @@ release:darwin:aarch64:
|
|||||||
- export HOMEBREW_CHANGE_ARCH_TO_ARM=1
|
- export HOMEBREW_CHANGE_ARCH_TO_ARM=1
|
||||||
|
|
||||||
# make sure to not pollute the machine with temp files etc
|
# make sure to not pollute the machine with temp files etc
|
||||||
- mkdir -p $CI_PROJECT_DIR/.brew_cache
|
- mkdir -p $CI_PROJECT_DIR/.bc
|
||||||
- export HOMEBREW_CACHE=$CI_PROJECT_DIR/.brew_cache
|
- export HOMEBREW_CACHE=$CI_PROJECT_DIR/.bc
|
||||||
- mkdir -p $CI_PROJECT_DIR/.brew_logs
|
- mkdir -p $CI_PROJECT_DIR/.bl
|
||||||
- export HOMEBREW_LOGS=$CI_PROJECT_DIR/.brew_logs
|
- export HOMEBREW_LOGS=$CI_PROJECT_DIR/.bl
|
||||||
- mkdir -p $CI_PROJECT_DIR/.brew_tmp
|
- mkdir -p $CI_PROJECT_DIR/.bt
|
||||||
- export HOMEBREW_TEMP=$CI_PROJECT_DIR/.brew_tmp
|
- export HOMEBREW_TEMP=$CI_PROJECT_DIR/.bt
|
||||||
|
|
||||||
# update and install packages
|
# update and install packages
|
||||||
- brew update
|
- brew update
|
||||||
|
|||||||
@ -12,6 +12,11 @@ constraints: http-io-streams -brotli,
|
|||||||
any.Cabal ==3.6.2.0,
|
any.Cabal ==3.6.2.0,
|
||||||
any.aeson >= 2.0.1.0
|
any.aeson >= 2.0.1.0
|
||||||
|
|
||||||
|
source-repository-package
|
||||||
|
type: git
|
||||||
|
location: https://github.com/input-output-hk/optparse-applicative
|
||||||
|
tag: 7497a29cb998721a9068d5725d49461f2bba0e7a
|
||||||
|
|
||||||
package libarchive
|
package libarchive
|
||||||
flags: -system-libarchive
|
flags: -system-libarchive
|
||||||
|
|
||||||
|
|||||||
10
ghcup.cabal
10
ghcup.cabal
@ -51,6 +51,14 @@ flag no-exe
|
|||||||
library
|
library
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
GHCup
|
GHCup
|
||||||
|
GHCup.Data.Versions
|
||||||
|
GHCup.GHC
|
||||||
|
GHCup.GHC.Rm
|
||||||
|
GHCup.GHC.Unset
|
||||||
|
GHCup.GHC.Set
|
||||||
|
GHCup.GHC.Compile
|
||||||
|
GHCup.GHC.Common
|
||||||
|
GHCup.GHC.Install
|
||||||
GHCup.Download
|
GHCup.Download
|
||||||
GHCup.Download.Common
|
GHCup.Download.Common
|
||||||
GHCup.Errors
|
GHCup.Errors
|
||||||
@ -233,7 +241,7 @@ executable ghcup
|
|||||||
, libarchive ^>=3.0.3.0
|
, libarchive ^>=3.0.3.0
|
||||||
, megaparsec >=8.0.0 && <9.1
|
, megaparsec >=8.0.0 && <9.1
|
||||||
, mtl ^>=2.2
|
, mtl ^>=2.2
|
||||||
, optparse-applicative >=0.15.1.0 && <0.17
|
, optparse-applicative-fork >=0.15.1.0 && <0.17
|
||||||
, pretty ^>=1.1.3.1
|
, pretty ^>=1.1.3.1
|
||||||
, pretty-terminal ^>=0.1.0.0
|
, pretty-terminal ^>=0.1.0.0
|
||||||
, resourcet ^>=1.2.2
|
, resourcet ^>=1.2.2
|
||||||
|
|||||||
937
lib/GHCup.hs
937
lib/GHCup.hs
@ -23,9 +23,14 @@ and so on.
|
|||||||
|
|
||||||
These are the entry points.
|
These are the entry points.
|
||||||
-}
|
-}
|
||||||
module GHCup where
|
module GHCup
|
||||||
|
( module GHCup.GHC
|
||||||
|
, module GHCup
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
|
||||||
|
import GHCup.GHC
|
||||||
import GHCup.Download
|
import GHCup.Download
|
||||||
import GHCup.Errors
|
import GHCup.Errors
|
||||||
import GHCup.Platform
|
import GHCup.Platform
|
||||||
@ -171,242 +176,6 @@ fetchGHCSrc v mfp = do
|
|||||||
-------------------------
|
-------------------------
|
||||||
|
|
||||||
|
|
||||||
-- | Like 'installGHCBin', except takes the 'DownloadInfo' as
|
|
||||||
-- argument instead of looking it up from 'GHCupDownloads'.
|
|
||||||
installGHCBindist :: ( MonadFail m
|
|
||||||
, MonadMask m
|
|
||||||
, MonadCatch m
|
|
||||||
, MonadReader env m
|
|
||||||
, HasDirs env
|
|
||||||
, HasSettings env
|
|
||||||
, HasPlatformReq env
|
|
||||||
, HasLog env
|
|
||||||
, MonadResource m
|
|
||||||
, MonadIO m
|
|
||||||
, MonadUnliftIO m
|
|
||||||
)
|
|
||||||
=> DownloadInfo -- ^ where/how to download
|
|
||||||
-> Version -- ^ the version to install
|
|
||||||
-> Maybe FilePath -- ^ isolated filepath if user passed any
|
|
||||||
-> Bool -- ^ Force install
|
|
||||||
-> Excepts
|
|
||||||
'[ AlreadyInstalled
|
|
||||||
, BuildFailed
|
|
||||||
, DigestError
|
|
||||||
, GPGError
|
|
||||||
, DownloadFailed
|
|
||||||
, NoDownload
|
|
||||||
, NotInstalled
|
|
||||||
, UnknownArchive
|
|
||||||
, TarDirDoesNotExist
|
|
||||||
, DirNotEmpty
|
|
||||||
, ArchiveResult
|
|
||||||
, ProcessError
|
|
||||||
]
|
|
||||||
m
|
|
||||||
()
|
|
||||||
installGHCBindist dlinfo ver isoFilepath forceInstall = do
|
|
||||||
let tver = mkTVer ver
|
|
||||||
|
|
||||||
lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver
|
|
||||||
|
|
||||||
regularGHCInstalled <- lift $ checkIfToolInstalled GHC ver
|
|
||||||
|
|
||||||
if
|
|
||||||
| not forceInstall
|
|
||||||
, regularGHCInstalled
|
|
||||||
, Nothing <- isoFilepath -> do
|
|
||||||
throwE $ AlreadyInstalled GHC ver
|
|
||||||
|
|
||||||
| forceInstall
|
|
||||||
, regularGHCInstalled
|
|
||||||
, Nothing <- isoFilepath -> do
|
|
||||||
lift $ logInfo "Removing the currently installed GHC version first!"
|
|
||||||
liftE $ rmGHCVer tver
|
|
||||||
|
|
||||||
| otherwise -> pure ()
|
|
||||||
|
|
||||||
-- download (or use cached version)
|
|
||||||
dl <- liftE $ downloadCached dlinfo Nothing
|
|
||||||
|
|
||||||
-- prepare paths
|
|
||||||
ghcdir <- lift $ ghcupGHCDir tver
|
|
||||||
|
|
||||||
toolchainSanityChecks
|
|
||||||
|
|
||||||
case isoFilepath of
|
|
||||||
Just isoDir -> do -- isolated install
|
|
||||||
lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir
|
|
||||||
liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver forceInstall
|
|
||||||
Nothing -> do -- regular install
|
|
||||||
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver forceInstall
|
|
||||||
|
|
||||||
-- make symlinks & stuff when regular install,
|
|
||||||
liftE $ postGHCInstall tver
|
|
||||||
|
|
||||||
where
|
|
||||||
toolchainSanityChecks = do
|
|
||||||
r <- forM ["CC", "LD"] (liftIO . lookupEnv)
|
|
||||||
case catMaybes r of
|
|
||||||
[] -> pure ()
|
|
||||||
_ -> do
|
|
||||||
lift $ logWarn $ "CC/LD environment variable is set. This will change the compiler/linker"
|
|
||||||
<> "\n" <> "GHC uses internally and can cause defunct GHC in some cases (e.g. in Anaconda"
|
|
||||||
<> "\n" <> "environments). If you encounter problems, unset CC and LD and reinstall."
|
|
||||||
|
|
||||||
|
|
||||||
-- | Install a packed GHC distribution. This only deals with unpacking and the GHC
|
|
||||||
-- build system and nothing else.
|
|
||||||
installPackedGHC :: ( MonadMask m
|
|
||||||
, MonadCatch m
|
|
||||||
, MonadReader env m
|
|
||||||
, HasDirs env
|
|
||||||
, HasPlatformReq env
|
|
||||||
, HasSettings env
|
|
||||||
, MonadThrow m
|
|
||||||
, HasLog env
|
|
||||||
, MonadIO m
|
|
||||||
, MonadUnliftIO m
|
|
||||||
, MonadFail m
|
|
||||||
)
|
|
||||||
=> FilePath -- ^ Path to the packed GHC bindist
|
|
||||||
-> Maybe TarDir -- ^ Subdir of the archive
|
|
||||||
-> FilePath -- ^ Path to install to
|
|
||||||
-> Version -- ^ The GHC version
|
|
||||||
-> Bool -- ^ Force install
|
|
||||||
-> Excepts
|
|
||||||
'[ BuildFailed
|
|
||||||
, UnknownArchive
|
|
||||||
, TarDirDoesNotExist
|
|
||||||
, DirNotEmpty
|
|
||||||
, ArchiveResult
|
|
||||||
, ProcessError
|
|
||||||
] m ()
|
|
||||||
installPackedGHC dl msubdir inst ver forceInstall = do
|
|
||||||
PlatformRequest {..} <- lift getPlatformReq
|
|
||||||
|
|
||||||
unless forceInstall
|
|
||||||
(liftE $ installDestSanityCheck inst)
|
|
||||||
|
|
||||||
-- unpack
|
|
||||||
tmpUnpack <- lift mkGhcupTmpDir
|
|
||||||
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
|
|
||||||
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
|
|
||||||
|
|
||||||
-- the subdir of the archive where we do the work
|
|
||||||
workdir <- maybe (pure tmpUnpack)
|
|
||||||
(liftE . intoSubdir tmpUnpack)
|
|
||||||
msubdir
|
|
||||||
|
|
||||||
liftE $ runBuildAction tmpUnpack
|
|
||||||
(Just inst)
|
|
||||||
(installUnpackedGHC workdir inst ver)
|
|
||||||
where
|
|
||||||
-- | Does basic checks for isolated installs
|
|
||||||
-- Isolated Directory:
|
|
||||||
-- 1. if it doesn't exist -> proceed
|
|
||||||
-- 2. if it exists and is empty -> proceed
|
|
||||||
-- 3. if it exists and is non-empty -> panic and leave the house
|
|
||||||
installDestSanityCheck :: ( MonadIO m
|
|
||||||
, MonadCatch m
|
|
||||||
) =>
|
|
||||||
FilePath ->
|
|
||||||
Excepts '[DirNotEmpty] m ()
|
|
||||||
installDestSanityCheck isoDir = do
|
|
||||||
hideErrorDef [doesNotExistErrorType] () $ do
|
|
||||||
contents <- liftIO $ getDirectoryContentsRecursive isoDir
|
|
||||||
unless (null contents) (throwE $ DirNotEmpty isoDir)
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- | Install an unpacked GHC distribution. This only deals with the GHC
|
|
||||||
-- build system and nothing else.
|
|
||||||
installUnpackedGHC :: ( MonadReader env m
|
|
||||||
, HasPlatformReq env
|
|
||||||
, HasDirs env
|
|
||||||
, HasSettings env
|
|
||||||
, MonadThrow m
|
|
||||||
, HasLog env
|
|
||||||
, MonadIO m
|
|
||||||
, MonadUnliftIO m
|
|
||||||
, MonadMask m
|
|
||||||
)
|
|
||||||
=> FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides)
|
|
||||||
-> FilePath -- ^ Path to install to
|
|
||||||
-> Version -- ^ The GHC version
|
|
||||||
-> Excepts '[ProcessError] m ()
|
|
||||||
installUnpackedGHC path inst ver
|
|
||||||
| isWindows = do
|
|
||||||
lift $ logInfo "Installing GHC (this may take a while)"
|
|
||||||
-- Windows bindists are relocatable and don't need
|
|
||||||
-- to run configure.
|
|
||||||
-- We also must make sure to preserve mtime to not confuse ghc-pkg.
|
|
||||||
lift $ withRunInIO $ \run -> flip onException (run $ recyclePathForcibly inst) $ copyDirectoryRecursive path inst $ \source dest -> do
|
|
||||||
mtime <- getModificationTime source
|
|
||||||
moveFilePortable source dest
|
|
||||||
setModificationTime dest mtime
|
|
||||||
| otherwise = do
|
|
||||||
PlatformRequest {..} <- lift getPlatformReq
|
|
||||||
|
|
||||||
let alpineArgs
|
|
||||||
| ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
|
|
||||||
= ["--disable-ld-override"]
|
|
||||||
| otherwise
|
|
||||||
= []
|
|
||||||
|
|
||||||
lift $ logInfo "Installing GHC (this may take a while)"
|
|
||||||
lEM $ execLogged "sh"
|
|
||||||
("./configure" : ("--prefix=" <> inst)
|
|
||||||
: alpineArgs
|
|
||||||
)
|
|
||||||
(Just path)
|
|
||||||
"ghc-configure"
|
|
||||||
Nothing
|
|
||||||
lEM $ make ["install"] (Just path)
|
|
||||||
pure ()
|
|
||||||
|
|
||||||
|
|
||||||
-- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
|
|
||||||
-- following symlinks in @~\/.ghcup\/bin@:
|
|
||||||
--
|
|
||||||
-- * @ghc-x.y.z -> ..\/ghc\/x.y.z\/bin/ghc@
|
|
||||||
-- * @ghc-x.y -> ..\/ghc\/x.y.z\/bin/ghc@ (if x.y.z is the latest x.y version)
|
|
||||||
installGHCBin :: ( MonadFail m
|
|
||||||
, MonadMask m
|
|
||||||
, MonadCatch m
|
|
||||||
, MonadReader env m
|
|
||||||
, HasPlatformReq env
|
|
||||||
, HasGHCupInfo env
|
|
||||||
, HasDirs env
|
|
||||||
, HasSettings env
|
|
||||||
, HasLog env
|
|
||||||
, MonadResource m
|
|
||||||
, MonadIO m
|
|
||||||
, MonadUnliftIO m
|
|
||||||
)
|
|
||||||
=> Version -- ^ the version to install
|
|
||||||
-> Maybe FilePath -- ^ isolated install filepath, if user passed any
|
|
||||||
-> Bool -- ^ force install
|
|
||||||
-> Excepts
|
|
||||||
'[ AlreadyInstalled
|
|
||||||
, BuildFailed
|
|
||||||
, DigestError
|
|
||||||
, GPGError
|
|
||||||
, DownloadFailed
|
|
||||||
, NoDownload
|
|
||||||
, NotInstalled
|
|
||||||
, UnknownArchive
|
|
||||||
, TarDirDoesNotExist
|
|
||||||
, DirNotEmpty
|
|
||||||
, ArchiveResult
|
|
||||||
, ProcessError
|
|
||||||
]
|
|
||||||
m
|
|
||||||
()
|
|
||||||
installGHCBin ver isoFilepath forceInstall = do
|
|
||||||
dlinfo <- liftE $ getDownloadInfo GHC ver
|
|
||||||
liftE $ installGHCBindist dlinfo ver isoFilepath forceInstall
|
|
||||||
|
|
||||||
|
|
||||||
-- | Like 'installCabalBin', except takes the 'DownloadInfo' as
|
-- | Like 'installCabalBin', except takes the 'DownloadInfo' as
|
||||||
-- argument instead of looking it up from 'GHCupDownloads'.
|
-- argument instead of looking it up from 'GHCupDownloads'.
|
||||||
@ -1049,124 +818,6 @@ installStackUnpacked path inst mver' forceInstall = do
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- | Set GHC symlinks in @~\/.ghcup\/bin@ for the requested GHC version. The behavior depends
|
|
||||||
-- on `SetGHC`:
|
|
||||||
--
|
|
||||||
-- * SetGHCOnly: @~\/.ghcup\/bin\/ghc -> ~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@
|
|
||||||
-- * SetGHC_XY: @~\/.ghcup\/bin\/ghc-X.Y -> ~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@
|
|
||||||
-- * SetGHC_XYZ: @~\/.ghcup\/bin\/ghc-\<ver\> -> ~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@
|
|
||||||
--
|
|
||||||
-- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@
|
|
||||||
-- for 'SetGHCOnly' constructor.
|
|
||||||
setGHC :: ( MonadReader env m
|
|
||||||
, HasDirs env
|
|
||||||
, HasLog env
|
|
||||||
, MonadThrow m
|
|
||||||
, MonadFail m
|
|
||||||
, MonadIO m
|
|
||||||
, MonadCatch m
|
|
||||||
, MonadMask m
|
|
||||||
, MonadUnliftIO m
|
|
||||||
)
|
|
||||||
=> GHCTargetVersion
|
|
||||||
-> SetGHC
|
|
||||||
-> Excepts '[NotInstalled] m GHCTargetVersion
|
|
||||||
setGHC ver sghc = do
|
|
||||||
let verS = T.unpack $ prettyVer (_tvVersion ver)
|
|
||||||
ghcdir <- lift $ ghcupGHCDir ver
|
|
||||||
|
|
||||||
whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver))
|
|
||||||
|
|
||||||
-- symlink destination
|
|
||||||
Dirs {..} <- lift getDirs
|
|
||||||
|
|
||||||
-- first delete the old symlinks (this fixes compatibility issues
|
|
||||||
-- with old ghcup)
|
|
||||||
case sghc of
|
|
||||||
SetGHCOnly -> liftE $ rmPlain (_tvTarget ver)
|
|
||||||
SetGHC_XY -> liftE $ rmMajorSymlinks ver
|
|
||||||
SetGHC_XYZ -> liftE $ rmMinorSymlinks ver
|
|
||||||
|
|
||||||
-- for ghc tools (ghc, ghci, haddock, ...)
|
|
||||||
verfiles <- ghcToolFiles ver
|
|
||||||
forM_ verfiles $ \file -> do
|
|
||||||
mTargetFile <- case sghc of
|
|
||||||
SetGHCOnly -> pure $ Just file
|
|
||||||
SetGHC_XY -> do
|
|
||||||
handle
|
|
||||||
(\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
|
|
||||||
$ do
|
|
||||||
(mj, mi) <- getMajorMinorV (_tvVersion ver)
|
|
||||||
let major' = intToText mj <> "." <> intToText mi
|
|
||||||
pure $ Just (file <> "-" <> T.unpack major')
|
|
||||||
SetGHC_XYZ ->
|
|
||||||
pure $ Just (file <> "-" <> verS)
|
|
||||||
|
|
||||||
-- create symlink
|
|
||||||
forM mTargetFile $ \targetFile -> do
|
|
||||||
let fullF = binDir </> targetFile <> exeExt
|
|
||||||
fileWithExt = file <> exeExt
|
|
||||||
destL <- lift $ ghcLinkDestination fileWithExt ver
|
|
||||||
lift $ createLink destL fullF
|
|
||||||
|
|
||||||
-- create symlink for share dir
|
|
||||||
when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verS
|
|
||||||
|
|
||||||
when (sghc == SetGHCOnly) $ lift warnAboutHlsCompatibility
|
|
||||||
|
|
||||||
pure ver
|
|
||||||
|
|
||||||
where
|
|
||||||
|
|
||||||
symlinkShareDir :: ( MonadReader env m
|
|
||||||
, HasDirs env
|
|
||||||
, MonadIO m
|
|
||||||
, HasLog env
|
|
||||||
, MonadCatch m
|
|
||||||
, MonadMask m
|
|
||||||
)
|
|
||||||
=> FilePath
|
|
||||||
-> String
|
|
||||||
-> m ()
|
|
||||||
symlinkShareDir ghcdir ver' = do
|
|
||||||
Dirs {..} <- getDirs
|
|
||||||
let destdir = baseDir
|
|
||||||
case sghc of
|
|
||||||
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
|
|
||||||
logDebug $ "rm -f " <> T.pack fullF
|
|
||||||
hideError doesNotExistErrorType $ rmDirectoryLink fullF
|
|
||||||
logDebug $ "ln -s " <> T.pack targetF <> " " <> T.pack fullF
|
|
||||||
|
|
||||||
if isWindows
|
|
||||||
then liftIO
|
|
||||||
-- On windows we need to be more permissive
|
|
||||||
-- in case symlinks can't be created, be just
|
|
||||||
-- give up here. This symlink isn't strictly necessary.
|
|
||||||
$ hideError permissionErrorType
|
|
||||||
$ hideError illegalOperationErrorType
|
|
||||||
$ createDirectoryLink targetF fullF
|
|
||||||
else liftIO
|
|
||||||
$ createDirectoryLink targetF fullF
|
|
||||||
_ -> pure ()
|
|
||||||
|
|
||||||
unsetGHC :: ( MonadReader env m
|
|
||||||
, HasDirs env
|
|
||||||
, HasLog env
|
|
||||||
, MonadThrow m
|
|
||||||
, MonadFail m
|
|
||||||
, MonadIO m
|
|
||||||
, MonadMask m
|
|
||||||
)
|
|
||||||
=> Maybe Text
|
|
||||||
-> Excepts '[NotInstalled] m ()
|
|
||||||
unsetGHC = rmPlain
|
|
||||||
|
|
||||||
|
|
||||||
-- | Set the @~\/.ghcup\/bin\/cabal@ symlink.
|
-- | Set the @~\/.ghcup\/bin\/cabal@ symlink.
|
||||||
setCabal :: ( MonadMask m
|
setCabal :: ( MonadMask m
|
||||||
@ -1303,31 +954,6 @@ unsetStack = do
|
|||||||
hideError doesNotExistErrorType $ rmLink stackbin
|
hideError doesNotExistErrorType $ rmLink stackbin
|
||||||
|
|
||||||
|
|
||||||
-- | Warn if the installed and set HLS is not compatible with the installed and
|
|
||||||
-- set GHC version.
|
|
||||||
warnAboutHlsCompatibility :: ( MonadReader env m
|
|
||||||
, HasDirs env
|
|
||||||
, HasLog env
|
|
||||||
, MonadThrow m
|
|
||||||
, MonadCatch m
|
|
||||||
, MonadIO m
|
|
||||||
)
|
|
||||||
=> m ()
|
|
||||||
warnAboutHlsCompatibility = do
|
|
||||||
supportedGHC <- hlsGHCVersions
|
|
||||||
currentGHC <- fmap _tvVersion <$> ghcSet Nothing
|
|
||||||
currentHLS <- hlsSet
|
|
||||||
|
|
||||||
case (currentGHC, currentHLS) of
|
|
||||||
(Just gv, Just hv) | gv `notElem` supportedGHC -> do
|
|
||||||
logWarn $
|
|
||||||
"GHC " <> T.pack (prettyShow gv) <> " is not compatible with " <>
|
|
||||||
"Haskell Language Server " <> T.pack (prettyShow hv) <> "." <> "\n" <>
|
|
||||||
"Haskell IDE support may not work until this is fixed." <> "\n" <>
|
|
||||||
"Install a different HLS version, or install and set one of the following GHCs:" <> "\n" <>
|
|
||||||
T.pack (prettyShow supportedGHC)
|
|
||||||
|
|
||||||
_ -> return ()
|
|
||||||
|
|
||||||
------------------
|
------------------
|
||||||
--[ List tools ]--
|
--[ List tools ]--
|
||||||
@ -1689,56 +1315,6 @@ listVersions lt' criteria = do
|
|||||||
--------------------
|
--------------------
|
||||||
|
|
||||||
|
|
||||||
-- | Delete a ghc version and all its symlinks.
|
|
||||||
--
|
|
||||||
-- This may leave GHCup without a "set" version.
|
|
||||||
-- Will try to fix the ghc-x.y symlink after removal (e.g. to an
|
|
||||||
-- older version).
|
|
||||||
rmGHCVer :: ( MonadReader env m
|
|
||||||
, HasDirs env
|
|
||||||
, MonadThrow m
|
|
||||||
, HasLog env
|
|
||||||
, MonadIO m
|
|
||||||
, MonadFail m
|
|
||||||
, MonadCatch m
|
|
||||||
, MonadMask m
|
|
||||||
, MonadUnliftIO m
|
|
||||||
)
|
|
||||||
=> GHCTargetVersion
|
|
||||||
-> Excepts '[NotInstalled] m ()
|
|
||||||
rmGHCVer ver = do
|
|
||||||
isSetGHC <- lift $ fmap (== Just ver) $ ghcSet (_tvTarget ver)
|
|
||||||
|
|
||||||
whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC ver))
|
|
||||||
dir <- lift $ ghcupGHCDir ver
|
|
||||||
|
|
||||||
-- this isn't atomic, order matters
|
|
||||||
when isSetGHC $ do
|
|
||||||
lift $ logInfo "Removing ghc symlinks"
|
|
||||||
liftE $ rmPlain (_tvTarget ver)
|
|
||||||
|
|
||||||
lift $ logInfo "Removing ghc-x.y.z symlinks"
|
|
||||||
liftE $ rmMinorSymlinks ver
|
|
||||||
|
|
||||||
lift $ logInfo "Removing/rewiring ghc-x.y symlinks"
|
|
||||||
-- first remove
|
|
||||||
handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorSymlinks ver
|
|
||||||
-- then fix them (e.g. with an earlier version)
|
|
||||||
|
|
||||||
lift $ logInfo $ "Removing directory recursively: " <> T.pack dir
|
|
||||||
lift $ recyclePathForcibly dir
|
|
||||||
|
|
||||||
v' <-
|
|
||||||
handle
|
|
||||||
(\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
|
|
||||||
$ fmap Just
|
|
||||||
$ getMajorMinorV (_tvVersion ver)
|
|
||||||
forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) (_tvTarget ver))
|
|
||||||
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
|
|
||||||
|
|
||||||
Dirs {..} <- lift getDirs
|
|
||||||
|
|
||||||
lift $ hideError doesNotExistErrorType $ rmDirectoryLink (baseDir </> "share")
|
|
||||||
|
|
||||||
|
|
||||||
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
|
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
|
||||||
@ -2066,476 +1642,6 @@ getDebugInfo = do
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
---------------
|
|
||||||
--[ Compile ]--
|
|
||||||
---------------
|
|
||||||
|
|
||||||
|
|
||||||
-- | Compile a GHC from source. This behaves wrt symlinks and installation
|
|
||||||
-- the same as 'installGHCBin'.
|
|
||||||
compileGHC :: ( MonadMask m
|
|
||||||
, MonadReader env m
|
|
||||||
, HasDirs env
|
|
||||||
, HasPlatformReq env
|
|
||||||
, HasGHCupInfo env
|
|
||||||
, HasSettings env
|
|
||||||
, MonadThrow m
|
|
||||||
, MonadResource m
|
|
||||||
, HasLog env
|
|
||||||
, MonadIO m
|
|
||||||
, MonadUnliftIO m
|
|
||||||
, MonadFail m
|
|
||||||
)
|
|
||||||
=> Either GHCTargetVersion GitBranch -- ^ version to install
|
|
||||||
-> Maybe Version -- ^ overwrite version
|
|
||||||
-> Either Version FilePath -- ^ version to bootstrap with
|
|
||||||
-> Maybe Int -- ^ jobs
|
|
||||||
-> Maybe FilePath -- ^ build config
|
|
||||||
-> Maybe FilePath -- ^ patch directory
|
|
||||||
-> [Text] -- ^ additional args to ./configure
|
|
||||||
-> Maybe String -- ^ build flavour
|
|
||||||
-> Bool
|
|
||||||
-> Maybe FilePath -- ^ isolate dir
|
|
||||||
-> Excepts
|
|
||||||
'[ AlreadyInstalled
|
|
||||||
, BuildFailed
|
|
||||||
, DigestError
|
|
||||||
, GPGError
|
|
||||||
, DownloadFailed
|
|
||||||
, GHCupSetError
|
|
||||||
, NoDownload
|
|
||||||
, NotFoundInPATH
|
|
||||||
, PatchFailed
|
|
||||||
, UnknownArchive
|
|
||||||
, TarDirDoesNotExist
|
|
||||||
, NotInstalled
|
|
||||||
, DirNotEmpty
|
|
||||||
, ArchiveResult
|
|
||||||
, FileDoesNotExistError
|
|
||||||
, HadrianNotFound
|
|
||||||
, InvalidBuildConfig
|
|
||||||
, ProcessError
|
|
||||||
, CopyError
|
|
||||||
, BuildFailed
|
|
||||||
]
|
|
||||||
m
|
|
||||||
GHCTargetVersion
|
|
||||||
compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour hadrian isolateDir
|
|
||||||
= do
|
|
||||||
PlatformRequest { .. } <- lift getPlatformReq
|
|
||||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
|
||||||
|
|
||||||
(workdir, tmpUnpack, tver) <- case targetGhc of
|
|
||||||
-- unpack from version tarball
|
|
||||||
Left tver -> do
|
|
||||||
lift $ logDebug $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap
|
|
||||||
|
|
||||||
-- download source tarball
|
|
||||||
dlInfo <-
|
|
||||||
preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls
|
|
||||||
?? NoDownload
|
|
||||||
dl <- liftE $ downloadCached dlInfo Nothing
|
|
||||||
|
|
||||||
-- unpack
|
|
||||||
tmpUnpack <- lift mkGhcupTmpDir
|
|
||||||
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
|
|
||||||
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
|
|
||||||
|
|
||||||
workdir <- maybe (pure tmpUnpack)
|
|
||||||
(liftE . intoSubdir tmpUnpack)
|
|
||||||
(view dlSubdir dlInfo)
|
|
||||||
forM_ patchdir (\dir -> liftE $ applyPatches dir workdir)
|
|
||||||
|
|
||||||
pure (workdir, tmpUnpack, tver)
|
|
||||||
|
|
||||||
-- clone from git
|
|
||||||
Right GitBranch{..} -> do
|
|
||||||
tmpUnpack <- lift mkGhcupTmpDir
|
|
||||||
let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing
|
|
||||||
tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH] DownloadFailed $ do
|
|
||||||
let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo
|
|
||||||
lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
|
|
||||||
lEM $ git [ "init" ]
|
|
||||||
lEM $ git [ "remote"
|
|
||||||
, "add"
|
|
||||||
, "origin"
|
|
||||||
, fromString rep ]
|
|
||||||
|
|
||||||
let fetch_args =
|
|
||||||
[ "fetch"
|
|
||||||
, "--depth"
|
|
||||||
, "1"
|
|
||||||
, "--quiet"
|
|
||||||
, "origin"
|
|
||||||
, fromString ref ]
|
|
||||||
lEM $ git fetch_args
|
|
||||||
|
|
||||||
lEM $ git [ "checkout", "FETCH_HEAD" ]
|
|
||||||
lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
|
|
||||||
forM_ patchdir (\dir -> liftE $ applyPatches dir tmpUnpack)
|
|
||||||
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
|
|
||||||
ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe' $ _stdOut
|
|
||||||
ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr))
|
|
||||||
|
|
||||||
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
|
|
||||||
lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to GHC version " <> prettyVer tver
|
|
||||||
|
|
||||||
pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver)
|
|
||||||
-- the version that's installed may differ from the
|
|
||||||
-- compiled version, so the user can overwrite it
|
|
||||||
let installVer = maybe tver (\ov' -> tver { _tvVersion = ov' }) ov
|
|
||||||
|
|
||||||
alreadyInstalled <- lift $ ghcInstalled installVer
|
|
||||||
alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer)
|
|
||||||
|
|
||||||
when alreadyInstalled $ do
|
|
||||||
case isolateDir of
|
|
||||||
Just isoDir ->
|
|
||||||
lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Isolate installing to " <> T.pack isoDir
|
|
||||||
Nothing ->
|
|
||||||
lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Will overwrite existing version."
|
|
||||||
lift $ logWarn
|
|
||||||
"...waiting for 10 seconds before continuing, you can still abort..."
|
|
||||||
liftIO $ threadDelay 10000000 -- give the user a sec to intervene
|
|
||||||
|
|
||||||
ghcdir <- case isolateDir of
|
|
||||||
Just isoDir -> pure isoDir
|
|
||||||
Nothing -> lift $ ghcupGHCDir installVer
|
|
||||||
|
|
||||||
(mBindist, bmk) <- liftE $ runBuildAction
|
|
||||||
tmpUnpack
|
|
||||||
Nothing
|
|
||||||
(do
|
|
||||||
b <- if hadrian
|
|
||||||
then compileHadrianBindist tver workdir ghcdir
|
|
||||||
else compileMakeBindist tver workdir ghcdir
|
|
||||||
bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk workdir)
|
|
||||||
pure (b, bmk)
|
|
||||||
)
|
|
||||||
|
|
||||||
case isolateDir of
|
|
||||||
Nothing ->
|
|
||||||
-- only remove old ghc in regular installs
|
|
||||||
when alreadyInstalled $ do
|
|
||||||
lift $ logInfo "Deleting existing installation"
|
|
||||||
liftE $ rmGHCVer installVer
|
|
||||||
|
|
||||||
_ -> pure ()
|
|
||||||
|
|
||||||
forM_ mBindist $ \bindist -> do
|
|
||||||
liftE $ installPackedGHC bindist
|
|
||||||
(Just $ RegexDir "ghc-.*")
|
|
||||||
ghcdir
|
|
||||||
(installVer ^. tvVersion)
|
|
||||||
False -- not a force install, since we already overwrite when compiling.
|
|
||||||
|
|
||||||
liftIO $ B.writeFile (ghcdir </> ghcUpSrcBuiltFile) bmk
|
|
||||||
|
|
||||||
case isolateDir of
|
|
||||||
-- set and make symlinks for regular (non-isolated) installs
|
|
||||||
Nothing -> do
|
|
||||||
reThrowAll GHCupSetError $ postGHCInstall installVer
|
|
||||||
-- restore
|
|
||||||
when alreadySet $ liftE $ void $ setGHC installVer SetGHCOnly
|
|
||||||
|
|
||||||
_ -> pure ()
|
|
||||||
|
|
||||||
pure installVer
|
|
||||||
|
|
||||||
where
|
|
||||||
defaultConf =
|
|
||||||
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")))
|
|
||||||
in case targetGhc of
|
|
||||||
Left (GHCTargetVersion (Just _) _) -> cross_mk
|
|
||||||
_ -> default_mk
|
|
||||||
|
|
||||||
compileHadrianBindist :: ( MonadReader env m
|
|
||||||
, HasDirs env
|
|
||||||
, HasSettings env
|
|
||||||
, HasPlatformReq env
|
|
||||||
, MonadThrow m
|
|
||||||
, MonadCatch m
|
|
||||||
, HasLog env
|
|
||||||
, MonadIO m
|
|
||||||
, MonadFail m
|
|
||||||
)
|
|
||||||
=> GHCTargetVersion
|
|
||||||
-> FilePath
|
|
||||||
-> FilePath
|
|
||||||
-> Excepts
|
|
||||||
'[ FileDoesNotExistError
|
|
||||||
, HadrianNotFound
|
|
||||||
, InvalidBuildConfig
|
|
||||||
, PatchFailed
|
|
||||||
, ProcessError
|
|
||||||
, NotFoundInPATH
|
|
||||||
, CopyError]
|
|
||||||
m
|
|
||||||
(Maybe FilePath) -- ^ output path of bindist, None for cross
|
|
||||||
compileHadrianBindist tver workdir ghcdir = do
|
|
||||||
lEM $ execWithGhcEnv "python3" ["./boot"] (Just workdir) "ghc-bootstrap"
|
|
||||||
|
|
||||||
liftE $ configureBindist tver workdir ghcdir
|
|
||||||
|
|
||||||
lift $ logInfo "Building (this may take a while)..."
|
|
||||||
hadrian_build <- liftE $ findHadrianFile workdir
|
|
||||||
lEM $ execWithGhcEnv hadrian_build
|
|
||||||
( maybe [] (\j -> ["-j" <> show j] ) jobs
|
|
||||||
++ maybe [] (\bf -> ["--flavour=" <> bf]) buildFlavour
|
|
||||||
++ ["binary-dist"]
|
|
||||||
)
|
|
||||||
(Just workdir) "ghc-make"
|
|
||||||
[tar] <- liftIO $ findFiles
|
|
||||||
(workdir </> "_build" </> "bindist")
|
|
||||||
(makeRegexOpts compExtended
|
|
||||||
execBlank
|
|
||||||
([s|^ghc-.*\.tar\..*$|] :: ByteString)
|
|
||||||
)
|
|
||||||
liftE $ fmap Just $ copyBindist tver tar (workdir </> "_build" </> "bindist")
|
|
||||||
|
|
||||||
findHadrianFile :: (MonadIO m)
|
|
||||||
=> FilePath
|
|
||||||
-> Excepts
|
|
||||||
'[HadrianNotFound]
|
|
||||||
m
|
|
||||||
FilePath
|
|
||||||
findHadrianFile workdir = do
|
|
||||||
let possible_files = if isWindows
|
|
||||||
then ((workdir </> "hadrian") </>) <$> ["build.bat"]
|
|
||||||
else ((workdir </> "hadrian") </>) <$> ["build", "build.sh"]
|
|
||||||
exsists <- forM possible_files (\f -> liftIO (doesFileExist f) <&> (,f))
|
|
||||||
case filter fst exsists of
|
|
||||||
[] -> throwE HadrianNotFound
|
|
||||||
((_, x):_) -> pure x
|
|
||||||
|
|
||||||
compileMakeBindist :: ( MonadReader env m
|
|
||||||
, HasDirs env
|
|
||||||
, HasSettings env
|
|
||||||
, HasPlatformReq env
|
|
||||||
, MonadThrow m
|
|
||||||
, MonadCatch m
|
|
||||||
, HasLog env
|
|
||||||
, MonadIO m
|
|
||||||
, MonadFail m
|
|
||||||
)
|
|
||||||
=> GHCTargetVersion
|
|
||||||
-> FilePath
|
|
||||||
-> FilePath
|
|
||||||
-> Excepts
|
|
||||||
'[ FileDoesNotExistError
|
|
||||||
, HadrianNotFound
|
|
||||||
, InvalidBuildConfig
|
|
||||||
, PatchFailed
|
|
||||||
, ProcessError
|
|
||||||
, NotFoundInPATH
|
|
||||||
, CopyError]
|
|
||||||
m
|
|
||||||
(Maybe FilePath) -- ^ output path of bindist, None for cross
|
|
||||||
compileMakeBindist tver workdir ghcdir = do
|
|
||||||
liftE $ configureBindist tver workdir ghcdir
|
|
||||||
|
|
||||||
case mbuildConfig of
|
|
||||||
Just bc -> liftIOException
|
|
||||||
doesNotExistErrorType
|
|
||||||
(FileDoesNotExistError bc)
|
|
||||||
(liftIO $ copyFile bc (build_mk workdir))
|
|
||||||
Nothing ->
|
|
||||||
liftIO $ T.writeFile (build_mk workdir) (addBuildFlavourToConf defaultConf)
|
|
||||||
|
|
||||||
liftE $ checkBuildConfig (build_mk workdir)
|
|
||||||
|
|
||||||
lift $ logInfo "Building (this may take a while)..."
|
|
||||||
lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
|
|
||||||
|
|
||||||
if | isCross tver -> do
|
|
||||||
lift $ logInfo "Installing cross toolchain..."
|
|
||||||
lEM $ make ["install"] (Just workdir)
|
|
||||||
pure Nothing
|
|
||||||
| otherwise -> do
|
|
||||||
lift $ logInfo "Creating bindist..."
|
|
||||||
lEM $ make ["binary-dist"] (Just workdir)
|
|
||||||
[tar] <- liftIO $ findFiles
|
|
||||||
workdir
|
|
||||||
(makeRegexOpts compExtended
|
|
||||||
execBlank
|
|
||||||
([s|^ghc-.*\.tar\..*$|] :: ByteString)
|
|
||||||
)
|
|
||||||
liftE $ fmap Just $ copyBindist tver tar workdir
|
|
||||||
|
|
||||||
build_mk workdir = workdir </> "mk" </> "build.mk"
|
|
||||||
|
|
||||||
copyBindist :: ( MonadReader env m
|
|
||||||
, HasDirs env
|
|
||||||
, HasSettings env
|
|
||||||
, HasPlatformReq env
|
|
||||||
, MonadIO m
|
|
||||||
, MonadThrow m
|
|
||||||
, MonadCatch m
|
|
||||||
, HasLog env
|
|
||||||
)
|
|
||||||
=> GHCTargetVersion
|
|
||||||
-> FilePath -- ^ tar file
|
|
||||||
-> FilePath -- ^ workdir
|
|
||||||
-> Excepts
|
|
||||||
'[CopyError]
|
|
||||||
m
|
|
||||||
FilePath
|
|
||||||
copyBindist tver tar workdir = do
|
|
||||||
Dirs {..} <- lift getDirs
|
|
||||||
pfreq <- lift getPlatformReq
|
|
||||||
c <- liftIO $ BL.readFile (workdir </> tar)
|
|
||||||
cDigest <-
|
|
||||||
fmap (T.take 8)
|
|
||||||
. lift
|
|
||||||
. throwEither
|
|
||||||
. E.decodeUtf8'
|
|
||||||
. B16.encode
|
|
||||||
. SHA256.hashlazy
|
|
||||||
$ c
|
|
||||||
cTime <- liftIO getCurrentTime
|
|
||||||
let tarName = makeValid ("ghc-"
|
|
||||||
<> T.unpack (tVerToText tver)
|
|
||||||
<> "-"
|
|
||||||
<> pfReqToString pfreq
|
|
||||||
<> "-"
|
|
||||||
<> iso8601Show cTime
|
|
||||||
<> "-"
|
|
||||||
<> T.unpack cDigest
|
|
||||||
<> ".tar"
|
|
||||||
<> takeExtension tar)
|
|
||||||
let tarPath = cacheDir </> tarName
|
|
||||||
copyFileE (workdir </> tar)
|
|
||||||
tarPath
|
|
||||||
lift $ logInfo $ "Copied bindist to " <> T.pack tarPath
|
|
||||||
pure tarPath
|
|
||||||
|
|
||||||
checkBuildConfig :: (MonadReader env m, MonadCatch m, MonadIO m, HasLog env)
|
|
||||||
=> FilePath
|
|
||||||
-> Excepts
|
|
||||||
'[FileDoesNotExistError, InvalidBuildConfig]
|
|
||||||
m
|
|
||||||
()
|
|
||||||
checkBuildConfig bc = do
|
|
||||||
c <- liftIOException
|
|
||||||
doesNotExistErrorType
|
|
||||||
(FileDoesNotExistError bc)
|
|
||||||
(liftIO $ B.readFile bc)
|
|
||||||
let lines' = fmap T.strip . T.lines $ decUTF8Safe c
|
|
||||||
|
|
||||||
-- for cross, we need Stage1Only
|
|
||||||
case targetGhc of
|
|
||||||
Left (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE
|
|
||||||
(InvalidBuildConfig
|
|
||||||
[s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|]
|
|
||||||
)
|
|
||||||
_ -> pure ()
|
|
||||||
|
|
||||||
forM_ buildFlavour $ \bf ->
|
|
||||||
when (T.pack ("BuildFlavour = " <> bf) `notElem` lines') $ do
|
|
||||||
lift $ logWarn $ "Customly specified build config overwrites --flavour=" <> T.pack bf <> " switch! Waiting 5 seconds..."
|
|
||||||
liftIO $ threadDelay 5000000
|
|
||||||
|
|
||||||
addBuildFlavourToConf bc = case buildFlavour of
|
|
||||||
Just bf -> "BuildFlavour = " <> T.pack bf <> "\n" <> bc
|
|
||||||
Nothing -> bc
|
|
||||||
|
|
||||||
isCross :: GHCTargetVersion -> Bool
|
|
||||||
isCross = isJust . _tvTarget
|
|
||||||
|
|
||||||
|
|
||||||
configureBindist :: ( MonadReader env m
|
|
||||||
, HasDirs env
|
|
||||||
, HasSettings env
|
|
||||||
, HasPlatformReq env
|
|
||||||
, MonadThrow m
|
|
||||||
, MonadCatch m
|
|
||||||
, HasLog env
|
|
||||||
, MonadIO m
|
|
||||||
, MonadFail m
|
|
||||||
)
|
|
||||||
=> GHCTargetVersion
|
|
||||||
-> FilePath
|
|
||||||
-> FilePath
|
|
||||||
-> Excepts
|
|
||||||
'[ FileDoesNotExistError
|
|
||||||
, InvalidBuildConfig
|
|
||||||
, PatchFailed
|
|
||||||
, ProcessError
|
|
||||||
, NotFoundInPATH
|
|
||||||
, CopyError
|
|
||||||
]
|
|
||||||
m
|
|
||||||
()
|
|
||||||
configureBindist tver workdir ghcdir = do
|
|
||||||
lift $ logInfo [s|configuring build|]
|
|
||||||
|
|
||||||
if | _tvVersion tver >= [vver|8.8.0|] -> do
|
|
||||||
lEM $ execWithGhcEnv
|
|
||||||
"sh"
|
|
||||||
("./configure" : 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"
|
|
||||||
| 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 ()
|
|
||||||
|
|
||||||
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
|
|
||||||
throwMaybeM (NotFoundInPATH bver) $ liftIO (searchPath spaths bver)
|
|
||||||
pure (("GHC", bghcPath) : cEnv)
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
---------------------
|
---------------------
|
||||||
--[ Upgrade GHCup ]--
|
--[ Upgrade GHCup ]--
|
||||||
---------------------
|
---------------------
|
||||||
@ -2618,31 +1724,6 @@ upgradeGHCup mtarget force' = do
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for
|
|
||||||
-- both installing from source and bindist.
|
|
||||||
postGHCInstall :: ( MonadReader env m
|
|
||||||
, HasDirs env
|
|
||||||
, HasLog env
|
|
||||||
, MonadThrow m
|
|
||||||
, MonadFail m
|
|
||||||
, MonadIO m
|
|
||||||
, MonadCatch m
|
|
||||||
, MonadMask m
|
|
||||||
, MonadUnliftIO m
|
|
||||||
)
|
|
||||||
=> GHCTargetVersion
|
|
||||||
-> Excepts '[NotInstalled] m ()
|
|
||||||
postGHCInstall ver@GHCTargetVersion {..} = do
|
|
||||||
void $ liftE $ setGHC ver SetGHC_XYZ
|
|
||||||
|
|
||||||
-- Create ghc-x.y symlinks. This may not be the current
|
|
||||||
-- version, create it regardless.
|
|
||||||
v' <-
|
|
||||||
handle (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
|
|
||||||
$ fmap Just
|
|
||||||
$ getMajorMinorV _tvVersion
|
|
||||||
forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) _tvTarget)
|
|
||||||
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
|
|
||||||
|
|
||||||
|
|
||||||
-- | Reports the binary location of a given tool:
|
-- | Reports the binary location of a given tool:
|
||||||
@ -2846,3 +1927,9 @@ rmTmp = do
|
|||||||
let p = tmpdir </> f
|
let p = tmpdir </> f
|
||||||
logDebug $ "rm -rf " <> T.pack p
|
logDebug $ "rm -rf " <> T.pack p
|
||||||
rmPathForcibly p
|
rmPathForcibly p
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -36,6 +36,9 @@ import GHCup.System.Console.Windows
|
|||||||
#else
|
#else
|
||||||
import GHCup.System.Console.Posix
|
import GHCup.System.Console.Posix
|
||||||
#endif
|
#endif
|
||||||
|
import {-# SOURCE #-} GHCup.GHC.Common
|
||||||
|
import {-# SOURCE #-} GHCup.GHC.Set
|
||||||
|
import GHCup.Data.Versions
|
||||||
import GHCup.Download
|
import GHCup.Download
|
||||||
import GHCup.Errors
|
import GHCup.Errors
|
||||||
import GHCup.Types
|
import GHCup.Types
|
||||||
@ -78,6 +81,7 @@ import System.FilePath
|
|||||||
import System.IO.Error
|
import System.IO.Error
|
||||||
import Text.Regex.Posix
|
import Text.Regex.Posix
|
||||||
import URI.ByteString
|
import URI.ByteString
|
||||||
|
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||||
|
|
||||||
import qualified Codec.Compression.BZip as BZip
|
import qualified Codec.Compression.BZip as BZip
|
||||||
import qualified Codec.Compression.GZip as GZip
|
import qualified Codec.Compression.GZip as GZip
|
||||||
@ -121,161 +125,6 @@ import qualified Data.List.NonEmpty as NE
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
------------------------
|
|
||||||
--[ Symlink handling ]--
|
|
||||||
------------------------
|
|
||||||
|
|
||||||
|
|
||||||
-- | The symlink destination of a ghc tool.
|
|
||||||
ghcLinkDestination :: ( MonadReader env m
|
|
||||||
, HasDirs env
|
|
||||||
, MonadThrow m, MonadIO m)
|
|
||||||
=> FilePath -- ^ the tool, such as 'ghc', 'haddock' etc.
|
|
||||||
-> GHCTargetVersion
|
|
||||||
-> m FilePath
|
|
||||||
ghcLinkDestination tool ver = do
|
|
||||||
Dirs {..} <- getDirs
|
|
||||||
ghcd <- ghcupGHCDir ver
|
|
||||||
pure (relativeSymlink binDir (ghcd </> "bin" </> tool))
|
|
||||||
|
|
||||||
|
|
||||||
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
|
|
||||||
rmMinorSymlinks :: ( MonadReader env m
|
|
||||||
, HasDirs env
|
|
||||||
, MonadIO m
|
|
||||||
, HasLog env
|
|
||||||
, MonadThrow m
|
|
||||||
, MonadFail m
|
|
||||||
, MonadMask m
|
|
||||||
)
|
|
||||||
=> GHCTargetVersion
|
|
||||||
-> Excepts '[NotInstalled] m ()
|
|
||||||
rmMinorSymlinks tv@GHCTargetVersion{..} = do
|
|
||||||
Dirs {..} <- lift getDirs
|
|
||||||
|
|
||||||
files <- liftE $ ghcToolFiles tv
|
|
||||||
forM_ files $ \f -> do
|
|
||||||
let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
|
|
||||||
let fullF = binDir </> f_xyz
|
|
||||||
lift $ logDebug ("rm -f " <> T.pack fullF)
|
|
||||||
lift $ hideError doesNotExistErrorType $ rmLink fullF
|
|
||||||
|
|
||||||
|
|
||||||
-- | Removes the set ghc version for the given target, if any.
|
|
||||||
rmPlain :: ( MonadReader env m
|
|
||||||
, HasDirs env
|
|
||||||
, HasLog env
|
|
||||||
, MonadThrow m
|
|
||||||
, MonadFail m
|
|
||||||
, MonadIO m
|
|
||||||
, MonadMask m
|
|
||||||
)
|
|
||||||
=> Maybe Text -- ^ target
|
|
||||||
-> Excepts '[NotInstalled] m ()
|
|
||||||
rmPlain target = do
|
|
||||||
Dirs {..} <- lift getDirs
|
|
||||||
mtv <- lift $ ghcSet target
|
|
||||||
forM_ mtv $ \tv -> do
|
|
||||||
files <- liftE $ ghcToolFiles tv
|
|
||||||
forM_ files $ \f -> do
|
|
||||||
let fullF = binDir </> f <> exeExt
|
|
||||||
lift $ logDebug ("rm -f " <> T.pack fullF)
|
|
||||||
lift $ hideError doesNotExistErrorType $ rmLink fullF
|
|
||||||
-- old ghcup
|
|
||||||
let hdc_file = binDir </> "haddock-ghc" <> exeExt
|
|
||||||
lift $ logDebug ("rm -f " <> T.pack hdc_file)
|
|
||||||
lift $ hideError doesNotExistErrorType $ rmLink hdc_file
|
|
||||||
|
|
||||||
|
|
||||||
-- | Remove the major GHC symlink, e.g. ghc-8.6.
|
|
||||||
rmMajorSymlinks :: ( MonadReader env m
|
|
||||||
, HasDirs env
|
|
||||||
, MonadIO m
|
|
||||||
, HasLog env
|
|
||||||
, MonadThrow m
|
|
||||||
, MonadFail m
|
|
||||||
, MonadMask m
|
|
||||||
)
|
|
||||||
=> GHCTargetVersion
|
|
||||||
-> Excepts '[NotInstalled] m ()
|
|
||||||
rmMajorSymlinks tv@GHCTargetVersion{..} = do
|
|
||||||
Dirs {..} <- lift getDirs
|
|
||||||
(mj, mi) <- getMajorMinorV _tvVersion
|
|
||||||
let v' = intToText mj <> "." <> intToText mi
|
|
||||||
|
|
||||||
files <- liftE $ ghcToolFiles tv
|
|
||||||
forM_ files $ \f -> do
|
|
||||||
let f_xy = f <> "-" <> T.unpack v' <> exeExt
|
|
||||||
let fullF = binDir </> f_xy
|
|
||||||
lift $ logDebug ("rm -f " <> T.pack fullF)
|
|
||||||
lift $ hideError doesNotExistErrorType $ rmLink fullF
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-----------------------------------
|
|
||||||
--[ Set/Installed introspection ]--
|
|
||||||
-----------------------------------
|
|
||||||
|
|
||||||
|
|
||||||
-- | Whether the given GHC versin is installed.
|
|
||||||
ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
|
|
||||||
ghcInstalled ver = do
|
|
||||||
ghcdir <- ghcupGHCDir ver
|
|
||||||
liftIO $ doesDirectoryExist 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 (ghcdir </> ghcUpSrcBuiltFile)
|
|
||||||
|
|
||||||
|
|
||||||
-- | Whether the given GHC version is set as the current.
|
|
||||||
ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
|
|
||||||
=> Maybe Text -- ^ the target of the GHC version, if any
|
|
||||||
-- (e.g. armv7-unknown-linux-gnueabihf)
|
|
||||||
-> m (Maybe GHCTargetVersion)
|
|
||||||
ghcSet mtarget = do
|
|
||||||
Dirs {..} <- getDirs
|
|
||||||
let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget
|
|
||||||
let ghcBin = binDir </> ghc <> exeExt
|
|
||||||
|
|
||||||
-- link destination is of the form ../ghc/<ver>/bin/ghc
|
|
||||||
-- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver>
|
|
||||||
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
|
|
||||||
link <- liftIO $ getLinkTarget ghcBin
|
|
||||||
Just <$> ghcLinkVersion link
|
|
||||||
where
|
|
||||||
ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersion
|
|
||||||
ghcLinkVersion (T.pack . dropSuffix exeExt -> t) = throwEither $ MP.parse parser "ghcLinkVersion" t
|
|
||||||
where
|
|
||||||
parser =
|
|
||||||
(do
|
|
||||||
_ <- parseUntil1 ghcSubPath
|
|
||||||
_ <- ghcSubPath
|
|
||||||
r <- parseUntil1 pathSep
|
|
||||||
rest <- MP.getInput
|
|
||||||
MP.setInput r
|
|
||||||
x <- ghcTargetVerP
|
|
||||||
MP.setInput rest
|
|
||||||
pure x
|
|
||||||
)
|
|
||||||
<* pathSep
|
|
||||||
<* MP.takeRest
|
|
||||||
<* MP.eof
|
|
||||||
ghcSubPath = pathSep <* MP.chunk "ghc" *> pathSep
|
|
||||||
|
|
||||||
-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
|
|
||||||
-- If a dir cannot be parsed, returns left.
|
|
||||||
getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion]
|
|
||||||
getInstalledGHCs = do
|
|
||||||
ghcdir <- ghcupGHCBaseDir
|
|
||||||
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir
|
|
||||||
forM fs $ \f -> case parseGHCupGHCDir f of
|
|
||||||
Right r -> pure $ Right r
|
|
||||||
Left _ -> pure $ Left f
|
|
||||||
|
|
||||||
|
|
||||||
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
|
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
|
||||||
@ -589,79 +438,6 @@ hlsSymlinks = do
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
-----------------------------------------
|
|
||||||
--[ Major version introspection (X.Y) ]--
|
|
||||||
-----------------------------------------
|
|
||||||
|
|
||||||
|
|
||||||
-- | Extract (major, minor) from any version.
|
|
||||||
getMajorMinorV :: MonadThrow m => Version -> m (Int, Int)
|
|
||||||
getMajorMinorV Version {..} = case _vChunks of
|
|
||||||
((Digits x :| []) :| ((Digits y :| []):_)) -> pure (fromIntegral x, fromIntegral y)
|
|
||||||
_ -> throwM $ ParseError "Could not parse X.Y from version"
|
|
||||||
|
|
||||||
|
|
||||||
matchMajor :: Version -> Int -> Int -> Bool
|
|
||||||
matchMajor v' major' minor' = case getMajorMinorV v' of
|
|
||||||
Just (x, y) -> x == major' && y == minor'
|
|
||||||
Nothing -> False
|
|
||||||
|
|
||||||
-- | Match PVP prefix.
|
|
||||||
--
|
|
||||||
-- >>> matchPVPrefix [pver|8.8|] [pver|8.8.4|]
|
|
||||||
-- True
|
|
||||||
-- >>> matchPVPrefix [pver|8|] [pver|8.8.4|]
|
|
||||||
-- True
|
|
||||||
-- >>> matchPVPrefix [pver|8.10|] [pver|8.8.4|]
|
|
||||||
-- False
|
|
||||||
-- >>> matchPVPrefix [pver|8.10|] [pver|8.10.7|]
|
|
||||||
-- True
|
|
||||||
matchPVPrefix :: PVP -> PVP -> Bool
|
|
||||||
matchPVPrefix (toL -> prefix) (toL -> full) = and $ zipWith (==) prefix full
|
|
||||||
|
|
||||||
toL :: PVP -> [Int]
|
|
||||||
toL (PVP inner) = fmap fromIntegral $ NE.toList inner
|
|
||||||
|
|
||||||
|
|
||||||
-- | Get the latest installed full GHC version that satisfies the given (possibly partial)
|
|
||||||
-- PVP version.
|
|
||||||
getGHCForPVP :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
|
|
||||||
=> PVP
|
|
||||||
-> Maybe Text -- ^ the target triple
|
|
||||||
-> m (Maybe GHCTargetVersion)
|
|
||||||
getGHCForPVP pvpIn mt = do
|
|
||||||
ghcs <- rights <$> getInstalledGHCs
|
|
||||||
-- we're permissive here... failed parse just means we have no match anyway
|
|
||||||
let ghcs' = catMaybes $ flip fmap ghcs $ \GHCTargetVersion{..} -> do
|
|
||||||
(pvp_, rest) <- versionToPVP _tvVersion
|
|
||||||
pure (pvp_, rest, _tvTarget)
|
|
||||||
|
|
||||||
getGHCForPVP' pvpIn ghcs' mt
|
|
||||||
|
|
||||||
-- | Like 'getGHCForPVP', except with explicit input parameter.
|
|
||||||
--
|
|
||||||
-- >>> getGHCForPVP' [pver|8|] installedVersions Nothing
|
|
||||||
-- Just (GHCTargetVersion {_tvTarget = Nothing, _tvVersion = Version {_vEpoch = Nothing, _vChunks = (Digits 8 :| []) :| [Digits 10 :| [],Digits 7 :| []], _vRel = [Str "debug" :| []], _vMeta = Just "lol"}})
|
|
||||||
-- >>> fmap prettyShow $ getGHCForPVP' [pver|8.8|] installedVersions Nothing
|
|
||||||
-- "Just 8.8.4"
|
|
||||||
-- >>> fmap prettyShow $ getGHCForPVP' [pver|8.10.4|] installedVersions Nothing
|
|
||||||
-- "Just 8.10.4"
|
|
||||||
getGHCForPVP' :: MonadThrow m
|
|
||||||
=> PVP
|
|
||||||
-> [(PVP, Text, Maybe Text)] -- ^ installed GHCs
|
|
||||||
-> Maybe Text -- ^ the target triple
|
|
||||||
-> m (Maybe GHCTargetVersion)
|
|
||||||
getGHCForPVP' pvpIn ghcs' mt = do
|
|
||||||
let mResult = lastMay
|
|
||||||
. sortBy (\(x, _, _) (y, _, _) -> compare x y)
|
|
||||||
. filter
|
|
||||||
(\(pvp_, _, target) ->
|
|
||||||
target == mt && matchPVPrefix pvp_ pvpIn
|
|
||||||
)
|
|
||||||
$ ghcs'
|
|
||||||
forM mResult $ \(pvp_, rest, target) -> do
|
|
||||||
ver' <- pvpToVersion pvp_ rest
|
|
||||||
pure (GHCTargetVersion target ver')
|
|
||||||
|
|
||||||
|
|
||||||
-- | Get the latest available ghc for the given PVP version, which
|
-- | Get the latest available ghc for the given PVP version, which
|
||||||
@ -811,39 +587,6 @@ getLatestBaseVersion av pvpVer =
|
|||||||
-------------
|
-------------
|
||||||
|
|
||||||
|
|
||||||
-- | Get tool files from @~\/.ghcup\/bin\/ghc\/\<ver\>\/bin\/\*@
|
|
||||||
-- while ignoring @*-\<ver\>@ symlinks and accounting for cross triple prefix.
|
|
||||||
--
|
|
||||||
-- Returns unversioned relative files without extension, e.g.:
|
|
||||||
--
|
|
||||||
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
|
|
||||||
ghcToolFiles :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
|
|
||||||
=> GHCTargetVersion
|
|
||||||
-> Excepts '[NotInstalled] m [FilePath]
|
|
||||||
ghcToolFiles ver = do
|
|
||||||
ghcdir <- lift $ ghcupGHCDir ver
|
|
||||||
let bindir = ghcdir </> "bin"
|
|
||||||
|
|
||||||
-- fail if ghc is not installed
|
|
||||||
whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
|
|
||||||
(throwE (NotInstalled GHC ver))
|
|
||||||
|
|
||||||
files <- liftIO (listDirectory bindir >>= filterM (doesFileExist . (bindir </>)))
|
|
||||||
pure (getUniqueTools . groupToolFiles . fmap (dropSuffix exeExt) $ files)
|
|
||||||
|
|
||||||
where
|
|
||||||
|
|
||||||
groupToolFiles :: [FilePath] -> [[(FilePath, String)]]
|
|
||||||
groupToolFiles = groupBy (\(a, _) (b, _) -> a == b) . fmap (splitOnPVP "-")
|
|
||||||
|
|
||||||
getUniqueTools :: [[(FilePath, String)]] -> [String]
|
|
||||||
getUniqueTools = filter (isNotAnyInfix blackListedTools) . nub . fmap fst . filter ((== "") . snd) . concat
|
|
||||||
|
|
||||||
blackListedTools :: [String]
|
|
||||||
blackListedTools = ["haddock-ghc"]
|
|
||||||
|
|
||||||
isNotAnyInfix :: [String] -> String -> Bool
|
|
||||||
isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs
|
|
||||||
|
|
||||||
|
|
||||||
-- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
|
-- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
|
||||||
@ -1142,3 +885,33 @@ ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
|
|||||||
ghcBinaryName :: GHCTargetVersion -> String
|
ghcBinaryName :: GHCTargetVersion -> String
|
||||||
ghcBinaryName (GHCTargetVersion (Just t) v') = T.unpack (t <> "-ghc-" <> prettyVer v' <> T.pack exeExt)
|
ghcBinaryName (GHCTargetVersion (Just t) v') = T.unpack (t <> "-ghc-" <> prettyVer v' <> T.pack exeExt)
|
||||||
ghcBinaryName (GHCTargetVersion Nothing v') = T.unpack ("ghc-" <> prettyVer v' <> T.pack exeExt)
|
ghcBinaryName (GHCTargetVersion Nothing v') = T.unpack ("ghc-" <> prettyVer v' <> T.pack exeExt)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- | Warn if the installed and set HLS is not compatible with the installed and
|
||||||
|
-- set GHC version.
|
||||||
|
warnAboutHlsCompatibility :: ( MonadReader env m
|
||||||
|
, HasDirs env
|
||||||
|
, HasLog env
|
||||||
|
, MonadThrow m
|
||||||
|
, MonadCatch m
|
||||||
|
, MonadIO m
|
||||||
|
)
|
||||||
|
=> m ()
|
||||||
|
warnAboutHlsCompatibility = do
|
||||||
|
supportedGHC <- hlsGHCVersions
|
||||||
|
currentGHC <- fmap _tvVersion <$> ghcSet Nothing
|
||||||
|
currentHLS <- hlsSet
|
||||||
|
|
||||||
|
case (currentGHC, currentHLS) of
|
||||||
|
(Just gv, Just hv) | gv `notElem` supportedGHC -> do
|
||||||
|
logWarn $
|
||||||
|
"GHC " <> T.pack (prettyShow gv) <> " is not compatible with " <>
|
||||||
|
"Haskell Language Server " <> T.pack (prettyShow hv) <> "." <> "\n" <>
|
||||||
|
"Haskell IDE support may not work until this is fixed." <> "\n" <>
|
||||||
|
"Install a different HLS version, or install and set one of the following GHCs:" <> "\n" <>
|
||||||
|
T.pack (prettyShow supportedGHC)
|
||||||
|
|
||||||
|
_ -> return ()
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user