imp: cli: use $PAGER when help output is taller than terminal

This works with hledger, hledger -h and hledger CMD -h.
This commit is contained in:
Simon Michael 2023-01-25 17:20:27 -10:00
parent 093fdda7db
commit d77d76e17f
4 changed files with 14 additions and 4 deletions

View File

@ -19,6 +19,9 @@ module Hledger.Utils.IO (
pprint, pprint,
pprint', pprint',
-- * Viewing with pager
pager,
-- * Command line arguments -- * Command line arguments
progArgs, progArgs,
outputFileOption, outputFileOption,
@ -57,7 +60,7 @@ import Control.Monad (when)
import Data.FileEmbed (makeRelativeToProject, embedStringFile) import Data.FileEmbed (makeRelativeToProject, embedStringFile)
import Data.List hiding (uncons) import Data.List hiding (uncons)
import Data.Maybe (isJust) import Data.Maybe (isJust)
import Data.Text (Text) import Data.Text (Text, pack)
import qualified Data.Text.IO as T import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TB import qualified Data.Text.Lazy.Builder as TB
@ -74,6 +77,7 @@ import System.IO
(Handle, IOMode (..), hGetEncoding, hSetEncoding, hSetNewlineMode, (Handle, IOMode (..), hGetEncoding, hSetEncoding, hSetNewlineMode,
openFile, stdin, stdout, stderr, universalNewlineMode, utf8_bom) openFile, stdin, stdout, stderr, universalNewlineMode, utf8_bom)
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import System.Pager
import Text.Pretty.Simple import Text.Pretty.Simple
(CheckColorTty(CheckColorTty), OutputOptions(..), (CheckColorTty(CheckColorTty), OutputOptions(..),
defaultOutputOptionsDarkBg, defaultOutputOptionsNoColor, pShowOpt, pPrintOpt) defaultOutputOptionsDarkBg, defaultOutputOptionsNoColor, pShowOpt, pPrintOpt)
@ -114,6 +118,11 @@ pprint' = pPrintOpt CheckColorTty prettyopts'
-- "Avoid using pshow, pprint, dbg* in the code below to prevent infinite loops." (?) -- "Avoid using pshow, pprint, dbg* in the code below to prevent infinite loops." (?)
-- | Display the given text on the terminal, using the user's $PAGER if the text is taller
-- than the current terminal and stdout is interactive.
pager :: String -> IO ()
pager s = printOrPage $ pack s
-- Command line arguments -- Command line arguments
-- | The command line arguments that were used at program startup. -- | The command line arguments that were used at program startup.

View File

@ -58,6 +58,7 @@ dependencies:
- microlens >=0.4 - microlens >=0.4
- microlens-th >=0.4 - microlens-th >=0.4
- mtl >=2.2.1 - mtl >=2.2.1
- pager >=0.1.1.0
- parser-combinators >=0.4.0 - parser-combinators >=0.4.0
- pretty-simple >4 && <5 - pretty-simple >4 && <5
- regex-tdfa - regex-tdfa

View File

@ -289,7 +289,7 @@ knownCommands = sort . commandsFromCommandsList . drop 1 $ commandsList progname
-- extra addons will be added under Misc. -- extra addons will be added under Misc.
printCommandsList :: String -> [String] -> IO () printCommandsList :: String -> [String] -> IO ()
printCommandsList progversion addonsFound = printCommandsList progversion addonsFound =
putStr . unlines . concatMap adjustline $ pager . unlines . concatMap adjustline $
commandsList progversion (map ('+':) unknownCommandsFound) commandsList progversion (map ('+':) unknownCommandsFound)
where where
commandsFound = map (' ':) builtinCommandNames ++ map ('+':) addonsFound commandsFound = map (' ':) builtinCommandNames ++ map ('+':) addonsFound

View File

@ -140,13 +140,13 @@ main = do
isExternalCommand = not (null cmd) && cmd `elem` addons -- probably isExternalCommand = not (null cmd) && cmd `elem` addons -- probably
isBadCommand = not (null rawcmd) && null cmd isBadCommand = not (null rawcmd) && null cmd
hasVersion = ("--version" `elem`) hasVersion = ("--version" `elem`)
printUsage = putStr $ showModeUsage $ mainmode addons printUsage = pager $ showModeUsage $ mainmode addons
badCommandError = error' ("command "++rawcmd++" is not recognized, run with no command to see a list") >> exitFailure -- PARTIAL: badCommandError = error' ("command "++rawcmd++" is not recognized, run with no command to see a list") >> exitFailure -- PARTIAL:
hasHelpFlag args1 = any (`elem` args1) ["-h","--help"] hasHelpFlag args1 = any (`elem` args1) ["-h","--help"]
hasManFlag args1 = (`elem` args1) "--man" hasManFlag args1 = (`elem` args1) "--man"
hasInfoFlag args1 = (`elem` args1) "--info" hasInfoFlag args1 = (`elem` args1) "--info"
f `orShowHelp` mode1 f `orShowHelp` mode1
| hasHelpFlag args = putStr $ showModeUsage mode1 | hasHelpFlag args = pager $ showModeUsage mode1
| hasInfoFlag args = runInfoForTopic "hledger" (headMay $ modeNames mode1) | hasInfoFlag args = runInfoForTopic "hledger" (headMay $ modeNames mode1)
| hasManFlag args = runManForTopic "hledger" (headMay $ modeNames mode1) | hasManFlag args = runManForTopic "hledger" (headMay $ modeNames mode1)
| otherwise = f | otherwise = f