Allow to install haskell-language-server wrt #65
This commit is contained in:
parent
b2027f1625
commit
bb7c4205db
@ -93,6 +93,18 @@ eghcup set ${GHC_VERSION}
|
||||
eghcup rm 8.4.4
|
||||
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
|
||||
|
||||
# install hls
|
||||
if [ "${OS}" = "DARWIN" ] ; then
|
||||
eghcup install hls
|
||||
haskell-language-server-wrapper --version
|
||||
elif [ "${OS}" = "LINUX" ] ; then
|
||||
if [ "${BIT}" = "64" ] ; then
|
||||
eghcup install hls
|
||||
haskell-language-server-wrapper --version
|
||||
fi
|
||||
fi
|
||||
|
||||
|
||||
eghcup rm $(ghc --numeric-version)
|
||||
|
||||
eghcup upgrade
|
||||
|
||||
@ -2,8 +2,9 @@
|
||||
|
||||
## 0.1.11 -- ????-??-??
|
||||
|
||||
* Allow to compile over existing version (`ghcup compile ghc -v 8.6.5 -b 8.6.5`) and replace it wrt #59
|
||||
* Add support for installing haskell-language-server, wrt #65
|
||||
* When compiling GHC from source create a bindist first, store that bindist in `~/.ghcup/cache` and install it, wrt #51
|
||||
* Allow to compile over existing version (`ghcup compile ghc -v 8.6.5 -b 8.6.5`) and replace it wrt #59
|
||||
* simplify installing from custom bindist wrt #60
|
||||
- `ghcup install ghc -u <url> <version>`
|
||||
* fix bug when cabal isn't marked executable in bindist
|
||||
|
||||
@ -83,7 +83,7 @@ ui AppState {..} =
|
||||
)
|
||||
|
||||
where
|
||||
renderItem b ListResult {..} =
|
||||
renderItem b listResult@(ListResult {..}) =
|
||||
let marks = if
|
||||
| lSet -> (withAttr "set" $ str "✔✔")
|
||||
| lInstalled -> (withAttr "installed" $ str "✓ ")
|
||||
@ -102,12 +102,18 @@ ui AppState {..} =
|
||||
(str $ (fmap toLower . show $ lTool) <> " " <> ver)
|
||||
)
|
||||
)
|
||||
<+> (padLeft (Pad 1) $ if null lTag
|
||||
<+> (padLeft (Pad 1) $ minHSize 20 $ if null lTag
|
||||
then emptyWidget
|
||||
else
|
||||
foldr1 (\x y -> x <+> str "," <+> y)
|
||||
$ (fmap printTag $ sort lTag)
|
||||
)
|
||||
<+> ( padLeft (Pad 5)
|
||||
$ let notes = printNotes listResult
|
||||
in if null notes
|
||||
then emptyWidget
|
||||
else foldr1 (\x y -> x <+> str "," <+> y) $ notes
|
||||
)
|
||||
)
|
||||
|
||||
printTag Recommended = withAttr "recommended" $ str "recommended"
|
||||
@ -116,6 +122,12 @@ ui AppState {..} =
|
||||
printTag (Base pvp'') = str ("base-" ++ T.unpack (prettyPVP pvp''))
|
||||
printTag (UnknownTag t ) = str t
|
||||
|
||||
printNotes ListResult{..} =
|
||||
(if hlsPowered then [withAttr "hls-powered" $ str "hls-powered"] else mempty)
|
||||
++ (if fromSrc then [str "compiled"] else mempty)
|
||||
++ (if lStray then [str "stray"] else mempty)
|
||||
++ (if lNoBindist then [str "no-bindist"] else mempty)
|
||||
|
||||
|
||||
minHSize :: Int -> Widget n -> Widget n
|
||||
minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
|
||||
@ -137,6 +149,7 @@ defaultAttributes = attrMap
|
||||
, ("set" , Vty.defAttr `Vty.withForeColor` Vty.green)
|
||||
, ("installed" , Vty.defAttr `Vty.withForeColor` Vty.green)
|
||||
, ("recommended" , Vty.defAttr `Vty.withForeColor` Vty.green)
|
||||
, ("hls-powered" , Vty.defAttr `Vty.withForeColor` Vty.green)
|
||||
, ("latest" , Vty.defAttr `Vty.withForeColor` Vty.yellow)
|
||||
, ("prerelease" , Vty.defAttr `Vty.withForeColor` Vty.red)
|
||||
, ("help" , Vty.defAttr `Vty.withStyle` Vty.italic)
|
||||
@ -223,6 +236,7 @@ install' AppState {..} (_, ListResult {..}) = do
|
||||
GHC -> liftE $ installGHCBin dls lVer pfreq
|
||||
Cabal -> liftE $ installCabalBin dls lVer pfreq
|
||||
GHCup -> liftE $ upgradeGHCup dls Nothing False pfreq $> ()
|
||||
HLS -> liftE $ installHLSBin dls lVer pfreq $> ()
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> pure $ Right ()
|
||||
@ -251,6 +265,7 @@ set' _ (_, ListResult {..}) = do
|
||||
case lTool of
|
||||
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
|
||||
Cabal -> liftE $ setCabal lVer $> ()
|
||||
HLS -> liftE $ setHLS lVer $> ()
|
||||
GHCup -> pure ()
|
||||
)
|
||||
>>= \case
|
||||
@ -270,6 +285,7 @@ del' _ (_, ListResult {..}) = do
|
||||
case lTool of
|
||||
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> ()
|
||||
Cabal -> liftE $ rmCabalVer lVer $> ()
|
||||
HLS -> liftE $ rmHLSVer lVer $> ()
|
||||
GHCup -> pure ()
|
||||
)
|
||||
>>= \case
|
||||
|
||||
@ -116,6 +116,7 @@ prettyToolVer (ToolTag t) = show t
|
||||
|
||||
data InstallCommand = InstallGHC InstallOptions
|
||||
| InstallCabal InstallOptions
|
||||
| InstallHLS InstallOptions
|
||||
|
||||
data InstallOptions = InstallOptions
|
||||
{ instVer :: Maybe ToolVersion
|
||||
@ -125,6 +126,7 @@ data InstallOptions = InstallOptions
|
||||
|
||||
data SetCommand = SetGHC SetOptions
|
||||
| SetCabal SetOptions
|
||||
| SetHLS SetOptions
|
||||
|
||||
data SetOptions = SetOptions
|
||||
{ sToolVer :: Maybe ToolVersion
|
||||
@ -138,6 +140,7 @@ data ListOptions = ListOptions
|
||||
|
||||
data RmCommand = RmGHC RmOptions
|
||||
| RmCabal Version
|
||||
| RmHLS Version
|
||||
|
||||
data RmOptions = RmOptions
|
||||
{ ghcVer :: GHCTargetVersion
|
||||
@ -394,10 +397,29 @@ installParser =
|
||||
)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"hls"
|
||||
( InstallHLS
|
||||
<$> (info
|
||||
(installOpts <**> helper)
|
||||
( progDesc "Install haskell-languge-server"
|
||||
<> footerDoc (Just $ text installHLSFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
<|> (Right <$> installOpts)
|
||||
where
|
||||
installHLSFooter :: String
|
||||
installHLSFooter = [s|Discussion:
|
||||
Installs haskell-language-server binaries and wrapper
|
||||
into "~/.ghcup/bin"
|
||||
|
||||
Examples:
|
||||
# install recommended GHC
|
||||
ghcup install hls|]
|
||||
|
||||
installGHCFooter :: String
|
||||
installGHCFooter = [s|Discussion:
|
||||
Installs the specified GHC version (or a recommended default one) into
|
||||
@ -470,6 +492,16 @@ setParser =
|
||||
)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"hls"
|
||||
( SetHLS
|
||||
<$> (info
|
||||
(setOpts <**> helper)
|
||||
( progDesc "Set haskell-language-server version"
|
||||
<> footerDoc (Just $ text setHLSFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
<|> (Right <$> setOpts)
|
||||
@ -484,6 +516,10 @@ setParser =
|
||||
setCabalFooter = [s|Discussion:
|
||||
Sets the the current Cabal version.|]
|
||||
|
||||
setHLSFooter :: String
|
||||
setHLSFooter = [s|Discussion:
|
||||
Sets the the current haskell-language-server version.|]
|
||||
|
||||
|
||||
setOpts :: Parser SetOptions
|
||||
setOpts = SetOptions <$> optional toolVersionArgument
|
||||
@ -526,6 +562,13 @@ rmParser =
|
||||
(progDesc "Remove Cabal version")
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"hls"
|
||||
( RmHLS
|
||||
<$> (info (versionParser' <**> helper)
|
||||
(progDesc "Remove haskell-language-server version")
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
<|> (Right <$> rmOpts)
|
||||
@ -976,6 +1019,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
, TagNotFound
|
||||
]
|
||||
|
||||
let
|
||||
runSetHLS =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE
|
||||
@'[ NotInstalled
|
||||
, TagNotFound
|
||||
]
|
||||
|
||||
let runListGHC = runLogger . flip runReaderT settings
|
||||
|
||||
let runRm =
|
||||
@ -1154,6 +1206,40 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
$(logError) [i|Also check the logs in #{logsDir}|]
|
||||
pure $ ExitFailure 4
|
||||
|
||||
let installHLS InstallOptions{..} =
|
||||
(case instBindist of
|
||||
Nothing -> runInstTool $ do
|
||||
v <- liftE $ fromVersion dls instVer HLS
|
||||
liftE $ installHLSBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
|
||||
Just uri -> runInstTool' settings{noVerify = True} $ do
|
||||
v <- liftE $ fromVersion dls instVer HLS
|
||||
liftE $ installHLSBindist
|
||||
(DownloadInfo uri Nothing "")
|
||||
(_tvVersion v)
|
||||
(fromMaybe pfreq instPlatform)
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> do
|
||||
runLogger $ $(logInfo) ("HLS installation successful")
|
||||
pure ExitSuccess
|
||||
VLeft (V (AlreadyInstalled _ v)) -> do
|
||||
runLogger $ $(logWarn)
|
||||
[i|HLS ver #{prettyVer v} already installed, you may want to run 'ghcup rm hls #{prettyVer v}' first|]
|
||||
pure ExitSuccess
|
||||
VLeft (V NoDownload) -> do
|
||||
|
||||
runLogger $ do
|
||||
case instVer of
|
||||
Just iver -> $(logError) [i|No available HLS version for #{prettyToolVer iver}|]
|
||||
Nothing -> $(logError) [i|No available recommended HLS version|]
|
||||
pure $ ExitFailure 4
|
||||
VLeft e -> do
|
||||
runLogger $ do
|
||||
$(logError) [i|#{e}|]
|
||||
$(logError) [i|Also check the logs in #{logsDir}|]
|
||||
pure $ ExitFailure 4
|
||||
|
||||
|
||||
let setGHC' SetOptions{..} =
|
||||
(runSetGHC $ do
|
||||
v <- liftE $ fromVersion dls sToolVer GHC
|
||||
@ -1180,6 +1266,17 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
runLogger ($(logError) [i|#{e}|])
|
||||
pure $ ExitFailure 14
|
||||
|
||||
let setHLS' SetOptions{..} =
|
||||
(runSetHLS $ do
|
||||
v <- liftE $ fromVersion dls sToolVer HLS
|
||||
liftE $ setHLS (_tvVersion v)
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger ($(logError) [i|#{e}|])
|
||||
pure $ ExitFailure 14
|
||||
|
||||
let rmGHC' RmOptions{..} =
|
||||
(runRm $ do
|
||||
liftE $ rmGHCVer ghcVer
|
||||
@ -1200,6 +1297,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
runLogger ($(logError) [i|#{e}|])
|
||||
pure $ ExitFailure 15
|
||||
|
||||
let rmHLS' tv =
|
||||
(runRm $ do
|
||||
liftE $ rmHLSVer tv
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger ($(logError) [i|#{e}|])
|
||||
pure $ ExitFailure 15
|
||||
|
||||
|
||||
res <- case optCommand of
|
||||
@ -1211,6 +1317,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
installGHC iopts
|
||||
Install (Left (InstallGHC iopts)) -> installGHC iopts
|
||||
Install (Left (InstallCabal iopts)) -> installCabal iopts
|
||||
Install (Left (InstallHLS iopts)) -> installHLS iopts
|
||||
InstallCabalLegacy iopts -> do
|
||||
runLogger ($(logWarn) [i|This is an old-style command for installing cabal. Use 'ghcup install cabal' instead.|])
|
||||
installCabal iopts
|
||||
@ -1220,6 +1327,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
setGHC' sopts
|
||||
Set (Left (SetGHC sopts)) -> setGHC' sopts
|
||||
Set (Left (SetCabal sopts)) -> setCabal' sopts
|
||||
Set (Left (SetHLS sopts)) -> setHLS' sopts
|
||||
|
||||
List (ListOptions {..}) ->
|
||||
(runListGHC $ do
|
||||
@ -1233,6 +1341,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
rmGHC' rmopts
|
||||
Rm (Left (RmGHC rmopts)) -> rmGHC' rmopts
|
||||
Rm (Left (RmCabal rmopts)) -> rmCabal' rmopts
|
||||
Rm (Left (RmHLS rmopts)) -> rmHLS' rmopts
|
||||
|
||||
DInfo ->
|
||||
do
|
||||
@ -1440,7 +1549,8 @@ printListResult raw lr = do
|
||||
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
|
||||
, intercalate "," $ (fmap printTag $ sort lTag)
|
||||
, intercalate ","
|
||||
$ (if fromSrc then [color' Blue "compiled"] else mempty)
|
||||
$ (if hlsPowered then [color' Green "hls-powered"] else mempty)
|
||||
++ (if fromSrc then [color' Blue "compiled"] else mempty)
|
||||
++ (if lStray then [color' Yellow "stray"] else mempty)
|
||||
++ (if lNoBindist then [color' Red "no-bindist"] else mempty)
|
||||
]
|
||||
@ -1482,6 +1592,13 @@ checkForUpdates dls pfreq = do
|
||||
$ $(logWarn)
|
||||
[i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|]
|
||||
|
||||
forM_ (getLatest dls HLS) $ \l -> do
|
||||
mcabal_ver <- latestInstalled HLS
|
||||
forM mcabal_ver $ \cabal_ver ->
|
||||
when (l > cabal_ver)
|
||||
$ $(logWarn)
|
||||
[i|New HLS version available: #{prettyVer l}. To upgrade, run 'ghcup install hls #{prettyVer l}'|]
|
||||
|
||||
where
|
||||
latestInstalled tool = (fmap lVer . lastMay)
|
||||
<$> (listVersions dls (Just tool) (Just ListInstalled) pfreq)
|
||||
|
||||
@ -1425,3 +1425,20 @@ ghcupDownloads:
|
||||
dlHash: 50ac43199b64bc0724400b0a3db674bef3ec53cf6d41acc04a2c4ca8557e534f
|
||||
Linux_Alpine:
|
||||
unknown_versioning: *ghcup-32
|
||||
|
||||
HLS:
|
||||
0.4.0:
|
||||
viTags:
|
||||
- Recommended
|
||||
- Latest
|
||||
viChangeLog: https://github.com/haskell/haskell-language-server/blob/master/ChangeLog.md#040
|
||||
viArch:
|
||||
A_64:
|
||||
Linux_UnknownLinux:
|
||||
unknown_versioning:
|
||||
dlUri: https://files.hasufell.de/hls/haskell-language-server-Linux-0.4.0.tar.gz
|
||||
dlHash: a132365554a1bfcbdfef7403366854f09e6f05376c6aec6562500f09e32af9ed
|
||||
Darwin:
|
||||
unknown_versioning:
|
||||
dlUri: https://files.hasufell.de/hls/haskell-language-server-macOS-0.4.0.tar.gz
|
||||
dlHash: 8f7ceaf1150774029d45420895546b50fd70605c0ef0b055344a3600e54721ce
|
||||
|
||||
18372
golden/GHCupInfo.json
18372
golden/GHCupInfo.json
File diff suppressed because it is too large
Load Diff
261
lib/GHCup.hs
261
lib/GHCup.hs
@ -357,6 +357,130 @@ installCabalBin bDls ver pfreq = do
|
||||
installCabalBindist dlinfo ver pfreq
|
||||
|
||||
|
||||
-- | Like 'installHLSBin, except takes the 'DownloadInfo' as
|
||||
-- argument instead of looking it up from 'GHCupDownloads'.
|
||||
installHLSBindist :: ( MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader Settings m
|
||||
, MonadLogger m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> DownloadInfo
|
||||
-> Version
|
||||
-> PlatformRequest
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, CopyError
|
||||
, DigestError
|
||||
, DownloadFailed
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, UnknownArchive
|
||||
, TarDirDoesNotExist
|
||||
#if !defined(TAR)
|
||||
, ArchiveResult
|
||||
#endif
|
||||
]
|
||||
m
|
||||
()
|
||||
installHLSBindist dlinfo ver (PlatformRequest {..}) = do
|
||||
lift $ $(logDebug) [i|Requested to install hls version #{ver}|]
|
||||
|
||||
Settings {dirs = Dirs {..}} <- lift ask
|
||||
|
||||
whenM (lift (hlsInstalled ver))
|
||||
$ (throwE $ AlreadyInstalled HLS ver)
|
||||
|
||||
-- download (or use cached version)
|
||||
dl <- liftE $ downloadCached dlinfo Nothing
|
||||
|
||||
-- unpack
|
||||
tmpUnpack <- lift withGHCupTmpDir
|
||||
liftE $ unpackToDir tmpUnpack dl
|
||||
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
|
||||
|
||||
-- the subdir of the archive where we do the work
|
||||
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
|
||||
|
||||
liftE $ installHLS' workdir binDir
|
||||
|
||||
-- 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
|
||||
|
||||
pure ()
|
||||
|
||||
where
|
||||
-- | Install an unpacked hls distribution.
|
||||
installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> Path Abs -- ^ Path to the unpacked hls bindist (where the executable resides)
|
||||
-> Path Abs -- ^ Path to install to
|
||||
-> Excepts '[CopyError] m ()
|
||||
installHLS' path inst = 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
|
||||
toF <- parseRel (toFilePath f <> "~" <> verToBS ver)
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> f)
|
||||
(inst </> toF)
|
||||
Overwrite
|
||||
lift $ chmod_777 (inst </> toF)
|
||||
|
||||
-- install haskell-language-server-wrapper
|
||||
let wrapper = [rel|haskell-language-server-wrapper|]
|
||||
toF <- parseRel (toFilePath wrapper <> "-" <> verToBS ver)
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> wrapper)
|
||||
(inst </> toF)
|
||||
Overwrite
|
||||
lift $ chmod_777 (inst </> toF)
|
||||
|
||||
|
||||
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@
|
||||
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
|
||||
installHLSBin :: ( MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader Settings m
|
||||
, MonadLogger m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Version
|
||||
-> PlatformRequest
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, CopyError
|
||||
, DigestError
|
||||
, DownloadFailed
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, UnknownArchive
|
||||
, TarDirDoesNotExist
|
||||
#if !defined(TAR)
|
||||
, ArchiveResult
|
||||
#endif
|
||||
]
|
||||
m
|
||||
()
|
||||
installHLSBin bDls ver pfreq = do
|
||||
dlinfo <- lE $ getDownloadInfo HLS ver pfreq bDls
|
||||
installHLSBindist dlinfo ver pfreq
|
||||
|
||||
|
||||
|
||||
|
||||
---------------------
|
||||
@ -487,6 +611,55 @@ setCabal ver = do
|
||||
|
||||
|
||||
|
||||
-- | Set the haskell-language-server symlinks.
|
||||
setHLS :: ( MonadCatch m
|
||||
, MonadReader Settings m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
, MonadIO m
|
||||
)
|
||||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
setHLS ver = do
|
||||
Settings { dirs = Dirs {..} } <- lift ask
|
||||
liftIO $ createDirRecursive' binDir
|
||||
|
||||
-- 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) [i|rm #{toFilePath (binDir </> f)}|]
|
||||
liftIO $ deleteFile (binDir </> f)
|
||||
|
||||
-- set haskell-language-server-<ghcver> symlinks
|
||||
bins <- lift $ hlsServerBinaries ver
|
||||
when (bins == []) $ throwE $ NotInstalled HLS (prettyVer ver)
|
||||
|
||||
forM_ bins $ \f -> do
|
||||
let destL = toFilePath f
|
||||
target <- parseRel . head . B.split _tilde . toFilePath $ f
|
||||
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath (binDir </> target)}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> target)
|
||||
|
||||
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath (binDir </> target)}|]
|
||||
liftIO $ createSymlink (binDir </> target) destL
|
||||
|
||||
-- set haskell-language-server-wrapper symlink
|
||||
let destL = "haskell-language-server-wrapper-" <> verToBS ver
|
||||
let wrapper = binDir </> [rel|haskell-language-server-wrapper|]
|
||||
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath wrapper}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile wrapper
|
||||
|
||||
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath wrapper}|]
|
||||
liftIO $ createSymlink wrapper destL
|
||||
|
||||
pure ()
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
@ -511,6 +684,7 @@ data ListResult = ListResult
|
||||
, fromSrc :: Bool -- ^ compiled from source
|
||||
, lStray :: Bool -- ^ not in download info
|
||||
, lNoBindist :: Bool -- ^ whether the version is available for this platform/arch
|
||||
, hlsPowered :: Bool
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
@ -544,22 +718,25 @@ listVersions av lt criteria pfreq = do
|
||||
lr <- filter' <$> forM (Map.toList avTools) (toListResult t)
|
||||
|
||||
case t of
|
||||
-- append stray GHCs
|
||||
GHC -> do
|
||||
slr <- strayGHCs avTools
|
||||
pure $ (sort (slr ++ lr))
|
||||
Cabal -> do
|
||||
slr <- strayCabals avTools
|
||||
pure $ (sort (slr ++ lr))
|
||||
_ -> pure lr
|
||||
HLS -> do
|
||||
slr <- strayHLS avTools
|
||||
pure $ (sort (slr ++ lr))
|
||||
GHCup -> pure lr
|
||||
Nothing -> do
|
||||
ghcvers <- listVersions av (Just GHC) criteria pfreq
|
||||
cabalvers <- listVersions av (Just Cabal) criteria pfreq
|
||||
hlsvers <- listVersions av (Just HLS) criteria pfreq
|
||||
ghcupvers <- listVersions av (Just GHCup) criteria pfreq
|
||||
pure (ghcvers <> cabalvers <> ghcupvers)
|
||||
pure (ghcvers <> cabalvers <> hlsvers <> ghcupvers)
|
||||
|
||||
where
|
||||
strayGHCs :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
|
||||
strayGHCs :: (MonadCatch m, MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
|
||||
=> Map.Map Version [Tag]
|
||||
-> m [ListResult]
|
||||
strayGHCs avTools = do
|
||||
@ -571,6 +748,7 @@ listVersions av lt criteria pfreq = do
|
||||
Nothing -> do
|
||||
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing
|
||||
fromSrc <- ghcSrcInstalled tver
|
||||
hlsPowered <- fmap (elem _tvVersion) $ hlsGHCVersions
|
||||
pure $ Just $ ListResult
|
||||
{ lTool = GHC
|
||||
, lVer = _tvVersion
|
||||
@ -584,6 +762,7 @@ listVersions av lt criteria pfreq = do
|
||||
Right tver@GHCTargetVersion{ .. } -> do
|
||||
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget
|
||||
fromSrc <- ghcSrcInstalled tver
|
||||
hlsPowered <- fmap (elem _tvVersion) $ hlsGHCVersions
|
||||
pure $ Just $ ListResult
|
||||
{ lTool = GHC
|
||||
, lVer = _tvVersion
|
||||
@ -619,6 +798,35 @@ listVersions av lt criteria pfreq = do
|
||||
, lStray = maybe True (const False) (Map.lookup ver avTools)
|
||||
, lNoBindist = False
|
||||
, fromSrc = False -- actually, we don't know :>
|
||||
, hlsPowered = False
|
||||
, ..
|
||||
}
|
||||
Left e -> do
|
||||
$(logWarn)
|
||||
[i|Could not parse version of stray directory #{toFilePath e}|]
|
||||
pure Nothing
|
||||
|
||||
strayHLS :: (MonadReader Settings m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
|
||||
=> Map.Map Version [Tag]
|
||||
-> m [ListResult]
|
||||
strayHLS avTools = do
|
||||
hlss <- getInstalledHLSs
|
||||
fmap catMaybes $ forM hlss $ \case
|
||||
Right ver ->
|
||||
case Map.lookup ver avTools of
|
||||
Just _ -> pure Nothing
|
||||
Nothing -> do
|
||||
lSet <- fmap (maybe False (== ver)) $ hlsSet
|
||||
pure $ Just $ ListResult
|
||||
{ lTool = HLS
|
||||
, lVer = ver
|
||||
, lCross = Nothing
|
||||
, lTag = []
|
||||
, lInstalled = True
|
||||
, lStray = maybe True (const False) (Map.lookup ver avTools)
|
||||
, lNoBindist = False
|
||||
, fromSrc = False -- actually, we don't know :>
|
||||
, hlsPowered = False
|
||||
, ..
|
||||
}
|
||||
Left e -> do
|
||||
@ -635,6 +843,7 @@ listVersions av lt criteria pfreq = do
|
||||
lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing
|
||||
lInstalled <- ghcInstalled tver
|
||||
fromSrc <- ghcSrcInstalled tver
|
||||
hlsPowered <- fmap (elem v) $ hlsGHCVersions
|
||||
pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. }
|
||||
Cabal -> do
|
||||
let lNoBindist = isLeft $ getDownloadInfo Cabal v pfreq av
|
||||
@ -646,6 +855,7 @@ listVersions av lt criteria pfreq = do
|
||||
, lTool = t
|
||||
, fromSrc = False
|
||||
, lStray = False
|
||||
, hlsPowered = False
|
||||
, ..
|
||||
}
|
||||
GHCup -> do
|
||||
@ -658,6 +868,20 @@ listVersions av lt criteria pfreq = do
|
||||
, fromSrc = False
|
||||
, lStray = False
|
||||
, lNoBindist = False
|
||||
, hlsPowered = False
|
||||
, ..
|
||||
}
|
||||
HLS -> do
|
||||
let lNoBindist = isLeft $ getDownloadInfo HLS v pfreq av
|
||||
lSet <- fmap (maybe False (== v)) $ hlsSet
|
||||
lInstalled <- hlsInstalled v
|
||||
pure ListResult { lVer = v
|
||||
, lCross = Nothing
|
||||
, lTag = tags
|
||||
, lTool = t
|
||||
, fromSrc = False
|
||||
, lStray = False
|
||||
, hlsPowered = False
|
||||
, ..
|
||||
}
|
||||
|
||||
@ -749,6 +973,35 @@ rmCabalVer ver = do
|
||||
(binDir </> [rel|cabal|])
|
||||
|
||||
|
||||
-- | Delete a hls version. Will try to fix the hls symlinks
|
||||
-- after removal (e.g. setting it to an older version).
|
||||
rmHLSVer :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m)
|
||||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmHLSVer ver = do
|
||||
whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (prettyVer ver))
|
||||
|
||||
isHlsSet <- lift $ hlsSet
|
||||
|
||||
Settings {dirs = Dirs {..}} <- lift ask
|
||||
|
||||
bins <- lift $ hlsAllBinaries ver
|
||||
forM_ bins $ \f -> liftIO $ deleteFile (binDir </> f)
|
||||
|
||||
when (maybe False (== ver) isHlsSet) $ do
|
||||
-- delete all set symlinks
|
||||
oldSyms <- lift hlsSymlinks
|
||||
forM_ oldSyms $ \f -> do
|
||||
lift $ $(logDebug) [i|rm #{toFilePath (binDir </> f)}|]
|
||||
liftIO $ deleteFile (binDir </> f)
|
||||
-- set latest hls
|
||||
hlsVers <- lift $ fmap rights $ getInstalledHLSs
|
||||
case headMay . reverse . sort $ hlsVers of
|
||||
Just latestver -> setHLS latestver
|
||||
Nothing -> pure ()
|
||||
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Debug info ]--
|
||||
|
||||
@ -152,3 +152,10 @@ data ParseError = ParseError String
|
||||
deriving Show
|
||||
|
||||
instance Exception ParseError
|
||||
|
||||
|
||||
data UnexpectedListLength = UnexpectedListLength String
|
||||
deriving Show
|
||||
|
||||
instance Exception UnexpectedListLength
|
||||
|
||||
|
||||
@ -76,6 +76,7 @@ type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
|
||||
data Tool = GHC
|
||||
| Cabal
|
||||
| GHCup
|
||||
| HLS
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
|
||||
|
||||
@ -301,6 +301,150 @@ cabalSet = do
|
||||
|
||||
|
||||
|
||||
-- | Get all installed hls, by matching on
|
||||
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@.
|
||||
getInstalledHLSs :: (MonadReader Settings m, MonadIO m, MonadCatch m)
|
||||
=> m [Either (Path Rel) Version]
|
||||
getInstalledHLSs = do
|
||||
Settings { dirs = Dirs {..} } <- ask
|
||||
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
(makeRegexOpts compExtended
|
||||
execBlank
|
||||
([s|^haskell-language-server-wrapper-.*$|] :: ByteString)
|
||||
)
|
||||
vs <- forM bins $ \f ->
|
||||
case
|
||||
fmap
|
||||
version
|
||||
(fmap decUTF8Safe . B.stripPrefix "haskell-language-server-wrapper-" . toFilePath $ f)
|
||||
of
|
||||
Just (Right r) -> pure $ Right r
|
||||
Just (Left _) -> pure $ Left f
|
||||
Nothing -> pure $ Left f
|
||||
pure $ vs
|
||||
|
||||
|
||||
-- | Whether the given HLS version is installed.
|
||||
hlsInstalled :: (MonadIO m, MonadReader Settings m, MonadCatch m) => Version -> m Bool
|
||||
hlsInstalled ver = do
|
||||
vers <- fmap rights $ getInstalledHLSs
|
||||
pure $ elem ver $ vers
|
||||
|
||||
|
||||
|
||||
-- Return the currently set hls version, if any.
|
||||
hlsSet :: (MonadReader Settings m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
|
||||
hlsSet = do
|
||||
Settings {dirs = Dirs {..}} <- ask
|
||||
let hlsBin = binDir </> [rel|haskell-language-server-wrapper|]
|
||||
|
||||
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
|
||||
broken <- isBrokenSymlink hlsBin
|
||||
if broken
|
||||
then pure Nothing
|
||||
else do
|
||||
link <- readSymbolicLink $ toFilePath hlsBin
|
||||
Just <$> linkVersion link
|
||||
where
|
||||
linkVersion :: MonadThrow m => ByteString -> m Version
|
||||
linkVersion bs = do
|
||||
t <- throwEither $ E.decodeUtf8' bs
|
||||
throwEither $ MP.parse parser "" t
|
||||
where
|
||||
parser =
|
||||
MP.chunk "haskell-language-server-wrapper-" *> version'
|
||||
|
||||
|
||||
-- | Return the GHC versions the currently selected HLS supports.
|
||||
hlsGHCVersions :: ( MonadReader Settings m
|
||||
, MonadIO m
|
||||
, MonadThrow m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> m [Version]
|
||||
hlsGHCVersions = do
|
||||
h <- hlsSet
|
||||
vers <- forM h $ \h' -> do
|
||||
bins <- hlsServerBinaries h'
|
||||
pure $ fmap
|
||||
(\bin ->
|
||||
version
|
||||
. decUTF8Safe
|
||||
. fromJust
|
||||
. B.stripPrefix "haskell-language-server-"
|
||||
. head
|
||||
. B.split _tilde
|
||||
. toFilePath
|
||||
$ bin
|
||||
)
|
||||
bins
|
||||
pure . rights . concat . maybeToList $ vers
|
||||
|
||||
|
||||
-- | Get all server binaries for an hls version, if any.
|
||||
hlsServerBinaries :: (MonadReader Settings m, MonadIO m)
|
||||
=> Version
|
||||
-> m [Path Rel]
|
||||
hlsServerBinaries ver = do
|
||||
Settings { dirs = Dirs {..} } <- ask
|
||||
liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
(makeRegexOpts
|
||||
compExtended
|
||||
execBlank
|
||||
([s|^haskell-language-server-.*~|] <> escapeVerRex ver <> [s|$|] :: ByteString
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
-- | Get the wrapper binary for an hls version, if any.
|
||||
hlsWrapperBinary :: (MonadReader Settings m, MonadThrow m, MonadIO m)
|
||||
=> Version
|
||||
-> m (Maybe (Path Rel))
|
||||
hlsWrapperBinary ver = do
|
||||
Settings { dirs = Dirs {..} } <- ask
|
||||
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
(makeRegexOpts
|
||||
compExtended
|
||||
execBlank
|
||||
([s|^haskell-language-server-wrapper-|] <> escapeVerRex ver <> [s|$|] :: ByteString
|
||||
)
|
||||
)
|
||||
case wrapper of
|
||||
[] -> pure $ Nothing
|
||||
[x] -> pure $ Just x
|
||||
_ -> throwM $ UnexpectedListLength
|
||||
"There were multiple hls wrapper binaries for a single version"
|
||||
|
||||
|
||||
-- | Get all binaries for an hls version, if any.
|
||||
hlsAllBinaries :: (MonadReader Settings m, MonadIO m, MonadThrow m) => Version -> m [Path Rel]
|
||||
hlsAllBinaries ver = do
|
||||
hls <- hlsServerBinaries ver
|
||||
wrapper <- hlsWrapperBinary ver
|
||||
pure (maybeToList wrapper ++ hls)
|
||||
|
||||
|
||||
-- | Get the active symlinks for hls.
|
||||
hlsSymlinks :: (MonadReader Settings m, MonadIO m, MonadCatch m) => m [Path Rel]
|
||||
hlsSymlinks = do
|
||||
Settings { dirs = Dirs {..} } <- ask
|
||||
oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
(makeRegexOpts compExtended
|
||||
execBlank
|
||||
([s|^haskell-language-server-.*$|] :: ByteString)
|
||||
)
|
||||
filterM
|
||||
( fmap (== SymbolicLink)
|
||||
. liftIO
|
||||
. getFileType
|
||||
. (binDir </>)
|
||||
)
|
||||
oldSyms
|
||||
|
||||
|
||||
|
||||
-----------------------------------------
|
||||
|
||||
@ -31,11 +31,13 @@ import Data.ByteString ( ByteString )
|
||||
import Data.String
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import Data.Word8
|
||||
import Haskus.Utils.Types.List
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import System.IO.Error
|
||||
import System.Posix.Env.ByteString ( getEnvironment )
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Strict.Maybe as S
|
||||
import qualified Data.Text as T
|
||||
@ -275,3 +277,13 @@ decUTF8Safe = E.decodeUtf8With E.lenientDecode
|
||||
|
||||
decUTF8Safe' :: L.ByteString -> Text
|
||||
decUTF8Safe' = TL.toStrict . TLE.decodeUtf8With E.lenientDecode
|
||||
|
||||
|
||||
-- | Escape a version for use in regex
|
||||
escapeVerRex :: Version -> ByteString
|
||||
escapeVerRex = B.pack . go . B.unpack . verToBS
|
||||
where
|
||||
go [] = []
|
||||
go (x : xs) | x == _period = [_backslash, _period] ++ go xs
|
||||
| otherwise = x : go xs
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user