Merge remote-tracking branch 'origin/merge-requests/127'
This commit is contained in:
commit
bd18fd9aa1
GPG Key ID:
3786C5262ECB4A3F
|
|
@ -442,25 +442,26 @@ install' _ (_, ListResult {..}) = do
|
|||
, DownloadFailed
|
||||
, NoUpdate
|
||||
, TarDirDoesNotExist
|
||||
, FileAlreadyExistsError
|
||||
]
|
||||
|
||||
run (do
|
||||
case lTool of
|
||||
GHC -> do
|
||||
let vi = getVersionInfo lVer GHC dls
|
||||
liftE $ installGHCBin lVer $> vi
|
||||
liftE $ installGHCBin lVer Nothing $> vi
|
||||
Cabal -> do
|
||||
let vi = getVersionInfo lVer Cabal dls
|
||||
liftE $ installCabalBin lVer $> vi
|
||||
liftE $ installCabalBin lVer Nothing $> vi
|
||||
GHCup -> do
|
||||
let vi = snd <$> getLatest dls GHCup
|
||||
liftE $ upgradeGHCup Nothing False $> vi
|
||||
HLS -> do
|
||||
let vi = getVersionInfo lVer HLS dls
|
||||
liftE $ installHLSBin lVer $> vi
|
||||
liftE $ installHLSBin lVer Nothing $> vi
|
||||
Stack -> do
|
||||
let vi = getVersionInfo lVer Stack dls
|
||||
liftE $ installStackBin lVer $> vi
|
||||
liftE $ installStackBin lVer Nothing $> vi
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
|
|
|
|||
|
|
@ -138,6 +138,7 @@ data InstallOptions = InstallOptions
|
|||
, instPlatform :: Maybe PlatformRequest
|
||||
, instBindist :: Maybe URI
|
||||
, instSet :: Bool
|
||||
, isolateDir :: Maybe FilePath
|
||||
}
|
||||
|
||||
data SetCommand = SetGHC SetOptions
|
||||
|
|
@ -185,6 +186,7 @@ data GHCCompileOptions = GHCCompileOptions
|
|||
, ovewrwiteVer :: Maybe Version
|
||||
, buildFlavour :: Maybe String
|
||||
, hadrian :: Bool
|
||||
, isolateDir :: Maybe FilePath
|
||||
}
|
||||
|
||||
data UpgradeOpts = UpgradeInplace
|
||||
|
|
@ -574,7 +576,7 @@ Examples:
|
|||
|
||||
installOpts :: Maybe Tool -> Parser InstallOptions
|
||||
installOpts tool =
|
||||
(\p (u, v) b -> InstallOptions v p u b)
|
||||
(\p (u, v) b is -> InstallOptions v p u b is)
|
||||
<$> optional
|
||||
(option
|
||||
(eitherReader platformParser)
|
||||
|
|
@ -603,6 +605,15 @@ installOpts tool =
|
|||
(long "set" <> help
|
||||
"Set as active version after install"
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader isolateParser)
|
||||
( short 'i'
|
||||
<> long "isolate"
|
||||
<> metavar "DIR"
|
||||
<> help "install in an isolated dir instead of the default one"
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
setParser :: Parser (Either SetCommand SetOptions)
|
||||
|
|
@ -1000,6 +1011,15 @@ ghcCompileOpts =
|
|||
<*> switch
|
||||
(long "hadrian" <> help "Use the hadrian build system instead of make (only git versions seem to be properly supported atm)"
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader isolateParser)
|
||||
( short 'i'
|
||||
<> long "isolate"
|
||||
<> metavar "DIR"
|
||||
<> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made"
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
toolVersionParser :: Parser ToolVersion
|
||||
|
|
@ -1215,6 +1235,10 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
|
|||
bindistParser :: String -> Either String URI
|
||||
bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString
|
||||
|
||||
isolateParser :: FilePath -> Either String FilePath
|
||||
isolateParser f = case isValid f of
|
||||
True -> Right $ normalise f
|
||||
False -> Left "Please enter a valid filepath for isolate dir."
|
||||
|
||||
toSettings :: Options -> IO (Settings, KeyBindings)
|
||||
toSettings options = do
|
||||
|
|
@ -1454,6 +1478,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
, TarDirDoesNotExist
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
, FileAlreadyExistsError
|
||||
]
|
||||
|
||||
let runInstTool mInstPlatform action' = do
|
||||
|
|
@ -1617,22 +1642,23 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
-----------------------
|
||||
|
||||
let installGHC InstallOptions{..} =
|
||||
(case instBindist of
|
||||
Nothing -> runInstTool instPlatform $ do
|
||||
(case instBindist of
|
||||
Nothing -> runInstTool instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer GHC
|
||||
liftE $ installGHCBin (_tvVersion v) isolateDir
|
||||
when instSet $ void $ liftE $ setGHC v SetGHCOnly
|
||||
pure vi
|
||||
Just uri -> do
|
||||
s' <- liftIO appState
|
||||
runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer GHC
|
||||
liftE $ installGHCBin (_tvVersion v)
|
||||
liftE $ installGHCBindist
|
||||
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
|
||||
(_tvVersion v)
|
||||
isolateDir
|
||||
when instSet $ void $ liftE $ setGHC v SetGHCOnly
|
||||
pure vi
|
||||
Just uri -> do
|
||||
s' <- liftIO appState
|
||||
runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer GHC
|
||||
liftE $ installGHCBindist
|
||||
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
|
||||
(_tvVersion v)
|
||||
when instSet $ void $ liftE $ setGHC v SetGHCOnly
|
||||
pure vi
|
||||
)
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
runLogger $ $(logInfo) "GHC installation successful"
|
||||
|
|
@ -1661,7 +1687,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
(case instBindist of
|
||||
Nothing -> runInstTool instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer Cabal
|
||||
liftE $ installCabalBin (_tvVersion v)
|
||||
liftE $ installCabalBin (_tvVersion v) isolateDir
|
||||
pure vi
|
||||
Just uri -> do
|
||||
s' <- appState
|
||||
|
|
@ -1670,6 +1696,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
liftE $ installCabalBindist
|
||||
(DownloadInfo uri Nothing "")
|
||||
(_tvVersion v)
|
||||
isolateDir
|
||||
pure vi
|
||||
)
|
||||
>>= \case
|
||||
|
|
@ -1689,10 +1716,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
pure $ ExitFailure 4
|
||||
|
||||
let installHLS InstallOptions{..} =
|
||||
(case instBindist of
|
||||
(case instBindist of
|
||||
Nothing -> runInstTool instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer HLS
|
||||
liftE $ installHLSBin (_tvVersion v)
|
||||
liftE $ installHLSBin (_tvVersion v) isolateDir
|
||||
pure vi
|
||||
Just uri -> do
|
||||
s' <- appState
|
||||
|
|
@ -1701,6 +1728,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
liftE $ installHLSBindist
|
||||
(DownloadInfo uri Nothing "")
|
||||
(_tvVersion v)
|
||||
isolateDir
|
||||
pure vi
|
||||
)
|
||||
>>= \case
|
||||
|
|
@ -1720,19 +1748,20 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
pure $ ExitFailure 4
|
||||
|
||||
let installStack InstallOptions{..} =
|
||||
(case instBindist of
|
||||
Nothing -> runInstTool instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer Stack
|
||||
liftE $ installStackBin (_tvVersion v)
|
||||
pure vi
|
||||
Just uri -> do
|
||||
s' <- appState
|
||||
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer Stack
|
||||
liftE $ installStackBindist
|
||||
(DownloadInfo uri Nothing "")
|
||||
(_tvVersion v)
|
||||
pure vi
|
||||
(case instBindist of
|
||||
Nothing -> runInstTool instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer Stack
|
||||
liftE $ installStackBin (_tvVersion v) isolateDir
|
||||
pure vi
|
||||
Just uri -> do
|
||||
s' <- appState
|
||||
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer Stack
|
||||
liftE $ installStackBindist
|
||||
(DownloadInfo uri Nothing "")
|
||||
(_tvVersion v)
|
||||
isolateDir
|
||||
pure vi
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
|
|
@ -1961,6 +1990,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
addConfArgs
|
||||
buildFlavour
|
||||
hadrian
|
||||
isolateDir
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
let vi = getVersionInfo (_tvVersion targetVer) GHC dls
|
||||
when setCompile $ void $ liftE $
|
||||
|
|
|
|||
316
lib/GHCup.hs
316
lib/GHCup.hs
|
|
@ -186,6 +186,7 @@ installGHCBindist :: ( MonadFail m
|
|||
)
|
||||
=> DownloadInfo -- ^ where/how to download
|
||||
-> Version -- ^ the version to install
|
||||
-> Maybe FilePath -- ^ isolated filepath if user passed any
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, BuildFailed
|
||||
|
|
@ -201,10 +202,15 @@ installGHCBindist :: ( MonadFail m
|
|||
]
|
||||
m
|
||||
()
|
||||
installGHCBindist dlinfo ver = do
|
||||
installGHCBindist dlinfo ver isoFilepath = do
|
||||
let tver = mkTVer ver
|
||||
|
||||
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
|
||||
whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver)
|
||||
|
||||
case isoFilepath of
|
||||
-- we only care for already installed errors in regular (non-isolated) installs
|
||||
Nothing -> whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver)
|
||||
_ -> pure ()
|
||||
|
||||
-- download (or use cached version)
|
||||
dl <- liftE $ downloadCached dlinfo Nothing
|
||||
|
|
@ -214,9 +220,15 @@ installGHCBindist dlinfo ver = do
|
|||
|
||||
toolchainSanityChecks
|
||||
|
||||
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver
|
||||
case isoFilepath of
|
||||
Just isoDir -> do -- isolated install
|
||||
lift $ $(logInfo) [i|isolated installing GHC to #{isoDir}|]
|
||||
liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver
|
||||
Nothing -> do -- regular install
|
||||
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver
|
||||
|
||||
liftE $ postGHCInstall tver
|
||||
-- make symlinks & stuff when regular install,
|
||||
liftE $ postGHCInstall tver
|
||||
|
||||
where
|
||||
toolchainSanityChecks = do
|
||||
|
|
@ -339,6 +351,7 @@ installGHCBin :: ( MonadFail m
|
|||
, MonadUnliftIO m
|
||||
)
|
||||
=> Version -- ^ the version to install
|
||||
-> Maybe FilePath -- ^ isolated install filepath, if user passed any
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, BuildFailed
|
||||
|
|
@ -354,9 +367,9 @@ installGHCBin :: ( MonadFail m
|
|||
]
|
||||
m
|
||||
()
|
||||
installGHCBin ver = do
|
||||
installGHCBin ver isoFilepath = do
|
||||
dlinfo <- liftE $ getDownloadInfo GHC ver
|
||||
installGHCBindist dlinfo ver
|
||||
installGHCBindist dlinfo ver isoFilepath
|
||||
|
||||
|
||||
-- | Like 'installCabalBin', except takes the 'DownloadInfo' as
|
||||
|
|
@ -375,6 +388,7 @@ installCabalBindist :: ( MonadMask m
|
|||
)
|
||||
=> DownloadInfo
|
||||
-> Version
|
||||
-> Maybe FilePath -- ^ isolated install filepath, if user provides any.
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, CopyError
|
||||
|
|
@ -387,23 +401,28 @@ installCabalBindist :: ( MonadMask m
|
|||
#if !defined(TAR)
|
||||
, ArchiveResult
|
||||
#endif
|
||||
, FileAlreadyExistsError
|
||||
]
|
||||
m
|
||||
()
|
||||
installCabalBindist dlinfo ver = do
|
||||
installCabalBindist dlinfo ver isoFilepath = do
|
||||
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
|
||||
|
||||
PlatformRequest {..} <- lift getPlatformReq
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
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)
|
||||
case isoFilepath of
|
||||
Nothing -> -- for regular install check if any previous versions installed
|
||||
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
|
||||
|
||||
-- download (or use cached version)
|
||||
dl <- liftE $ downloadCached dlinfo Nothing
|
||||
|
|
@ -416,30 +435,38 @@ installCabalBindist dlinfo ver = do
|
|||
-- the subdir of the archive where we do the work
|
||||
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
|
||||
|
||||
liftE $ installCabal' workdir binDir
|
||||
case isoFilepath of
|
||||
Just isoDir -> do -- isolated install
|
||||
lift $ $(logInfo) [i|isolated installing Cabal to #{isoDir}|]
|
||||
liftE $ installCabalUnpacked workdir isoDir ver
|
||||
|
||||
-- create symlink if this is the latest version
|
||||
cVers <- lift $ fmap rights getInstalledCabals
|
||||
let lInstCabal = headMay . reverse . sort $ cVers
|
||||
when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver
|
||||
Nothing -> do -- regular install
|
||||
liftE $ installCabalUnpacked workdir binDir ver
|
||||
|
||||
where
|
||||
-- | Install an unpacked cabal distribution.
|
||||
installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)
|
||||
-> FilePath -- ^ Path to install to
|
||||
-> Excepts '[CopyError] m ()
|
||||
installCabal' path inst = do
|
||||
lift $ $(logInfo) "Installing cabal"
|
||||
let cabalFile = "cabal"
|
||||
liftIO $ createDirRecursive' inst
|
||||
let destFileName = cabalFile <> "-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
let destPath = inst </> destFileName
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> cabalFile <> exeExt)
|
||||
destPath
|
||||
lift $ chmod_755 destPath
|
||||
-- create symlink if this is the latest version for regular installs
|
||||
cVers <- lift $ fmap rights getInstalledCabals
|
||||
let lInstCabal = headMay . reverse . sort $ cVers
|
||||
when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver
|
||||
|
||||
-- | Install an unpacked cabal distribution.
|
||||
installCabalUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)
|
||||
-> FilePath -- ^ Path to install to
|
||||
-> Version
|
||||
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
|
||||
installCabalUnpacked path inst ver = do
|
||||
lift $ $(logInfo) "Installing cabal"
|
||||
let cabalFile = "cabal"
|
||||
liftIO $ createDirRecursive' inst
|
||||
let destFileName = cabalFile <> "-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
let destPath = inst </> destFileName
|
||||
whenM
|
||||
(liftIO $ doesFileExist destPath)
|
||||
(throwE $ FileAlreadyExistsError destPath)
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> cabalFile <> exeExt)
|
||||
destPath
|
||||
lift $ chmod_755 destPath
|
||||
|
||||
-- | Installs cabal into @~\/.ghcup\/bin/cabal-\<ver\>@ and
|
||||
-- creates a default @cabal -> cabal-x.y.z.q@ symlink for
|
||||
|
|
@ -458,6 +485,7 @@ installCabalBin :: ( MonadMask m
|
|||
, MonadFail m
|
||||
)
|
||||
=> Version
|
||||
-> Maybe FilePath -- isolated install Path, if user provided any
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, CopyError
|
||||
|
|
@ -470,12 +498,13 @@ installCabalBin :: ( MonadMask m
|
|||
#if !defined(TAR)
|
||||
, ArchiveResult
|
||||
#endif
|
||||
, FileAlreadyExistsError
|
||||
]
|
||||
m
|
||||
()
|
||||
installCabalBin ver = do
|
||||
installCabalBin ver isoFilepath = do
|
||||
dlinfo <- liftE $ getDownloadInfo Cabal ver
|
||||
installCabalBindist dlinfo ver
|
||||
installCabalBindist dlinfo ver isoFilepath
|
||||
|
||||
|
||||
-- | Like 'installHLSBin, except takes the 'DownloadInfo' as
|
||||
|
|
@ -494,6 +523,7 @@ installHLSBindist :: ( MonadMask m
|
|||
)
|
||||
=> DownloadInfo
|
||||
-> Version
|
||||
-> Maybe FilePath -- ^ isolated install path, if user passed any
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, CopyError
|
||||
|
|
@ -509,14 +539,19 @@ installHLSBindist :: ( MonadMask m
|
|||
]
|
||||
m
|
||||
()
|
||||
installHLSBindist dlinfo ver = do
|
||||
installHLSBindist dlinfo ver isoFilepath = do
|
||||
lift $ $(logDebug) [i|Requested to install hls version #{ver}|]
|
||||
|
||||
PlatformRequest {..} <- lift getPlatformReq
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
whenM (lift (hlsInstalled ver))
|
||||
(throwE $ AlreadyInstalled HLS ver)
|
||||
case isoFilepath of
|
||||
Nothing ->
|
||||
-- we only check for already installed in regular (non-isolated) installs
|
||||
whenM (lift (hlsInstalled ver))
|
||||
(throwE $ AlreadyInstalled HLS ver)
|
||||
|
||||
_ -> pure ()
|
||||
|
||||
-- download (or use cached version)
|
||||
dl <- liftE $ downloadCached dlinfo Nothing
|
||||
|
|
@ -529,46 +564,52 @@ installHLSBindist dlinfo ver = do
|
|||
-- the subdir of the archive where we do the work
|
||||
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
|
||||
|
||||
liftE $ installHLS' workdir binDir
|
||||
case isoFilepath of
|
||||
Just isoDir -> do
|
||||
lift $ $(logInfo) [i|isolated installing HLS to #{isoDir}|]
|
||||
liftE $ installHLSUnpacked workdir isoDir ver
|
||||
|
||||
-- create symlink if this is the latest version
|
||||
hlsVers <- lift $ fmap rights getInstalledHLSs
|
||||
let lInstHLS = headMay . reverse . sort $ hlsVers
|
||||
when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver
|
||||
Nothing -> do
|
||||
liftE $ installHLSUnpacked workdir binDir ver
|
||||
|
||||
where
|
||||
-- | Install an unpacked hls distribution.
|
||||
installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
|
||||
-> FilePath -- ^ Path to install to
|
||||
-> Excepts '[CopyError] m ()
|
||||
installHLS' path inst = do
|
||||
lift $ $(logInfo) "Installing HLS"
|
||||
liftIO $ createDirRecursive' inst
|
||||
-- create symlink if this is the latest version in a regular install
|
||||
hlsVers <- lift $ fmap rights getInstalledHLSs
|
||||
let lInstHLS = headMay . reverse . sort $ hlsVers
|
||||
when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver
|
||||
|
||||
-- install haskell-language-server-<ghcver>
|
||||
bins@(_:_) <- liftIO $ findFiles
|
||||
path
|
||||
(makeRegexOpts compExtended
|
||||
execBlank
|
||||
([s|^haskell-language-server-[0-9].*$|] :: ByteString)
|
||||
)
|
||||
forM_ bins $ \f -> do
|
||||
let toF = dropSuffix exeExt f
|
||||
<> "~" <> T.unpack (prettyVer ver) <> exeExt
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> f)
|
||||
(inst </> toF)
|
||||
lift $ chmod_755 (inst </> toF)
|
||||
|
||||
-- install haskell-language-server-wrapper
|
||||
let wrapper = "haskell-language-server-wrapper"
|
||||
toF = wrapper <> "-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
-- | Install an unpacked hls distribution.
|
||||
installHLSUnpacked :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
|
||||
-> FilePath -- ^ Path to install to
|
||||
-> Version
|
||||
-> Excepts '[CopyError] m ()
|
||||
installHLSUnpacked path inst ver = do
|
||||
lift $ $(logInfo) "Installing HLS"
|
||||
liftIO $ createDirRecursive' inst
|
||||
|
||||
-- install haskell-language-server-<ghcver>
|
||||
bins@(_:_) <- liftIO $ findFiles
|
||||
path
|
||||
(makeRegexOpts compExtended
|
||||
execBlank
|
||||
([s|^haskell-language-server-[0-9].*$|] :: ByteString)
|
||||
)
|
||||
forM_ bins $ \f -> do
|
||||
let toF = dropSuffix exeExt f
|
||||
<> "~" <> T.unpack (prettyVer ver) <> exeExt
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> wrapper <> exeExt)
|
||||
(path </> f)
|
||||
(inst </> toF)
|
||||
lift $ chmod_755 (inst </> toF)
|
||||
|
||||
-- install haskell-language-server-wrapper
|
||||
let wrapper = "haskell-language-server-wrapper"
|
||||
toF = wrapper <> "-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> wrapper <> exeExt)
|
||||
(inst </> toF)
|
||||
lift $ chmod_755 (inst </> toF)
|
||||
|
||||
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@
|
||||
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
|
||||
|
|
@ -586,6 +627,7 @@ installHLSBin :: ( MonadMask m
|
|||
, MonadFail m
|
||||
)
|
||||
=> Version
|
||||
-> Maybe FilePath
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, CopyError
|
||||
|
|
@ -601,9 +643,9 @@ installHLSBin :: ( MonadMask m
|
|||
]
|
||||
m
|
||||
()
|
||||
installHLSBin ver = do
|
||||
installHLSBin ver isoFilepath = do
|
||||
dlinfo <- liftE $ getDownloadInfo HLS ver
|
||||
installHLSBindist dlinfo ver
|
||||
installHLSBindist dlinfo ver isoFilepath
|
||||
|
||||
|
||||
-- | Installs stack into @~\/.ghcup\/bin/stack-\<ver\>@ and
|
||||
|
|
@ -623,6 +665,7 @@ installStackBin :: ( MonadMask m
|
|||
, MonadFail m
|
||||
)
|
||||
=> Version
|
||||
-> Maybe FilePath
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, CopyError
|
||||
|
|
@ -638,9 +681,9 @@ installStackBin :: ( MonadMask m
|
|||
]
|
||||
m
|
||||
()
|
||||
installStackBin ver = do
|
||||
installStackBin ver isoFilepath = do
|
||||
dlinfo <- liftE $ getDownloadInfo Stack ver
|
||||
installStackBindist dlinfo ver
|
||||
installStackBindist dlinfo ver isoFilepath
|
||||
|
||||
|
||||
-- | Like 'installStackBin', except takes the 'DownloadInfo' as
|
||||
|
|
@ -659,6 +702,7 @@ installStackBindist :: ( MonadMask m
|
|||
)
|
||||
=> DownloadInfo
|
||||
-> Version
|
||||
-> Maybe FilePath
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, CopyError
|
||||
|
|
@ -674,14 +718,18 @@ installStackBindist :: ( MonadMask m
|
|||
]
|
||||
m
|
||||
()
|
||||
installStackBindist dlinfo ver = do
|
||||
installStackBindist dlinfo ver isoFilepath = do
|
||||
lift $ $(logDebug) [i|Requested to install stack version #{ver}|]
|
||||
|
||||
PlatformRequest {..} <- lift getPlatformReq
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
whenM (lift (stackInstalled ver))
|
||||
(throwE $ AlreadyInstalled Stack ver)
|
||||
case isoFilepath of
|
||||
Nothing -> -- check previous versions in case of regular installs
|
||||
whenM (lift (stackInstalled ver))
|
||||
(throwE $ AlreadyInstalled Stack ver)
|
||||
|
||||
_ -> pure () -- don't do shit for isolates
|
||||
|
||||
-- download (or use cached version)
|
||||
dl <- liftE $ downloadCached dlinfo Nothing
|
||||
|
|
@ -694,31 +742,35 @@ installStackBindist dlinfo ver = do
|
|||
-- the subdir of the archive where we do the work
|
||||
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
|
||||
|
||||
liftE $ installStack' workdir binDir
|
||||
case isoFilepath of
|
||||
Just isoDir -> do -- isolated install
|
||||
lift $ $(logInfo) [i|isolated installing Stack to #{isoDir}|]
|
||||
liftE $ installStackUnpacked workdir isoDir ver
|
||||
Nothing -> do -- regular install
|
||||
liftE $ installStackUnpacked workdir binDir ver
|
||||
|
||||
-- create symlink if this is the latest version
|
||||
sVers <- lift $ fmap rights getInstalledStacks
|
||||
let lInstStack = headMay . reverse . sort $ sVers
|
||||
when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver
|
||||
|
||||
where
|
||||
-- | Install an unpacked stack distribution.
|
||||
installStack' :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> FilePath -- ^ Path to the unpacked stack bindist (where the executable resides)
|
||||
-> FilePath -- ^ Path to install to
|
||||
-> Excepts '[CopyError] m ()
|
||||
installStack' path inst = do
|
||||
lift $ $(logInfo) "Installing stack"
|
||||
let stackFile = "stack"
|
||||
liftIO $ createDirRecursive' inst
|
||||
let destFileName = stackFile <> "-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
let destPath = inst </> destFileName
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> stackFile <> exeExt)
|
||||
destPath
|
||||
lift $ chmod_755 destPath
|
||||
-- create symlink if this is the latest version and a regular install
|
||||
sVers <- lift $ fmap rights getInstalledStacks
|
||||
let lInstStack = headMay . reverse . sort $ sVers
|
||||
when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver
|
||||
|
||||
|
||||
-- | Install an unpacked stack distribution.
|
||||
installStackUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> FilePath -- ^ Path to the unpacked stack bindist (where the executable resides)
|
||||
-> FilePath -- ^ Path to install to
|
||||
-> Version
|
||||
-> Excepts '[CopyError] m ()
|
||||
installStackUnpacked path inst ver = do
|
||||
lift $ $(logInfo) "Installing stack"
|
||||
let stackFile = "stack"
|
||||
liftIO $ createDirRecursive' inst
|
||||
let destFileName = stackFile <> "-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
let destPath = inst </> destFileName
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> stackFile <> exeExt)
|
||||
destPath
|
||||
lift $ chmod_755 destPath
|
||||
|
||||
|
||||
---------------------
|
||||
|
|
@ -1700,6 +1752,7 @@ compileGHC :: ( MonadMask m
|
|||
-> [Text] -- ^ additional args to ./configure
|
||||
-> Maybe String -- ^ build flavour
|
||||
-> Bool
|
||||
-> Maybe FilePath -- ^ isolate dir
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, BuildFailed
|
||||
|
|
@ -1718,7 +1771,7 @@ compileGHC :: ( MonadMask m
|
|||
]
|
||||
m
|
||||
GHCTargetVersion
|
||||
compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour hadrian
|
||||
compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour hadrian isolateDir
|
||||
= do
|
||||
PlatformRequest { .. } <- lift getPlatformReq
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
|
|
@ -1788,12 +1841,18 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
|
|||
alreadyInstalled <- lift $ ghcInstalled installVer
|
||||
alreadySet <- fmap (== Just tver) $ lift $ ghcSet (_tvTarget tver)
|
||||
when alreadyInstalled $ do
|
||||
lift $ $(logWarn) [i|GHC #{prettyShow tver} already installed. Will overwrite existing version.|]
|
||||
case isolateDir of
|
||||
Just isoDir ->
|
||||
lift $ $(logWarn) [i|GHC #{prettyShow tver} already installed. Isolate installing to #{isoDir} |]
|
||||
Nothing ->
|
||||
lift $ $(logWarn) [i|GHC #{prettyShow tver} 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 <- lift $ ghcupGHCDir installVer
|
||||
ghcdir <- case isolateDir of
|
||||
Just isoDir -> pure isoDir
|
||||
Nothing -> lift $ ghcupGHCDir installVer
|
||||
|
||||
bghc <- case bstrap of
|
||||
Right g -> pure $ Right g
|
||||
|
|
@ -1810,9 +1869,14 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
|
|||
pure (b, bmk)
|
||||
)
|
||||
|
||||
when alreadyInstalled $ do
|
||||
lift $ $(logInfo) [i|Deleting existing installation|]
|
||||
liftE $ rmGHCVer tver
|
||||
case isolateDir of
|
||||
Nothing ->
|
||||
-- only remove old ghc in regular installs
|
||||
when alreadyInstalled $ do
|
||||
lift $ $(logInfo) [i|Deleting existing installation|]
|
||||
liftE $ rmGHCVer tver
|
||||
|
||||
_ -> pure ()
|
||||
|
||||
forM_ mBindist $ \bindist -> do
|
||||
liftE $ installPackedGHC bindist
|
||||
|
|
@ -1821,11 +1885,15 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
|
|||
(tver ^. tvVersion)
|
||||
|
||||
liftIO $ B.writeFile (ghcdir </> ghcUpSrcBuiltFile) bmk
|
||||
|
||||
reThrowAll GHCupSetError $ postGHCInstall tver
|
||||
|
||||
-- restore
|
||||
when alreadySet $ liftE $ void $ setGHC tver SetGHCOnly
|
||||
|
||||
case isolateDir of
|
||||
-- set and make symlinks for regular (non-isolated) installs
|
||||
Nothing -> do
|
||||
reThrowAll GHCupSetError $ postGHCInstall tver
|
||||
-- restore
|
||||
when alreadySet $ liftE $ void $ setGHC tver SetGHCOnly
|
||||
|
||||
_ -> pure ()
|
||||
|
||||
pure tver
|
||||
|
||||
|
|
@ -2184,6 +2252,28 @@ upgradeGHCup mtarget force' = do
|
|||
--[ Other ]--
|
||||
-------------
|
||||
|
||||
-- | Does basic checks for isolated installs
|
||||
-- Isolated Directory:
|
||||
-- 1. if it doesn't exist -> proceed
|
||||
-- 2. if it exists and is empty -> proceed
|
||||
-- 3. if it exists and is non-empty -> panic and leave the house
|
||||
|
||||
isolatedInstallSanityCheck :: ( MonadIO m
|
||||
, MonadThrow m
|
||||
) =>
|
||||
FilePath ->
|
||||
Excepts '[IsolatedDirNotEmpty] m ()
|
||||
isolatedInstallSanityCheck isoDir = do
|
||||
dirExists <- liftIO $ doesDirectoryExist isoDir
|
||||
if not dirExists
|
||||
then pure ()
|
||||
else do
|
||||
len <- liftIO $ length <$> listDirectory isoDir
|
||||
let isDirEmpty = len == 0
|
||||
if isDirEmpty
|
||||
then pure ()
|
||||
else (throwE $ IsolatedDirNotEmpty isoDir)
|
||||
|
||||
|
||||
-- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for
|
||||
-- both installing from source and bindist.
|
||||
|
|
|
|||
|
|
@ -134,6 +134,14 @@ instance Pretty AlreadyInstalled where
|
|||
pPrint (AlreadyInstalled tool ver') =
|
||||
text [i|#{tool}-#{prettyShow ver'} is already installed|]
|
||||
|
||||
-- | The Directory for isolated install already exists and is not empty
|
||||
-- | This is done to prevent any overwriting
|
||||
data IsolatedDirNotEmpty = IsolatedDirNotEmpty {path :: FilePath}
|
||||
|
||||
instance Pretty IsolatedDirNotEmpty where
|
||||
pPrint (IsolatedDirNotEmpty path) = do
|
||||
text [i| The directory for isolated install already exists and is NOT EMPTY : #{path}|]
|
||||
|
||||
-- | The tool is not installed. Some operations rely on a tool
|
||||
-- to be installed (such as setting the current GHC version).
|
||||
data NotInstalled = NotInstalled Tool GHCTargetVersion
|
||||
|
|
@ -168,6 +176,16 @@ instance Pretty FileDoesNotExistError where
|
|||
pPrint (FileDoesNotExistError file) =
|
||||
text [i|File "#{file}" does not exist.|]
|
||||
|
||||
-- | The file already exists
|
||||
-- (e.g. when we use isolated installs with the same path).
|
||||
-- (e.g. This is done to prevent any overwriting)
|
||||
data FileAlreadyExistsError = FileAlreadyExistsError FilePath
|
||||
deriving Show
|
||||
|
||||
instance Pretty FileAlreadyExistsError where
|
||||
pPrint (FileAlreadyExistsError file) =
|
||||
text [i|File "#{file}" Already exists.|]
|
||||
|
||||
data TarDirDoesNotExist = TarDirDoesNotExist TarDir
|
||||
deriving Show
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue