From d6fa61e223cf5b0f07b76a9ec700bdb69a537f7c Mon Sep 17 00:00:00 2001 From: Huw campbell Date: Thu, 25 Feb 2021 00:18:11 +1100 Subject: [PATCH] Add command line completions for installed and available versions. When running `ghcup set ghc` and pressing tab, one should be able to autocomplete the currently installed GHCs we have available. Add an optparse applicative completer for install, rm, and set commands which shows tags and versions. For installation, all are shown; while for remove and set, only those installed are. --- app/ghcup/Main.hs | 106 +++++++++++++++++++++++++++++++++------------ lib/GHCup/Utils.hs | 9 ++++ 2 files changed, 87 insertions(+), 28 deletions(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index c354d10..ef4c404 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -192,10 +192,10 @@ data ChangeLogOptions = ChangeLogOptions -- by default. For example: -- -- > invertableSwitch "recursive" True (help "do not recurse into directories") --- --- This example makes --recursive enabled by default, so +-- +-- This example makes --recursive enabled by default, so -- the help is shown only for --no-recursive. -invertableSwitch +invertableSwitch :: String -- ^ long option -> Char -- ^ short option for the non-default option -> Bool -- ^ is switch enabled by default? @@ -363,7 +363,7 @@ com = ( command "install-cabal" ((info - ((InstallCabalLegacy <$> installOpts) <**> helper) + ((InstallCabalLegacy <$> installOpts (Just Cabal)) <**> helper) ( progDesc "Install or update cabal" <> footerDoc (Just $ text installCabalFooter) ) @@ -413,7 +413,7 @@ installParser = "ghc" ( InstallGHC <$> (info - (installOpts <**> helper) + (installOpts (Just GHC) <**> helper) ( progDesc "Install GHC" <> footerDoc (Just $ text installGHCFooter) ) @@ -423,7 +423,7 @@ installParser = "cabal" ( InstallCabal <$> (info - (installOpts <**> helper) + (installOpts (Just Cabal) <**> helper) ( progDesc "Install Cabal" <> footerDoc (Just $ text installCabalFooter) ) @@ -433,7 +433,7 @@ installParser = "hls" ( InstallHLS <$> (info - (installOpts <**> helper) + (installOpts (Just HLS) <**> helper) ( progDesc "Install haskell-languge-server" <> footerDoc (Just $ text installHLSFooter) ) @@ -441,7 +441,7 @@ installParser = ) ) ) - <|> (Right <$> installOpts) + <|> (Right <$> installOpts Nothing) where installHLSFooter :: String installHLSFooter = [s|Discussion: @@ -472,8 +472,8 @@ Examples: ghcup install ghc -u https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27 head|] -installOpts :: Parser InstallOptions -installOpts = +installOpts :: Maybe Tool -> Parser InstallOptions +installOpts tool = (\p (u, v) b -> InstallOptions v p u b) <$> (optional (option @@ -495,9 +495,9 @@ installOpts = ) ) ) - <*> (Just <$> toolVersionArgument) + <*> (Just <$> toolVersionArgument Nothing tool) ) - <|> ((,) <$> pure Nothing <*> optional toolVersionArgument) + <|> (pure (Nothing, Nothing)) ) <*> flag False @@ -514,7 +514,7 @@ setParser = "ghc" ( SetGHC <$> (info - (setOpts <**> helper) + (setOpts (Just GHC) <**> helper) ( progDesc "Set GHC version" <> footerDoc (Just $ text setGHCFooter) ) @@ -524,7 +524,7 @@ setParser = "cabal" ( SetCabal <$> (info - (setOpts <**> helper) + (setOpts (Just Cabal) <**> helper) ( progDesc "Set Cabal version" <> footerDoc (Just $ text setCabalFooter) ) @@ -534,7 +534,7 @@ setParser = "hls" ( SetHLS <$> (info - (setOpts <**> helper) + (setOpts (Just HLS) <**> helper) ( progDesc "Set haskell-language-server version" <> footerDoc (Just $ text setHLSFooter) ) @@ -542,7 +542,7 @@ setParser = ) ) ) - <|> (Right <$> setOpts) + <|> (Right <$> setOpts Nothing) where setGHCFooter :: String setGHCFooter = [s|Discussion: @@ -559,8 +559,8 @@ setParser = Sets the the current haskell-language-server version.|] -setOpts :: Parser SetOptions -setOpts = SetOptions <$> optional toolVersionArgument +setOpts :: Maybe Tool -> Parser SetOptions +setOpts tool = SetOptions <$> optional (toolVersionArgument (Just ListInstalled) tool) listOpts :: Parser ListOptions listOpts = @@ -592,7 +592,7 @@ rmParser = (Left <$> subparser ( command "ghc" - (RmGHC <$> (info (rmOpts <**> helper) (progDesc "Remove GHC version"))) + (RmGHC <$> (info (rmOpts (Just GHC) <**> helper) (progDesc "Remove GHC version"))) <> command "cabal" ( RmCabal @@ -609,12 +609,12 @@ rmParser = ) ) ) - <|> (Right <$> rmOpts) + <|> (Right <$> rmOpts Nothing) -rmOpts :: Parser RmOptions -rmOpts = RmOptions <$> versionArgument +rmOpts :: Maybe Tool -> Parser RmOptions +rmOpts tool = RmOptions <$> versionArgument (Just ListInstalled) tool changelogP :: Parser ChangeLogOptions @@ -636,7 +636,7 @@ changelogP = ) ) ) - <*> optional toolVersionArgument + <*> optional (toolVersionArgument Nothing Nothing) compileP :: Parser CompileCommand compileP = subparser @@ -765,13 +765,63 @@ toolVersionParser = verP' <|> toolP ) -- | same as toolVersionParser, except as an argument. -toolVersionArgument :: Parser ToolVersion -toolVersionArgument = - argument (eitherReader toolVersionEither) (metavar "VERSION|TAG") +toolVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion +toolVersionArgument criterial tool = + argument (eitherReader toolVersionEither) (metavar "VERSION|TAG" <> completer tagCompleter <> foldMap (completer . versionCompleter criterial) tool) -versionArgument :: Parser GHCTargetVersion -versionArgument = argument (eitherReader tVersionEither) (metavar "VERSION") +versionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion +versionArgument criterial tool = argument (eitherReader tVersionEither) (metavar "VERSION" <> foldMap (completer . versionCompleter criterial) tool) + + +tagCompleter :: Completer +tagCompleter = + listCompleter [ + "recommended", "latest" + ] + + +versionCompleter :: Maybe ListCriteria -> Tool -> Completer +versionCompleter criteria tool = + listIOCompleter $ do + let + loggerConfig = + LoggerConfig + { lcPrintDebug = False + , colorOutter = mempty + , rawOutter = mempty + } + + runLogger = + myLoggerT loggerConfig + + mpFreq <- + runLogger . runE $ + platformRequest + + forFold mpFreq $ \pfreq -> do + dirs <- getDirs + let + simpleSettings = + Settings False False Never Curl False GHCupURL + simpleAppState = + AppState simpleSettings dirs defaultKeyBindings + runEnv = + runLogger . flip runReaderT simpleAppState + + mGhcUpInfo <- + runEnv . runE $ + getDownloadsF $ + urlSource simpleSettings + + forFold mGhcUpInfo $ \(GHCupInfo _ dls) -> do + installedVersions <- + runEnv $ + listVersions dls (Just tool) criteria pfreq + + return $ + T.unpack . prettyVer . lVer <$> installedVersions + versionParser :: Parser GHCTargetVersion versionParser = option diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 077ed9e..6d0e68b 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -808,3 +808,12 @@ getVersionInfo v' tool dls = % _head ) dls + + +-- Gathering monoidal values +traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b +traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty) + +-- | Gathering monoidal values +forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b +forFold = flip traverseFold