From 4767f3db5b226a2e756363803a0ac8f7ce6a4022 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 19 Sep 2021 13:50:51 +0200 Subject: [PATCH] Implement ghcup unset --- .gitlab/ghcup_env | 6 +- .gitlab/script/ghcup_version.sh | 12 ++++ app/ghcup/Main.hs | 110 ++++++++++++++++++++++++++++++++ lib/GHCup.hs | 54 ++++++++++++++-- lib/GHCup/Utils/File/Common.hs | 9 +++ 5 files changed, 183 insertions(+), 8 deletions(-) diff --git a/.gitlab/ghcup_env b/.gitlab/ghcup_env index 99d3409..0b807ca 100644 --- a/.gitlab/ghcup_env +++ b/.gitlab/ghcup_env @@ -1,9 +1,11 @@ if [ "${OS}" = "WINDOWS" ] ; then export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR" - export PATH="$GHCUP_INSTALL_BASE_PREFIX/ghcup/bin:$CI_PROJECT_DIR/.local/bin:$PATH" + export GHCUP_BIN="$CI_PROJECT_DIR/ghcup/bin" + export PATH="$GHCUP_BIN:$CI_PROJECT_DIR/.local/bin:$PATH" export TMPDIR="$CI_PROJECT_DIR/tmp" else export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR" - export PATH="$CI_PROJECT_DIR/.ghcup/bin:$CI_PROJECT_DIR/.local/bin:/opt/llvm/bin:$PATH" + export GHCUP_BIN="$CI_PROJECT_DIR/.ghcup/bin" + export PATH="$GHCUP_BIN:$CI_PROJECT_DIR/.local/bin:/opt/llvm/bin:$PATH" export TMPDIR="$CI_PROJECT_DIR/tmp" fi diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index 1737a2c..01be778 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -101,6 +101,10 @@ eghcup install ghc ${GHC_VERSION} eghcup set ghc ${GHC_VERSION} eghcup install cabal ${CABAL_VERSION} [ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ] +eghcup unset cabal +"$GHCUP_BIN"/cabal --version && exit || echo yes +eghcup set cabal ${CABAL_VERSION} +[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ] cabal --version @@ -151,9 +155,13 @@ else [ "$(ghc --numeric-version)" = "8.10.3" ] eghcup set ${GHC_VERSION} [ "$(ghc --numeric-version)" = "${ghc_ver}" ] + eghcup unset ghc + "$GHCUP_BIN"/ghc --numeric-version && exit || echo yes + eghcup set ${GHC_VERSION} eghcup --offline rm 8.10.3 [ "$(ghc --numeric-version)" = "${ghc_ver}" ] + if [ "${OS}" = "DARWIN" ] ; then eghcup install hls $(eghcup whereis hls) --version @@ -164,9 +172,13 @@ else if [ "${ARCH}" = "64" ] ; then eghcup install hls haskell-language-server-wrapper --version + eghcup unset hls + "$GHCUP_BIN"/haskell-language-server-wrapper --version && exit || echo yes eghcup install stack stack --version + eghcup unset hls + "$GHCUP_BIN"/stack --version && exit || echo yes fi fi fi diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 4f96dc8..0ed292a 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -103,6 +103,7 @@ data Command = Install (Either InstallCommand InstallOptions) | InstallCabalLegacy InstallOptions | Set (Either SetCommand SetOptions) + | UnSet UnsetCommand | List ListOptions | Rm (Either RmCommand RmOptions) | DInfo @@ -150,6 +151,11 @@ data SetCommand = SetGHC SetOptions | SetHLS SetOptions | SetStack SetOptions +data UnsetCommand = UnsetGHC UnsetOptions + | UnsetCabal UnsetOptions + | UnsetHLS UnsetOptions + | UnsetStack UnsetOptions + -- a superset of ToolVersion data SetToolVersion = SetToolVersion GHCTargetVersion | SetToolTag Tag @@ -160,6 +166,10 @@ data SetOptions = SetOptions { sToolVer :: SetToolVersion } +data UnsetOptions = UnsetOptions + { sToolVer :: Maybe Text -- target platform triple + } + data ListOptions = ListOptions { loTool :: Maybe Tool , lCriteria :: Maybe ListCriteria @@ -357,6 +367,14 @@ com = <> footerDoc (Just $ text setFooter) ) ) + <> command + "unset" + (info + (UnSet <$> unsetParser <**> helper) + ( progDesc "Unset currently active GHC/cabal version" + <> footerDoc (Just $ text unsetFooter) + ) + ) <> command "rm" (info @@ -470,6 +488,10 @@ com = is given, sets GHC to 'recommended' version). It is recommended to always specify a subcommand (ghc/cabal/hls/stack).|] + unsetFooter :: String + unsetFooter = [s|Discussion: + Unsets the currently active GHC or cabal version.|] + rmFooter :: String rmFooter = [s|Discussion: Remove the given GHC or cabal version. When no command is given, @@ -715,12 +737,74 @@ setParser = setHLSFooter = [s|Discussion: Sets the the current haskell-language-server version.|] +unsetParser :: Parser UnsetCommand +unsetParser = + (subparser + ( command + "ghc" + ( UnsetGHC + <$> info + (unsetOpts <**> helper) + ( progDesc "Unset GHC version" + <> footerDoc (Just $ text unsetGHCFooter) + ) + ) + <> command + "cabal" + ( UnsetCabal + <$> info + (unsetOpts <**> helper) + ( progDesc "Unset Cabal version" + <> footerDoc (Just $ text unsetCabalFooter) + ) + ) + <> command + "hls" + ( UnsetHLS + <$> info + (unsetOpts <**> helper) + ( progDesc "Unset haskell-language-server version" + <> footerDoc (Just $ text unsetHLSFooter) + ) + ) + <> command + "stack" + ( UnsetStack + <$> info + (unsetOpts <**> helper) + ( progDesc "Unset stack version" + <> footerDoc (Just $ text unsetStackFooter) + ) + ) + ) + ) + where + unsetGHCFooter :: String + unsetGHCFooter = [s|Discussion: + Unsets the the current GHC version. That means there won't + be a ~/.ghcup/bin/ghc anymore.|] + + unsetCabalFooter :: String + unsetCabalFooter = [s|Discussion: + Unsets the the current Cabal version.|] + + unsetStackFooter :: String + unsetStackFooter = [s|Discussion: + Unsets the the current Stack version.|] + + unsetHLSFooter :: String + unsetHLSFooter = [s|Discussion: + Unsets the the current haskell-language-server version.|] + setOpts :: Maybe Tool -> Parser SetOptions setOpts tool = SetOptions <$> (fromMaybe SetRecommended <$> optional (setVersionArgument (Just ListInstalled) tool)) +unsetOpts :: Parser UnsetOptions +unsetOpts = UnsetOptions . fmap T.pack <$> optional (argument str (metavar "TRIPLE")) + listOpts :: Parser ListOptions listOpts = ListOptions @@ -1629,6 +1713,11 @@ Report bugs at |] , NoToolVersionSet ] + runUnsetGHC = + runAppState + . runE + @'[ NotInstalled ] + let runLeanSetCabal = runLeanAppState @@ -2089,6 +2178,27 @@ Report bugs at |] Set (Left (SetHLS sopts)) -> setHLS' sopts Set (Left (SetStack sopts)) -> setStack' sopts + UnSet (UnsetGHC (UnsetOptions triple)) -> runUnsetGHC (unsetGHC triple) + >>= \case + VRight _ -> do + runLogger $ logInfo "GHC successfully unset" + pure ExitSuccess + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 14 + UnSet (UnsetCabal (UnsetOptions _)) -> do + runAppState unsetCabal + runLogger $ logInfo "Cabal successfully unset" + pure ExitSuccess + UnSet (UnsetHLS (UnsetOptions _)) -> do + runAppState unsetHLS + runLogger $ logInfo "HLS successfully unset" + pure ExitSuccess + UnSet (UnsetStack (UnsetOptions _)) -> do + runAppState unsetStack + runLogger $ logInfo "Stack successfully unset" + pure ExitSuccess + List ListOptions {..} -> runListGHC (do l <- listVersions loTool lCriteria diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 877159e..2c04cc8 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -968,6 +968,17 @@ setGHC ver sghc = do $ createDirectoryLink targetF fullF _ -> pure () +unsetGHC :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadThrow m + , MonadFail m + , MonadIO m + , MonadMask m + ) + => Maybe Text + -> Excepts '[NotInstalled] m () +unsetGHC = rmPlain -- | Set the @~\/.ghcup\/bin\/cabal@ symlink. @@ -975,7 +986,6 @@ setCabal :: ( MonadMask m , MonadReader env m , HasDirs env , HasLog env - , MonadThrow m , MonadFail m , MonadIO m , MonadUnliftIO m) @@ -999,18 +1009,24 @@ setCabal ver = do pure () - +unsetCabal :: ( MonadMask m + , MonadReader env m + , HasDirs env + , MonadIO m) + => m () +unsetCabal = do + Dirs {..} <- getDirs + let cabalbin = binDir "cabal" <> exeExt + hideError doesNotExistErrorType $ rmLink cabalbin -- | Set the haskell-language-server symlinks. -setHLS :: ( MonadCatch m - , MonadReader env m +setHLS :: ( MonadReader env m , HasDirs env , HasLog env - , MonadThrow m - , MonadFail m , MonadIO m , MonadMask m + , MonadFail m , MonadUnliftIO m ) => Version @@ -1045,6 +1061,21 @@ setHLS ver = do pure () +unsetHLS :: ( MonadMask m + , MonadReader env m + , HasDirs env + , MonadIO m) + => m () +unsetHLS = do + Dirs {..} <- getDirs + let wrapper = binDir "haskell-language-server-wrapper" <> exeExt + bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles' + binDir + (MP.chunk "haskell-language-server-" <* pvp' <* MP.chunk (T.pack exeExt) <* MP.eof) + forM_ bins (hideError doesNotExistErrorType . rmLink . (binDir )) + hideError doesNotExistErrorType $ rmLink wrapper + + -- | Set the @~\/.ghcup\/bin\/stack@ symlink. setStack :: ( MonadMask m , MonadReader env m @@ -1074,6 +1105,17 @@ setStack ver = do pure () +unsetStack :: ( MonadMask m + , MonadReader env m + , HasDirs env + , MonadIO m) + => m () +unsetStack = do + Dirs {..} <- getDirs + let stackbin = binDir "stack" <> exeExt + hideError doesNotExistErrorType $ rmLink stackbin + + -- | Warn if the installed and set HLS is not compatible with the installed and -- set GHC version. warnAboutHlsCompatibility :: ( MonadReader env m diff --git a/lib/GHCup/Utils/File/Common.hs b/lib/GHCup/Utils/File/Common.hs index 1fd0447..00c86f6 100644 --- a/lib/GHCup/Utils/File/Common.hs +++ b/lib/GHCup/Utils/File/Common.hs @@ -9,6 +9,8 @@ import GHCup.Utils.Prelude import Control.Monad.Reader import Data.Maybe +import Data.Text ( Text ) +import Data.Void import GHC.IO.Exception import Optics hiding ((<|), (|>)) import System.Directory @@ -16,7 +18,9 @@ import System.FilePath import Text.PrettyPrint.HughesPJClass hiding ( (<>) ) import Text.Regex.Posix +import qualified Data.Text as T import qualified Data.ByteString.Lazy as BL +import qualified Text.Megaparsec as MP @@ -101,6 +105,11 @@ findFiles path regex = do contents <- listDirectory path pure $ filter (match regex) contents +findFiles' :: FilePath -> MP.Parsec Void Text a -> IO [FilePath] +findFiles' path parser = do + contents <- listDirectory path + pure $ filter (\fp -> either (const False) (const True) $ MP.parse parser "" (T.pack fp)) contents + checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool checkFileAlreadyExists fp = liftIO $ doesFileExist fp