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

Refactor code around isolateDirs, so we have proper knowledge

This commit is contained in:
Julian Ospald 2022-05-11 15:47:08 +02:00
parent a34d9b7b89
commit 991e540c11
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
7 changed files with 188 additions and 157 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
app/ghcup/BrickMain.hs
View File

@ -446,19 +446,19 @@ install' _ (_, ListResult {..}) = do
case lTool of case lTool of
GHC -> do GHC -> do
let vi = getVersionInfo lVer GHC dls let vi = getVersionInfo lVer GHC dls
liftE $ installGHCBin lVer Nothing False $> (vi, dirs, ce) liftE $ installGHCBin lVer GHCupInternal False $> (vi, dirs, ce)
Cabal -> do Cabal -> do
let vi = getVersionInfo lVer Cabal dls let vi = getVersionInfo lVer Cabal dls
liftE $ installCabalBin lVer Nothing False $> (vi, dirs, ce) liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce)
GHCup -> do GHCup -> do
let vi = snd <$> getLatest dls GHCup let vi = snd <$> getLatest dls GHCup
liftE $ upgradeGHCup Nothing False $> (vi, dirs, ce) liftE $ upgradeGHCup Nothing False $> (vi, dirs, ce)
HLS -> do HLS -> do
let vi = getVersionInfo lVer HLS dls let vi = getVersionInfo lVer HLS dls
liftE $ installHLSBin lVer Nothing False $> (vi, dirs, ce) liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce)
Stack -> do Stack -> do
let vi = getVersionInfo lVer Stack dls let vi = getVersionInfo lVer Stack dls
liftE $ installStackBin lVer Nothing False $> (vi, dirs, ce) liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce)
) )
>>= \case >>= \case
VRight (vi, Dirs{..}, Just ce) -> do 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 ghcs
jobs jobs
ovewrwiteVer ovewrwiteVer
isolateDir (maybe GHCupInternal IsolateDir isolateDir)
cabalProject cabalProject
cabalProjectLocal cabalProjectLocal
patches patches
@ -524,7 +524,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
addConfArgs addConfArgs
buildFlavour buildFlavour
hadrian hadrian
isolateDir (maybe GHCupInternal IsolateDir isolateDir)
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion targetVer) GHC dls let vi = getVersionInfo (_tvVersion targetVer) GHC dls
when setCompile $ void $ liftE $ when setCompile $ void $ liftE $

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

@ -216,7 +216,7 @@ installOpts tool =
Nothing -> False Nothing -> False
Just GHC -> False Just GHC -> False
Just _ -> True Just _ -> True
@ -395,7 +395,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
(v, vi) <- liftE $ fromVersion instVer GHC (v, vi) <- liftE $ fromVersion instVer GHC
void $ liftE $ sequenceE (installGHCBin void $ liftE $ sequenceE (installGHCBin
(_tvVersion v) (_tvVersion v)
isolateDir (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
) )
$ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing $ 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 void $ liftE $ sequenceE (installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "") (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v) (_tvVersion v)
isolateDir (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
) )
$ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing $ 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 (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
void $ liftE $ sequenceE (installCabalBin void $ liftE $ sequenceE (installCabalBin
v v
isolateDir (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v ) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v
pure vi pure vi
@ -477,7 +477,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
void $ liftE $ sequenceE (installCabalBindist void $ liftE $ sequenceE (installCabalBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
v v
isolateDir (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v ) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v
pure vi pure vi
@ -518,7 +518,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
void $ liftE $ sequenceE (installHLSBin void $ liftE $ sequenceE (installHLSBin
v v
isolateDir (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing ) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing
pure vi pure vi
@ -529,7 +529,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
void $ liftE $ sequenceE (installHLSBindist void $ liftE $ sequenceE (installHLSBindist
(DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "") (DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "")
v v
isolateDir (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing ) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing
pure vi pure vi
@ -578,7 +578,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
void $ liftE $ sequenceE (installStackBin void $ liftE $ sequenceE (installStackBin
v v
isolateDir (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v ) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v
pure vi pure vi
@ -588,7 +588,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
void $ liftE $ sequenceE (installStackBindist void $ liftE $ sequenceE (installStackBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
v v
isolateDir (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v ) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v
pure vi 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 Just (GHC, v) -> do
unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin
(_tvVersion v) (_tvVersion v)
Nothing GHCupInternal
False False
setTool GHC v tmp setTool GHC v tmp
Just (Cabal, v) -> do Just (Cabal, v) -> do
unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin
(_tvVersion v) (_tvVersion v)
Nothing GHCupInternal
False False
setTool Cabal v tmp setTool Cabal v tmp
Just (Stack, v) -> do Just (Stack, v) -> do
unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin
(_tvVersion v) (_tvVersion v)
Nothing GHCupInternal
False False
setTool Stack v tmp setTool Stack v tmp
Just (HLS, v) -> do Just (HLS, v) -> do
unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin
(_tvVersion v) (_tvVersion v)
Nothing GHCupInternal
False False
setTool HLS v tmp setTool HLS v tmp
_ -> pure () _ -> pure ()

289
lib/GHCup.hs
View File

@ -187,7 +187,7 @@ installGHCBindist :: ( MonadFail m
) )
=> DownloadInfo -- ^ where/how to download => DownloadInfo -- ^ where/how to download
-> Version -- ^ the version to install -> Version -- ^ the version to install
-> Maybe FilePath -- ^ isolated filepath if user passed any -> InstallDir
-> Bool -- ^ Force install -> Bool -- ^ Force install
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
@ -205,22 +205,22 @@ installGHCBindist :: ( MonadFail m
] ]
m m
() ()
installGHCBindist dlinfo ver isoFilepath forceInstall = do installGHCBindist dlinfo ver installDir forceInstall = do
let tver = mkTVer ver let tver = mkTVer ver
lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver
regularGHCInstalled <- lift $ checkIfToolInstalled GHC ver regularGHCInstalled <- lift $ checkIfToolInstalled GHC ver
if if
| not forceInstall | not forceInstall
, regularGHCInstalled , regularGHCInstalled
, Nothing <- isoFilepath -> do , GHCupInternal <- installDir -> do
throwE $ AlreadyInstalled GHC ver throwE $ AlreadyInstalled GHC ver
| forceInstall | forceInstall
, regularGHCInstalled , regularGHCInstalled
, Nothing <- isoFilepath -> do , GHCupInternal <- installDir -> do
lift $ logInfo "Removing the currently installed GHC version first!" lift $ logInfo "Removing the currently installed GHC version first!"
liftE $ rmGHCVer tver liftE $ rmGHCVer tver
@ -229,17 +229,18 @@ installGHCBindist dlinfo ver isoFilepath forceInstall = do
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
-- prepare paths
ghcdir <- lift $ ghcupGHCDir tver
toolchainSanityChecks toolchainSanityChecks
case isoFilepath of case installDir of
Just isoDir -> do -- isolated install IsolateDir isoDir -> do -- isolated install
lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir
liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver forceInstall liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) ver forceInstall
Nothing -> do -- regular install GHCupInternal -> do -- regular install
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver forceInstall -- prepare paths
ghcdir <- lift $ ghcupGHCDir tver
liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) ver forceInstall
-- make symlinks & stuff when regular install, -- make symlinks & stuff when regular install,
liftE $ postGHCInstall tver liftE $ postGHCInstall tver
@ -271,7 +272,7 @@ installPackedGHC :: ( MonadMask m
) )
=> FilePath -- ^ Path to the packed GHC bindist => FilePath -- ^ Path to the packed GHC bindist
-> Maybe TarDir -- ^ Subdir of the archive -> Maybe TarDir -- ^ Subdir of the archive
-> FilePath -- ^ Path to install to -> InstallDirResolved
-> Version -- ^ The GHC version -> Version -- ^ The GHC version
-> Bool -- ^ Force install -> Bool -- ^ Force install
-> Excepts -> Excepts
@ -297,9 +298,13 @@ installPackedGHC dl msubdir inst ver forceInstall = do
workdir <- maybe (pure tmpUnpack) workdir <- maybe (pure tmpUnpack)
(liftE . intoSubdir tmpUnpack) (liftE . intoSubdir tmpUnpack)
msubdir msubdir
liftE $ runBuildAction tmpUnpack 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) (installUnpackedGHC workdir inst ver)
@ -315,11 +320,11 @@ installUnpackedGHC :: ( MonadReader env m
, MonadUnliftIO m , MonadUnliftIO m
, MonadMask m , MonadMask m
) )
=> FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides) => 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 -> Version -- ^ The GHC version
-> Excepts '[ProcessError] m () -> Excepts '[ProcessError] m ()
installUnpackedGHC path inst ver installUnpackedGHC path (fromInstallDir -> inst) ver
| isWindows = do | isWindows = do
lift $ logInfo "Installing GHC (this may take a while)" lift $ logInfo "Installing GHC (this may take a while)"
-- Windows bindists are relocatable and don't need -- Windows bindists are relocatable and don't need
@ -340,7 +345,7 @@ installUnpackedGHC path inst ver
lift $ logInfo "Installing GHC (this may take a while)" lift $ logInfo "Installing GHC (this may take a while)"
lEM $ execLogged "sh" lEM $ execLogged "sh"
("./configure" : ("--prefix=" <> inst) ("./configure" : ("--prefix=" <> inst)
: alpineArgs : alpineArgs
) )
(Just path) (Just path)
@ -369,7 +374,7 @@ installGHCBin :: ( MonadFail m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> Version -- ^ the version to install => Version -- ^ the version to install
-> Maybe FilePath -- ^ isolated install filepath, if user passed any -> InstallDir
-> Bool -- ^ force install -> Bool -- ^ force install
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
@ -387,9 +392,9 @@ installGHCBin :: ( MonadFail m
] ]
m m
() ()
installGHCBin ver isoFilepath forceInstall = do installGHCBin ver installDir forceInstall = do
dlinfo <- liftE $ getDownloadInfo GHC ver dlinfo <- liftE $ getDownloadInfo GHC ver
liftE $ installGHCBindist dlinfo ver isoFilepath forceInstall liftE $ installGHCBindist dlinfo ver installDir forceInstall
-- | Like 'installCabalBin', except takes the 'DownloadInfo' as -- | Like 'installCabalBin', except takes the 'DownloadInfo' as
@ -408,8 +413,8 @@ installCabalBindist :: ( MonadMask m
) )
=> DownloadInfo => DownloadInfo
-> Version -> Version
-> Maybe FilePath -- ^ isolated install filepath, if user provides any. -> InstallDir
-> Bool -- ^ Force install -> Bool -- ^ Force install
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, CopyError , CopyError
@ -425,7 +430,7 @@ installCabalBindist :: ( MonadMask m
] ]
m m
() ()
installCabalBindist dlinfo ver isoFilepath forceInstall = do installCabalBindist dlinfo ver installDir forceInstall = do
lift $ logDebug $ "Requested to install cabal version " <> prettyVer ver lift $ logDebug $ "Requested to install cabal version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq PlatformRequest {..} <- lift getPlatformReq
@ -437,18 +442,18 @@ installCabalBindist dlinfo ver isoFilepath forceInstall = do
if if
| not forceInstall | not forceInstall
, regularCabalInstalled , regularCabalInstalled
, Nothing <- isoFilepath -> do , GHCupInternal <- installDir -> do
throwE $ AlreadyInstalled Cabal ver throwE $ AlreadyInstalled Cabal ver
| forceInstall | forceInstall
, regularCabalInstalled , regularCabalInstalled
, Nothing <- isoFilepath -> do , GHCupInternal <- installDir -> do
lift $ logInfo "Removing the currently installed version first!" lift $ logInfo "Removing the currently installed version first!"
liftE $ rmCabalVer ver liftE $ rmCabalVer ver
| otherwise -> pure () | otherwise -> pure ()
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
@ -460,34 +465,37 @@ installCabalBindist dlinfo ver isoFilepath forceInstall = do
-- the subdir of the archive where we do the work -- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
case isoFilepath of case installDir of
Just isoDir -> do -- isolated install IsolateDir isoDir -> do -- isolated install
lift $ logInfo $ "isolated installing Cabal to " <> T.pack isoDir lift $ logInfo $ "isolated installing Cabal to " <> T.pack isoDir
liftE $ installCabalUnpacked workdir isoDir Nothing forceInstall liftE $ installCabalUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall
GHCupInternal -> do -- regular install
liftE $ installCabalUnpacked workdir (GHCupDir binDir) ver forceInstall
Nothing -> do -- regular install
liftE $ installCabalUnpacked workdir binDir (Just ver) forceInstall
-- | Install an unpacked cabal distribution.Symbol -- | Install an unpacked cabal distribution.Symbol
installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m) installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m)
=> FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides) => FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)
-> FilePath -- ^ Path to install to -> InstallDirResolved -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated install -> Version
-> Bool -- ^ Force Install -> Bool -- ^ Force Install
-> Excepts '[CopyError, FileAlreadyExistsError] m () -> Excepts '[CopyError, FileAlreadyExistsError] m ()
installCabalUnpacked path inst mver' forceInstall = do installCabalUnpacked path inst ver forceInstall = do
lift $ logInfo "Installing cabal" lift $ logInfo "Installing cabal"
let cabalFile = "cabal" let cabalFile = "cabal"
liftIO $ createDirRecursive' inst liftIO $ createDirRecursive' (fromInstallDir inst)
let destFileName = cabalFile let destFileName = cabalFile
<> maybe "" (("-" <>) . T.unpack . prettyVer) mver' <> (case inst of
IsolateDirResolved _ -> ""
GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver
)
<> exeExt <> exeExt
let destPath = inst </> destFileName let destPath = fromInstallDir inst </> destFileName
unless forceInstall -- Overwrite it when it IS a force install unless forceInstall -- Overwrite it when it IS a force install
(liftE $ throwIfFileAlreadyExists destPath) (liftE $ throwIfFileAlreadyExists destPath)
copyFileE copyFileE
(path </> cabalFile <> exeExt) (path </> cabalFile <> exeExt)
destPath destPath
@ -510,7 +518,7 @@ installCabalBin :: ( MonadMask m
, MonadFail m , MonadFail m
) )
=> Version => Version
-> Maybe FilePath -- isolated install Path, if user provided any -> InstallDir
-> Bool -- force install -> Bool -- force install
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
@ -527,9 +535,9 @@ installCabalBin :: ( MonadMask m
] ]
m m
() ()
installCabalBin ver isoFilepath forceInstall = do installCabalBin ver installDir forceInstall = do
dlinfo <- liftE $ getDownloadInfo Cabal ver dlinfo <- liftE $ getDownloadInfo Cabal ver
installCabalBindist dlinfo ver isoFilepath forceInstall installCabalBindist dlinfo ver installDir forceInstall
-- | Like 'installHLSBin, except takes the 'DownloadInfo' as -- | Like 'installHLSBin, except takes the 'DownloadInfo' as
@ -548,8 +556,8 @@ installHLSBindist :: ( MonadMask m
) )
=> DownloadInfo => DownloadInfo
-> Version -> Version
-> Maybe FilePath -- ^ isolated install path, if user passed any -> InstallDir -- ^ isolated install path, if user passed any
-> Bool -- ^ Force install -> Bool -- ^ Force install
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, CopyError , CopyError
@ -567,7 +575,7 @@ installHLSBindist :: ( MonadMask m
] ]
m m
() ()
installHLSBindist dlinfo ver isoFilepath forceInstall = do installHLSBindist dlinfo ver installDir forceInstall = do
lift $ logDebug $ "Requested to install hls version " <> prettyVer ver lift $ logDebug $ "Requested to install hls version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq PlatformRequest {..} <- lift getPlatformReq
@ -578,17 +586,17 @@ installHLSBindist dlinfo ver isoFilepath forceInstall = do
if if
| not forceInstall | not forceInstall
, regularHLSInstalled , regularHLSInstalled
, Nothing <- isoFilepath -> do -- regular install , GHCupInternal <- installDir -> do -- regular install
throwE $ AlreadyInstalled HLS ver throwE $ AlreadyInstalled HLS ver
| forceInstall | forceInstall
, regularHLSInstalled , 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!" lift $ logInfo "Removing the currently installed version of HLS before force installing!"
liftE $ rmHLSVer ver liftE $ rmHLSVer ver
| otherwise -> pure () | otherwise -> pure ()
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
@ -604,22 +612,22 @@ installHLSBindist dlinfo ver isoFilepath forceInstall = do
if if
| not forceInstall | not forceInstall
, not legacy , not legacy
, (Just fp) <- isoFilepath -> liftE $ installDestSanityCheck fp , (IsolateDir fp) <- installDir -> liftE $ installDestSanityCheck (IsolateDirResolved fp)
| otherwise -> pure () | otherwise -> pure ()
case isoFilepath of case installDir of
Just isoDir -> do IsolateDir isoDir -> do
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
if legacy if legacy
then liftE $ installHLSUnpackedLegacy workdir isoDir Nothing forceInstall then liftE $ installHLSUnpackedLegacy workdir (IsolateDirResolved isoDir) ver forceInstall
else liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir isoDir ver else liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir (IsolateDirResolved isoDir) ver
Nothing -> do GHCupInternal -> do
if legacy if legacy
then liftE $ installHLSUnpackedLegacy workdir binDir (Just ver) forceInstall then liftE $ installHLSUnpackedLegacy workdir (GHCupDir binDir) ver forceInstall
else do else do
inst <- ghcupHLSDir ver inst <- ghcupHLSDir ver
liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir inst ver liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir (GHCupDir inst) ver
liftE $ setHLS ver SetHLS_XYZ Nothing liftE $ setHLS ver SetHLS_XYZ Nothing
@ -631,10 +639,10 @@ isLegacyHLSBindist path = do
-- | Install an unpacked hls distribution. -- | 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) 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 the unpacked hls bindist (where the executable resides)
-> FilePath -- ^ Path to install to -> InstallDirResolved -- ^ Path to install to
-> Version -> Version
-> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m () -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m ()
installHLSUnpacked path inst _ = do installHLSUnpacked path (fromInstallDir -> inst) _ = do
lift $ logInfo "Installing HLS" lift $ logInfo "Installing HLS"
liftIO $ createDirRecursive' inst liftIO $ createDirRecursive' inst
lEM $ make ["PREFIX=" <> inst, "install"] (Just path) lEM $ make ["PREFIX=" <> inst, "install"] (Just path)
@ -642,13 +650,13 @@ installHLSUnpacked path inst _ = do
-- | Install an unpacked hls distribution (legacy). -- | Install an unpacked hls distribution (legacy).
installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m) 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 the unpacked hls bindist (where the executable resides)
-> FilePath -- ^ Path to install to -> InstallDirResolved -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated install -> Version
-> Bool -- ^ is it a force install -> Bool -- ^ is it a force install
-> Excepts '[CopyError, FileAlreadyExistsError] m () -> Excepts '[CopyError, FileAlreadyExistsError] m ()
installHLSUnpackedLegacy path inst mver' forceInstall = do installHLSUnpackedLegacy path installDir ver forceInstall = do
lift $ logInfo "Installing HLS" lift $ logInfo "Installing HLS"
liftIO $ createDirRecursive' inst liftIO $ createDirRecursive' (fromInstallDir installDir)
-- install haskell-language-server-<ghcver> -- install haskell-language-server-<ghcver>
bins@(_:_) <- liftIO $ findFiles bins@(_:_) <- liftIO $ findFiles
@ -659,15 +667,18 @@ installHLSUnpackedLegacy path inst mver' forceInstall = do
) )
forM_ bins $ \f -> do forM_ bins $ \f -> do
let toF = dropSuffix exeExt f let toF = dropSuffix exeExt f
<> maybe "" (("~" <>) . T.unpack . prettyVer) mver' <> (case installDir of
IsolateDirResolved _ -> ""
GHCupDir _ -> ("~" <>) . T.unpack . prettyVer $ ver
)
<> exeExt <> exeExt
let srcPath = path </> f let srcPath = path </> f
let destPath = inst </> toF let destPath = fromInstallDir installDir </> toF
unless forceInstall -- if it is a force install, overwrite it. unless forceInstall -- if it is a force install, overwrite it.
(liftE $ throwIfFileAlreadyExists destPath) (liftE $ throwIfFileAlreadyExists destPath)
copyFileE copyFileE
srcPath srcPath
destPath destPath
@ -676,18 +687,21 @@ installHLSUnpackedLegacy path inst mver' forceInstall = do
-- install haskell-language-server-wrapper -- install haskell-language-server-wrapper
let wrapper = "haskell-language-server-wrapper" let wrapper = "haskell-language-server-wrapper"
toF = wrapper toF = wrapper
<> maybe "" (("-" <>) . T.unpack . prettyVer) mver' <> (case installDir of
IsolateDirResolved _ -> ""
GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver
)
<> exeExt <> exeExt
srcWrapperPath = path </> wrapper <> exeExt srcWrapperPath = path </> wrapper <> exeExt
destWrapperPath = inst </> toF destWrapperPath = fromInstallDir installDir </> toF
unless forceInstall unless forceInstall
(liftE $ throwIfFileAlreadyExists destWrapperPath) (liftE $ throwIfFileAlreadyExists destWrapperPath)
copyFileE copyFileE
srcWrapperPath srcWrapperPath
destWrapperPath destWrapperPath
lift $ chmod_755 destWrapperPath lift $ chmod_755 destWrapperPath
@ -708,7 +722,7 @@ installHLSBin :: ( MonadMask m
, MonadFail m , MonadFail m
) )
=> Version => Version
-> Maybe FilePath -- isolated install Dir (if any) -> InstallDir
-> Bool -- force install -> Bool -- force install
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
@ -727,9 +741,9 @@ installHLSBin :: ( MonadMask m
] ]
m m
() ()
installHLSBin ver isoFilepath forceInstall = do installHLSBin ver installDir forceInstall = do
dlinfo <- liftE $ getDownloadInfo HLS ver dlinfo <- liftE $ getDownloadInfo HLS ver
installHLSBindist dlinfo ver isoFilepath forceInstall installHLSBindist dlinfo ver installDir forceInstall
compileHLS :: ( MonadMask m compileHLS :: ( MonadMask m
@ -749,7 +763,7 @@ compileHLS :: ( MonadMask m
-> [Version] -> [Version]
-> Maybe Int -> Maybe Int
-> Maybe Version -> Maybe Version
-> Maybe FilePath -> InstallDir
-> Maybe (Either FilePath URI) -> Maybe (Either FilePath URI)
-> Maybe URI -> Maybe URI
-> Maybe (Either FilePath [URI]) -- ^ patches -> Maybe (Either FilePath [URI]) -- ^ patches
@ -764,7 +778,7 @@ compileHLS :: ( MonadMask m
, BuildFailed , BuildFailed
, NotInstalled , NotInstalled
] m Version ] 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 PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
Dirs { .. } <- lift getDirs Dirs { .. } <- lift getDirs
@ -805,7 +819,7 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc
, "origin" , "origin"
, fromString rep ] , fromString rep ]
let fetch_args = let fetch_args =
[ "fetch" [ "fetch"
, "--depth" , "--depth"
, "1" , "1"
@ -837,8 +851,8 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc
workdir workdir
Nothing Nothing
(reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do
let installDir = workdir </> "out" let tmpInstallDir = workdir </> "out"
liftIO $ createDirRecursive' installDir liftIO $ createDirRecursive' tmpInstallDir
-- apply patches -- apply patches
liftE $ applyAnyPatch patches workdir liftE $ applyAnyPatch patches workdir
@ -861,8 +875,8 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc
cpl <- liftE $ download uri Nothing Nothing tmpUnpack (Just (cp <.> "local")) False cpl <- liftE $ download uri Nothing Nothing tmpUnpack (Just (cp <.> "local")) False
copyFileE cpl (workdir </> cp <.> "local") copyFileE cpl (workdir </> cp <.> "local")
artifacts <- forM (sort ghcs) $ \ghc -> do artifacts <- forM (sort ghcs) $ \ghc -> do
let ghcInstallDir = installDir </> T.unpack (prettyVer ghc) let ghcInstallDir = tmpInstallDir </> T.unpack (prettyVer ghc)
liftIO $ createDirRecursive' installDir liftIO $ createDirRecursive' tmpInstallDir
lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc
liftE $ lEM @_ @'[ProcessError] $ liftE $ lEM @_ @'[ProcessError] $
execLogged "cabal" ( [ "v2-install" execLogged "cabal" ( [ "v2-install"
@ -885,17 +899,17 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc
forM_ artifacts $ \artifact -> do forM_ artifacts $ \artifact -> do
liftIO $ renameFile (artifact </> "haskell-language-server" <.> exeExt) 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) liftIO $ renameFile (artifact </> "haskell-language-server-wrapper" <.> exeExt)
(installDir </> "haskell-language-server-wrapper" <.> exeExt) (tmpInstallDir </> "haskell-language-server-wrapper" <.> exeExt)
liftIO $ rmPathForcibly artifact liftIO $ rmPathForcibly artifact
case isolateDir of case installDir of
Just isoDir -> do IsolateDir isoDir -> do
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
liftE $ installHLSUnpackedLegacy installDir isoDir Nothing True liftE $ installHLSUnpackedLegacy tmpInstallDir (IsolateDirResolved isoDir) installVer True
Nothing -> do GHCupInternal -> do
liftE $ installHLSUnpackedLegacy installDir binDir (Just installVer) True liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupDir binDir) installVer True
) )
pure installVer pure installVer
@ -919,7 +933,7 @@ installStackBin :: ( MonadMask m
, MonadFail m , MonadFail m
) )
=> Version => Version
-> Maybe FilePath -- ^ isolate install Dir (if any) -> InstallDir
-> Bool -- ^ Force install -> Bool -- ^ Force install
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
@ -936,9 +950,9 @@ installStackBin :: ( MonadMask m
] ]
m m
() ()
installStackBin ver isoFilepath forceInstall = do installStackBin ver installDir forceInstall = do
dlinfo <- liftE $ getDownloadInfo Stack ver dlinfo <- liftE $ getDownloadInfo Stack ver
installStackBindist dlinfo ver isoFilepath forceInstall installStackBindist dlinfo ver installDir forceInstall
-- | Like 'installStackBin', except takes the 'DownloadInfo' as -- | Like 'installStackBin', except takes the 'DownloadInfo' as
@ -957,7 +971,7 @@ installStackBindist :: ( MonadMask m
) )
=> DownloadInfo => DownloadInfo
-> Version -> Version
-> Maybe FilePath -- ^ isolate install Dir (if any) -> InstallDir
-> Bool -- ^ Force install -> Bool -- ^ Force install
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
@ -974,7 +988,7 @@ installStackBindist :: ( MonadMask m
] ]
m m
() ()
installStackBindist dlinfo ver isoFilepath forceInstall = do installStackBindist dlinfo ver installDir forceInstall = do
lift $ logDebug $ "Requested to install stack version " <> prettyVer ver lift $ logDebug $ "Requested to install stack version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq PlatformRequest {..} <- lift getPlatformReq
@ -985,12 +999,12 @@ installStackBindist dlinfo ver isoFilepath forceInstall = do
if if
| not forceInstall | not forceInstall
, regularStackInstalled , regularStackInstalled
, Nothing <- isoFilepath -> do , GHCupInternal <- installDir -> do
throwE $ AlreadyInstalled Stack ver throwE $ AlreadyInstalled Stack ver
| forceInstall | forceInstall
, regularStackInstalled , regularStackInstalled
, Nothing <- isoFilepath -> do , GHCupInternal <- installDir -> do
lift $ logInfo "Removing the currently installed version of Stack first!" lift $ logInfo "Removing the currently installed version of Stack first!"
liftE $ rmStackVer ver liftE $ rmStackVer ver
@ -1007,33 +1021,36 @@ installStackBindist dlinfo ver isoFilepath forceInstall = do
-- the subdir of the archive where we do the work -- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
case isoFilepath of case installDir of
Just isoDir -> do -- isolated install IsolateDir isoDir -> do -- isolated install
lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir
liftE $ installStackUnpacked workdir isoDir Nothing forceInstall liftE $ installStackUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall
Nothing -> do -- regular install GHCupInternal -> do -- regular install
liftE $ installStackUnpacked workdir binDir (Just ver) forceInstall liftE $ installStackUnpacked workdir (GHCupDir binDir) ver forceInstall
-- | Install an unpacked stack distribution. -- | Install an unpacked stack distribution.
installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m) installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked stack bindist (where the executable resides) => FilePath -- ^ Path to the unpacked stack bindist (where the executable resides)
-> FilePath -- ^ Path to install to -> InstallDirResolved
-> Maybe Version -- ^ Nothing for isolated installs -> Version
-> Bool -- ^ Force install -> Bool -- ^ Force install
-> Excepts '[CopyError, FileAlreadyExistsError] m () -> Excepts '[CopyError, FileAlreadyExistsError] m ()
installStackUnpacked path inst mver' forceInstall = do installStackUnpacked path installDir ver forceInstall = do
lift $ logInfo "Installing stack" lift $ logInfo "Installing stack"
let stackFile = "stack" let stackFile = "stack"
liftIO $ createDirRecursive' inst liftIO $ createDirRecursive' (fromInstallDir installDir)
let destFileName = stackFile let destFileName = stackFile
<> maybe "" (("-" <>) . T.unpack . prettyVer) mver' <> (case installDir of
IsolateDirResolved _ -> ""
GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver
)
<> exeExt <> exeExt
destPath = inst </> destFileName destPath = fromInstallDir installDir </> destFileName
unless forceInstall unless forceInstall
(liftE $ throwIfFileAlreadyExists destPath) (liftE $ throwIfFileAlreadyExists destPath)
copyFileE copyFileE
(path </> stackFile <> exeExt) (path </> stackFile <> exeExt)
destPath destPath
@ -1099,7 +1116,7 @@ setGHC ver sghc mBinDir = do
SetGHC_XY -> do SetGHC_XY -> do
handle handle
(\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing) (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
$ do $ do
(mj, mi) <- getMajorMinorV (_tvVersion ver) (mj, mi) <- getMajorMinorV (_tvVersion ver)
let major' = intToText mj <> "." <> intToText mi let major' = intToText mj <> "." <> intToText mi
pure $ Just (file <> "-" <> T.unpack major') pure $ Just (file <> "-" <> T.unpack major')
@ -1223,7 +1240,7 @@ setHLS :: ( MonadReader env m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> Version => Version
-> SetHLS -- Nothing for legacy -> SetHLS
-> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin -> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin
-- and don't want mess with other versions -- and don't want mess with other versions
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
@ -1357,7 +1374,7 @@ warnAboutHlsCompatibility = do
"Haskell IDE support may not work until this is fixed." <> "\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" <> "Install a different HLS version, or install and set one of the following GHCs:" <> "\n" <>
T.pack (prettyShow supportedGHC) T.pack (prettyShow supportedGHC)
_ -> return () _ -> return ()
------------------ ------------------
@ -1962,7 +1979,7 @@ rmGhcupDirs = do
handleRm $ rmEnvFile envFilePath handleRm $ rmEnvFile envFilePath
handleRm $ rmConfFile confFilePath handleRm $ rmConfFile confFilePath
-- for xdg dirs, the order matters here -- for xdg dirs, the order matters here
handleRm $ rmDir logsDir handleRm $ rmDir logsDir
handleRm $ rmDir cacheDir handleRm $ rmDir cacheDir
@ -2036,7 +2053,7 @@ rmGhcupDirs = do
cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>) cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
forM_ cs removeEmptyDirsRecursive forM_ cs removeEmptyDirsRecursive
hideError InappropriateType $ removeDirIfEmptyOrIsSymlink fp hideError InappropriateType $ removeDirIfEmptyOrIsSymlink fp
-- we expect only files inside cache/log dir -- we expect only files inside cache/log dir
-- we report remaining files/dirs later, -- we report remaining files/dirs later,
@ -2121,7 +2138,7 @@ compileGHC :: ( MonadMask m
-> [Text] -- ^ additional args to ./configure -> [Text] -- ^ additional args to ./configure
-> Maybe String -- ^ build flavour -> Maybe String -- ^ build flavour
-> Bool -> Bool
-> Maybe FilePath -- ^ isolate dir -> InstallDir
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, BuildFailed , BuildFailed
@ -2146,7 +2163,7 @@ compileGHC :: ( MonadMask m
] ]
m m
GHCTargetVersion GHCTargetVersion
compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian isolateDir compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian installDir
= do = do
PlatformRequest { .. } <- lift getPlatformReq PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
@ -2187,7 +2204,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
, "origin" , "origin"
, fromString rep ] , fromString rep ]
let fetch_args = let fetch_args =
[ "fetch" [ "fetch"
, "--depth" , "--depth"
, "1" , "1"
@ -2219,18 +2236,18 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer) alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer)
when alreadyInstalled $ do when alreadyInstalled $ do
case isolateDir of case installDir of
Just isoDir -> IsolateDir isoDir ->
lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Isolate installing to " <> T.pack 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 $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Will overwrite existing version."
lift $ logWarn lift $ logWarn
"...waiting for 10 seconds before continuing, you can still abort..." "...waiting for 10 seconds before continuing, you can still abort..."
liftIO $ threadDelay 10000000 -- give the user a sec to intervene liftIO $ threadDelay 10000000 -- give the user a sec to intervene
ghcdir <- case isolateDir of ghcdir <- case installDir of
Just isoDir -> pure isoDir IsolateDir isoDir -> pure $ IsolateDirResolved isoDir
Nothing -> lift $ ghcupGHCDir installVer GHCupInternal -> GHCupDir <$> lift (ghcupGHCDir installVer)
(mBindist, bmk) <- liftE $ runBuildAction (mBindist, bmk) <- liftE $ runBuildAction
tmpUnpack tmpUnpack
@ -2243,13 +2260,13 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
pure (b, bmk) pure (b, bmk)
) )
case isolateDir of case installDir of
Nothing -> GHCupInternal ->
-- only remove old ghc in regular installs -- only remove old ghc in regular installs
when alreadyInstalled $ do when alreadyInstalled $ do
lift $ logInfo "Deleting existing installation" lift $ logInfo "Deleting existing installation"
liftE $ rmGHCVer installVer liftE $ rmGHCVer installVer
_ -> pure () _ -> pure ()
forM_ mBindist $ \bindist -> do forM_ mBindist $ \bindist -> do
@ -2259,21 +2276,21 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
(installVer ^. tvVersion) (installVer ^. tvVersion)
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 (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 -- set and make symlinks for regular (non-isolated) installs
Nothing -> do GHCupInternal -> do
reThrowAll GHCupSetError $ postGHCInstall installVer reThrowAll GHCupSetError $ postGHCInstall installVer
-- restore -- restore
when alreadySet $ liftE $ void $ setGHC installVer SetGHCOnly Nothing when alreadySet $ liftE $ void $ setGHC installVer SetGHCOnly Nothing
_ -> pure () _ -> pure ()
pure installVer pure installVer
where where
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")))
default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default"))) default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default")))
in case targetGhc of in case targetGhc of
@ -2292,7 +2309,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
) )
=> GHCTargetVersion => GHCTargetVersion
-> FilePath -> FilePath
-> FilePath -> InstallDirResolved
-> Excepts -> Excepts
'[ FileDoesNotExistError '[ FileDoesNotExistError
, HadrianNotFound , HadrianNotFound
@ -2351,7 +2368,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
) )
=> GHCTargetVersion => GHCTargetVersion
-> FilePath -> FilePath
-> FilePath -> InstallDirResolved
-> Excepts -> Excepts
'[ FileDoesNotExistError '[ FileDoesNotExistError
, HadrianNotFound , HadrianNotFound
@ -2486,7 +2503,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
) )
=> GHCTargetVersion => GHCTargetVersion
-> FilePath -> FilePath
-> FilePath -> InstallDirResolved
-> Excepts -> Excepts
'[ FileDoesNotExistError '[ FileDoesNotExistError
, InvalidBuildConfig , InvalidBuildConfig
@ -2497,7 +2514,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
] ]
m m
() ()
configureBindist tver workdir ghcdir = do configureBindist tver workdir (fromInstallDir -> ghcdir) = do
lift $ logInfo [s|configuring build|] lift $ logInfo [s|configuring build|]
if | _tvVersion tver >= [vver|8.8.0|] -> do if | _tvVersion tver >= [vver|8.8.0|] -> do

13
lib/GHCup/Types.hs
View File

@ -628,3 +628,16 @@ data CapturedProcess = CapturedProcess
deriving (Eq, Show) deriving (Eq, Show)
makeLenses ''CapturedProcess 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 installDestSanityCheck :: ( MonadIO m
, MonadCatch m , MonadCatch m
) => ) =>
FilePath -> InstallDirResolved ->
Excepts '[DirNotEmpty] m () Excepts '[DirNotEmpty] m ()
installDestSanityCheck isoDir = do installDestSanityCheck (IsolateDirResolved isoDir) = do
hideErrorDef [doesNotExistErrorType] () $ do hideErrorDef [doesNotExistErrorType] () $ do
contents <- liftIO $ getDirectoryContentsRecursive isoDir contents <- liftIO $ getDirectoryContentsRecursive isoDir
unless (null contents) (throwE $ DirNotEmpty isoDir) unless (null contents) (throwE $ DirNotEmpty isoDir)
installDestSanityCheck _ = pure ()