Allow to install haskell-language-server wrt #65

.gitlab/script/ghcup_version.sh

@@ -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

CHANGELOG.md

@@ -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

app/ghcup/BrickMain.hs

@@ -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

app/ghcup/Main.hs

@@ -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)

ghcup-0.0.2.yaml

@@ -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

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 ]--

lib/GHCup/Errors.hs

@@ -152,3 +152,10 @@ data ParseError = ParseError String
   deriving Show
 
 instance Exception ParseError
+
+
+data UnexpectedListLength = UnexpectedListLength String
+  deriving Show
+
+instance Exception UnexpectedListLength
+

lib/GHCup/Types.hs

@@ -76,6 +76,7 @@ type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
 data Tool = GHC
           | Cabal
           | GHCup
+          | HLS
   deriving (Eq, GHC.Generic, Ord, Show)
 
 

lib/GHCup/Utils.hs

@@ -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
+
 
 
     -----------------------------------------

lib/GHCup/Utils/Prelude.hs

@@ -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
+