imp:cli: detect --color more safely in most cases

--color now also works in a config file, like --pager, except for two
cases: it does not affect colouring of debug output, or the colouring
helpers used in the check recentassertions error message.

hledger-lib/Hledger/Data/RawOptions.hs

@@ -9,7 +9,6 @@ more easily by hledger commands/scripts in this and other packages.
 
 module Hledger.Data.RawOptions (
   RawOpts,
-  YNA,
   mkRawOpts,
   overRawOpts,
   setopt,
@@ -153,8 +152,6 @@ maybeynopt name rawopts =
     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

hledger-lib/Hledger/Read/Common.hs

@@ -192,14 +192,14 @@ instance Show (Reader m) where show r = show (rFormat r) ++ " reader"
 
 -- | Parse an InputOpts from a RawOpts and a provided date.
 -- This will fail with a usage error if the forecast period expression cannot be parsed.
-rawOptsToInputOpts :: Day -> RawOpts -> InputOpts
-rawOptsToInputOpts day rawopts =
+rawOptsToInputOpts :: Day -> Bool -> RawOpts -> InputOpts
+rawOptsToInputOpts day usecoloronstdout rawopts =
 
     let noinferbalancingcosts = boolopt "strict" rawopts || stringopt "args" rawopts == "balanced"
 
         -- Do we really need to do all this work just to get the requested end date? This is duplicating
         -- much of reportOptsToSpec.
-        ropts = rawOptsToReportOpts day rawopts
+        ropts = rawOptsToReportOpts day usecoloronstdout rawopts
         argsquery = map fst . rights . map (parseQueryTerm day) $ querystring_ ropts
         datequery = simplifyQuery . filterQuery queryIsDate . And $ queryFromFlags ropts : argsquery
 

hledger-lib/Hledger/Reports/ReportOptions.hs

@@ -226,14 +226,14 @@ defreportopts = ReportOpts
     , layout_           = LayoutWide Nothing
     }
 
--- | Generate a ReportOpts from raw command-line input, given a day.
+-- | Generate a ReportOpts from raw command-line input, given a day and whether to use ANSI colour/styles in standard output.
 -- This will fail with a usage error if it is passed
 -- - an invalid --format argument,
 -- - an invalid --value argument,
 -- - if --valuechange is called with a valuation type other than -V/--value=end.
 -- - an invalid --pretty argument,
-rawOptsToReportOpts :: Day -> RawOpts -> ReportOpts
-rawOptsToReportOpts d rawopts =
+rawOptsToReportOpts :: Day -> Bool -> RawOpts -> ReportOpts
+rawOptsToReportOpts d usecoloronstdout rawopts =
 
     let formatstring = T.pack <$> maybestringopt "format" rawopts
         querystring  = map T.pack $ listofstringopt "args" rawopts  -- doesn't handle an arg like "" right
@@ -277,7 +277,7 @@ rawOptsToReportOpts d rawopts =
           ,percent_          = boolopt "percent" rawopts
           ,invert_           = boolopt "invert" rawopts
           ,pretty_           = pretty
-          ,color_            = useColorOnStdout -- a lower-level helper
+          ,color_            = usecoloronstdout
           ,transpose_        = boolopt "transpose" rawopts
           ,layout_           = layoutopt rawopts
           }
@@ -941,5 +941,5 @@ updateReportSpecWith = overEither reportOpts
 
 -- | Generate a ReportSpec from RawOpts and a provided day, or return an error
 -- string if there are regular expression errors.
-rawOptsToReportSpec :: Day -> RawOpts -> Either String ReportSpec
-rawOptsToReportSpec day = reportOptsToSpec day . rawOptsToReportOpts day
+rawOptsToReportSpec :: Day -> Bool -> RawOpts -> Either String ReportSpec
+rawOptsToReportSpec day coloronstdout = reportOptsToSpec day . rawOptsToReportOpts day coloronstdout

hledger-lib/Hledger/Utils/IO.hs

@@ -33,13 +33,17 @@ module Hledger.Utils.IO (
   outputFileOption,
   hasOutputFile,
   splitFlagsAndVals,
-  getLongOpt,
+  getOpt,
   parseYN,
+  parseYNA,
+  YNA(..),
 
   -- * ANSI color
-  colorOption,
   useColorOnStdout,
   useColorOnStderr,
+  colorOption,
+  useColorOnStdoutUnsafe,
+  useColorOnStderrUnsafe,
   -- XXX needed for using color/bgColor/colorB/bgColorB, but clashing with UIUtils:
   -- Color(..),
   -- ColorIntensity(..),
@@ -142,11 +146,12 @@ import Data.Char (toLower)
 
 -- | pretty-simple options with colour enabled if allowed.
 prettyopts =
-  (if useColorOnStderr then defaultOutputOptionsDarkBg else defaultOutputOptionsNoColor)
+  (if useColorOnStderrUnsafe then defaultOutputOptionsDarkBg else defaultOutputOptionsNoColor)
     { outputOptionsIndentAmount = 2
     -- , outputOptionsCompact      = True  -- fills lines, but does not respect page width (https://github.com/cdepillabout/pretty-simple/issues/126)
     -- , outputOptionsPageWidth    = fromMaybe 80 $ unsafePerformIO getTerminalWidth
     }
+-- XXX unsafe detection of color option for debug output, does not respect config file (perhaps evaluated before withArgs ?)
 
 -- | pretty-simple options with colour disabled.
 prettyoptsNoColor =
@@ -155,7 +160,7 @@ prettyoptsNoColor =
     }
 
 -- | Pretty show. An easier alias for pretty-simple's pShow.
--- This will probably show in colour if useColorOnStderr is true.
+-- This will probably show in colour if useColorOnStderrUnsafe is true.
 pshow :: Show a => a -> String
 pshow = TL.unpack . pShowOpt prettyopts
 
@@ -164,9 +169,9 @@ pshow' :: Show a => a -> String
 pshow' = TL.unpack . pShowOpt prettyoptsNoColor
 
 -- | Pretty print a showable value. An easier alias for pretty-simple's pPrint.
--- This will print in colour if useColorOnStderr is true.
+-- This will print in colour if useColorOnStderrUnsafe is true.
 pprint :: Show a => a -> IO ()
-pprint = pPrintOpt (if useColorOnStderr then CheckColorTty else NoCheckColorTty) prettyopts
+pprint = pPrintOpt (if useColorOnStderrUnsafe then CheckColorTty else NoCheckColorTty) prettyopts
 
 -- | Monochrome version of pprint. This will never print in colour.
 pprint' :: Show a => a -> IO ()
@@ -224,7 +229,7 @@ runPager = putStr
 #else
 runPager s = do
   -- disable pager with --pager=no
-  mpager <- getLongOpt "pager"
+  mpager <- getOpt ["pager"]
   let nopager = not $ maybe True parseYN mpager
   -- disable pager when TERM=dumb (for Emacs shell users)
   dumbterm <- (== Just "dumb") <$> lookupEnv "TERM"
@@ -247,24 +252,28 @@ runPager s = do
     s
 #endif
 
--- | Given a list of arguments, split any of the form --flag=val into --flag, val.
+-- | Given a list of arguments, split any of the form --flag=VAL or -fVAL
+-- into separate list items. Multiple valueless short flags joined together is not supported.
 splitFlagsAndVals :: [String] -> [String]
-splitFlagsAndVals =
-  concatMap
-    (\a ->
-      if "--" `isPrefixOf` a && '=' `elem` a
-      then let (x,y) = break (=='=') a in [x, drop 1 y]
-      else [a])
+splitFlagsAndVals = concatMap $
+  \case
+    a@('-':'-':_) | '=' `elem` a -> let (x,y) = break (=='=') a in [x, drop 1 y]
+    a@('-':f:_:_) | not $ f=='-' -> [take 2 a, drop 2 a]
+    a -> [a]
 
--- | Read the value of the rightmost long option of this name from the command line arguments.
+toFlag [c] = ['-',c]
+toFlag s   = '-':'-':s
+
+-- | Given one or more long or short option names, read the rightmost value of this option from the command line arguments.
 -- If the value is missing raise an error.
-getLongOpt :: String -> IO (Maybe String)
-getLongOpt name = do
+getOpt :: [String] -> IO (Maybe String)
+getOpt names = do
   rargs <- reverse . splitFlagsAndVals <$> getArgs
-  let flag = "--"<>name
+  let flags = map toFlag names
   return $
-    case break (==flag) rargs of
-      ([],_)        -> error' $ flag <> " requires a value"
+    case break ((`elem` flags)) rargs of
+      (_,[])        -> Nothing
+      ([],flag:_)   -> 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.
@@ -275,6 +284,17 @@ parseYN s
   | otherwise = error' $ "value should be one of " <> (intercalate ", " ["y","yes","n","no"])
   where l = map toLower s
 
+data YNA = Yes | No | Auto deriving (Eq,Show)
+
+-- | Parse y/yes/always or n/no/never or a/auto to a YNA choice, or with any other value raise an error.
+parseYNA :: String -> YNA
+parseYNA s
+  | l `elem` ["y","yes","always"] = Yes
+  | l `elem` ["n","no","never"]   = No
+  | l `elem` ["a","auto"]         = Auto
+  | otherwise = error' $ "value should be one of " <> (intercalate ", " ["y","yes","n","no","a","auto"])
+  where l = map toLower s
+
 -- Command line arguments
 
 -- | The command line arguments that were used at program startup.
@@ -290,39 +310,25 @@ progArgs = unsafePerformIO getArgs
 --  the enabling of orderdates and assertions checks in journalFinalise
 -- Separate these into unsafe and safe variants and try to use the latter more
 
--- | Read the value of the -o/--output-file command line option provided at program startup,
--- if any, using unsafePerformIO.
-outputFileOption :: Maybe String
-outputFileOption =
-  -- keep synced with output-file flag definition in hledger:CliOptions.
-  let args = progArgs in
-  case dropWhile (not . ("-o" `isPrefixOf`)) args of
-    -- -oARG
-    ('-':'o':v@(_:_)):_ -> Just v
-    -- -o ARG
-    "-o":v:_ -> Just v
-    _ ->
-      case dropWhile (/="--output-file") args of
-        -- --output-file ARG
-        "--output-file":v:_ -> Just v
-        _ ->
-          case take 1 $ filter ("--output-file=" `isPrefixOf`) args of
-            -- --output=file=ARG
-            ['-':'-':'o':'u':'t':'p':'u':'t':'-':'f':'i':'l':'e':'=':v] -> Just v
-            _ -> Nothing
+outputFileOption :: IO (Maybe String)
+outputFileOption = getOpt ["output-file","o"]
 
--- | Check whether the -o/--output-file option has been used at program startup
--- with an argument other than "-", using unsafePerformIO.
-hasOutputFile :: Bool
-hasOutputFile = outputFileOption `notElem` [Nothing, Just "-"]
--- XXX shouldn't we check that stdout is interactive. instead ?
+hasOutputFile :: IO Bool
+hasOutputFile = do
+  mv <- getOpt ["output-file","o"]
+  return $
+    case mv of
+      Nothing  -> False
+      Just "-" -> False
+      _        -> True
 
 -- ANSI colour
-
-ifAnsi f = if useColorOnStdout then f else id
+-- XXX unsafe detection of --color option. At the moment this is always true in ghci,
+-- respects the command line --color if compiled, and ignores the config file.
+ifAnsi f = if useColorOnStdoutUnsafe then f else id
 
 -- | Versions of some of text-ansi's string colors/styles which are more careful
--- to not print junk onscreen. These use our useColorOnStdout.
+-- to not print junk onscreen. These use our useColorOnStdoutUnsafe.
 bold' :: String -> String
 bold'  = ifAnsi bold
 
@@ -380,29 +386,30 @@ brightWhite'  = ifAnsi brightWhite
 rgb' :: Word8 -> Word8 -> Word8 -> String -> String
 rgb' r g b  = ifAnsi (rgb r g b)
 
--- | Read the value of the --color or --colour command line option provided at program startup
--- using unsafePerformIO. If this option was not provided, returns the empty string.
-colorOption :: String
-colorOption =
-  -- similar to debugLevel
-  -- keep synced with color/colour flag definition in hledger:CliOptions
-  let args = progArgs in
-  case dropWhile (/="--color") args of
-    -- --color ARG
-    "--color":v:_ -> v
-    _ ->
-      case take 1 $ filter ("--color=" `isPrefixOf`) args of
-        -- --color=ARG
-        ['-':'-':'c':'o':'l':'o':'r':'=':v] -> v
-        _ ->
-          case dropWhile (/="--colour") args of
-            -- --colour ARG
-            "--colour":v:_ -> v
-            _ ->
-              case take 1 $ filter ("--colour=" `isPrefixOf`) args of
-                -- --colour=ARG
-                ['-':'-':'c':'o':'l':'o':'u':'r':'=':v] -> v
-                _ -> ""
+-- | Get the value of the rightmost --color option from the command line arguments.
+useColorOnStdout :: IO Bool
+useColorOnStdout = do
+  nooutputfile <- not <$> hasOutputFile
+  usecolor <- useColorOnHandle stdout
+  return $ nooutputfile && usecolor
+
+-- traceWith (("USE COLOR ON STDOUT: "<>).show) <$> 
+
+useColorOnStderr :: IO Bool
+useColorOnStderr = useColorOnHandle stderr
+
+-- | Should ANSI color & styling be used with this output handle ?
+useColorOnHandle :: Handle -> IO Bool
+useColorOnHandle h = do
+  no_color       <- isJust <$> lookupEnv "NO_COLOR"
+  supports_color <- hSupportsANSIColor h
+  yna            <- colorOption
+  return $ yna==Yes || (yna==Auto && not no_color && supports_color)
+
+colorOption :: IO YNA
+colorOption = do
+  mcolor <- getOpt ["color","colour"]
+  return $ maybe Auto parseYNA mcolor
 
 -- | Check the IO environment to see if ANSI colour codes should be used on stdout.
 -- This is done using unsafePerformIO so it can be used anywhere, eg in
@@ -415,21 +422,13 @@ colorOption =
 --   and stdout supports ANSI color
 --   and -o/--output-file was not used, or its value is "-"
 -- ).
-useColorOnStdout :: Bool
-useColorOnStdout = not hasOutputFile && useColorOnHandle stdout
+useColorOnStdoutUnsafe :: Bool
+useColorOnStdoutUnsafe = unsafePerformIO useColorOnStdout
 
--- | Like useColorOnStdout, but checks for ANSI color support on stderr,
+-- | Like useColorOnStdoutUnsafe, but checks for ANSI color support on stderr,
 -- and is not affected by -o/--output-file.
-useColorOnStderr :: Bool
-useColorOnStderr = useColorOnHandle stderr
-
-useColorOnHandle :: Handle -> Bool
-useColorOnHandle h = unsafePerformIO $ do
-  no_color       <- isJust <$> lookupEnv "NO_COLOR"
-  supports_color <- hSupportsANSIColor h
-  let coloroption = colorOption
-  return $ coloroption `elem` ["always","yes","y"]
-       || (coloroption `notElem` ["never","no","n"] && not no_color && supports_color)
+useColorOnStderrUnsafe :: Bool
+useColorOnStderrUnsafe = unsafePerformIO useColorOnStderr
 
 -- | Wrap a string in ANSI codes to set and reset foreground colour.
 -- ColorIntensity is @Dull@ or @Vivid@ (ie normal and bold).

hledger-ui/Hledger/UI/Main.hs

@@ -66,7 +66,8 @@ hledgerUiMain = withGhcDebug' $ withProgName "hledger-ui.log" $ do  -- force Hle
   dbg1IO "debugLevel" debugLevel
 
   -- try to encourage user's $PAGER to properly display ANSI (in command line help)
-  when useColorOnStdout setupPager
+  usecolor <- useColorOnStdout
+  when usecolor setupPager
 
   opts@UIOpts{uoCliOpts=copts@CliOpts{inputopts_=iopts,rawopts_=rawopts}} <- getHledgerUIOpts
   -- when (debug_ $ cliopts_ opts) $ printf "%s\n" prognameandversion >> printf "opts: %s\n" (show opts)

hledger-web/Hledger/Web/Main.hs

@@ -50,7 +50,8 @@ hledgerWebMain = withGhcDebug' $ do
   when (ghcDebugMode == GDPauseAtStart) $ ghcDebugPause'
 
   -- try to encourage user's $PAGER to properly display ANSI (in command line help)
-  when useColorOnStdout setupPager
+  usecolor <- useColorOnStdout
+  when usecolor setupPager
 
   wopts@WebOpts{cliopts_=copts@CliOpts{debug_, rawopts_}} <- getHledgerWebOpts
   when (debug_ > 0) $ printf "%s\n" prognameandversion >> printf "opts: %s\n" (show wopts)

hledger-web/Hledger/Web/Test.hs

@@ -126,9 +126,10 @@ hledgerWebTest = do
 
     -- yit "can add transactions" $ do
 
+  usecolor <- useColorOnStdout
   let
     rawopts = [("forecast","")]
-    iopts = rawOptsToInputOpts d $ mkRawOpts rawopts
+    iopts = rawOptsToInputOpts d usecolor $ mkRawOpts rawopts
     f = "fake"  -- need a non-null filename so forecast transactions get index 0
   pj <- readJournal' (T.pack $ unlines  -- PARTIAL: readJournal' should not fail
     ["~ monthly"

hledger.conf

@@ -1,6 +1,14 @@
 # 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
+
+# --pager n
+# this works
+
+# --color n
+# this mostly works, but does not affect
+# 1. debug output
+# 2. the ansi helpers used by check recentassertions
+
 #--debug
+# this doesn't work in config files yet

hledger/Hledger/Cli.hs

@@ -204,7 +204,8 @@ main = withGhcDebug' $ do
   -- give ghc-debug a chance to take control
   when (ghcDebugMode == GDPauseAtStart) $ ghcDebugPause'
   -- try to encourage user's $PAGER to display ANSI when supported
-  when useColorOnStdout setupPager
+  usecolor <- useColorOnStdout
+  when usecolor setupPager
   -- Search PATH for addon commands. Exclude any that match builtin command names.
   addons <- hledgerAddons <&> filter (not . (`elem` builtinCommandNames) . dropExtension)
 
@@ -269,6 +270,7 @@ main = withGhcDebug' $ do
     -- the command line contains a bad flag or wrongly present/missing flag value,
     -- cmdname will be "".
     args = [confcmdarg | not $ null confcmdarg] <> cliargswithcmdfirstwithoutclispecific
+    -- XXX Unknown flag: --depth while parsing these args for command name
     cmdname = stringopt "command" $ cmdargsParse "for command name" (mainmode addons) args
     badcmdprovided = null cmdname && not nocmdprovided
     isaddoncmd     = not (null cmdname) && cmdname `elem` addons

hledger/Hledger/Cli/CliOptions.hs

@@ -493,7 +493,7 @@ showModeUsage =
 
 -- | Add some ANSI decoration to cmdargs' help output.
 highlightHelp
-  | not useColorOnStdout = id
+  | not useColorOnStdoutUnsafe = id   -- XXX unsafe boldening help headings - seems to work, even respecting config file
   | otherwise = unlines . zipWith (curry f) [1..] . lines
   where
     f (n,l)
@@ -606,8 +606,9 @@ rawOptsToCliOpts rawopts = do
               Nothing -> currentDay
               Just d  -> either (const err) fromEFDay $ fixSmartDateStrEither' currentDay (T.pack d)
                 where err = error' $ "Unable to parse date \"" ++ d ++ "\""
-  let iopts = rawOptsToInputOpts day rawopts
-  rspec <- either error' pure $ rawOptsToReportSpec day rawopts  -- PARTIAL:
+  usecolor <- useColorOnStdout
+  let iopts = rawOptsToInputOpts day usecolor rawopts
+  rspec <- either error' pure $ rawOptsToReportSpec day usecolor rawopts  -- PARTIAL:
   mcolumns <- readMay <$> getEnvSafe "COLUMNS"
   mtermwidth <-
 #ifdef mingw32_HOST_OS

hledger/Hledger/Cli/Commands.hs

@@ -163,7 +163,7 @@ _banner_speed = drop 1 [""
 -- picking one that will contrast with the current terminal background colour.
 accent :: String -> String
 accent
-  | not useColorOnStdout          = id
+  | not useColorOnStdoutUnsafe    = id  -- XXX unsafe accenting the title banner - seems to work, even respecting config file
   | terminalIsLight == Just False = brightWhite
   | terminalIsLight == Just True  = brightBlack
   | otherwise                     = id