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

Merge remote-tracking branch 'origin/merge-requests/156'

Browse Source
This commit is contained in:
Julian Ospald 2021-09-18 15:19:06 +02:00
commit d3a36c2c9a
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
4 changed files with 172 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
app/ghcup/BrickMain.hs
View File

@ -440,19 +440,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 $> 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 $> vi liftE $ installCabalBin lVer Nothing False $> vi
GHCup -> do GHCup -> do
let vi = snd <$> getLatest dls GHCup let vi = snd <$> getLatest dls GHCup
liftE $ upgradeGHCup Nothing False $> vi liftE $ upgradeGHCup Nothing False $> vi
HLS -> do HLS -> do
let vi = getVersionInfo lVer HLS dls let vi = getVersionInfo lVer HLS dls
liftE $ installHLSBin lVer Nothing $> vi liftE $ installHLSBin lVer Nothing False $> vi
Stack -> do Stack -> do
let vi = getVersionInfo lVer Stack dls let vi = getVersionInfo lVer Stack dls
liftE $ installStackBin lVer Nothing $> vi liftE $ installStackBin lVer Nothing False $> vi
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do

56
app/ghcup/Main.hs
View File

@ -141,6 +141,7 @@ data InstallOptions = InstallOptions
, instBindist :: Maybe URI , instBindist :: Maybe URI
, instSet :: Bool , instSet :: Bool
, isolateDir :: Maybe FilePath , isolateDir :: Maybe FilePath
, forceInstall :: Bool
} }
data SetCommand = SetGHC SetOptions data SetCommand = SetGHC SetOptions
@ -602,7 +603,7 @@ Examples:
installOpts :: Maybe Tool -> Parser InstallOptions installOpts :: Maybe Tool -> Parser InstallOptions
installOpts tool = installOpts tool =
(\p (u, v) b is -> InstallOptions v p u b is) (\p (u, v) b is f -> InstallOptions v p u b is f)
<$> optional <$> optional
(option (option
(eitherReader platformParser) (eitherReader platformParser)
@ -640,6 +641,9 @@ installOpts tool =
<> help "install in an isolated dir instead of the default one" <> help "install in an isolated dir instead of the default one"
) )
) )
<*> switch
(short 'f' <> long "force" <> help "Force install")
setParser :: Parser (Either SetCommand SetOptions) setParser :: Parser (Either SetCommand SetOptions)
@ -1733,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
@ -1741,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
) )
@ -1775,16 +1783,20 @@ 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 Cabal (v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBin (_tvVersion v) isolateDir liftE $ installCabalBin
(_tvVersion v)
isolateDir
forceInstall
pure vi pure vi
Just uri -> do Just uri -> do
s' <- appState s' <- appState
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Cabal (v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBindist liftE $ installCabalBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
(_tvVersion v) (_tvVersion v)
isolateDir isolateDir
forceInstall
pure vi pure vi
) )
>>= \case >>= \case
@ -1807,16 +1819,20 @@ 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 HLS (v, vi) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBin (_tvVersion v) isolateDir liftE $ installHLSBin
(_tvVersion v)
isolateDir
forceInstall
pure vi pure vi
Just uri -> do Just uri -> do
s' <- appState s' <- appState
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer HLS (v, vi) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBindist liftE $ installHLSBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
(_tvVersion v) (_tvVersion v)
isolateDir isolateDir
forceInstall
pure vi pure vi
) )
>>= \case >>= \case
@ -1843,16 +1859,20 @@ 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 Stack (v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBin (_tvVersion v) isolateDir liftE $ installStackBin
(_tvVersion v)
isolateDir
forceInstall
pure vi pure vi
Just uri -> do Just uri -> do
s' <- appState s' <- appState
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack (v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBindist liftE $ installStackBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
(_tvVersion v) (_tvVersion v)
isolateDir isolateDir
forceInstall
pure vi pure vi
) )
>>= \case >>= \case

192
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
@ -401,6 +416,7 @@ installCabalBindist :: ( MonadMask m
=> DownloadInfo => DownloadInfo
-> Version -> Version
-> Maybe FilePath -- ^ isolated install filepath, if user provides any. -> Maybe FilePath -- ^ isolated install filepath, if user provides any.
-> Bool -- ^ Force install
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, CopyError , CopyError
@ -415,25 +431,30 @@ installCabalBindist :: ( MonadMask m
] ]
m m
() ()
installCabalBindist dlinfo ver isoFilepath = do installCabalBindist dlinfo ver isoFilepath 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
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
case isoFilepath of -- check if we already have a regular cabal already installed
Nothing -> -- for regular install check if any previous versions installed regularCabalInstalled <- lift $ checkIfToolInstalled Cabal ver
whenM
(lift (cabalInstalled ver) >>= \a -> liftIO $
handleIO (\_ -> pure False)
$ fmap (\x -> a && x)
-- ignore when the installation is a legacy cabal (binary, not symlink)
$ pathIsLink (binDir </> "cabal" <> exeExt)
)
(throwE $ AlreadyInstalled Cabal ver)
_ -> pure () -- check isn't required in isolated installs if
| not forceInstall
, regularCabalInstalled
, Nothing <- isoFilepath -> do
throwE $ AlreadyInstalled Cabal ver
| forceInstall
, regularCabalInstalled
, Nothing <- isoFilepath -> do
lift $ logInfo $ "Removing the currently installed version first!"
liftE $ rmCabalVer ver
| otherwise -> pure ()
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
@ -448,23 +469,24 @@ installCabalBindist dlinfo ver isoFilepath = do
case isoFilepath of case isoFilepath of
Just isoDir -> do -- isolated install Just 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 liftE $ installCabalUnpacked workdir isoDir Nothing forceInstall
Nothing -> do -- regular install Nothing -> do -- regular install
liftE $ installCabalUnpacked workdir binDir (Just ver) liftE $ installCabalUnpacked workdir binDir (Just ver) forceInstall
-- create symlink if this is the latest version for regular installs -- create symlink if this is the latest version for regular installs
cVers <- lift $ fmap rights getInstalledCabals cVers <- lift $ fmap rights getInstalledCabals
let lInstCabal = headMay . reverse . sort $ cVers let lInstCabal = headMay . reverse . sort $ cVers
when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver
-- | Install an unpacked cabal distribution. -- | Install an unpacked cabal distribution.Symbol
installCabalUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO 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 -> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated install -> Maybe Version -- ^ Nothing for isolated install
-> Bool -- ^ Force Install
-> Excepts '[CopyError, FileAlreadyExistsError] m () -> Excepts '[CopyError, FileAlreadyExistsError] m ()
installCabalUnpacked path inst mver' = do installCabalUnpacked path inst mver' forceInstall = do
lift $ logInfo "Installing cabal" lift $ logInfo "Installing cabal"
let cabalFile = "cabal" let cabalFile = "cabal"
liftIO $ createDirRecursive' inst liftIO $ createDirRecursive' inst
@ -473,7 +495,8 @@ installCabalUnpacked path inst mver' = do
<> exeExt <> exeExt
let destPath = inst </> destFileName let destPath = inst </> destFileName
liftE $ throwIfFileAlreadyExists destPath unless forceInstall -- Overwrite it when it IS a force install
(liftE $ throwIfFileAlreadyExists destPath)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile <> exeExt) (path </> cabalFile <> exeExt)
@ -498,6 +521,7 @@ installCabalBin :: ( MonadMask m
) )
=> Version => Version
-> Maybe FilePath -- isolated install Path, if user provided any -> Maybe FilePath -- isolated install Path, if user provided any
-> Bool -- force install
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, CopyError , CopyError
@ -512,9 +536,9 @@ installCabalBin :: ( MonadMask m
] ]
m m
() ()
installCabalBin ver isoFilepath = do installCabalBin ver isoFilepath forceInstall = do
dlinfo <- liftE $ getDownloadInfo Cabal ver dlinfo <- liftE $ getDownloadInfo Cabal ver
installCabalBindist dlinfo ver isoFilepath installCabalBindist dlinfo ver isoFilepath forceInstall
-- | Like 'installHLSBin, except takes the 'DownloadInfo' as -- | Like 'installHLSBin, except takes the 'DownloadInfo' as
@ -534,6 +558,7 @@ installHLSBindist :: ( MonadMask m
=> DownloadInfo => DownloadInfo
-> Version -> Version
-> Maybe FilePath -- ^ isolated install path, if user passed any -> Maybe FilePath -- ^ isolated install path, if user passed any
-> Bool -- ^ Force install
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, CopyError , CopyError
@ -548,20 +573,28 @@ installHLSBindist :: ( MonadMask m
] ]
m m
() ()
installHLSBindist dlinfo ver isoFilepath = do installHLSBindist dlinfo ver isoFilepath 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
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
case isoFilepath of regularHLSInstalled <- lift $ checkIfToolInstalled HLS ver
Nothing ->
-- we only check for already installed in regular (non-isolated) installs
whenM (lift (hlsInstalled ver))
(throwE $ AlreadyInstalled HLS ver)
_ -> pure () if
| not forceInstall
, regularHLSInstalled
, Nothing <- isoFilepath -> do -- regular install
throwE $ AlreadyInstalled HLS ver
| forceInstall
, regularHLSInstalled
, Nothing <- isoFilepath -> do -- regular forced install
lift $ logInfo "Removing the currently installed version of HLS before force installing!"
liftE $ rmHLSVer ver
| otherwise -> pure ()
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
@ -576,10 +609,10 @@ installHLSBindist dlinfo ver isoFilepath = do
case isoFilepath of case isoFilepath of
Just isoDir -> do Just isoDir -> do
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
liftE $ installHLSUnpacked workdir isoDir Nothing liftE $ installHLSUnpacked workdir isoDir Nothing forceInstall
Nothing -> do Nothing -> do
liftE $ installHLSUnpacked workdir binDir (Just ver) liftE $ installHLSUnpacked workdir binDir (Just ver) forceInstall
-- create symlink if this is the latest version in a regular install -- create symlink if this is the latest version in a regular install
hlsVers <- lift $ fmap rights getInstalledHLSs hlsVers <- lift $ fmap rights getInstalledHLSs
@ -592,8 +625,9 @@ installHLSUnpacked :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch 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 -> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated install -> Maybe Version -- ^ Nothing for isolated install
-> Bool -- ^ is it a force install
-> Excepts '[CopyError, FileAlreadyExistsError] m () -> Excepts '[CopyError, FileAlreadyExistsError] m ()
installHLSUnpacked path inst mver' = do installHLSUnpacked path inst mver' forceInstall = do
lift $ logInfo "Installing HLS" lift $ logInfo "Installing HLS"
liftIO $ createDirRecursive' inst liftIO $ createDirRecursive' inst
@ -612,7 +646,8 @@ installHLSUnpacked path inst mver' = do
let srcPath = path </> f let srcPath = path </> f
let destPath = inst </> toF let destPath = inst </> toF
liftE $ throwIfFileAlreadyExists destPath unless forceInstall -- if it is a force install, overwrite it.
(liftE $ throwIfFileAlreadyExists destPath)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile handleIO (throwE . CopyError . show) $ liftIO $ copyFile
srcPath srcPath
@ -627,7 +662,8 @@ installHLSUnpacked path inst mver' = do
srcWrapperPath = path </> wrapper <> exeExt srcWrapperPath = path </> wrapper <> exeExt
destWrapperPath = inst </> toF destWrapperPath = inst </> toF
liftE $ throwIfFileAlreadyExists destWrapperPath unless forceInstall
(liftE $ throwIfFileAlreadyExists destWrapperPath)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile handleIO (throwE . CopyError . show) $ liftIO $ copyFile
srcWrapperPath srcWrapperPath
@ -651,7 +687,8 @@ installHLSBin :: ( MonadMask m
, MonadFail m , MonadFail m
) )
=> Version => Version
-> Maybe FilePath -> Maybe FilePath -- isolated install Dir (if any)
-> Bool -- force install
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, CopyError , CopyError
@ -666,9 +703,9 @@ installHLSBin :: ( MonadMask m
] ]
m m
() ()
installHLSBin ver isoFilepath = do installHLSBin ver isoFilepath forceInstall = do
dlinfo <- liftE $ getDownloadInfo HLS ver dlinfo <- liftE $ getDownloadInfo HLS ver
installHLSBindist dlinfo ver isoFilepath installHLSBindist dlinfo ver isoFilepath forceInstall
-- | Installs stack into @~\/.ghcup\/bin/stack-\<ver\>@ and -- | Installs stack into @~\/.ghcup\/bin/stack-\<ver\>@ and
@ -688,7 +725,8 @@ installStackBin :: ( MonadMask m
, MonadFail m , MonadFail m
) )
=> Version => Version
-> Maybe FilePath -> Maybe FilePath -- ^ isolate install Dir (if any)
-> Bool -- ^ Force install
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, CopyError , CopyError
@ -703,9 +741,9 @@ installStackBin :: ( MonadMask m
] ]
m m
() ()
installStackBin ver isoFilepath = do installStackBin ver isoFilepath forceInstall = do
dlinfo <- liftE $ getDownloadInfo Stack ver dlinfo <- liftE $ getDownloadInfo Stack ver
installStackBindist dlinfo ver isoFilepath installStackBindist dlinfo ver isoFilepath forceInstall
-- | Like 'installStackBin', except takes the 'DownloadInfo' as -- | Like 'installStackBin', except takes the 'DownloadInfo' as
@ -724,7 +762,8 @@ installStackBindist :: ( MonadMask m
) )
=> DownloadInfo => DownloadInfo
-> Version -> Version
-> Maybe FilePath -> Maybe FilePath -- ^ isolate install Dir (if any)
-> Bool -- ^ Force install
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, CopyError , CopyError
@ -739,18 +778,27 @@ installStackBindist :: ( MonadMask m
] ]
m m
() ()
installStackBindist dlinfo ver isoFilepath = do installStackBindist dlinfo ver isoFilepath 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
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
case isoFilepath of regularStackInstalled <- lift $ checkIfToolInstalled Stack ver
Nothing -> -- check previous versions in case of regular installs
whenM (lift (stackInstalled ver))
(throwE $ AlreadyInstalled Stack ver)
_ -> pure () -- don't do shit for isolates if
| not forceInstall
, regularStackInstalled
, Nothing <- isoFilepath -> do
throwE $ AlreadyInstalled Stack ver
| forceInstall
, regularStackInstalled
, Nothing <- isoFilepath -> do
lift $ logInfo $ "Removing the currently installed version of Stack first!"
liftE $ rmStackVer ver
| otherwise -> pure ()
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
@ -766,9 +814,9 @@ installStackBindist dlinfo ver isoFilepath = do
case isoFilepath of case isoFilepath of
Just isoDir -> do -- isolated install Just 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 liftE $ installStackUnpacked workdir isoDir Nothing forceInstall
Nothing -> do -- regular install Nothing -> do -- regular install
liftE $ installStackUnpacked workdir binDir (Just ver) liftE $ installStackUnpacked workdir binDir (Just ver) forceInstall
-- create symlink if this is the latest version and a regular install -- create symlink if this is the latest version and a regular install
sVers <- lift $ fmap rights getInstalledStacks sVers <- lift $ fmap rights getInstalledStacks
@ -781,8 +829,9 @@ 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 -> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated installs -> Maybe Version -- ^ Nothing for isolated installs
-> Bool -- ^ Force install
-> Excepts '[CopyError, FileAlreadyExistsError] m () -> Excepts '[CopyError, FileAlreadyExistsError] m ()
installStackUnpacked path inst mver' = do installStackUnpacked path inst mver' forceInstall = do
lift $ logInfo "Installing stack" lift $ logInfo "Installing stack"
let stackFile = "stack" let stackFile = "stack"
liftIO $ createDirRecursive' inst liftIO $ createDirRecursive' inst
@ -791,7 +840,8 @@ installStackUnpacked path inst mver' = do
<> exeExt <> exeExt
destPath = inst </> destFileName destPath = inst </> destFileName
liftE $ throwIfFileAlreadyExists destPath unless forceInstall
(liftE $ throwIfFileAlreadyExists destPath)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> stackFile <> exeExt) (path </> stackFile <> exeExt)
@ -1937,6 +1987,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
@ -2383,6 +2434,21 @@ whereIsTool tool ver@GHCTargetVersion {..} = do
currentRunningExecPath <- liftIO getExecutablePath currentRunningExecPath <- liftIO getExecutablePath
liftIO $ canonicalizePath currentRunningExecPath liftIO $ canonicalizePath currentRunningExecPath
checkIfToolInstalled :: ( MonadIO m
, MonadReader env m
, HasDirs env
, MonadCatch m) =>
Tool ->
Version ->
m Bool
checkIfToolInstalled tool ver =
case tool of
Cabal -> cabalInstalled ver
HLS -> hlsInstalled ver
Stack -> stackInstalled ver
GHC -> ghcInstalled $ mkTVer ver
_ -> pure False
throwIfFileAlreadyExists :: ( MonadIO m ) => throwIfFileAlreadyExists :: ( MonadIO m ) =>
FilePath -> FilePath ->

3
lib/GHCup/Utils.hs
View File

@ -250,7 +250,6 @@ getInstalledGHCs = do
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@. -- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
getInstalledCabals :: ( MonadReader env m getInstalledCabals :: ( MonadReader env m
, HasDirs env , HasDirs env
, HasLog env
, MonadIO m , MonadIO m
, MonadCatch m , MonadCatch m
) )
@ -268,7 +267,7 @@ getInstalledCabals = do
-- | Whether the given cabal version is installed. -- | Whether the given cabal version is installed.
cabalInstalled :: (HasLog env, MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool cabalInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
cabalInstalled ver = do cabalInstalled ver = do
vers <- fmap rights getInstalledCabals vers <- fmap rights getInstalledCabals
pure $ elem ver vers pure $ elem ver vers