From 51690d1df3ea46b8b174840ba1cefcb9127f9e44 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 5 Feb 2022 01:53:04 +0100 Subject: [PATCH 1/6] 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 From e40777a5d316c7b44a31275d8752125d47f1b364 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 5 Feb 2022 16:44:00 +0100 Subject: [PATCH 2/6] Resolve paths when using XDG dirs, fixes #311 --- lib/GHCup/Utils.hs | 8 ++++++-- lib/GHCup/Utils/Dirs.hs | 1 + 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index fa6de9c..af2744e 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -137,7 +137,9 @@ ghcLinkDestination :: ( MonadReader env m ghcLinkDestination tool ver = do Dirs {..} <- getDirs ghcd <- ghcupGHCDir ver - pure (relativeSymlink binDir (ghcd "bin" tool)) + ghcd' <- liftIO $ canonicalizePath ghcd + binDir' <- liftIO $ canonicalizePath binDir + pure (relativeSymlink binDir' (ghcd' "bin" tool)) -- | The symlink destination of a hls binary. @@ -152,7 +154,9 @@ hlsLinkDestination :: ( MonadReader env m hlsLinkDestination tool ver = do Dirs {..} <- getDirs hlsd <- ghcupHLSDir ver - pure (relativeSymlink binDir (hlsd "bin" tool)) + 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. diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index c4749b8..15e6fcb 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -335,6 +335,7 @@ useXDG :: IO Bool useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS" +-- | Like 'relpath'. Assumes the inputs are resolved in case of symlinks. relativeSymlink :: FilePath -- ^ the path in which to create the symlink -> FilePath -- ^ the symlink destination -> FilePath From 68313372892c90484c9e3567a1e0453c67fdc702 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 5 Feb 2022 19:11:56 +0100 Subject: [PATCH 3/6] Refactoring and fixes --- lib/GHCup.hs | 26 ++++----- lib/GHCup/Utils.hs | 99 +++++++++++++++++++++------------- lib/GHCup/Utils/File/Common.hs | 17 +++++- 3 files changed, 91 insertions(+), 51 deletions(-) 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 From 6b978b42bc005a42ef2292554df0465ae36ea108 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 5 Feb 2022 19:12:13 +0100 Subject: [PATCH 4/6] Improve rmHLSNoGHC --- app/ghcup/GHCup/OptParse/GC.hs | 2 +- lib/GHCup.hs | 22 ++++++++++++++++------ 2 files changed, 17 insertions(+), 7 deletions(-) diff --git a/app/ghcup/GHCup/OptParse/GC.hs b/app/ghcup/GHCup/OptParse/GC.hs index b3488d1..f8a1310 100644 --- a/app/ghcup/GHCup/OptParse/GC.hs +++ b/app/ghcup/GHCup/OptParse/GC.hs @@ -132,7 +132,7 @@ gc GCOptions{..} runAppState runLogger = runGC runAppState (do when gcOldGHC rmOldGHC lift $ when gcProfilingLibs rmProfilingLibs lift $ when gcShareDir rmShareDir - lift $ when gcHLSNoGHC rmHLSNoGHC + liftE $ when gcHLSNoGHC rmHLSNoGHC lift $ when gcCache rmCache lift $ when gcTmp rmTmp ) >>= \case diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 86cb1cb..e043bfb 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -2836,21 +2836,31 @@ rmHLSNoGHC :: ( MonadReader env m , HasLog env , MonadIO m , MonadMask m + , MonadFail m + , MonadUnliftIO m ) - => m () + => Excepts '[NotInstalled] m () rmHLSNoGHC = do Dirs {..} <- getDirs ghcs <- fmap rights getInstalledGHCs hlses <- fmap rights getInstalledHLSs forM_ hlses $ \hls -> do hlsGHCs <- fmap mkTVer <$> hlsGHCVersions' hls - forM_ hlsGHCs $ \ghc -> do - when (ghc `notElem` ghcs) $ do - bins <- hlsServerBinaries hls (Just $ _tvVersion ghc) - forM_ bins $ \bin -> do - let f = binDir bin + let candidates = filter (`notElem` ghcs) $ hlsGHCs + if (length hlsGHCs - length candidates) <= 0 + then rmHLSVer hls + else + forM_ candidates $ \ghc -> do + bins1 <- fmap (binDir ) <$> hlsServerBinaries hls (Just $ _tvVersion ghc) + bins2 <- ifM (isLegacyHLS hls) (pure []) $ do + shs <- hlsInternalServerScripts hls (Just $ _tvVersion ghc) + bins <- hlsInternalServerBinaries hls (Just $ _tvVersion ghc) + libs <- hlsInternalServerLibs hls (_tvVersion ghc) + pure (shs ++ bins ++ libs) + forM_ (bins1 ++ bins2) $ \f -> do logDebug $ "rm " <> T.pack f rmFile f + pure () rmCache :: ( MonadReader env m From 684953464bdd821b9e8c1867657c334112ada4b0 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 5 Feb 2022 19:39:00 +0100 Subject: [PATCH 5/6] Silence hlint --- lib/GHCup.hs | 8 +++----- lib/GHCup/Utils.hs | 14 +++++++------- 2 files changed, 10 insertions(+), 12 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index e043bfb..ca02662 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-| @@ -1252,7 +1253,7 @@ setHLS ver shls = do -- not for legacy SetHLS_XYZ -> liftE $ rmMinorHLSSymlinks ver -- legacy and new - SetHLSOnly -> liftE $ rmPlainHLS + SetHLSOnly -> liftE rmPlainHLS case shls of -- not for legacy @@ -1267,7 +1268,6 @@ setHLS ver shls = do else fname <> "~" <> T.unpack (prettyVer ver) <> exeExt lift $ createLink destL (binDir target) - pure () -- legacy and new SetHLSOnly -> do -- set haskell-language-server- symlinks @@ -1287,8 +1287,6 @@ setHLS ver shls = do lift warnAboutHlsCompatibility - pure () - unsetHLS :: ( MonadMask m , MonadReader env m @@ -2846,7 +2844,7 @@ rmHLSNoGHC = do hlses <- fmap rights getInstalledHLSs forM_ hlses $ \hls -> do hlsGHCs <- fmap mkTVer <$> hlsGHCVersions' hls - let candidates = filter (`notElem` ghcs) $ hlsGHCs + let candidates = filter (`notElem` ghcs) hlsGHCs if (length hlsGHCs - length candidates) <= 0 then rmHLSVer hls else diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index a51d5c1..a05dbfb 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -251,7 +251,7 @@ 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))) + hlsBins <- fmap (filter (\f -> not ("haskell-language-server-wrapper" `isPrefixOf` f) && ('~' `notElem` f))) $ liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString)) @@ -518,7 +518,7 @@ hlsInstalled ver = do isLegacyHLS :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool isLegacyHLS ver = do bdir <- ghcupHLSDir ver - not <$> (liftIO $ doesDirectoryExist bdir) + not <$> liftIO (doesDirectoryExist bdir) -- Return the currently set hls version, if any. @@ -620,8 +620,8 @@ hlsInternalServerScripts :: (MonadReader env m, HasDirs env, MonadIO m, MonadThr hlsInternalServerScripts ver mghcVer = do dir <- ghcupHLSDir ver let bdir = dir "bin" - (fmap (bdir ) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer)) - <$> (liftIO $ listDirectory bdir) + 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. @@ -633,8 +633,8 @@ 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) + 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. @@ -647,7 +647,7 @@ 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) + fmap (bdir ) <$> liftIO (listDirectory bdir) -- | Get the wrapper binary for an hls version, if any. From 907365ddff6ffd2d501f76323032171355f13d06 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 5 Feb 2022 19:43:24 +0100 Subject: [PATCH 6/6] Fix FreeBSD CI --- .gitlab/before_script/freebsd/install_deps.sh | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/.gitlab/before_script/freebsd/install_deps.sh b/.gitlab/before_script/freebsd/install_deps.sh index c35fe9d..b8bd04f 100755 --- a/.gitlab/before_script/freebsd/install_deps.sh +++ b/.gitlab/before_script/freebsd/install_deps.sh @@ -8,7 +8,15 @@ set -eux mkdir -p "${TMPDIR}" -curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-portbld-freebsd-ghcup > ./ghcup-bin +if freebsd-version | grep -E '^12.*' ; then + freebsd_ver=12 +elif freebsd-version | grep -E '^13.*' ; then + freebsd_ver=13 +else + (>&2 echo "Unsupported FreeBSD version! Please report a bug at https://gitlab.haskell.org/haskell/ghcup-hs/-/issues") + exit 1 +fi +curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-freebsd${freebsd_ver}-ghcup > ./ghcup-bin chmod +x ghcup-bin ./ghcup-bin -v upgrade -i -f