Support HLS dynamic builds

2022-02-05 01:53:04 +01:00
parent 72a06e964c
commit 51690d1df3
8 changed files with 277 additions and 126 deletions
--- a/lib/GHCup/Types.hs
+++ b/lib/GHCup/Types.hs
@@ -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
--- a/lib/GHCup/Utils.hs
+++ b/lib/GHCup/Utils.hs
@@ -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,18 +140,33 @@ 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
-                   , HasDirs env
-                   , MonadIO m
-                   , HasLog env
-                   , MonadThrow m
-                   , MonadFail m
-                   , MonadMask m
-                   )
-                => GHCTargetVersion
-                -> Excepts '[NotInstalled] m ()
-rmMinorSymlinks tv@GHCTargetVersion{..} = do
+rmMinorGHCSymlinks :: ( MonadReader env m
+                      , HasDirs env
+                      , MonadIO m
+                      , HasLog env
+                      , MonadThrow m
+                      , MonadFail m
+                      , MonadMask m
+                      )
+                   => GHCTargetVersion
+                   -> Excepts '[NotInstalled] m ()
+rmMinorGHCSymlinks tv@GHCTargetVersion{..} = do
  Dirs {..}  <- lift getDirs

  files                         <- liftE $ ghcToolFiles tv
@@ -161,17 +178,17 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do


 -- | Removes the set ghc version for the given target, if any.
-rmPlain :: ( MonadReader env m
-           , HasDirs env
-           , HasLog env
-           , MonadThrow m
-           , MonadFail m
-           , MonadIO m
-           , MonadMask m
-           )
-        => Maybe Text -- ^ target
-        -> Excepts '[NotInstalled] m ()
-rmPlain target = do
+rmPlainGHC :: ( MonadReader env m
+              , HasDirs env
+              , HasLog env
+              , MonadThrow m
+              , MonadFail m
+              , MonadIO m
+              , MonadMask m
+              )
+           => Maybe Text -- ^ target
+           -> Excepts '[NotInstalled] m ()
+rmPlainGHC target = do
  Dirs {..}  <- lift getDirs
  mtv                           <- lift $ ghcSet target
  forM_ mtv $ \tv -> do
@@ -187,17 +204,17 @@ rmPlain target = do


 -- | Remove the major GHC symlink, e.g. ghc-8.6.
-rmMajorSymlinks :: ( MonadReader env m
-                   , HasDirs env
-                   , MonadIO m
-                   , HasLog env
-                   , MonadThrow m
-                   , MonadFail m
-                   , MonadMask m
-                   )
-                => GHCTargetVersion
-                -> Excepts '[NotInstalled] m ()
-rmMajorSymlinks tv@GHCTargetVersion{..} = do
+rmMajorGHCSymlinks :: ( MonadReader env m
+                      , HasDirs env
+                      , MonadIO m
+                      , HasLog env
+                      , MonadThrow m
+                      , MonadFail m
+                      , MonadMask m
+                      )
+                   => GHCTargetVersion
+                   -> Excepts '[NotInstalled] m ()
+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)
--- a/lib/GHCup/Utils/Dirs.hs
+++ b/lib/GHCup/Utils/Dirs.hs
@@ -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