Refactoring and fixes

2022-02-05 19:11:56 +01:00 · 2022-02-05 19:11:56 +01:00 · 6831337289
parent e40777a5d3
commit 6831337289
3 changed files with 91 additions and 51 deletions
--- a/lib/GHCup.hs
+++ b/lib/GHCup.hs
@ -1125,9 +1125,10 @@ setGHC ver sghc = do

    -- create symlink
    forM_ mTargetFile $ \targetFile -> do
+      bindir <- ghcInternalBinDir ver
      let fullF = binDir </> targetFile  <> exeExt
-          fileWithExt = file <> exeExt
-      destL <- lift $ ghcLinkDestination fileWithExt ver
+          fileWithExt = bindir </> file <> exeExt
+      destL <- binarySymLinkDestination fileWithExt
      lift $ createLink destL fullF

  -- create symlink for share dir
@ -1256,13 +1257,14 @@ setHLS ver shls = do
  case shls of
    -- not for legacy
    SetHLS_XYZ -> do
-      bins <- lift $ hlsInternalServerBinaries ver
+      bins <- lift $ hlsInternalServerScripts ver Nothing

      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
+        let fname = takeFileName f
+        destL <- binarySymLinkDestination f
+        let target = if "haskell-language-server-wrapper" `isPrefixOf` fname
+                     then fname <> "-" <> T.unpack (prettyVer ver) <> exeExt
+                     else fname <> "~" <> T.unpack (prettyVer ver) <> exeExt
        lift $ createLink destL (binDir </> target)

      pure ()
@ -2717,11 +2719,11 @@ whereIsTool tool ver@GHCTargetVersion {..} = do
    HLS -> do
      whenM (lift $ fmap not $ hlsInstalled _tvVersion)
        $ throwE (NotInstalled HLS (GHCTargetVersion Nothing _tvVersion))
-      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)
+      ifM (lift $ isLegacyHLS _tvVersion)
+        (pure (binDir dirs </> "haskell-language-server-wrapper-" <> T.unpack (prettyVer _tvVersion) <> exeExt))
+        $ do
+          bdir <- lift $ ghcupHLSDir _tvVersion
+          pure (bdir </> "bin" </> "haskell-language-server-wrapper" <> exeExt)

    Stack -> do
      whenM (lift $ fmap not $ stackInstalled _tvVersion)
--- a/lib/GHCup/Utils.hs
+++ b/lib/GHCup/Utils.hs
@ -125,38 +125,20 @@ import qualified Data.List.NonEmpty            as NE
    ------------------------


-- | The symlink destination of a ghc tool.
-ghcLinkDestination :: ( MonadReader env m
-                      , HasDirs env
-                      , MonadThrow m
-                      , MonadIO m
-                      )
-                   => FilePath -- ^ the tool, such as 'ghc', 'haddock' etc.
-                   -> GHCTargetVersion
-                   -> m FilePath
-ghcLinkDestination tool ver = do
+-- | Create a relative symlink destination for the binary directory,
+-- given a target toolpath.
+binarySymLinkDestination :: ( MonadReader env m
+                            , HasDirs env
+                            , MonadThrow m
+                            , MonadIO m
+                            )
+                         => FilePath -- ^ the full toolpath
+                         -> m FilePath
+binarySymLinkDestination toolPath = do
  Dirs {..}  <- getDirs
-  ghcd <- ghcupGHCDir ver
-  ghcd' <- liftIO $ canonicalizePath ghcd
+  toolPath' <- liftIO $ canonicalizePath toolPath
  binDir' <- liftIO $ canonicalizePath binDir
-  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
-  hlsd' <- liftIO $ canonicalizePath hlsd
-  binDir' <- liftIO $ canonicalizePath binDir
-  pure (relativeSymlink binDir' (hlsd' </> "bin" </> tool))
+  pure (relativeSymlink binDir' toolPath')


 -- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
@ -533,6 +515,10 @@ hlsInstalled ver = do
  vers <- fmap rights getInstalledHLSs
  pure $ elem ver vers

+isLegacyHLS :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
+isLegacyHLS ver = do
+  bdir <- ghcupHLSDir ver
+  not <$> (liftIO $ doesDirectoryExist bdir)


 -- Return the currently set hls version, if any.
@ -625,13 +611,43 @@ 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)
+-- | Get all scripts for a hls version from the ~/.ghcup/hls/<ver>/bin directory, if any.
+-- Returns the full path.
+hlsInternalServerScripts :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
                          => Version
+                          -> Maybe Version   -- ^ optional GHC version
                          -> m [FilePath]
-hlsInternalServerBinaries ver = do
+hlsInternalServerScripts ver mghcVer = do
  dir <- ghcupHLSDir ver
-  liftIO $ listDirectory (dir </> "bin")
+  let bdir = dir </> "bin"
+  (fmap (bdir </>) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer))
+    <$> (liftIO $ listDirectory bdir)
+
+-- | Get all binaries for a hls version from the ~/.ghcup/hls/<ver>/lib/haskell-language-server-<ver>/bin directory, if any.
+-- Returns the full path.
+hlsInternalServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadFail m)
+                          => Version
+                          -> Maybe Version   -- ^ optional GHC version
+                          -> m [FilePath]
+hlsInternalServerBinaries ver mghcVer = do
+  dir <- ghcupHLSDir ver
+  let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString)
+  (Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir </> "lib"), Right regex, Left "bin"]
+  (fmap (bdir </>) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer))
+    <$> (liftIO $ listDirectory bdir)
+
+-- | Get all libraries for a hls version from the ~/.ghcup/hls/<ver>/lib/haskell-language-server-<ver>/lib/<ghc-ver>/
+-- directory, if any.
+-- Returns the full path.
+hlsInternalServerLibs :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadFail m)
+                      => Version
+                      -> Version   -- ^ GHC version
+                      -> m [FilePath]
+hlsInternalServerLibs ver ghcVer = do
+  dir <- ghcupHLSDir ver
+  let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString)
+  (Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir </> "lib"), Right regex, Left ("lib" </> T.unpack (prettyVer ghcVer))]
+  (fmap (bdir </>)) <$> (liftIO $ listDirectory bdir)


 -- | Get the wrapper binary for an hls version, if any.
@ -887,8 +903,16 @@ getLatestBaseVersion av pvpVer =
    --[ Other ]--
    -------------

+-- | Usually @~\/.ghcup\/ghc\/\<ver\>\/bin\/@
+ghcInternalBinDir :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
+                  => GHCTargetVersion
+                  -> m FilePath
+ghcInternalBinDir ver = do
+  ghcdir <- ghcupGHCDir ver
+  pure (ghcdir </> "bin")

-- | Get tool files from @~\/.ghcup\/bin\/ghc\/\<ver\>\/bin\/\*@
+
+-- | Get tool files from @~\/.ghcup\/ghc\/\<ver\>\/bin\/\*@
 -- while ignoring @*-\<ver\>@ symlinks and accounting for cross triple prefix.
 --
 -- Returns unversioned relative files without extension, e.g.:
@ -898,11 +922,10 @@ ghcToolFiles :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, Mona
             => GHCTargetVersion
             -> Excepts '[NotInstalled] m [FilePath]
 ghcToolFiles ver = do
-  ghcdir <- lift $ ghcupGHCDir ver
-  let bindir = ghcdir </> "bin"
+  bindir <- ghcInternalBinDir ver

  -- fail if ghc is not installed
-  whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
+  whenM (fmap not $ ghcInstalled ver)
        (throwE (NotInstalled GHC ver))

  files <- liftIO (listDirectory bindir >>= filterM (doesFileExist . (bindir </>)))
--- a/lib/GHCup/Utils/File/Common.hs
+++ b/lib/GHCup/Utils/File/Common.hs
@ -13,7 +13,7 @@ import           Data.Text               ( Text )
 import           Data.Void
 import           GHC.IO.Exception
 import           Optics                  hiding ((<|), (|>))
-import           System.Directory
+import           System.Directory        hiding (findFiles)
 import           System.FilePath
 import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
 import           Text.Regex.Posix
@ -100,6 +100,21 @@ isInPath p = do
  else pure False


+-- | Follows the first match in case of Regex.
+expandFilePath :: [Either FilePath Regex] -> IO [FilePath]
+expandFilePath = go ""
+ where
+  go :: FilePath -> [Either FilePath Regex] -> IO [FilePath]
+  go p [] = pure [p]
+  go p (x:xs) = do
+    case x of
+      Left s -> go (p </> s) xs
+      Right regex -> do
+        fps <- findFiles p regex
+        res <- forM fps $ \fp -> go (p </> fp) xs
+        pure $ mconcat res
+
+
 findFiles :: FilePath -> Regex -> IO [FilePath]
 findFiles path regex = do
  contents <- listDirectory path