imp:cli: --no-pager -> --pager, make this and --color safe options

hledger-lib/Hledger/Data/RawOptions.hs

@@ -9,6 +9,7 @@ more easily by hledger commands/scripts in this and other packages.
 
 module Hledger.Data.RawOptions (
   RawOpts,
+  YNA,
   mkRawOpts,
   overRawOpts,
   setopt,
@@ -26,7 +27,9 @@ module Hledger.Data.RawOptions (
   posintopt,
   maybeintopt,
   maybeposintopt,
-  maybecharopt
+  maybecharopt,
+  maybeynopt,
+  maybeynaopt,
 )
 where
 
@@ -35,6 +38,8 @@ import Data.Default (Default(..))
 import Safe (headMay, lastMay, readDef)
 
 import Hledger.Utils
+import Data.Char (toLower)
+import Data.List (intercalate)
 
 
 -- | The result of running cmdargs: an association list of option names to string values.
@@ -139,3 +144,22 @@ maybeclippedintopt minVal maxVal name =
                                          ++ " must lie in the range "
                                          ++ show minVal ++ " to " ++ show maxVal
                                          ++ ", but is " ++ show n
+
+maybeynopt :: String -> RawOpts -> Maybe Bool
+maybeynopt name rawopts =
+  case maybestringopt name rawopts of
+    Just v | map toLower v `elem` ["y","yes","always"] -> Just True
+    Just v | map toLower v `elem` ["n","no","never"]   -> Just False
+    Just _ -> error' $ name <> " value should be one of " <> (intercalate ", " ["y","yes","n","no"])
+    _ -> Nothing
+
+data YNA = Yes | No | Auto deriving (Eq,Show)
+
+maybeynaopt :: String -> RawOpts -> Maybe YNA
+maybeynaopt name rawopts =
+  case maybestringopt name rawopts of
+    Just v | map toLower v `elem` ["y","yes","always"] -> Just Yes
+    Just v | map toLower v `elem` ["n","no","never"]   -> Just No
+    Just v | map toLower v `elem` ["a","auto"]         -> Just Auto
+    Just _ -> error' $ name <> " value should be one of " <> (intercalate ", " ["y","yes","n","no","a","auto"])
+    _ -> Nothing

hledger-lib/Hledger/Reports/ReportOptions.hs

@@ -346,7 +346,7 @@ ynopt opt rawopts = case maybestringopt opt rawopts of
     Just "never"  -> Just False
     Just "no"     -> Just False
     Just "n"      -> Just False
-    Just _        -> usageError "--pretty's argument should be \"yes\" or \"no\" (or y, n, always, never)"
+    Just _        -> usageError "this argument should be one of y, yes, n, no"
     _             -> Nothing
 
 balanceAccumulationOverride :: RawOpts -> Maybe BalanceAccumulation

hledger-lib/Hledger/Utils/IO.hs

@@ -20,8 +20,8 @@ module Hledger.Utils.IO (
   pprint',
 
   -- * Viewing with pager
-  pager,
   setupPager,
+  runPager,
 
   -- * Terminal size
   getTerminalHeightWidth,
@@ -32,6 +32,9 @@ module Hledger.Utils.IO (
   progArgs,
   outputFileOption,
   hasOutputFile,
+  splitFlagsAndVals,
+  getLongOpt,
+  parseYN,
 
   -- * ANSI color
   colorOption,
@@ -130,6 +133,7 @@ import           Text.Pretty.Simple
   defaultOutputOptionsDarkBg, defaultOutputOptionsNoColor, pShowOpt, pPrintOpt)
 
 import Hledger.Utils.Text (WideBuilder(WideBuilder))
+import Data.Char (toLower)
 
 
 -- Pretty showing/printing with pretty-simple
@@ -210,13 +214,18 @@ setupPager = do
 -- supports those, the pager should be configured to display those, otherwise
 -- users will see junk on screen (#2015).
 -- Call "setupPager" at program startup to make that less likely.
-pager :: String -> IO ()
+--
+-- Pager use is influenced by the --pager option, at least.
+-- Rather than pass in a huge CliOpts, or duplicate conditional logic at every call site,
+-- this does some redundant local options parsing.
+runPager :: String -> IO ()
 #ifdef mingw32_HOST_OS
-pager = putStr
+runPager = putStr
 #else
-pager s = do
+runPager s = do
-  -- disable pager when --no-pager is specified
+  -- disable pager with --pager=no
-  nopager <- elem "--no-pager" <$> getArgs
+  mpager <- getLongOpt "pager"
+  let nopager = not $ maybe True parseYN mpager
   -- disable pager when TERM=dumb (for Emacs shell users)
   dumbterm <- (== Just "dumb") <$> lookupEnv "TERM"
   -- disable pager with single-line output (https://github.com/pharpend/pager/issues/2)
@@ -238,6 +247,33 @@ pager s = do
     s
 #endif
 
+-- | Given a list of arguments, split any of the form --flag=val into --flag, val.
+splitFlagsAndVals :: [String] -> [String]
+splitFlagsAndVals =
+  concatMap
+    (\a ->
+      if "--" `isPrefixOf` a && '=' `elem` a
+      then let (x,y) = break (=='=') a in [x, drop 1 y]
+      else [a])
+
+-- | Read the value of the rightmost long option of this name from the command line arguments.
+-- If the value is missing raise an error.
+getLongOpt :: String -> IO (Maybe String)
+getLongOpt name = do
+  rargs <- reverse . splitFlagsAndVals <$> getArgs
+  let flag = "--"<>name
+  return $
+    case break (==flag) rargs of
+      ([],_)        -> error' $ flag <> " requires a value"
+      (argsafter,_) -> Just $ last argsafter
+
+-- | Parse y/yes/always or n/no/never to true or false, or with any other value raise an error.
+parseYN :: String -> Bool
+parseYN s
+  | l `elem` ["y","yes","always"] = True
+  | l `elem` ["n","no","never"]   = False
+  | otherwise = error' $ "value should be one of " <> (intercalate ", " ["y","yes","n","no"])
+  where l = map toLower s
 
 -- Command line arguments
 

hledger-ui/Hledger/UI/Main.hs

@@ -75,7 +75,7 @@ hledgerUiMain = withGhcDebug' $ withProgName "hledger-ui.log" $ do  -- force Hle
   let copts' = copts{inputopts_=iopts{forecast_=forecast_ iopts <|> Just nulldatespan}}
 
   case True of
-    _ | boolopt "help"    rawopts -> pager $ showModeUsage uimode ++ "\n"
+    _ | boolopt "help"    rawopts -> runPager $ showModeUsage uimode ++ "\n"
     _ | boolopt "tldr"    rawopts -> runTldrForPage "hledger-ui"
     _ | boolopt "info"    rawopts -> runInfoForTopic "hledger-ui" Nothing
     _ | boolopt "man"     rawopts -> runManForTopic  "hledger-ui" Nothing

hledger-web/Hledger/Web/Main.hs

@@ -55,7 +55,7 @@ hledgerWebMain = withGhcDebug' $ do
   wopts@WebOpts{cliopts_=copts@CliOpts{debug_, rawopts_}} <- getHledgerWebOpts
   when (debug_ > 0) $ printf "%s\n" prognameandversion >> printf "opts: %s\n" (show wopts)
   if
-    | boolopt "help"            rawopts_ -> pager $ showModeUsage webmode ++ "\n"
+    | boolopt "help"            rawopts_ -> runPager $ showModeUsage webmode ++ "\n"
     | boolopt "tldr"            rawopts_ -> runTldrForPage "hledger-web"
     | boolopt "info"            rawopts_ -> runInfoForTopic "hledger-web" Nothing
     | boolopt "man"             rawopts_ -> runManForTopic  "hledger-web" Nothing

hledger.conf

@@ -1,3 +1,6 @@
 # This is an empty config file, to disable your personal hledger config
 # while developing and testing hledger in this directory.
 # For an example config, see hledger.conf.sample.
+--pager yes
+# --color=no
+# --debug

hledger/Hledger/Cli.hs

@@ -345,7 +345,7 @@ main = withGhcDebug' $ do
   withArgs (progname:finalargs) $
    if
     -- 6.1. no command and a help/doc flag found - show general help/docs
-    | nocmdprovided && helpFlag -> pager $ showModeUsage (mainmode []) ++ "\n"
+    | nocmdprovided && helpFlag -> runPager $ showModeUsage (mainmode []) ++ "\n"
     | nocmdprovided && tldrFlag -> runTldrForPage  "hledger"
     | nocmdprovided && infoFlag -> runInfoForTopic "hledger" Nothing
     | nocmdprovided && manFlag  -> runManForTopic  "hledger" Nothing
@@ -375,7 +375,7 @@ main = withGhcDebug' $ do
       -- run the builtin command according to its type
       if
         -- 6.5.1. help/doc flag - show command help/docs
-        | helpFlag  -> pager $ showModeUsage cmdmode ++ "\n"
+        | helpFlag  -> runPager $ showModeUsage cmdmode ++ "\n"
         | tldrFlag  -> runTldrForPage tldrpagename
         | infoFlag  -> runInfoForTopic "hledger" mmodecmdname
         | manFlag   -> runManForTopic "hledger"  mmodecmdname

hledger/Hledger/Cli/CliOptions.hs

@@ -22,8 +22,8 @@ module Hledger.Cli.CliOptions (
   -- * cmdargs flags & modes
   inputflags,
   reportflags,
-  terminalflags,
   helpflags,
+  terminalflags,
   helpflagstitle,
   flattreeflags,
   confflags,
@@ -240,17 +240,17 @@ helpflags = [
   -- flagOpt would be more correct for --debug, showing --debug[=LVL] rather than --debug=[LVL] in help.
   -- But flagReq plus special handling in Cli.hs makes the = optional, removing a source of confusion.
  ,flagReq  ["debug"]    (\s opts -> Right $ setopt "debug" s opts) "[1-9]" "show this much debug output (default: 1)"
- ]
+ ] -- XXX why are these duplicated in defCommandMode below ?
--- XXX why are these duplicated in defCommandMode below ?
  <> terminalflags
 
 -- Low-level flags affecting terminal output.
 -- These are included in helpflags so they appear everywhere.
 terminalflags = [
-  flagNone ["no-pager"] (setboolopt "no-pager") "don't use a pager for long output"
+  flagReq  ["pager"] (\s opts -> Right $ setopt "pager" s opts) "YN"
+   "use pager for long output ? y/yes or n/no"
   -- This has special support in hledger-lib:colorOption, keep synced
  ,flagReq  ["color","colour"] (\s opts -> Right $ setopt "color" s opts) "YN"
-   "use ANSI color in terminal ? 'y'/'yes', 'n'/'no', or 'auto' (default)"
+   "use ANSI color ? y/yes, n/no, or auto (default)"
  ]
 
 -- | Flags for selecting flat/tree mode, used for reports organised by account.
@@ -542,6 +542,8 @@ data CliOpts = CliOpts {
     ,reportspec_      :: ReportSpec
     ,output_file_     :: Maybe FilePath
     ,output_format_   :: Maybe String
+    ,pageropt_        :: Maybe Bool     -- ^ --pager
+    ,coloropt_        :: Maybe YNA      -- ^ --color. Controls use of ANSI color and ANSI styles.
     ,debug_           :: Int            -- ^ debug level, set by @--debug[=N]@. See also 'Hledger.Utils.debugLevel'.
     ,no_new_accounts_ :: Bool           -- add
     ,width_           :: Maybe String   -- ^ the --width value provided, if any
@@ -563,6 +565,8 @@ defcliopts = CliOpts
     , reportspec_      = def
     , output_file_     = Nothing
     , output_format_   = Nothing
+    , pageropt_        = Nothing
+    , coloropt_        = Nothing
     , debug_           = 0
     , no_new_accounts_ = False
     , width_           = Nothing
@@ -621,6 +625,8 @@ rawOptsToCliOpts rawopts = do
              ,reportspec_      = rspec
              ,output_file_     = maybestringopt "output-file" rawopts
              ,output_format_   = maybestringopt "output-format" rawopts
+             ,pageropt_        = maybeynopt "pager" rawopts
+             ,coloropt_        = maybeynaopt "color" rawopts
              ,debug_           = posintopt "debug" rawopts
              ,no_new_accounts_ = boolopt "no-new-accounts" rawopts -- add
              ,width_           = maybestringopt "width" rawopts

hledger/Hledger/Cli/Commands.hs

@@ -327,7 +327,7 @@ printCommandsList progversion installedaddons =
   seq (length $ dbg8 "uninstalledknownaddons" uninstalledknownaddons) $  -- for debug output
   seq (length $ dbg8 "installedknownaddons"   installedknownaddons)   $
   seq (length $ dbg8 "installedunknownaddons" installedunknownaddons) $
-  pager $ unlines $ map unplus $ filter (not.isuninstalledaddon) $
+  runPager $ unlines $ map unplus $ filter (not.isuninstalledaddon) $
   commandsList progversion installedunknownaddons
   where
     knownaddons = knownAddonCommands

hledger/Hledger/Cli/Utils.hs

@@ -130,7 +130,7 @@ writeOutput opts s = do
 writeOutputLazyText :: CliOpts -> TL.Text -> IO ()
 writeOutputLazyText opts s = do
   f <- outputFileFromOpts opts
-  maybe (pager . TL.unpack) TL.writeFile f s
+  maybe (runPager . TL.unpack) TL.writeFile f s
 
 -- -- | Get a journal from the given string and options, or throw an error.
 -- readJournal :: CliOpts -> String -> IO Journal