From 8f10cba691b0477c474557cc0f472a0d3bc6cc74 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 12 Aug 2024 18:21:53 +0800 Subject: [PATCH] Implement pager support wrt #1118 --- app/ghcup/Main.hs | 14 ++++++--- ghcup.cabal | 2 ++ lib-opt/GHCup/OptParse.hs | 2 ++ lib-opt/GHCup/OptParse/Config.hs | 3 +- lib-opt/GHCup/OptParse/List.hs | 24 +++++++++++---- lib/GHCup/Types.hs | 22 ++++++++++++-- lib/GHCup/Types/JSON.hs | 12 ++++++++ lib/GHCup/Utils/Pager.hs | 51 ++++++++++++++++++++++++++++++++ 8 files changed, 118 insertions(+), 12 deletions(-) create mode 100644 lib/GHCup/Utils/Pager.hs diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 391d932d..fe2983fc 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -27,6 +27,7 @@ import GHCup.Types import GHCup.Types.Optics hiding ( toolRequirements ) import GHCup.Utils import GHCup.Utils.Parsers (fromVersion) +import GHCup.Utils.Pager import GHCup.Prelude import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ @@ -55,6 +56,7 @@ import Prelude hiding ( appendFile ) import System.Environment import System.Exit import System.IO hiding ( appendFile ) +import System.IO.Unsafe ( unsafeInterleaveIO ) import Text.PrettyPrint.HughesPJClass ( prettyShow ) import qualified Data.ByteString as B @@ -68,6 +70,7 @@ import qualified GHCup.Types as Types toSettings :: Options -> IO (Settings, KeyBindings, UserSettings) toSettings options = do noColor <- isJust <$> lookupEnv "NO_COLOR" + pagerCmd <- unsafeInterleaveIO getPager userConf <- runE @'[ JSONError ] ghcupConfigFile >>= \case VRight r -> pure r VLeft (V (JSONDecodeError e)) -> do @@ -75,10 +78,10 @@ toSettings options = do pure defaultUserSettings _ -> do die "Unexpected error!" - pure $ (\(s', k) -> (s', k, userConf)) $ mergeConf options userConf noColor + pure $ (\(s', k) -> (s', k, userConf)) $ mergeConf options userConf noColor pagerCmd where - mergeConf :: Options -> UserSettings -> Bool -> (Settings, KeyBindings) - mergeConf Options{..} UserSettings{..} noColor = + mergeConf :: Options -> UserSettings -> Bool -> Maybe FilePath -> (Settings, KeyBindings) + mergeConf Options{..} UserSettings{..} noColor pagerCmd = let cache = fromMaybe (fromMaybe (Types.cache defaultSettings) uCache) optCache metaCache = fromMaybe (fromMaybe (Types.metaCache defaultSettings) uMetaCache) optMetaCache metaMode = fromMaybe (fromMaybe (Types.metaMode defaultSettings) uMetaMode) optMetaMode @@ -93,6 +96,9 @@ toSettings options = do platformOverride = optPlatform <|> (uPlatformOverride <|> Types.platformOverride defaultSettings) mirrors = fromMaybe (Types.mirrors defaultSettings) uMirrors defGHCConfOptions = fromMaybe (Types.defGHCConfOptions defaultSettings) uDefGHCConfOptions + pager = case fromMaybe (fromMaybe (Types.pager defaultSettings) uPager) (flip PagerConfig Nothing <$> optPager) of + PagerConfig b Nothing -> PagerConfig b pagerCmd + x -> x in (Settings {..}, keyBindings) #if defined(INTERNAL_DOWNLOADER) defaultDownloader = Internal @@ -299,7 +305,7 @@ Report bugs at |] Test testCommand -> test testCommand settings appState runLogger Set setCommand -> set setCommand runAppState runLeanAppState runLogger UnSet unsetCommand -> unset unsetCommand runLeanAppState runLogger - List lo -> list lo no_color runAppState + List lo -> list lo no_color (pager settings) runAppState Rm rmCommand -> rm rmCommand runAppState runLogger DInfo -> dinfo runAppState runLogger Compile compileCommand -> compile compileCommand settings dirs runAppState runLogger diff --git a/ghcup.cabal b/ghcup.cabal index ffea3050..19f63237 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -145,6 +145,7 @@ library GHCup.Utils.Tar GHCup.Utils.Tar.Types GHCup.Utils.URI + GHCup.Utils.Pager GHCup.Utils.Parsers GHCup.Version @@ -185,6 +186,7 @@ library , casing ^>=0.1.4.1 , containers ^>=0.6 , conduit ^>=1.3 + , conduit-extra ^>=1.3 , cryptohash-sha256 ^>=0.11.101.0 , deepseq ^>=1.4.4.0 , directory ^>=1.3.6.0 diff --git a/lib-opt/GHCup/OptParse.hs b/lib-opt/GHCup/OptParse.hs index 3bda4035..e0907f83 100644 --- a/lib-opt/GHCup/OptParse.hs +++ b/lib-opt/GHCup/OptParse.hs @@ -81,6 +81,7 @@ data Options = Options , optNoNetwork :: Maybe Bool , optGpg :: Maybe GPGSetting , optStackSetup :: Maybe Bool + , optPager :: Maybe Bool -- commands , optCommand :: Command } @@ -177,6 +178,7 @@ opts = <> completer (listCompleter ["strict", "lax", "none"]) )) <*> invertableSwitch "stack-setup" Nothing False (help "Use stack's setup info for discovering and installing GHC versions") + <*> (invertableSwitch "paginate" Nothing False (help "Send output (e.g. from 'ghcup list') through pager (default: disabled)")) <*> com diff --git a/lib-opt/GHCup/OptParse/Config.hs b/lib-opt/GHCup/OptParse/Config.hs index c2f58505..2f7f345d 100644 --- a/lib-opt/GHCup/OptParse/Config.hs +++ b/lib-opt/GHCup/OptParse/Config.hs @@ -135,7 +135,8 @@ updateSettings usl usr = platformOverride' = uPlatformOverride usl <|> uPlatformOverride usr mirrors' = uMirrors usl <|> uMirrors usr defGHCconfOptions' = uDefGHCConfOptions usl <|> uDefGHCConfOptions usr - in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors' defGHCconfOptions' + pagerConfig' = uPager usl <|> uPager usr + in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors' defGHCconfOptions' pagerConfig' where updateKeyBindings :: Maybe UserKeyBindings -> Maybe UserKeyBindings -> Maybe UserKeyBindings updateKeyBindings Nothing Nothing = Nothing diff --git a/lib-opt/GHCup/OptParse/List.hs b/lib-opt/GHCup/OptParse/List.hs index f82b9f8c..f34fcfc2 100644 --- a/lib-opt/GHCup/OptParse/List.hs +++ b/lib-opt/GHCup/OptParse/List.hs @@ -17,6 +17,7 @@ import GHCup.Types import GHCup.Utils.Parsers (dayParser, toolParser, criteriaParser) import GHCup.OptParse.Common import GHCup.Prelude.String.QQ +import GHCup.Utils.Pager #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -139,8 +140,9 @@ Examples: ----------------- -printListResult :: Bool -> Bool -> [ListResult] -> IO () -printListResult no_color raw lr = do +printListResult :: (HasLog env , MonadReader env m, MonadIO m) + => Bool -> PagerConfig -> Bool -> [ListResult] -> m () +printListResult no_color (PagerConfig pList pCmd) raw lr = do let color | raw || no_color = (\_ x -> x) @@ -197,9 +199,13 @@ printListResult no_color raw lr = do lengths = fmap (maximum . fmap strWidth) cols padded = fmap (\xs -> zipWith padTo xs lengths) rows - forM_ (if raw then rows else padded) $ \row -> putStrLn $ unwords row + let text = fmap unwords (if raw then rows else padded) + if | pList + , not raw + , Just cmd <- pCmd -> do where + padTo :: String -> Int -> String padTo str' x = let lstr = strWidth str' add' = x - lstr @@ -287,6 +293,13 @@ printListResult no_color raw lr = do | c >= '\x1F300' && c <= '\x1F773' -> 1 | c >= '\x20000' && c <= '\x3FFFD' -> 2 | otherwise -> 1 + r <- liftIO $ sendToPager cmd (T.pack <$> text) + case r of + Left e -> do + logDebug $ "Failed to send to pager '" <> T.pack cmd <> "': " <> T.pack (show e) + liftIO $ forM_ text putStrLn + Right _ -> pure () + | otherwise -> liftIO $ forM_ text putStrLn @@ -305,11 +318,12 @@ list :: ( Monad m ) => ListOptions -> Bool + -> PagerConfig -> (ReaderT AppState m ExitCode -> m ExitCode) -> m ExitCode -list ListOptions{..} no_color runAppState = +list ListOptions{..} no_color pgc runAppState = runAppState (do l <- listVersions loTool (maybeToList lCriteria) lHideOld lShowNightly (lFrom, lTo) - liftIO $ printListResult no_color lRawFormat l + printListResult no_color pgc lRawFormat l pure ExitSuccess ) diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 98cb2c13..6e27284f 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -393,11 +393,12 @@ data UserSettings = UserSettings , uPlatformOverride :: Maybe PlatformRequest , uMirrors :: Maybe DownloadMirrors , uDefGHCConfOptions :: Maybe [String] + , uPager :: Maybe PagerConfig } deriving (Show, GHC.Generic, Eq) defaultUserSettings :: UserSettings -defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing +defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing fromSettings :: Settings -> Maybe KeyBindings -> UserSettings fromSettings Settings{..} Nothing = @@ -416,6 +417,7 @@ fromSettings Settings{..} Nothing = , uPlatformOverride = platformOverride , uMirrors = Just mirrors , uDefGHCConfOptions = Just defGHCConfOptions + , uPager = Just pager } fromSettings Settings{..} (Just KeyBindings{..}) = let ukb = UserKeyBindings @@ -443,6 +445,7 @@ fromSettings Settings{..} (Just KeyBindings{..}) = , uPlatformOverride = platformOverride , uMirrors = Just mirrors , uDefGHCConfOptions = Just defGHCConfOptions + , uPager = Just pager } data UserKeyBindings = UserKeyBindings @@ -529,14 +532,29 @@ data Settings = Settings , platformOverride :: Maybe PlatformRequest , mirrors :: DownloadMirrors , defGHCConfOptions :: [String] + , pager :: PagerConfig } deriving (Show, GHC.Generic) +data PagerConfig = PagerConfig { + pagerList :: Bool + , pagerCmd :: Maybe String + } + deriving (Show, GHC.Generic, Eq) + +instance NFData PagerConfig + +defaultPagerConfig :: PagerConfig +defaultPagerConfig = PagerConfig False Nothing + +allPagerConfig :: String -> PagerConfig +allPagerConfig cmd = PagerConfig True (Just cmd) + defaultMetaCache :: Integer defaultMetaCache = 300 -- 5 minutes defaultSettings :: Settings -defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing (DM mempty) [] +defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing (DM mempty) [] defaultPagerConfig instance NFData Settings diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index ce95303b..98176e37 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -434,6 +434,18 @@ instance FromJSON KeyCombination where instance ToJSON KeyCombination where toJSON (KeyCombination k m) = object ["Key" .= k, "Mods" .= m] +instance FromJSON PagerConfig where + parseJSON v = p1 v <|> p2 v <|> p3 v + where + p2 = withBool "PagerConfig" $ \b -> pure $ PagerConfig b Nothing + p3 = withText "PagerConfig" $ \t -> pure $ allPagerConfig (T.unpack t) + p1 = withObject "PagerConfig" $ \o -> do + list <- o .: "list" + cmd <- o .:? "cmd" + pure $ PagerConfig list cmd + + +deriveToJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "pager-") . T.pack . kebab $ str' } ''PagerConfig deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings diff --git a/lib/GHCup/Utils/Pager.hs b/lib/GHCup/Utils/Pager.hs new file mode 100644 index 00000000..7cda2a9d --- /dev/null +++ b/lib/GHCup/Utils/Pager.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module GHCup.Utils.Pager where + +import GHCup.Prelude +import System.Environment +import GHCup.Utils.Dirs (findExecutable) +import Control.Applicative (asum) +import System.Process +import System.Exit +import System.IO +import Data.Text (Text) +import qualified Data.Text.IO as T +import Control.Monad (forM_) +import Control.Exception (IOException, try) + + +getPager :: IO (Maybe FilePath) +getPager = do + lookupEnv "GHCUP_PAGER" >>= \case + Just r -> pure $ Just r + Nothing -> lookupEnv "PAGER" >>= \case + Just r' -> pure $ Just r' + Nothing -> do + let pagers + | isWindows = ["most.exe", "more.exe", "less.exe"] + | otherwise = ["most", "more", "less"] + asum $ fmap findExecutable pagers + +sendToPager :: FilePath -> [Text] -> IO (Either IOException ()) +sendToPager pager text = do + (Just stdinH, _, Just stderrH, ph) <- + createProcess + $ (shell pager) { std_in = CreatePipe + , std_err = CreatePipe + } + try @IOException (forM_ text $ T.hPutStrLn stdinH) >>= \case + Left e -> pure $ Left e + Right _ -> do + hClose stdinH + exitCode <- waitForProcess ph + case exitCode of + ExitFailure i -> + do errContents <- hGetContents stderrH + fail (unlines [mappend "Pager exited with exit code " (show i) + ,errContents]) + _ -> pure $ Right () +