From 51690d1df3ea46b8b174840ba1cefcb9127f9e44 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 5 Feb 2022 01:53:04 +0100 Subject: [PATCH] Support HLS dynamic builds --- app/ghcup/BrickMain.hs | 2 +- app/ghcup/GHCup/OptParse/Compile.hs | 2 +- app/ghcup/GHCup/OptParse/Install.hs | 3 +- app/ghcup/GHCup/OptParse/Set.hs | 4 +- lib/GHCup.hs | 170 ++++++++++++++---------- lib/GHCup/Types.hs | 4 + lib/GHCup/Utils.hs | 196 ++++++++++++++++++++-------- lib/GHCup/Utils/Dirs.hs | 22 ++++ 8 files changed, 277 insertions(+), 126 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index c6e870c..8e07456 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -495,7 +495,7 @@ set' _ (_, ListResult {..}) = do case lTool of GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> () Cabal -> liftE $ setCabal lVer $> () - HLS -> liftE $ setHLS lVer $> () + HLS -> liftE $ setHLS lVer SetHLSOnly $> () Stack -> liftE $ setStack lVer $> () GHCup -> pure () ) diff --git a/app/ghcup/GHCup/OptParse/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs index fda6810..a79ef47 100644 --- a/app/ghcup/GHCup/OptParse/Compile.hs +++ b/app/ghcup/GHCup/OptParse/Compile.hs @@ -466,7 +466,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo targetVer HLS dls when setCompile $ void $ liftE $ - setHLS targetVer + setHLS targetVer SetHLSOnly pure (vi, targetVer) ) >>= \case diff --git a/app/ghcup/GHCup/OptParse/Install.hs b/app/ghcup/GHCup/OptParse/Install.hs index 1eec1bf..1204e5f 100644 --- a/app/ghcup/GHCup/OptParse/Install.hs +++ b/app/ghcup/GHCup/OptParse/Install.hs @@ -469,8 +469,9 @@ install installCommand settings getAppState' runLogger = case installCommand of Just uri -> do runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do (v, vi) <- liftE $ fromVersion instVer HLS + -- TODO: support legacy liftE $ installHLSBindist - (DownloadInfo uri Nothing "") + (DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "") (_tvVersion v) isolateDir forceInstall diff --git a/app/ghcup/GHCup/OptParse/Set.hs b/app/ghcup/GHCup/OptParse/Set.hs index b03d53a..a1f7b94 100644 --- a/app/ghcup/GHCup/OptParse/Set.hs +++ b/app/ghcup/GHCup/OptParse/Set.hs @@ -311,10 +311,10 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of -> m ExitCode setHLS' SetOptions{ sToolVer } = case sToolVer of - (SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS (_tvVersion v) >> pure v) + (SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS (_tvVersion v) SetHLSOnly >> pure v) _ -> runSetHLS runAppState (do v <- liftE $ fst <$> fromVersion' sToolVer HLS - liftE $ setHLS (_tvVersion v) + liftE $ setHLS (_tvVersion v) SetHLSOnly pure v ) >>= \case diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 5a86ba2..32ece88 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -6,7 +6,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} {-| Module : GHCup @@ -301,22 +300,6 @@ installPackedGHC dl msubdir inst ver forceInstall = do liftE $ runBuildAction tmpUnpack (Just inst) (installUnpackedGHC workdir inst ver) - where - -- | 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) - -- | Install an unpacked GHC distribution. This only deals with the GHC @@ -582,6 +565,8 @@ installHLSBindist :: ( MonadMask m , TarDirDoesNotExist , ArchiveResult , FileAlreadyExistsError + , ProcessError + , DirNotEmpty ] m () @@ -617,26 +602,55 @@ installHLSBindist dlinfo ver isoFilepath forceInstall = do -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) + legacy <- liftIO $ isLegacyHLSBindist workdir + + if + | not forceInstall + , not legacy + , (Just fp) <- isoFilepath -> liftE $ installDestSanityCheck fp + | otherwise -> pure () case isoFilepath of Just isoDir -> do lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir - liftE $ installHLSUnpacked workdir isoDir Nothing forceInstall + if legacy + then liftE $ installHLSUnpackedLegacy workdir isoDir Nothing forceInstall + else liftE $ installHLSUnpacked workdir isoDir ver Nothing -> do - liftE $ installHLSUnpacked workdir binDir (Just ver) forceInstall + if legacy + then liftE $ installHLSUnpackedLegacy workdir binDir (Just ver) forceInstall + else do + inst <- ghcupHLSDir ver + liftE $ installHLSUnpacked workdir inst ver + liftE $ setHLS ver SetHLS_XYZ liftE $ installHLSPostInst isoFilepath ver +isLegacyHLSBindist :: FilePath -- ^ Path to the unpacked hls bindist + -> IO Bool +isLegacyHLSBindist path = do + not <$> doesFileExist (path "GNUmakefile") -- | Install an unpacked hls distribution. -installHLSUnpacked :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m) - => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) - -> FilePath -- ^ Path to install to - -> Maybe Version -- ^ Nothing for isolated install - -> Bool -- ^ is it a force install - -> Excepts '[CopyError, FileAlreadyExistsError] m () -installHLSUnpacked path inst mver' forceInstall = do +installHLSUnpacked :: (MonadMask m, MonadUnliftIO m, MonadReader env m, MonadFail m, HasLog env, HasDirs env, HasSettings env, MonadCatch m, MonadIO m) + => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) + -> FilePath -- ^ Path to install to + -> Version + -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m () +installHLSUnpacked path inst _ = do + lift $ logInfo "Installing HLS" + liftIO $ createDirRecursive' inst + lEM $ make ["PREFIX=" <> inst, "install"] (Just path) + +-- | Install an unpacked hls distribution (legacy). +installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m) + => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) + -> FilePath -- ^ Path to install to + -> Maybe Version -- ^ Nothing for isolated install + -> Bool -- ^ is it a force install + -> Excepts '[CopyError, FileAlreadyExistsError] m () +installHLSUnpackedLegacy path inst mver' forceInstall = do lift $ logInfo "Installing HLS" liftIO $ createDirRecursive' inst @@ -692,7 +706,7 @@ installHLSPostInst isoFilepath ver = -- create symlink if this is the latest version in a regular install hlsVers <- lift $ fmap rights getInstalledHLSs let lInstHLS = headMay . reverse . sort $ hlsVers - when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver + when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver SetHLSOnly -- | Installs hls binaries @haskell-language-server-\@ @@ -725,6 +739,8 @@ installHLSBin :: ( MonadMask m , TarDirDoesNotExist , ArchiveResult , FileAlreadyExistsError + , ProcessError + , DirNotEmpty ] m () @@ -894,9 +910,9 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc case isolateDir of Just isoDir -> do lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir - liftE $ installHLSUnpacked installDir isoDir Nothing True + liftE $ installHLSUnpackedLegacy installDir isoDir Nothing True Nothing -> do - liftE $ installHLSUnpacked installDir binDir (Just installVer) True + liftE $ installHLSUnpackedLegacy installDir binDir (Just installVer) True ) liftE $ installHLSPostInst isolateDir installVer @@ -1088,9 +1104,9 @@ setGHC ver sghc = do -- first delete the old symlinks (this fixes compatibility issues -- with old ghcup) case sghc of - SetGHCOnly -> liftE $ rmPlain (_tvTarget ver) - SetGHC_XY -> liftE $ rmMajorSymlinks ver - SetGHC_XYZ -> liftE $ rmMinorSymlinks ver + SetGHCOnly -> liftE $ rmPlainGHC (_tvTarget ver) + SetGHC_XY -> liftE $ rmMajorGHCSymlinks ver + SetGHC_XYZ -> liftE $ rmMinorGHCSymlinks ver -- for ghc tools (ghc, ghci, haddock, ...) verfiles <- ghcToolFiles ver @@ -1170,7 +1186,7 @@ unsetGHC :: ( MonadReader env m ) => Maybe Text -> Excepts '[NotInstalled] m () -unsetGHC = rmPlain +unsetGHC = rmPlainGHC -- | Set the @~\/.ghcup\/bin\/cabal@ symlink. @@ -1222,35 +1238,54 @@ setHLS :: ( MonadReader env m , MonadUnliftIO m ) => Version + -> SetHLS -- Nothing for legacy -> Excepts '[NotInstalled] m () -setHLS ver = do +setHLS ver shls = do + whenM (lift $ not <$> hlsInstalled ver) (throwE (NotInstalled HLS (GHCTargetVersion Nothing ver))) + + -- symlink destination Dirs {..} <- lift getDirs - -- 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 $ "rm " <> T.pack (binDir f) - lift $ rmLink (binDir f) + -- first delete the old symlinks + case shls of + -- not for legacy + SetHLS_XYZ -> liftE $ rmMinorHLSSymlinks ver + -- legacy and new + SetHLSOnly -> liftE $ rmPlainHLS - -- set haskell-language-server- symlinks - bins <- lift $ hlsServerBinaries ver Nothing - when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver) + case shls of + -- not for legacy + SetHLS_XYZ -> do + bins <- lift $ hlsInternalServerBinaries ver - forM_ bins $ \f -> do - let destL = f - let target = (<> exeExt) . head . splitOn "~" $ f - lift $ createLink destL (binDir target) + 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 + lift $ createLink destL (binDir target) - -- set haskell-language-server-wrapper symlink - let destL = "haskell-language-server-wrapper-" <> T.unpack (prettyVer ver) <> exeExt - let wrapper = binDir "haskell-language-server-wrapper" <> exeExt + pure () + -- legacy and new + SetHLSOnly -> do + -- set haskell-language-server- symlinks + bins <- lift $ hlsServerBinaries ver Nothing + when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver) - lift $ createLink destL wrapper + forM_ bins $ \f -> do + let destL = f + let target = (<> exeExt) . head . splitOn "~" $ f + lift $ createLink destL (binDir target) - lift warnAboutHlsCompatibility + -- set haskell-language-server-wrapper symlink + let destL = "haskell-language-server-wrapper-" <> T.unpack (prettyVer ver) <> exeExt + let wrapper = binDir "haskell-language-server-wrapper" <> exeExt - pure () + lift $ createLink destL wrapper + + lift warnAboutHlsCompatibility + + pure () unsetHLS :: ( MonadMask m @@ -1720,14 +1755,14 @@ rmGHCVer ver = do -- this isn't atomic, order matters when isSetGHC $ do lift $ logInfo "Removing ghc symlinks" - liftE $ rmPlain (_tvTarget ver) + liftE $ rmPlainGHC (_tvTarget ver) lift $ logInfo "Removing ghc-x.y.z symlinks" - liftE $ rmMinorSymlinks ver + liftE $ rmMinorGHCSymlinks ver lift $ logInfo "Removing/rewiring ghc-x.y symlinks" -- first remove - handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorSymlinks ver + handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorGHCSymlinks ver -- then fix them (e.g. with an earlier version) lift $ logInfo $ "Removing directory recursively: " <> T.pack dir @@ -1794,24 +1829,19 @@ rmHLSVer :: ( MonadMask m rmHLSVer ver = do whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver)) - isHlsSet <- lift hlsSet + isHlsSet <- lift hlsSet - Dirs {..} <- lift getDirs - - bins <- lift $ hlsAllBinaries ver - forM_ bins $ \f -> lift $ recycleFile (binDir f) + liftE $ rmMinorHLSSymlinks ver + hlsDir <- ghcupHLSDir ver + recyclePathForcibly hlsDir when (Just ver == isHlsSet) $ do -- delete all set symlinks - oldSyms <- lift hlsSymlinks - forM_ oldSyms $ \f -> do - let fullF = binDir f - lift $ logDebug $ "rm " <> T.pack fullF - lift $ rmLink fullF + rmPlainHLS -- set latest hls hlsVers <- lift $ fmap rights getInstalledHLSs case headMay . reverse . sort $ hlsVers of - Just latestver -> setHLS latestver + Just latestver -> setHLS latestver SetHLSOnly Nothing -> pure () @@ -2687,7 +2717,11 @@ whereIsTool tool ver@GHCTargetVersion {..} = do HLS -> do whenM (lift $ fmap not $ hlsInstalled _tvVersion) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing _tvVersion)) - pure (binDir dirs "haskell-language-server-wrapper-" <> T.unpack (prettyVer _tvVersion) <> exeExt) + 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) Stack -> do whenM (lift $ fmap not $ stackInstalled _tvVersion) diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index d4fb570..5014196 100644 --- 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 diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index db686d6..fa6de9c 100644 --- 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//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) diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index 9af0747..c4749b8 100644 --- 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/' 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