diff --git a/hledger-lib/Hledger/Data/RawOptions.hs b/hledger-lib/Hledger/Data/RawOptions.hs index 48ad9996d..17b52058e 100644 --- a/hledger-lib/Hledger/Data/RawOptions.hs +++ b/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 diff --git a/hledger-lib/Hledger/Read/Common.hs b/hledger-lib/Hledger/Read/Common.hs index 2029cf952..1b3f84c6d 100644 --- a/hledger-lib/Hledger/Read/Common.hs +++ b/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 diff --git a/hledger-lib/Hledger/Reports/ReportOptions.hs b/hledger-lib/Hledger/Reports/ReportOptions.hs index fe51344bb..ec3f9efab 100644 --- a/hledger-lib/Hledger/Reports/ReportOptions.hs +++ b/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 diff --git a/hledger-lib/Hledger/Utils/IO.hs b/hledger-lib/Hledger/Utils/IO.hs index 2d15df096..007a1299e 100644 --- a/hledger-lib/Hledger/Utils/IO.hs +++ b/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). diff --git a/hledger-ui/Hledger/UI/Main.hs b/hledger-ui/Hledger/UI/Main.hs index 1fbab2035..aec912c42 100644 --- a/hledger-ui/Hledger/UI/Main.hs +++ b/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) diff --git a/hledger-web/Hledger/Web/Main.hs b/hledger-web/Hledger/Web/Main.hs index 97f4a0f63..bc887bce7 100644 --- a/hledger-web/Hledger/Web/Main.hs +++ b/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) diff --git a/hledger-web/Hledger/Web/Test.hs b/hledger-web/Hledger/Web/Test.hs index 36acfacd6..a141da0bb 100644 --- a/hledger-web/Hledger/Web/Test.hs +++ b/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" diff --git a/hledger.conf b/hledger.conf index ca4385c13..d6afe111d 100644 --- a/hledger.conf +++ b/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 -# --debug + +# --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 diff --git a/hledger/Hledger/Cli.hs b/hledger/Hledger/Cli.hs index 0cbc44272..77ac7ccac 100644 --- a/hledger/Hledger/Cli.hs +++ b/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 diff --git a/hledger/Hledger/Cli/CliOptions.hs b/hledger/Hledger/Cli/CliOptions.hs index a72f73005..d55a9d0c1 100644 --- a/hledger/Hledger/Cli/CliOptions.hs +++ b/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 diff --git a/hledger/Hledger/Cli/Commands.hs b/hledger/Hledger/Cli/Commands.hs index 377f80c58..56295085a 100644 --- a/hledger/Hledger/Cli/Commands.hs +++ b/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