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

Merge branch 'isolateDir'

Browse Source
This commit is contained in:
Julian Ospald 2022-05-11 20:35:38 +02:00
commit f7811961b5
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
10 changed files with 195 additions and 158 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitlab/script/ghcup_version.sh
View File

@ -176,6 +176,8 @@ else
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
ls -lah "$GHCUP_BIN"
if [ "${OS}" = "DARWIN" ] ; then
eghcup install hls
$(eghcup whereis hls) --version

3
CHANGELOG.md
View File

@ -2,6 +2,9 @@
## 0.1.17.8 -- XXXX-XX-XX
* Fix HLS build not cleaning up properly on failed installations, fixes [#361](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/361)
- this also fixes a significant bug on installation failure when combining `--isolate DIR` with `--force`
* Fix parsing of symlinks with multiple slashes, wrt [#353](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/353)
* Re-enable upgrade functionality for all configurations wrt [#250](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/250)
## 0.1.17.7 -- 2022-04-21

8
app/ghcup/BrickMain.hs
View File

@ -447,19 +447,19 @@ install' _ (_, ListResult {..}) = do
case lTool of
GHC -> do
let vi = getVersionInfo lVer GHC dls
liftE $ installGHCBin lVer Nothing False $> (vi, dirs, ce)
liftE $ installGHCBin lVer GHCupInternal False $> (vi, dirs, ce)
Cabal -> do
let vi = getVersionInfo lVer Cabal dls
liftE $ installCabalBin lVer Nothing False $> (vi, dirs, ce)
liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce)
GHCup -> do
let vi = snd <$> getLatest dls GHCup
liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce)
HLS -> do
let vi = getVersionInfo lVer HLS dls
liftE $ installHLSBin lVer Nothing False $> (vi, dirs, ce)
liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce)
Stack -> do
let vi = getVersionInfo lVer Stack dls
liftE $ installStackBin lVer Nothing False $> (vi, dirs, ce)
liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce)
)
>>= \case
VRight (vi, Dirs{..}, Just ce) -> do

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

@ -469,7 +469,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
ghcs
jobs
ovewrwiteVer
isolateDir
(maybe GHCupInternal IsolateDir isolateDir)
cabalProject
cabalProjectLocal
patches
@ -524,7 +524,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
addConfArgs
buildFlavour
hadrian
isolateDir
(maybe GHCupInternal IsolateDir isolateDir)
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion targetVer) GHC dls
when setCompile $ void $ liftE $

16
app/ghcup/GHCup/OptParse/Install.hs
View File

@ -395,7 +395,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
(v, vi) <- liftE $ fromVersion instVer GHC
void $ liftE $ sequenceE (installGHCBin
(_tvVersion v)
isolateDir
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
)
$ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing
@ -406,7 +406,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
void $ liftE $ sequenceE (installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v)
isolateDir
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
)
$ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing
@ -467,7 +467,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
void $ liftE $ sequenceE (installCabalBin
v
isolateDir
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v
pure vi
@ -477,7 +477,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
void $ liftE $ sequenceE (installCabalBindist
(DownloadInfo uri Nothing "")
v
isolateDir
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v
pure vi
@ -518,7 +518,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
void $ liftE $ sequenceE (installHLSBin
v
isolateDir
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing
pure vi
@ -529,7 +529,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
void $ liftE $ sequenceE (installHLSBindist
(DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "")
v
isolateDir
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing
pure vi
@ -578,7 +578,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
void $ liftE $ sequenceE (installStackBin
v
isolateDir
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v
pure vi
@ -588,7 +588,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
void $ liftE $ sequenceE (installStackBindist
(DownloadInfo uri Nothing "")
v
isolateDir
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v
pure vi

8
app/ghcup/GHCup/OptParse/Run.hs
View File

@ -351,25 +351,25 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
Just (GHC, v) -> do
unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin
(_tvVersion v)
Nothing
GHCupInternal
False
setTool GHC v tmp
Just (Cabal, v) -> do
unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin
(_tvVersion v)
Nothing
GHCupInternal
False
setTool Cabal v tmp
Just (Stack, v) -> do
unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin
(_tvVersion v)
Nothing
GHCupInternal
False
setTool Stack v tmp
Just (HLS, v) -> do
unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin
(_tvVersion v)
Nothing
GHCupInternal
False
setTool HLS v tmp
_ -> pure ()

2
ghcup.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 3.0
name: ghcup
version: 0.1.17.7
version: 0.1.17.8
license: LGPL-3.0-only
license-file: LICENSE
copyright: Julian Ospald 2020

238
lib/GHCup.hs
View File

@ -187,7 +187,7 @@ installGHCBindist :: ( MonadFail m
)
=> DownloadInfo -- ^ where/how to download
-> Version -- ^ the version to install
-> Maybe FilePath -- ^ isolated filepath if user passed any
-> InstallDir
-> Bool -- ^ Force install
-> Excepts
'[ AlreadyInstalled
@ -205,7 +205,7 @@ installGHCBindist :: ( MonadFail m
]
m
()
installGHCBindist dlinfo ver isoFilepath forceInstall = do
installGHCBindist dlinfo ver installDir forceInstall = do
let tver = mkTVer ver
lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver
@ -215,12 +215,12 @@ installGHCBindist dlinfo ver isoFilepath forceInstall = do
if
| not forceInstall
, regularGHCInstalled
, Nothing <- isoFilepath -> do
, GHCupInternal <- installDir -> do
throwE $ AlreadyInstalled GHC ver
| forceInstall
, regularGHCInstalled
, Nothing <- isoFilepath -> do
, GHCupInternal <- installDir -> do
lift $ logInfo "Removing the currently installed GHC version first!"
liftE $ rmGHCVer tver
@ -229,17 +229,18 @@ installGHCBindist dlinfo ver isoFilepath forceInstall = do
-- 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
case installDir of
IsolateDir 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
liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) ver forceInstall
GHCupInternal -> do -- regular install
-- prepare paths
ghcdir <- lift $ ghcupGHCDir tver
liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) ver forceInstall
-- make symlinks & stuff when regular install,
liftE $ postGHCInstall tver
@ -271,7 +272,7 @@ installPackedGHC :: ( MonadMask m
)
=> FilePath -- ^ Path to the packed GHC bindist
-> Maybe TarDir -- ^ Subdir of the archive
-> FilePath -- ^ Path to install to
-> InstallDirResolved
-> Version -- ^ The GHC version
-> Bool -- ^ Force install
-> Excepts
@ -299,7 +300,11 @@ installPackedGHC dl msubdir inst ver forceInstall = do
msubdir
liftE $ runBuildAction tmpUnpack
(Just inst)
(case inst of
IsolateDirResolved _ -> Nothing -- don't clean up for isolated installs, since that'd potentially delete other
-- user files if '--force' is supplied
GHCupDir d -> Just d
)
(installUnpackedGHC workdir inst ver)
@ -316,10 +321,10 @@ installUnpackedGHC :: ( MonadReader env m
, MonadMask m
)
=> FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> FilePath -- ^ Path to install to
-> InstallDirResolved -- ^ Path to install to
-> Version -- ^ The GHC version
-> Excepts '[ProcessError] m ()
installUnpackedGHC path inst ver
installUnpackedGHC path (fromInstallDir -> inst) ver
| isWindows = do
lift $ logInfo "Installing GHC (this may take a while)"
-- Windows bindists are relocatable and don't need
@ -369,7 +374,7 @@ installGHCBin :: ( MonadFail m
, MonadUnliftIO m
)
=> Version -- ^ the version to install
-> Maybe FilePath -- ^ isolated install filepath, if user passed any
-> InstallDir
-> Bool -- ^ force install
-> Excepts
'[ AlreadyInstalled
@ -387,9 +392,9 @@ installGHCBin :: ( MonadFail m
]
m
()
installGHCBin ver isoFilepath forceInstall = do
installGHCBin ver installDir forceInstall = do
dlinfo <- liftE $ getDownloadInfo GHC ver
liftE $ installGHCBindist dlinfo ver isoFilepath forceInstall
liftE $ installGHCBindist dlinfo ver installDir forceInstall
-- | Like 'installCabalBin', except takes the 'DownloadInfo' as
@ -408,7 +413,7 @@ installCabalBindist :: ( MonadMask m
)
=> DownloadInfo
-> Version
-> Maybe FilePath -- ^ isolated install filepath, if user provides any.
-> InstallDir
-> Bool -- ^ Force install
-> Excepts
'[ AlreadyInstalled
@ -425,7 +430,7 @@ installCabalBindist :: ( MonadMask m
]
m
()
installCabalBindist dlinfo ver isoFilepath forceInstall = do
installCabalBindist dlinfo ver installDir forceInstall = do
lift $ logDebug $ "Requested to install cabal version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq
@ -437,12 +442,12 @@ installCabalBindist dlinfo ver isoFilepath forceInstall = do
if
| not forceInstall
, regularCabalInstalled
, Nothing <- isoFilepath -> do
, GHCupInternal <- installDir -> do
throwE $ AlreadyInstalled Cabal ver
| forceInstall
, regularCabalInstalled
, Nothing <- isoFilepath -> do
, GHCupInternal <- installDir -> do
lift $ logInfo "Removing the currently installed version first!"
liftE $ rmCabalVer ver
@ -460,30 +465,33 @@ installCabalBindist dlinfo ver isoFilepath forceInstall = do
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
case isoFilepath of
Just isoDir -> do -- isolated install
case installDir of
IsolateDir isoDir -> do -- isolated install
lift $ logInfo $ "isolated installing Cabal to " <> T.pack isoDir
liftE $ installCabalUnpacked workdir isoDir Nothing forceInstall
liftE $ installCabalUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall
Nothing -> do -- regular install
liftE $ installCabalUnpacked workdir binDir (Just ver) forceInstall
GHCupInternal -> do -- regular install
liftE $ installCabalUnpacked workdir (GHCupDir binDir) ver forceInstall
-- | Install an unpacked cabal distribution.Symbol
installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m)
=> FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated install
-> InstallDirResolved -- ^ Path to install to
-> Version
-> Bool -- ^ Force Install
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installCabalUnpacked path inst mver' forceInstall = do
installCabalUnpacked path inst ver forceInstall = do
lift $ logInfo "Installing cabal"
let cabalFile = "cabal"
liftIO $ createDirRecursive' inst
liftIO $ createDirRecursive' (fromInstallDir inst)
let destFileName = cabalFile
<> maybe "" (("-" <>) . T.unpack . prettyVer) mver'
<> (case inst of
IsolateDirResolved _ -> ""
GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver
)
<> exeExt
let destPath = inst </> destFileName
let destPath = fromInstallDir inst </> destFileName
unless forceInstall -- Overwrite it when it IS a force install
(liftE $ throwIfFileAlreadyExists destPath)
@ -510,7 +518,7 @@ installCabalBin :: ( MonadMask m
, MonadFail m
)
=> Version
-> Maybe FilePath -- isolated install Path, if user provided any
-> InstallDir
-> Bool -- force install
-> Excepts
'[ AlreadyInstalled
@ -527,9 +535,9 @@ installCabalBin :: ( MonadMask m
]
m
()
installCabalBin ver isoFilepath forceInstall = do
installCabalBin ver installDir forceInstall = do
dlinfo <- liftE $ getDownloadInfo Cabal ver
installCabalBindist dlinfo ver isoFilepath forceInstall
installCabalBindist dlinfo ver installDir forceInstall
-- | Like 'installHLSBin, except takes the 'DownloadInfo' as
@ -548,7 +556,7 @@ installHLSBindist :: ( MonadMask m
)
=> DownloadInfo
-> Version
-> Maybe FilePath -- ^ isolated install path, if user passed any
-> InstallDir -- ^ isolated install path, if user passed any
-> Bool -- ^ Force install
-> Excepts
'[ AlreadyInstalled
@ -567,7 +575,7 @@ installHLSBindist :: ( MonadMask m
]
m
()
installHLSBindist dlinfo ver isoFilepath forceInstall = do
installHLSBindist dlinfo ver installDir forceInstall = do
lift $ logDebug $ "Requested to install hls version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq
@ -578,12 +586,12 @@ installHLSBindist dlinfo ver isoFilepath forceInstall = do
if
| not forceInstall
, regularHLSInstalled
, Nothing <- isoFilepath -> do -- regular install
, GHCupInternal <- installDir -> do -- regular install
throwE $ AlreadyInstalled HLS ver
| forceInstall
, regularHLSInstalled
, Nothing <- isoFilepath -> do -- regular forced install
, GHCupInternal <- installDir -> do -- regular forced install
lift $ logInfo "Removing the currently installed version of HLS before force installing!"
liftE $ rmHLSVer ver
@ -604,22 +612,23 @@ installHLSBindist dlinfo ver isoFilepath forceInstall = do
if
| not forceInstall
, not legacy
, (Just fp) <- isoFilepath -> liftE $ installDestSanityCheck fp
, (IsolateDir fp) <- installDir -> liftE $ installDestSanityCheck (IsolateDirResolved fp)
| otherwise -> pure ()
case isoFilepath of
Just isoDir -> do
case installDir of
IsolateDir isoDir -> do
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
if legacy
then liftE $ installHLSUnpackedLegacy workdir isoDir Nothing forceInstall
else liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir isoDir ver
then liftE $ installHLSUnpackedLegacy workdir (IsolateDirResolved isoDir) ver forceInstall
else liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir (IsolateDirResolved isoDir) ver
Nothing -> do
GHCupInternal -> do
if legacy
then liftE $ installHLSUnpackedLegacy workdir binDir (Just ver) forceInstall
then liftE $ installHLSUnpackedLegacy workdir (GHCupDir binDir) ver forceInstall
else do
inst <- ghcupHLSDir ver
liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir inst ver
liftE $ runBuildAction tmpUnpack (Just inst)
$ installHLSUnpacked workdir (GHCupDir inst) ver
liftE $ setHLS ver SetHLS_XYZ Nothing
@ -631,10 +640,10 @@ isLegacyHLSBindist path = do
-- | Install an unpacked hls distribution.
installHLSUnpacked :: (MonadMask m, MonadUnliftIO m, MonadReader env m, MonadFail m, HasLog env, HasDirs env, HasSettings env, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> InstallDirResolved -- ^ Path to install to
-> Version
-> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m ()
installHLSUnpacked path inst _ = do
installHLSUnpacked path (fromInstallDir -> inst) _ = do
lift $ logInfo "Installing HLS"
liftIO $ createDirRecursive' inst
lEM $ make ["PREFIX=" <> inst, "install"] (Just path)
@ -642,13 +651,13 @@ installHLSUnpacked path inst _ = do
-- | Install an unpacked hls distribution (legacy).
installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated install
-> InstallDirResolved -- ^ Path to install to
-> Version
-> Bool -- ^ is it a force install
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installHLSUnpackedLegacy path inst mver' forceInstall = do
installHLSUnpackedLegacy path installDir ver forceInstall = do
lift $ logInfo "Installing HLS"
liftIO $ createDirRecursive' inst
liftIO $ createDirRecursive' (fromInstallDir installDir)
-- install haskell-language-server-<ghcver>
bins@(_:_) <- liftIO $ findFiles
@ -659,11 +668,14 @@ installHLSUnpackedLegacy path inst mver' forceInstall = do
)
forM_ bins $ \f -> do
let toF = dropSuffix exeExt f
<> maybe "" (("~" <>) . T.unpack . prettyVer) mver'
<> (case installDir of
IsolateDirResolved _ -> ""
GHCupDir _ -> ("~" <>) . T.unpack . prettyVer $ ver
)
<> exeExt
let srcPath = path </> f
let destPath = inst </> toF
let destPath = fromInstallDir installDir </> toF
unless forceInstall -- if it is a force install, overwrite it.
(liftE $ throwIfFileAlreadyExists destPath)
@ -676,10 +688,13 @@ installHLSUnpackedLegacy path inst mver' forceInstall = do
-- install haskell-language-server-wrapper
let wrapper = "haskell-language-server-wrapper"
toF = wrapper
<> maybe "" (("-" <>) . T.unpack . prettyVer) mver'
<> (case installDir of
IsolateDirResolved _ -> ""
GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver
)
<> exeExt
srcWrapperPath = path </> wrapper <> exeExt
destWrapperPath = inst </> toF
destWrapperPath = fromInstallDir installDir </> toF
unless forceInstall
(liftE $ throwIfFileAlreadyExists destWrapperPath)
@ -708,7 +723,7 @@ installHLSBin :: ( MonadMask m
, MonadFail m
)
=> Version
-> Maybe FilePath -- isolated install Dir (if any)
-> InstallDir
-> Bool -- force install
-> Excepts
'[ AlreadyInstalled
@ -727,9 +742,9 @@ installHLSBin :: ( MonadMask m
]
m
()
installHLSBin ver isoFilepath forceInstall = do
installHLSBin ver installDir forceInstall = do
dlinfo <- liftE $ getDownloadInfo HLS ver
installHLSBindist dlinfo ver isoFilepath forceInstall
installHLSBindist dlinfo ver installDir forceInstall
compileHLS :: ( MonadMask m
@ -749,7 +764,7 @@ compileHLS :: ( MonadMask m
-> [Version]
-> Maybe Int
-> Maybe Version
-> Maybe FilePath
-> InstallDir
-> Maybe (Either FilePath URI)
-> Maybe URI
-> Maybe (Either FilePath [URI]) -- ^ patches
@ -764,7 +779,7 @@ compileHLS :: ( MonadMask m
, BuildFailed
, NotInstalled
] m Version
compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patches cabalArgs = do
compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patches cabalArgs = do
PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
Dirs { .. } <- lift getDirs
@ -837,8 +852,8 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc
workdir
Nothing
(reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do
let installDir = workdir </> "out"
liftIO $ createDirRecursive' installDir
let tmpInstallDir = workdir </> "out"
liftIO $ createDirRecursive' tmpInstallDir
-- apply patches
liftE $ applyAnyPatch patches workdir
@ -861,8 +876,8 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc
cpl <- liftE $ download uri Nothing Nothing tmpUnpack (Just (cp <.> "local")) False
copyFileE cpl (workdir </> cp <.> "local")
artifacts <- forM (sort ghcs) $ \ghc -> do
let ghcInstallDir = installDir </> T.unpack (prettyVer ghc)
liftIO $ createDirRecursive' installDir
let ghcInstallDir = tmpInstallDir </> T.unpack (prettyVer ghc)
liftIO $ createDirRecursive' tmpInstallDir
lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc
liftE $ lEM @_ @'[ProcessError] $
execLogged "cabal" ( [ "v2-install"
@ -885,17 +900,17 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc
forM_ artifacts $ \artifact -> do
liftIO $ renameFile (artifact </> "haskell-language-server" <.> exeExt)
(installDir </> "haskell-language-server-" <> takeFileName artifact <.> exeExt)
(tmpInstallDir </> "haskell-language-server-" <> takeFileName artifact <.> exeExt)
liftIO $ renameFile (artifact </> "haskell-language-server-wrapper" <.> exeExt)
(installDir </> "haskell-language-server-wrapper" <.> exeExt)
(tmpInstallDir </> "haskell-language-server-wrapper" <.> exeExt)
liftIO $ rmPathForcibly artifact
case isolateDir of
Just isoDir -> do
case installDir of
IsolateDir isoDir -> do
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
liftE $ installHLSUnpackedLegacy installDir isoDir Nothing True
Nothing -> do
liftE $ installHLSUnpackedLegacy installDir binDir (Just installVer) True
liftE $ installHLSUnpackedLegacy tmpInstallDir (IsolateDirResolved isoDir) installVer True
GHCupInternal -> do
liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupDir binDir) installVer True
)
pure installVer
@ -919,7 +934,7 @@ installStackBin :: ( MonadMask m
, MonadFail m
)
=> Version
-> Maybe FilePath -- ^ isolate install Dir (if any)
-> InstallDir
-> Bool -- ^ Force install
-> Excepts
'[ AlreadyInstalled
@ -936,9 +951,9 @@ installStackBin :: ( MonadMask m
]
m
()
installStackBin ver isoFilepath forceInstall = do
installStackBin ver installDir forceInstall = do
dlinfo <- liftE $ getDownloadInfo Stack ver
installStackBindist dlinfo ver isoFilepath forceInstall
installStackBindist dlinfo ver installDir forceInstall
-- | Like 'installStackBin', except takes the 'DownloadInfo' as
@ -957,7 +972,7 @@ installStackBindist :: ( MonadMask m
)
=> DownloadInfo
-> Version
-> Maybe FilePath -- ^ isolate install Dir (if any)
-> InstallDir
-> Bool -- ^ Force install
-> Excepts
'[ AlreadyInstalled
@ -974,7 +989,7 @@ installStackBindist :: ( MonadMask m
]
m
()
installStackBindist dlinfo ver isoFilepath forceInstall = do
installStackBindist dlinfo ver installDir forceInstall = do
lift $ logDebug $ "Requested to install stack version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq
@ -985,12 +1000,12 @@ installStackBindist dlinfo ver isoFilepath forceInstall = do
if
| not forceInstall
, regularStackInstalled
, Nothing <- isoFilepath -> do
, GHCupInternal <- installDir -> do
throwE $ AlreadyInstalled Stack ver
| forceInstall
, regularStackInstalled
, Nothing <- isoFilepath -> do
, GHCupInternal <- installDir -> do
lift $ logInfo "Removing the currently installed version of Stack first!"
liftE $ rmStackVer ver
@ -1007,29 +1022,32 @@ installStackBindist dlinfo ver isoFilepath forceInstall = do
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
case isoFilepath of
Just isoDir -> do -- isolated install
case installDir of
IsolateDir isoDir -> do -- isolated install
lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir
liftE $ installStackUnpacked workdir isoDir Nothing forceInstall
Nothing -> do -- regular install
liftE $ installStackUnpacked workdir binDir (Just ver) forceInstall
liftE $ installStackUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall
GHCupInternal -> do -- regular install
liftE $ installStackUnpacked workdir (GHCupDir binDir) ver forceInstall
-- | Install an unpacked stack distribution.
installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked stack bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated installs
-> InstallDirResolved
-> Version
-> Bool -- ^ Force install
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installStackUnpacked path inst mver' forceInstall = do
installStackUnpacked path installDir ver forceInstall = do
lift $ logInfo "Installing stack"
let stackFile = "stack"
liftIO $ createDirRecursive' inst
liftIO $ createDirRecursive' (fromInstallDir installDir)
let destFileName = stackFile
<> maybe "" (("-" <>) . T.unpack . prettyVer) mver'
<> (case installDir of
IsolateDirResolved _ -> ""
GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver
)
<> exeExt
destPath = inst </> destFileName
destPath = fromInstallDir installDir </> destFileName
unless forceInstall
(liftE $ throwIfFileAlreadyExists destPath)
@ -1223,7 +1241,7 @@ setHLS :: ( MonadReader env m
, MonadUnliftIO m
)
=> Version
-> SetHLS -- Nothing for legacy
-> SetHLS
-> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin
-- and don't want mess with other versions
-> Excepts '[NotInstalled] m ()
@ -2121,7 +2139,7 @@ compileGHC :: ( MonadMask m
-> [Text] -- ^ additional args to ./configure
-> Maybe String -- ^ build flavour
-> Bool
-> Maybe FilePath -- ^ isolate dir
-> InstallDir
-> Excepts
'[ AlreadyInstalled
, BuildFailed
@ -2146,7 +2164,7 @@ compileGHC :: ( MonadMask m
]
m
GHCTargetVersion
compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian isolateDir
compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian installDir
= do
PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
@ -2219,18 +2237,18 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer)
when alreadyInstalled $ do
case isolateDir of
Just isoDir ->
case installDir of
IsolateDir isoDir ->
lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Isolate installing to " <> T.pack isoDir
Nothing ->
GHCupInternal ->
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
ghcdir <- case installDir of
IsolateDir isoDir -> pure $ IsolateDirResolved isoDir
GHCupInternal -> GHCupDir <$> lift (ghcupGHCDir installVer)
(mBindist, bmk) <- liftE $ runBuildAction
tmpUnpack
@ -2243,8 +2261,8 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
pure (b, bmk)
)
case isolateDir of
Nothing ->
case installDir of
GHCupInternal ->
-- only remove old ghc in regular installs
when alreadyInstalled $ do
lift $ logInfo "Deleting existing installation"
@ -2259,11 +2277,11 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
(installVer ^. tvVersion)
False -- not a force install, since we already overwrite when compiling.
liftIO $ B.writeFile (ghcdir </> ghcUpSrcBuiltFile) bmk
liftIO $ B.writeFile (fromInstallDir ghcdir </> ghcUpSrcBuiltFile) bmk
case isolateDir of
case installDir of
-- set and make symlinks for regular (non-isolated) installs
Nothing -> do
GHCupInternal -> do
reThrowAll GHCupSetError $ postGHCInstall installVer
-- restore
when alreadySet $ liftE $ void $ setGHC installVer SetGHCOnly Nothing
@ -2292,7 +2310,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
)
=> GHCTargetVersion
-> FilePath
-> FilePath
-> InstallDirResolved
-> Excepts
'[ FileDoesNotExistError
, HadrianNotFound
@ -2351,7 +2369,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
)
=> GHCTargetVersion
-> FilePath
-> FilePath
-> InstallDirResolved
-> Excepts
'[ FileDoesNotExistError
, HadrianNotFound
@ -2486,7 +2504,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
)
=> GHCTargetVersion
-> FilePath
-> FilePath
-> InstallDirResolved
-> Excepts
'[ FileDoesNotExistError
, InvalidBuildConfig
@ -2497,7 +2515,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
]
m
()
configureBindist tver workdir ghcdir = do
configureBindist tver workdir (fromInstallDir -> ghcdir) = do
lift $ logInfo [s|configuring build|]
if | _tvVersion tver >= [vver|8.8.0|] -> do

13
lib/GHCup/Types.hs
View File

@ -628,3 +628,16 @@ data CapturedProcess = CapturedProcess
deriving (Eq, Show)
makeLenses ''CapturedProcess
data InstallDir = IsolateDir FilePath
| GHCupInternal
deriving (Eq, Show)
data InstallDirResolved = IsolateDirResolved FilePath
| GHCupDir FilePath
deriving (Eq, Show)
fromInstallDir :: InstallDirResolved -> FilePath
fromInstallDir (IsolateDirResolved fp) = fp
fromInstallDir (GHCupDir fp) = fp

5
lib/GHCup/Utils.hs
View File

@ -1265,9 +1265,10 @@ ghcBinaryName (GHCTargetVersion Nothing _) = T.unpack ("ghc" <> T.pack exeExt)
installDestSanityCheck :: ( MonadIO m
, MonadCatch m
) =>
FilePath ->
InstallDirResolved ->
Excepts '[DirNotEmpty] m ()
installDestSanityCheck isoDir = do
installDestSanityCheck (IsolateDirResolved isoDir) = do
hideErrorDef [doesNotExistErrorType] () $ do
contents <- liftIO $ getDirectoryContentsRecursive isoDir
unless (null contents) (throwE $ DirNotEmpty isoDir)
installDestSanityCheck _ = pure ()