diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 32ece88..86cb1cb 100644 --- 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) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index af2744e..a51d5c1 100644 --- 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//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//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//lib/haskell-language-server-/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//lib/haskell-language-server-/lib// +-- 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\/\\/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\/\\/bin\/\*@ + +-- | Get tool files from @~\/.ghcup\/ghc\/\\/bin\/\*@ -- while ignoring @*-\@ 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 ))) diff --git a/lib/GHCup/Utils/File/Common.hs b/lib/GHCup/Utils/File/Common.hs index 23ba8af..f777c61 100644 --- 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