Refactoring and fixes

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
+          fileWithExt = bindir </> file <> exeExt
-      destL <- lift $ ghcLinkDestination fileWithExt ver
+      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 fname = takeFileName f
-        let target = if "haskell-language-server-wrapper" `isPrefixOf` f
+        destL <- binarySymLinkDestination f
-                     then f <> "-" <> T.unpack (prettyVer ver) <> exeExt
+        let target = if "haskell-language-server-wrapper" `isPrefixOf` fname
-                     else f <> "~" <> T.unpack (prettyVer ver) <> exeExt
+                     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))
+      ifM (lift $ isLegacyHLS _tvVersion)
+        (pure (binDir dirs </> "haskell-language-server-wrapper-" <> T.unpack (prettyVer _tvVersion) <> exeExt))
+        $ do
           bdir <- lift $ ghcupHLSDir _tvVersion
-      liftIO $ doesDirectoryExist bdir >>= \case
+          pure (bdir </> "bin" </> "haskell-language-server-wrapper" <> exeExt)
-        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)

lib/GHCup/Utils.hs

@@ -125,38 +125,20 @@ import qualified Data.List.NonEmpty            as NE
     ------------------------
 
 
--- | The symlink destination of a ghc tool.
+-- | Create a relative symlink destination for the binary directory,
-ghcLinkDestination :: ( MonadReader env m
+-- given a target toolpath.
+binarySymLinkDestination :: ( MonadReader env m
                             , HasDirs env
                             , MonadThrow m
                             , MonadIO m
                             )
-                   => FilePath -- ^ the tool, such as 'ghc', 'haddock' etc.
+                         => FilePath -- ^ the full toolpath
-                   -> GHCTargetVersion
                          -> m FilePath
-ghcLinkDestination tool ver = do
+binarySymLinkDestination toolPath = do
   Dirs {..}  <- getDirs
-  ghcd <- ghcupGHCDir ver
+  toolPath' <- liftIO $ canonicalizePath toolPath
-  ghcd' <- liftIO $ canonicalizePath ghcd
   binDir' <- liftIO $ canonicalizePath binDir
-  pure (relativeSymlink binDir' (ghcd' </> "bin" </> tool))
+  pure (relativeSymlink binDir' toolPath')
-
-
--- | 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))
 
 
 -- | 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.
+-- | Get all scripts for a hls version from the ~/.ghcup/hls/<ver>/bin directory, if any.
-hlsInternalServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
+-- 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
+  bindir <- ghcInternalBinDir ver
-  let bindir = ghcdir </> "bin"
 
   -- 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 </>)))

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