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

Implements --force install for GHC

Browse Source
This commit is contained in:
Arjun Kathuria 2021-09-11 23:20:06 +05:30
parent 10a30bbf38
commit cadb5086e1
3 changed files with 40 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
app/ghcup/BrickMain.hs
View File

@ -440,7 +440,7 @@ 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 $> vi liftE $ installGHCBin lVer Nothing False $> vi
Cabal -> do Cabal -> do
let vi = getVersionInfo lVer Cabal dls let vi = getVersionInfo lVer Cabal dls
liftE $ installCabalBin lVer Nothing False $> vi liftE $ installCabalBin lVer Nothing False $> vi

12
app/ghcup/Main.hs
View File

@ -1737,7 +1737,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(case instBindist of (case instBindist of
Nothing -> runInstTool instPlatform $ do Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC (v, vi) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBin (_tvVersion v) isolateDir liftE $ installGHCBin
(_tvVersion v)
isolateDir
forceInstall
when instSet $ void $ liftE $ setGHC v SetGHCOnly when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi pure vi
Just uri -> do Just uri -> do
@ -1745,9 +1748,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC (v, vi) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBindist liftE $ installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "") (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v) (_tvVersion v)
isolateDir isolateDir
forceInstall
when instSet $ void $ liftE $ setGHC v SetGHCOnly when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi pure vi
) )

45
lib/GHCup.hs
View File

@ -184,6 +184,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 -> Maybe FilePath -- ^ isolated filepath if user passed any
-> Bool -- ^ Force install
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, BuildFailed , BuildFailed
@ -198,15 +199,26 @@ installGHCBindist :: ( MonadFail m
] ]
m m
() ()
installGHCBindist dlinfo ver isoFilepath = do installGHCBindist dlinfo ver isoFilepath 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
case isoFilepath of regularGHCInstalled <- lift $ checkIfToolInstalled GHC ver
-- we only care for already installed errors in regular (non-isolated) installs
Nothing -> whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver) if
_ -> pure () | 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) -- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
@ -215,13 +227,13 @@ installGHCBindist dlinfo ver isoFilepath = do
ghcdir <- lift $ ghcupGHCDir tver ghcdir <- lift $ ghcupGHCDir tver
toolchainSanityChecks toolchainSanityChecks
case isoFilepath of case isoFilepath of
Just isoDir -> do -- isolated install Just 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 liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver forceInstall
Nothing -> do -- regular install Nothing -> do -- regular install
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver forceInstall
-- make symlinks & stuff when regular install, -- make symlinks & stuff when regular install,
liftE $ postGHCInstall tver liftE $ postGHCInstall tver
@ -254,6 +266,7 @@ installPackedGHC :: ( MonadMask m
-> Maybe TarDir -- ^ Subdir of the archive -> Maybe TarDir -- ^ Subdir of the archive
-> FilePath -- ^ Path to install to -> FilePath -- ^ Path to install to
-> Version -- ^ The GHC version -> Version -- ^ The GHC version
-> Bool -- ^ Force install
-> Excepts -> Excepts
'[ BuildFailed '[ BuildFailed
, UnknownArchive , UnknownArchive
@ -261,10 +274,11 @@ installPackedGHC :: ( MonadMask m
, DirNotEmpty , DirNotEmpty
, ArchiveResult , ArchiveResult
] m () ] m ()
installPackedGHC dl msubdir inst ver = do installPackedGHC dl msubdir inst ver forceInstall = do
PlatformRequest {..} <- lift getPlatformReq PlatformRequest {..} <- lift getPlatformReq
liftE $ installDestSanityCheck inst unless forceInstall
(liftE $ installDestSanityCheck inst)
-- unpack -- unpack
tmpUnpack <- lift mkGhcupTmpDir tmpUnpack <- lift mkGhcupTmpDir
@ -275,7 +289,7 @@ installPackedGHC dl msubdir inst ver = 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) (Just inst)
(installUnpackedGHC workdir inst ver) (installUnpackedGHC workdir inst ver)
@ -365,6 +379,7 @@ installGHCBin :: ( MonadFail m
) )
=> Version -- ^ the version to install => Version -- ^ the version to install
-> Maybe FilePath -- ^ isolated install filepath, if user passed any -> Maybe FilePath -- ^ isolated install filepath, if user passed any
-> Bool -- ^ force install
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, BuildFailed , BuildFailed
@ -379,9 +394,9 @@ installGHCBin :: ( MonadFail m
] ]
m m
() ()
installGHCBin ver isoFilepath = do installGHCBin ver isoFilepath forceInstall = do
dlinfo <- liftE $ getDownloadInfo GHC ver dlinfo <- liftE $ getDownloadInfo GHC ver
installGHCBindist dlinfo ver isoFilepath installGHCBindist dlinfo ver isoFilepath forceInstall
-- | Like 'installCabalBin', except takes the 'DownloadInfo' as -- | Like 'installCabalBin', except takes the 'DownloadInfo' as
@ -479,8 +494,9 @@ checkIfToolInstalled tool ver = do
Cabal -> cabalInstalled ver Cabal -> cabalInstalled ver
HLS -> hlsInstalled ver HLS -> hlsInstalled ver
Stack -> stackInstalled ver Stack -> stackInstalled ver
GHC -> ghcInstalled $ mkTVer ver
_ -> pure False _ -> pure False
-- | 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)
@ -1960,6 +1976,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
(Just $ RegexDir "ghc-.*") (Just $ RegexDir "ghc-.*")
ghcdir ghcdir
(tver ^. tvVersion) (tver ^. tvVersion)
False -- not a force install, since we already overwrite when compiling.
liftIO $ B.writeFile (ghcdir </> ghcUpSrcBuiltFile) bmk liftIO $ B.writeFile (ghcdir </> ghcUpSrcBuiltFile) bmk