Implement pager support wrt #1118

app/ghcup/Main.hs

@@ -20,6 +20,7 @@ import qualified GHCup.GHC as GHC
 import qualified GHCup.HLS as HLS
 import           GHCup.OptParse
 
+import           GHCup.Utils.Pager
 import           GHCup.Download
 import           GHCup.Errors
 import           GHCup.Platform
@@ -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
@@ -65,20 +67,19 @@ import qualified GHCup.Types                   as Types
 
 
 
-toSettings :: Options -> IO (Settings, KeyBindings, UserSettings)
-toSettings options = do
-  noColor <- isJust <$> lookupEnv "NO_COLOR"
+toSettings :: Bool -> Maybe FilePath -> Options -> IO (Settings, KeyBindings, UserSettings)
+toSettings noColor pagerCmd options = do
   userConf <- runE @'[ JSONError ] ghcupConfigFile >>= \case
     VRight r -> pure r
     VLeft (V (JSONDecodeError e)) -> do
       B.hPut stderr ("Error decoding config file: " <> (E.encodeUtf8 . T.pack . show $ e))
       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
  where
-   mergeConf :: Options -> UserSettings -> Bool -> (Settings, KeyBindings)
-   mergeConf Options{..} UserSettings{..} noColor =
+   mergeConf :: Options -> UserSettings -> (Settings, KeyBindings)
+   mergeConf Options{..} UserSettings{..} =
      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 +94,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
@@ -166,22 +170,30 @@ ENV variables:
 
 Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
 
-  customExecParser
+  args <- getArgs
+  pagerCmd <- unsafeInterleaveIO getPager
+
+  let
+    parseArgsWith opts' = execParserPure
       (prefs showHelpOnError)
-      (info (opts <**> helper <**> versionHelp <**> numericVersionHelp <**> planJson <**> listCommands)
+      (info (opts' <**> helper <**> versionHelp <**> numericVersionHelp <**> planJson <**> listCommands)
             (footerDoc (Just $ text main_footer))
-      )
-    >>= \opt@Options {..} -> do
+      ) args
+
+
+  handleParseResult' pagerCmd (argsHasHelp args) (parseArgsWith opts) >>= \case
+      opt@Options {..} -> do
+
           dirs@Dirs{..} <- getAllDirs
 
           -- create ~/.ghcup dir
           ensureDirectories dirs
 
-          (settings, keybindings, userConf) <- toSettings opt
+          no_color <- isJust <$> lookupEnv "NO_COLOR"
+          (settings, keybindings, userConf) <- toSettings no_color pagerCmd opt
 
           -- logger interpreter
           logfile <- runReaderT initGHCupFileLogging dirs
-          no_color <- isJust <$> lookupEnv "NO_COLOR"
           let loggerConfig = LoggerConfig
                 { lcPrintDebug = verbose settings
                 , consoleOutter  = T.hPutStr stderr
@@ -299,7 +311,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
             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

data/config.yaml

@@ -137,3 +137,15 @@ mirrors:
 def-ghc-conf-options:
   - "--enable-ld-override"
 
+# Use a pager for e.g. 'ghcup list' output. 'cmd' is optional (if omitted
+# will try to discover pager via GHCUP_PAGER/PAGER env vars or a predefined set of executables).
+#
+# You can also set only a boolean value:
+#   pager: true
+#
+# Or only a cmd (implies 'true' for all boolean values):
+#   pager: "less -R"
+pager:
+  list: true     # enabled for list action
+  cmd: "less -R" # the command
+

docs/guide.md

@@ -54,6 +54,25 @@ Other tags include:
 For man pages to work you need [man-db](http://man-db.nongnu.org/) as your `man` provider, then issue `man ghc`. Manpages only work for the currently set ghc.
 `MANPATH` may be required to be unset.
 
+## Pager
+
+You can have `ghcup list` use a pager, similar to git. E.g. run:
+
+```sh
+ghcup --paginate list
+```
+
+To set a specific pager you can use either `GHCUP_PAGER` or `PAGER` environment variable.
+
+To make the changes permanent, you can add the following to your config:
+
+```yaml
+pager: most
+```
+
+Refer to the [config.yaml](https://github.com/haskell/ghcup-hs/blob/master/data/config.yaml) template for more fine-grained
+control.
+
 ## Shell-completion
 
 Shell completions are in [scripts/shell-completions](https://github.com/haskell/ghcup-hs/tree/master/scripts/shell-completions) directory of this repository.

ghcup.cabal

@@ -145,6 +145,8 @@ library
     GHCup.Utils.Tar
     GHCup.Utils.Tar.Types
     GHCup.Utils.URI
+    GHCup.Utils.Output
+    GHCup.Utils.Pager
     GHCup.Utils.Parsers
     GHCup.Version
 
@@ -185,6 +187,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
@@ -209,6 +212,7 @@ library
     , strict-base           ^>=0.4
     , template-haskell       >=2.7      && <2.22
     , temporary             ^>=1.3
+    , terminal-size         ^>=0.3.3
     , text                  ^>=2.0
     , time                  >=1.9.3      && <1.12
     , unliftio-core         ^>=0.2.0.1
@@ -263,7 +267,6 @@ library
     install-includes: dirutils.h
     c-sources:        cbits/dirutils.c
     build-depends:
-      , terminal-size    ^>=0.3.3
       , unix             ^>=2.7 || ^>=2.8
       , unix-bytestring  ^>=0.3.7.3
 

lib-opt/GHCup/OptParse.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 
 
@@ -63,6 +64,12 @@ import           Data.Maybe
 import           Options.Applicative     hiding ( style )
 import           Options.Applicative.Help.Pretty ( text )
 import           Prelude                 hiding ( appendFile )
+import System.Exit
+import System.Environment (getProgName)
+import System.IO
+import GHCup.Utils.Pager
+import qualified Data.Text as T
+import Data.Function ((&))
 
 
 
@@ -81,6 +88,7 @@ data Options = Options
   , optNoNetwork   :: Maybe Bool
   , optGpg         :: Maybe GPGSetting
   , optStackSetup  :: Maybe Bool
+  , optPager       :: Maybe Bool
   -- commands
   , optCommand     :: Command
   }
@@ -177,6 +185,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
 
 
@@ -358,3 +367,26 @@ com =
                      (progDesc ""))
            <> internal
           )
+
+-- | Handle `ParserResult`.
+handleParseResult' :: Maybe FilePath -> Bool -> ParserResult a -> IO a
+handleParseResult' _ _ (Success a) = return a
+handleParseResult' pagerCmd hasHelp (Failure failure) = do
+      progn <- getProgName
+      let (msg, exit) = renderFailure failure progn
+      case exit of
+        ExitSuccess
+          | hasHelp -> sendToPager' pagerCmd (T.lines $ T.pack msg)
+          | otherwise -> putStrLn msg
+        _           -> hPutStrLn stderr msg
+      exitWith exit
+handleParseResult' _ _ (CompletionInvoked compl) = do
+      progn <- getProgName
+      msg <- execCompletion compl progn
+      putStr msg
+      exitSuccess
+
+-- | Checks whether any non-longopts args are '--help'.
+argsHasHelp :: [String] -> Bool
+argsHasHelp args = takeWhile (/= "--") args & elem "--help"
+

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