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

Support HLS dynamic builds

Browse Source
This commit is contained in:
Julian Ospald 2022-02-05 01:53:04 +01:00
parent 72a06e964c
commit 51690d1df3
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
8 changed files with 277 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
app/ghcup/BrickMain.hs
View File

@ -495,7 +495,7 @@ set' _ (_, ListResult {..}) = do
case lTool of
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
Cabal -> liftE $ setCabal lVer $> ()
HLS -> liftE $ setHLS lVer $> ()
HLS -> liftE $ setHLS lVer SetHLSOnly $> ()
Stack -> liftE $ setStack lVer $> ()
GHCup -> pure ()
)

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

@ -466,7 +466,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer HLS dls
when setCompile $ void $ liftE $
setHLS targetVer
setHLS targetVer SetHLSOnly
pure (vi, targetVer)
)
>>= \case

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

@ -469,8 +469,9 @@ install installCommand settings getAppState' runLogger = case installCommand of
Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer HLS
-- TODO: support legacy
liftE $ installHLSBindist
(DownloadInfo uri Nothing "")
(DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "")
(_tvVersion v)
isolateDir
forceInstall

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

@ -311,10 +311,10 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
-> m ExitCode
setHLS' SetOptions{ sToolVer } =
case sToolVer of
(SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS (_tvVersion v) >> pure v)
(SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS (_tvVersion v) SetHLSOnly >> pure v)
_ -> runSetHLS runAppState (do
v <- liftE $ fst <$> fromVersion' sToolVer HLS
liftE $ setHLS (_tvVersion v)
liftE $ setHLS (_tvVersion v) SetHLSOnly
pure v
)
>>= \case

132
lib/GHCup.hs
View File

@ -6,7 +6,6 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-|
Module : GHCup
@ -301,22 +300,6 @@ installPackedGHC dl msubdir inst ver forceInstall = do
liftE $ runBuildAction tmpUnpack
(Just inst)
(installUnpackedGHC workdir inst ver)
where
-- | 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
installDestSanityCheck :: ( MonadIO m
, MonadCatch m
) =>
FilePath ->
Excepts '[DirNotEmpty] m ()
installDestSanityCheck isoDir = do
hideErrorDef [doesNotExistErrorType] () $ do
contents <- liftIO $ getDirectoryContentsRecursive isoDir
unless (null contents) (throwE $ DirNotEmpty isoDir)
-- | Install an unpacked GHC distribution. This only deals with the GHC
@ -582,6 +565,8 @@ installHLSBindist :: ( MonadMask m
, TarDirDoesNotExist
, ArchiveResult
, FileAlreadyExistsError
, ProcessError
, DirNotEmpty
]
m
()
@ -617,26 +602,55 @@ installHLSBindist dlinfo ver isoFilepath forceInstall = do
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
legacy <- liftIO $ isLegacyHLSBindist workdir
if
| not forceInstall
, not legacy
, (Just fp) <- isoFilepath -> liftE $ installDestSanityCheck fp
| otherwise -> pure ()
case isoFilepath of
Just isoDir -> do
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
liftE $ installHLSUnpacked workdir isoDir Nothing forceInstall
if legacy
then liftE $ installHLSUnpackedLegacy workdir isoDir Nothing forceInstall
else liftE $ installHLSUnpacked workdir isoDir ver
Nothing -> do
liftE $ installHLSUnpacked workdir binDir (Just ver) forceInstall
if legacy
then liftE $ installHLSUnpackedLegacy workdir binDir (Just ver) forceInstall
else do
inst <- ghcupHLSDir ver
liftE $ installHLSUnpacked workdir inst ver
liftE $ setHLS ver SetHLS_XYZ
liftE $ installHLSPostInst isoFilepath ver
isLegacyHLSBindist :: FilePath -- ^ Path to the unpacked hls bindist
-> IO Bool
isLegacyHLSBindist path = do
not <$> doesFileExist (path </> "GNUmakefile")
-- | Install an unpacked hls distribution.
installHLSUnpacked :: (MonadReader env m, MonadFail m, HasLog 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 install to
-> Version
-> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m ()
installHLSUnpacked path inst _ = do
lift $ logInfo "Installing HLS"
liftIO $ createDirRecursive' inst
lEM $ make ["PREFIX=" <> inst, "install"] (Just path)
-- | Install an unpacked hls distribution (legacy).
installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated install
-> Bool -- ^ is it a force install
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installHLSUnpacked path inst mver' forceInstall = do
installHLSUnpackedLegacy path inst mver' forceInstall = do
lift $ logInfo "Installing HLS"
liftIO $ createDirRecursive' inst
@ -692,7 +706,7 @@ installHLSPostInst isoFilepath ver =
-- 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
when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver SetHLSOnly
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@
@ -725,6 +739,8 @@ installHLSBin :: ( MonadMask m
, TarDirDoesNotExist
, ArchiveResult
, FileAlreadyExistsError
, ProcessError
, DirNotEmpty
]
m
()
@ -894,9 +910,9 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc
case isolateDir of
Just isoDir -> do
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
liftE $ installHLSUnpacked installDir isoDir Nothing True
liftE $ installHLSUnpackedLegacy installDir isoDir Nothing True
Nothing -> do
liftE $ installHLSUnpacked installDir binDir (Just installVer) True
liftE $ installHLSUnpackedLegacy installDir binDir (Just installVer) True
)
liftE $ installHLSPostInst isolateDir installVer
@ -1088,9 +1104,9 @@ setGHC ver sghc = do
-- first delete the old symlinks (this fixes compatibility issues
-- with old ghcup)
case sghc of
SetGHCOnly -> liftE $ rmPlain (_tvTarget ver)
SetGHC_XY -> liftE $ rmMajorSymlinks ver
SetGHC_XYZ -> liftE $ rmMinorSymlinks ver
SetGHCOnly -> liftE $ rmPlainGHC (_tvTarget ver)
SetGHC_XY -> liftE $ rmMajorGHCSymlinks ver
SetGHC_XYZ -> liftE $ rmMinorGHCSymlinks ver
-- for ghc tools (ghc, ghci, haddock, ...)
verfiles <- ghcToolFiles ver
@ -1170,7 +1186,7 @@ unsetGHC :: ( MonadReader env m
)
=> Maybe Text
-> Excepts '[NotInstalled] m ()
unsetGHC = rmPlain
unsetGHC = rmPlainGHC
-- | Set the @~\/.ghcup\/bin\/cabal@ symlink.
@ -1222,17 +1238,36 @@ setHLS :: ( MonadReader env m
, MonadUnliftIO m
)
=> Version
-> SetHLS -- Nothing for legacy
-> Excepts '[NotInstalled] m ()
setHLS ver = do
setHLS ver shls = do
whenM (lift $ not <$> hlsInstalled ver) (throwE (NotInstalled HLS (GHCTargetVersion Nothing ver)))
-- symlink destination
Dirs {..} <- lift getDirs
-- Delete old symlinks, since these might have different ghc versions than the
-- selected version, so we could end up with stray or incorrect symlinks.
oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do
lift $ logDebug $ "rm " <> T.pack (binDir </> f)
lift $ rmLink (binDir </> f)
-- first delete the old symlinks
case shls of
-- not for legacy
SetHLS_XYZ -> liftE $ rmMinorHLSSymlinks ver
-- legacy and new
SetHLSOnly -> liftE $ rmPlainHLS
case shls of
-- not for legacy
SetHLS_XYZ -> do
bins <- lift $ hlsInternalServerBinaries ver
forM_ bins $ \f -> do
destL <- hlsLinkDestination f ver
let target = if "haskell-language-server-wrapper" `isPrefixOf` f
then f <> "-" <> T.unpack (prettyVer ver) <> exeExt
else f <> "~" <> T.unpack (prettyVer ver) <> exeExt
lift $ createLink destL (binDir </> target)
pure ()
-- legacy and new
SetHLSOnly -> do
-- set haskell-language-server-<ghcver> symlinks
bins <- lift $ hlsServerBinaries ver Nothing
when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver)
@ -1720,14 +1755,14 @@ rmGHCVer ver = do
-- this isn't atomic, order matters
when isSetGHC $ do
lift $ logInfo "Removing ghc symlinks"
liftE $ rmPlain (_tvTarget ver)
liftE $ rmPlainGHC (_tvTarget ver)
lift $ logInfo "Removing ghc-x.y.z symlinks"
liftE $ rmMinorSymlinks ver
liftE $ rmMinorGHCSymlinks ver
lift $ logInfo "Removing/rewiring ghc-x.y symlinks"
-- first remove
handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorSymlinks ver
handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorGHCSymlinks ver
-- then fix them (e.g. with an earlier version)
lift $ logInfo $ "Removing directory recursively: " <> T.pack dir
@ -1796,22 +1831,17 @@ rmHLSVer ver = do
isHlsSet <- lift hlsSet
Dirs {..} <- lift getDirs
bins <- lift $ hlsAllBinaries ver
forM_ bins $ \f -> lift $ recycleFile (binDir </> f)
liftE $ rmMinorHLSSymlinks ver
hlsDir <- ghcupHLSDir ver
recyclePathForcibly hlsDir
when (Just ver == isHlsSet) $ do
-- delete all set symlinks
oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do
let fullF = binDir </> f
lift $ logDebug $ "rm " <> T.pack fullF
lift $ rmLink fullF
rmPlainHLS
-- set latest hls
hlsVers <- lift $ fmap rights getInstalledHLSs
case headMay . reverse . sort $ hlsVers of
Just latestver -> setHLS latestver
Just latestver -> setHLS latestver SetHLSOnly
Nothing -> pure ()
@ -2687,7 +2717,11 @@ whereIsTool tool ver@GHCTargetVersion {..} = do
HLS -> do
whenM (lift $ fmap not $ hlsInstalled _tvVersion)
$ throwE (NotInstalled HLS (GHCTargetVersion Nothing _tvVersion))
pure (binDir dirs </> "haskell-language-server-wrapper-" <> T.unpack (prettyVer _tvVersion) <> exeExt)
bdir <- lift $ ghcupHLSDir _tvVersion
liftIO $ doesDirectoryExist bdir >>= \case
True -> pure (bdir </> "bin" </> "haskell-language-server-wrapper" <> exeExt)
-- legacy
False -> pure (binDir dirs </> "haskell-language-server-wrapper-" <> T.unpack (prettyVer _tvVersion) <> exeExt)
Stack -> do
whenM (lift $ fmap not $ stackInstalled _tvVersion)

4
lib/GHCup/Types.hs
View File

@ -484,6 +484,10 @@ data SetGHC = SetGHCOnly -- ^ unversioned 'ghc'
| SetGHC_XYZ -- ^ ghc-x.y.z
deriving (Eq, Show)
data SetHLS = SetHLSOnly -- ^ unversioned 'hls'
| SetHLS_XYZ -- ^ haskell-language-server-a.b.c~x.y.z, where a.b.c is GHC version and x.y.z is HLS version
deriving (Eq, Show)
data PlatformResult = PlatformResult
{ _platform :: Platform

142
lib/GHCup/Utils.hs
View File

@ -128,7 +128,9 @@ import qualified Data.List.NonEmpty as NE
-- | The symlink destination of a ghc tool.
ghcLinkDestination :: ( MonadReader env m
, HasDirs env
, MonadThrow m, MonadIO m)
, MonadThrow m
, MonadIO m
)
=> FilePath -- ^ the tool, such as 'ghc', 'haddock' etc.
-> GHCTargetVersion
-> m FilePath
@ -138,8 +140,23 @@ ghcLinkDestination tool ver = do
pure (relativeSymlink binDir (ghcd </> "bin" </> tool))
-- | The symlink destination of a hls binary.
hlsLinkDestination :: ( MonadReader env m
, HasDirs env
, MonadThrow m
, MonadIO m
)
=> FilePath -- ^ the binary
-> Version
-> m FilePath
hlsLinkDestination tool ver = do
Dirs {..} <- getDirs
hlsd <- ghcupHLSDir ver
pure (relativeSymlink binDir (hlsd </> "bin" </> tool))
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
rmMinorSymlinks :: ( MonadReader env m
rmMinorGHCSymlinks :: ( MonadReader env m
, HasDirs env
, MonadIO m
, HasLog env
@ -149,7 +166,7 @@ rmMinorSymlinks :: ( MonadReader env m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
rmMinorSymlinks tv@GHCTargetVersion{..} = do
rmMinorGHCSymlinks tv@GHCTargetVersion{..} = do
Dirs {..} <- lift getDirs
files <- liftE $ ghcToolFiles tv
@ -161,7 +178,7 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
-- | Removes the set ghc version for the given target, if any.
rmPlain :: ( MonadReader env m
rmPlainGHC :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadThrow m
@ -171,7 +188,7 @@ rmPlain :: ( MonadReader env m
)
=> Maybe Text -- ^ target
-> Excepts '[NotInstalled] m ()
rmPlain target = do
rmPlainGHC target = do
Dirs {..} <- lift getDirs
mtv <- lift $ ghcSet target
forM_ mtv $ \tv -> do
@ -187,7 +204,7 @@ rmPlain target = do
-- | Remove the major GHC symlink, e.g. ghc-8.6.
rmMajorSymlinks :: ( MonadReader env m
rmMajorGHCSymlinks :: ( MonadReader env m
, HasDirs env
, MonadIO m
, HasLog env
@ -197,7 +214,7 @@ rmMajorSymlinks :: ( MonadReader env m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
rmMajorSymlinks tv@GHCTargetVersion{..} = do
rmMajorGHCSymlinks tv@GHCTargetVersion{..} = do
Dirs {..} <- lift getDirs
(mj, mi) <- getMajorMinorV _tvVersion
let v' = intToText mj <> "." <> intToText mi
@ -210,6 +227,62 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
lift $ hideError doesNotExistErrorType $ rmLink fullF
-- | Removes the minor HLS files, e.g. 'haskell-language-server-8.10.7~1.6.1.0'
-- and 'haskell-language-server-wrapper-1.6.1.0'.
rmMinorHLSSymlinks :: ( MonadReader env m
, HasDirs env
, MonadIO m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadMask m
)
=> Version
-> Excepts '[NotInstalled] m ()
rmMinorHLSSymlinks ver = do
Dirs {..} <- lift getDirs
hlsBins <- hlsAllBinaries ver
forM_ hlsBins $ \f -> do
let fullF = binDir </> f <> exeExt
lift $ logDebug ("rm -f " <> T.pack fullF)
-- on unix, this may be either a file (legacy) or a symlink
-- on windows, this is always a file... hence 'rmFile'
-- works consistently across platforms
lift $ rmFile fullF
-- | Removes the set HLS version, if any.
rmPlainHLS :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadMask m
)
=> Excepts '[NotInstalled] m ()
rmPlainHLS = do
Dirs {..} <- lift getDirs
-- delete 'haskell-language-server-8.10.7'
hlsBins <- fmap (filter (\f -> not ("haskell-language-server-wrapper" `isPrefixOf` f) && not ('~' `elem` f)))
$ liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString))
forM_ hlsBins $ \f -> do
let fullF = binDir </> f
lift $ logDebug ("rm -f " <> T.pack fullF)
if isWindows
then lift $ rmLink fullF
else lift $ rmFile fullF
-- 'haskell-language-server-wrapper'
let hlswrapper = binDir </> "haskell-language-server-wrapper" <> exeExt
lift $ logDebug ("rm -f " <> T.pack hlswrapper)
if isWindows
then lift $ hideError doesNotExistErrorType $ rmLink hlswrapper
else lift $ hideError doesNotExistErrorType $ rmFile hlswrapper
-----------------------------------
@ -353,7 +426,8 @@ cabalSet = do
-- | Get all installed hls, by matching on
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@.
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@,
-- as well as @~\/.ghcup\/hls\/<\hlsver\>@
getInstalledHLSs :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
=> m [Either FilePath Version]
getInstalledHLSs = do
@ -364,7 +438,7 @@ getInstalledHLSs = do
execBlank
([s|^haskell-language-server-wrapper-.*$|] :: ByteString)
)
forM bins $ \f ->
legacy <- forM bins $ \f ->
case
version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "haskell-language-server-wrapper-" f)
of
@ -372,6 +446,14 @@ getInstalledHLSs = do
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
hlsdir <- ghcupHLSBaseDir
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory hlsdir
new <- forM fs $ \f -> case parseGHCupHLSDir f of
Right r -> pure $ Right r
Left _ -> pure $ Left f
pure (nub (new <> legacy))
-- | Get all installed stacks, by matching on
-- @~\/.ghcup\/bin/stack-<\stackver\>@.
getInstalledStacks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
@ -518,7 +600,7 @@ hlsGHCVersions' v' = do
pure . sortBy (flip compare) . rights $ vers
-- | Get all server binaries for an hls version, if any.
-- | Get all server binaries for an hls version from the ~/.ghcup/bin directory, if any.
hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m)
=> Version
-> Maybe Version -- ^ optional GHC version
@ -539,6 +621,14 @@ hlsServerBinaries ver mghcVer = do
)
)
-- | Get all binaries for an hls version from the ~/.ghcup/hls/<ver>/bin directory, if any.
hlsInternalServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
=> Version
-> m [FilePath]
hlsInternalServerBinaries ver = do
dir <- ghcupHLSDir ver
liftIO $ listDirectory (dir </> "bin")
-- | Get the wrapper binary for an hls version, if any.
hlsWrapperBinary :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
@ -569,22 +659,6 @@ hlsAllBinaries ver = do
pure (maybeToList wrapper ++ hls)
-- | Get the active symlinks for hls.
hlsSymlinks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) => m [FilePath]
hlsSymlinks = do
Dirs {..} <- getDirs
oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-.*$|] :: ByteString)
)
filterM
( liftIO
. pathIsLink
. (binDir </>)
)
oldSyms
@ -1157,3 +1231,19 @@ ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
ghcBinaryName :: GHCTargetVersion -> String
ghcBinaryName (GHCTargetVersion (Just t) _) = T.unpack (t <> "-ghc" <> T.pack exeExt)
ghcBinaryName (GHCTargetVersion Nothing _) = T.unpack ("ghc" <> T.pack exeExt)
-- | 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
installDestSanityCheck :: ( MonadIO m
, MonadCatch m
) =>
FilePath ->
Excepts '[DirNotEmpty] m ()
installDestSanityCheck isoDir = do
hideErrorDef [doesNotExistErrorType] () $ do
contents <- liftIO $ getDirectoryContentsRecursive isoDir
unless (null contents) (throwE $ DirNotEmpty isoDir)

22
lib/GHCup/Utils/Dirs.hs
View File

@ -20,8 +20,11 @@ module GHCup.Utils.Dirs
, ghcupCacheDir
, ghcupGHCBaseDir
, ghcupGHCDir
, ghcupHLSBaseDir
, ghcupHLSDir
, mkGhcupTmpDir
, parseGHCupGHCDir
, parseGHCupHLSDir
, relativeSymlink
, withGHCupTmpDir
, getConfigFilePath
@ -46,6 +49,7 @@ import Control.Monad.Reader
import Control.Monad.Trans.Resource hiding (throwM)
import Data.Bifunctor
import Data.Maybe
import Data.Versions
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
import Haskus.Utils.Variant.Excepts
import Optics
@ -244,6 +248,24 @@ parseGHCupGHCDir :: MonadThrow m => FilePath -> m GHCTargetVersion
parseGHCupGHCDir (T.pack -> fp) =
throwEither $ MP.parse ghcTargetVerP "" fp
parseGHCupHLSDir :: MonadThrow m => FilePath -> m Version
parseGHCupHLSDir (T.pack -> fp) =
throwEither $ MP.parse version' "" fp
-- | ~/.ghcup/hls by default, for new-style installs.
ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
ghcupHLSBaseDir = do
Dirs {..} <- getDirs
pure (baseDir </> "hls")
-- | Gets '~/.ghcup/hls/<hls-ver>' for new-style installs.
ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m)
=> Version
-> m FilePath
ghcupHLSDir ver = do
basedir <- ghcupHLSBaseDir
let verdir = T.unpack $ prettyVer ver
pure (basedir </> verdir)
mkGhcupTmpDir :: ( MonadReader env m
, HasDirs env