From d6fa61e223cf5b0f07b76a9ec700bdb69a537f7c Mon Sep 17 00:00:00 2001 From: Huw campbell Date: Thu, 25 Feb 2021 00:18:11 +1100 Subject: [PATCH 1/3] 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 From 1a5f0259f443d32d221020471d73fbb11f129987 Mon Sep 17 00:00:00 2001 From: Huw campbell Date: Thu, 25 Feb 2021 10:07:38 +1100 Subject: [PATCH 2/3] Just use the cache for commands which refer to locally stored objects. Setting a version of GHC will fail if provided with a version not installed, and we don't neede to check the most recent list of GHCs available to know that. --- app/ghcup/Main.hs | 34 +++++++++++++++------------ lib/GHCup/Download.hs | 54 +++++++++++++++++++++++-------------------- 2 files changed, 48 insertions(+), 40 deletions(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index ef4c404..f2646fa 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -495,7 +495,7 @@ installOpts tool = ) ) ) - <*> (Just <$> toolVersionArgument Nothing tool) + <*> (Just <$> toolVersionArgument True Nothing tool) ) <|> (pure (Nothing, Nothing)) ) @@ -560,7 +560,7 @@ setParser = setOpts :: Maybe Tool -> Parser SetOptions -setOpts tool = SetOptions <$> optional (toolVersionArgument (Just ListInstalled) tool) +setOpts tool = SetOptions <$> optional (toolVersionArgument False (Just ListInstalled) tool) listOpts :: Parser ListOptions listOpts = @@ -614,7 +614,7 @@ rmParser = rmOpts :: Maybe Tool -> Parser RmOptions -rmOpts tool = RmOptions <$> versionArgument (Just ListInstalled) tool +rmOpts tool = RmOptions <$> versionArgument False (Just ListInstalled) tool changelogP :: Parser ChangeLogOptions @@ -636,7 +636,7 @@ changelogP = ) ) ) - <*> optional (toolVersionArgument Nothing Nothing) + <*> optional (toolVersionArgument True Nothing Nothing) compileP :: Parser CompileCommand compileP = subparser @@ -765,13 +765,13 @@ toolVersionParser = verP' <|> toolP ) -- | same as toolVersionParser, except as an argument. -toolVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion -toolVersionArgument criterial tool = - argument (eitherReader toolVersionEither) (metavar "VERSION|TAG" <> completer tagCompleter <> foldMap (completer . versionCompleter criterial) tool) +toolVersionArgument :: Bool -> Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion +toolVersionArgument networkSensitive criteria tool = + argument (eitherReader toolVersionEither) (metavar "VERSION|TAG" <> completer tagCompleter <> foldMap (completer . versionCompleter networkSensitive criteria) tool) -versionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion -versionArgument criterial tool = argument (eitherReader tVersionEither) (metavar "VERSION" <> foldMap (completer . versionCompleter criterial) tool) +versionArgument :: Bool -> Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion +versionArgument networkSensitive criteria tool = argument (eitherReader tVersionEither) (metavar "VERSION" <> foldMap (completer . versionCompleter networkSensitive criteria) tool) tagCompleter :: Completer @@ -781,8 +781,8 @@ tagCompleter = ] -versionCompleter :: Maybe ListCriteria -> Tool -> Completer -versionCompleter criteria tool = +versionCompleter :: Bool -> Maybe ListCriteria -> Tool -> Completer +versionCompleter networkSensitive criteria tool = listIOCompleter $ do let loggerConfig = @@ -811,8 +811,12 @@ versionCompleter criteria tool = mGhcUpInfo <- runEnv . runE $ - getDownloadsF $ - urlSource simpleSettings + if networkSensitive then + getDownloadsF GHCupURL + else + catchE + (\(FileDoesNotExistError _) -> getDownloadsF GHCupURL) + readFromCache forFold mGhcUpInfo $ \(GHCupInfo _ dls) -> do installedVersions <- @@ -831,7 +835,7 @@ versionParser = option versionParser' :: Parser Version versionParser' = argument - (eitherReader (bimap show id . version . T.pack)) + (eitherReader (first show . version . T.pack)) (metavar "VERSION") @@ -842,7 +846,7 @@ tagEither s' = case fmap toLower s' of ('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of Right x -> Right (Base x) Left _ -> Left [i|Invalid PVP version for base #{ver'}|] - other -> Left ([i|Unknown tag #{other}|]) + other -> Left [i|Unknown tag #{other}|] tVersionEither :: String -> Either String GHCTargetVersion diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index ce6a2f9..dc6f633 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -137,30 +137,8 @@ getDownloadsF urlSource = do bsExt <- reThrowAll DownloadFailed $ downloadBS uri ext <- lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bsExt) pure (mergeGhcupInfo base ext) - where - readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m) - => Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo - readFromCache = do - AppState {dirs = Dirs {..}} <- lift ask - lift $ $(logWarn) - [i|Could not get download info, trying cached version (this may not be recent!)|] - let path = view pathL' ghcupURL - yaml_file <- (cacheDir ) <$> urlBaseName path - bs <- - handleIO' NoSuchThing - (\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file)) - $ liftIO - $ readFile yaml_file - lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs) - getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m) - => Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo - getBase = - handleIO (\_ -> readFromCache) - $ catchE @_ @'[JSONError, FileDoesNotExistError] - (\(DownloadFailed _) -> readFromCache) - $ ((reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed $ smartDl ghcupURL) - >>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict)) + where mergeGhcupInfo :: GHCupInfo -- ^ base to merge with -> GHCupInfo -- ^ extension overwriting the base @@ -172,6 +150,32 @@ getDownloadsF urlSource = do ) base in GHCupInfo tr new + +readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m) + => Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo +readFromCache = do + AppState {dirs = Dirs {..}} <- lift ask + lift $ $(logWarn) + [i|Could not get download info, trying cached version (this may not be recent!)|] + let path = view pathL' ghcupURL + yaml_file <- (cacheDir ) <$> urlBaseName path + bs <- + handleIO' NoSuchThing + (\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file)) + $ liftIO + $ readFile yaml_file + lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs) + + +getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m) + => Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo +getBase = + handleIO (\_ -> readFromCache) + $ catchE @_ @'[JSONError, FileDoesNotExistError] + (\(DownloadFailed _) -> readFromCache) + $ ((reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed $ smartDl ghcupURL) + >>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict)) + where -- First check if the json file is in the ~/.ghcup/cache dir -- and check it's access time. If it has been accessed within the -- last 5 minutes, just reuse it. @@ -209,8 +213,8 @@ getDownloadsF urlSource = do then do accessTime <- PF.accessTimeHiRes - <$> (liftIO $ PF.getFileStatus (toFilePath json_file)) - currentTime <- liftIO $ getPOSIXTime + <$> liftIO (PF.getFileStatus (toFilePath json_file)) + currentTime <- liftIO getPOSIXTime -- access time won't work on most linuxes, but we can try regardless if (currentTime - accessTime) > 300 From 453a29fdf790e89b164f3c979f848dc06d65c4ca Mon Sep 17 00:00:00 2001 From: Huw campbell Date: Thu, 25 Feb 2021 12:45:52 +1100 Subject: [PATCH 3/3] Respect the user's configuration settings Only lookup user configuration before doing a search; implement version completion for Cabal and HLS removal --- app/ghcup/Main.hs | 21 +++++++++++++-------- lib/GHCup/Utils/Dirs.hs | 4 ++-- 2 files changed, 15 insertions(+), 10 deletions(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index f2646fa..96b5e8e 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -596,14 +596,14 @@ rmParser = <> command "cabal" ( RmCabal - <$> (info (versionParser' <**> helper) + <$> (info (versionParser' False (Just ListInstalled) (Just Cabal) <**> helper) (progDesc "Remove Cabal version") ) ) <> command "hls" ( RmHLS - <$> (info (versionParser' <**> helper) + <$> (info (versionParser' False (Just ListInstalled) (Just HLS) <**> helper) (progDesc "Remove haskell-language-server version") ) ) @@ -795,6 +795,11 @@ versionCompleter networkSensitive criteria tool = runLogger = myLoggerT loggerConfig + downloadWithUserSource = do + userConf <- runE @'[ JSONError ] ghcupConfigFile + getDownloadsF $ + veitherCont (const GHCupURL) (fromMaybe GHCupURL . uUrlSource) userConf + mpFreq <- runLogger . runE $ platformRequest @@ -811,11 +816,11 @@ versionCompleter networkSensitive criteria tool = mGhcUpInfo <- runEnv . runE $ - if networkSensitive then - getDownloadsF GHCupURL + if networkSensitive then do + downloadWithUserSource else catchE - (\(FileDoesNotExistError _) -> getDownloadsF GHCupURL) + (\(FileDoesNotExistError _) -> downloadWithUserSource) readFromCache forFold mGhcUpInfo $ \(GHCupInfo _ dls) -> do @@ -833,10 +838,10 @@ versionParser = option (short 'v' <> long "version" <> metavar "VERSION" <> help "The target version" ) -versionParser' :: Parser Version -versionParser' = argument +versionParser' :: Bool -> Maybe ListCriteria -> Maybe Tool -> Parser Version +versionParser' networkSensitive criteria tool = argument (eitherReader (first show . version . T.pack)) - (metavar "VERSION") + (metavar "VERSION" <> foldMap (completer . versionCompleter networkSensitive criteria) tool) tagEither :: String -> Either String Tag diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index 0c2df15..67d394d 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -185,9 +185,9 @@ getDirs = do ghcupConfigFile :: (MonadIO m) => Excepts '[JSONError] m UserSettings ghcupConfigFile = do - confDir <- liftIO $ ghcupConfigDir + confDir <- liftIO ghcupConfigDir let file = confDir [rel|config.yaml|] - bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ fmap Just $ readFile file + bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> readFile file case bs of Nothing -> pure defaultUserSettings Just bs' -> lE' JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict $ bs'