bal: show negative amounts in red

The balance command now shows negative amounts in red, when it thinks
ANSI codes are supported, ie when TERM is not "dumb" and stdout is not
being redirected or piped somewhere.

hledger-lib/Hledger/Data/Amount.hs

@@ -61,6 +61,7 @@ module Hledger.Data.Amount (
   -- ** rendering
   amountstyle,
   showAmount,
+  cshowAmount,
   showAmountWithZeroCommodity,
   showAmountDebug,
   showAmountWithoutPrice,
@@ -95,6 +96,8 @@ module Hledger.Data.Amount (
   showMixedAmountDebug,
   showMixedAmountWithoutPrice,
   showMixedAmountOneLineWithoutPrice,
+  cshowMixedAmountWithoutPrice,
+  cshowMixedAmountOneLineWithoutPrice,
   showMixedAmountWithZeroCommodity,
   showMixedAmountWithPrecision,
   setMixedAmountPrecision,
@@ -239,6 +242,10 @@ showAmountDebug Amount{..} = printf "Amount {acommodity=%s, aquantity=%s, aprice
 showAmountWithoutPrice :: Amount -> String
 showAmountWithoutPrice a = showAmount a{aprice=NoPrice}
 
+-- | Colour version.
+cshowAmountWithoutPrice :: Amount -> String
+cshowAmountWithoutPrice a = cshowAmount a{aprice=NoPrice}
+
 -- | Get the string representation of an amount, without any price or commodity symbol.
 showAmountWithoutPriceOrCommodity :: Amount -> String
 showAmountWithoutPriceOrCommodity a = showAmount a{acommodity="", aprice=NoPrice}
@@ -260,6 +267,13 @@ showPriceDebug (TotalPrice pa) = " @@ " ++ showAmountDebug pa
 showAmount :: Amount -> String
 showAmount = showAmountHelper False
 
+-- | Colour version. For a negative amount, adds ANSI codes to change the colour, 
+-- currently to hard-coded red.
+cshowAmount :: Amount -> String
+cshowAmount a =
+  (if isNegativeAmount a then color Dull Red else id) $
+  showAmountHelper False a
+
 showAmountHelper :: Bool -> Amount -> String
 showAmountHelper _ Amount{acommodity="AUTO"} = ""
 showAmountHelper showzerocommodity a@(Amount{acommodity=c, aprice=p, astyle=AmountStyle{..}}) =
@@ -559,6 +573,17 @@ showMixedAmountWithoutPrice m = concat $ intersperse "\n" $ map showfixedwidth a
       width = maximum $ map (length . showAmount) as
       showfixedwidth = printf (printf "%%%ds" width) . showAmountWithoutPrice
 
+-- | Colour version.
+cshowMixedAmountWithoutPrice :: MixedAmount -> String
+cshowMixedAmountWithoutPrice m = concat $ intersperse "\n" $ map showamt as
+    where
+      (Mixed as) = normaliseMixedAmountSquashPricesForDisplay $ stripPrices m
+      stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{aprice=NoPrice}
+      width = maximum $ map (length . showAmount) as
+      showamt a = 
+        (if isNegativeAmount a then color Dull Red else id) $
+        printf (printf "%%%ds" width) $ showAmountWithoutPrice a
+
 -- | Get the one-line string representation of a mixed amount, but without
 -- any \@ prices.
 showMixedAmountOneLineWithoutPrice :: MixedAmount -> String
@@ -567,6 +592,13 @@ showMixedAmountOneLineWithoutPrice m = concat $ intersperse ", " $ map showAmoun
       (Mixed as) = normaliseMixedAmountSquashPricesForDisplay $ stripPrices m
       stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{aprice=NoPrice}
 
+-- | Colour version.
+cshowMixedAmountOneLineWithoutPrice :: MixedAmount -> String
+cshowMixedAmountOneLineWithoutPrice m = concat $ intersperse ", " $ map cshowAmountWithoutPrice as
+    where
+      (Mixed as) = normaliseMixedAmountSquashPricesForDisplay $ stripPrices m
+      stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{aprice=NoPrice}
+
 -- | Canonicalise a mixed amount's display styles using the provided commodity style map.
 canonicaliseMixedAmount :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount
 canonicaliseMixedAmount styles (Mixed as) = Mixed $ map (canonicaliseAmount styles) as

hledger-lib/Hledger/Reports/ReportOptions.hs

@@ -40,6 +40,8 @@ import Data.Typeable (Typeable)
 import Data.Time.Calendar
 import Data.Default
 import Safe
+import System.Console.ANSI (hSupportsANSI)
+import System.IO (stdout)
 import Test.HUnit
 import Text.Megaparsec.Error
 
@@ -92,6 +94,7 @@ data ReportOpts = ReportOpts {
     ,no_total_       :: Bool
     ,value_          :: Bool
     ,pretty_tables_  :: Bool
+    ,color_          :: Bool
  } deriving (Show, Data, Typeable)
 
 instance Default ReportOpts where def = defreportopts
@@ -120,11 +123,13 @@ defreportopts = ReportOpts
     def
     def
     def
+    def
 
 rawOptsToReportOpts :: RawOpts -> IO ReportOpts
 rawOptsToReportOpts rawopts = checkReportOpts <$> do
-  d <- getCurrentDay
   let rawopts' = checkRawOpts rawopts
+  d <- getCurrentDay
+  color <- hSupportsANSI stdout
   return defreportopts{
      period_      = periodFromRawOpts d rawopts'
     ,interval_    = intervalFromRawOpts rawopts'
@@ -147,6 +152,7 @@ rawOptsToReportOpts rawopts = checkReportOpts <$> do
     ,no_total_    = boolopt "no-total" rawopts'
     ,value_       = boolopt "value" rawopts'
     ,pretty_tables_ = boolopt "pretty-tables" rawopts'
+    ,color_       = color
     }
 
 -- | Do extra validation of raw option values, raising an error if there's a problem.

hledger/Hledger/Cli/Balance.hs

@@ -358,7 +358,7 @@ balanceReportAsText opts ((items, total)) = unlines $ concat lines ++ t
                 let
                   -- abuse renderBalanceReportItem to render the total with similar format
                   acctcolwidth = maximum' [T.length fullname | (fullname, _, _, _) <- items]
-                  totallines = map rstrip $ renderBalanceReportItem fmt (T.replicate (acctcolwidth+1) " ", 0, total)
+                  totallines = map rstrip $ renderBalanceReportItem opts fmt (T.replicate (acctcolwidth+1) " ", 0, total)
                   -- with a custom format, extend the line to the full report width;
                   -- otherwise show the usual 20-char line for compatibility
                   overlinewidth | isJust (format_ opts) = maximum' $ map length $ concat lines
@@ -399,52 +399,69 @@ This implementation turned out to be a bit convoluted but implements the followi
 -- The output will be one or more lines depending on the format and number of commodities.
 balanceReportItemAsText :: ReportOpts -> StringFormat -> BalanceReportItem -> [String]
 balanceReportItemAsText opts fmt (_, accountName, depth, amt) =
-  renderBalanceReportItem fmt (
+  renderBalanceReportItem opts fmt (
     maybeAccountNameDrop opts accountName,
     depth,
     normaliseMixedAmountSquashPricesForDisplay amt
     )
 
 -- | Render a balance report item using the given StringFormat, generating one or more lines of text.
-renderBalanceReportItem :: StringFormat -> (AccountName, Int, MixedAmount) -> [String]
-renderBalanceReportItem fmt (acctname, depth, total) =
+renderBalanceReportItem :: ReportOpts -> StringFormat -> (AccountName, Int, MixedAmount) -> [String]
+renderBalanceReportItem opts fmt (acctname, depth, total) =
   lines $
   case fmt of
     OneLine comps       -> concatOneLine      $ render1 comps
     TopAligned comps    -> concatBottomPadded $ render comps
     BottomAligned comps -> concatTopPadded    $ render comps
   where
-    render1 = map (renderComponent1 (acctname, depth, total))
-    render  = map (renderComponent (acctname, depth, total))
+    render1 = map (renderComponent1 opts (acctname, depth, total))
+    render  = map (renderComponent opts (acctname, depth, total))
 
 defaultTotalFieldWidth = 20
 
 -- | Render one StringFormat component for a balance report item.
-renderComponent :: (AccountName, Int, MixedAmount) -> StringFormatComponent -> String
-renderComponent _ (FormatLiteral s) = s
-renderComponent (acctname, depth, total) (FormatField ljust min max field) = case field of
+renderComponent :: ReportOpts -> (AccountName, Int, MixedAmount) -> StringFormatComponent -> String
+renderComponent _ _ (FormatLiteral s) = s
+renderComponent opts (acctname, depth, total) (FormatField ljust min max field) = case field of
   DepthSpacerField -> formatString ljust Nothing max $ replicate d ' '
                       where d = case min of
                                  Just m  -> depth * m
                                  Nothing -> depth
   AccountField     -> formatString ljust min max (T.unpack acctname)
-  TotalField       -> fitStringMulti min max True False $ showMixedAmountWithoutPrice total
+  TotalField       ->
+    -- TODO: does not color multicommodity amounts
+--    setamtcolor $ fitStringMulti min max True False $ showMixedAmountWithoutPrice total
+    fitStringMulti min max True False $ showamt total
   _                -> ""
+  where
+    showamt | color_ opts = cshowMixedAmountWithoutPrice
+            | otherwise   = showMixedAmountWithoutPrice
+--    setamtcolor
+--      | color_ opts && isNegativeMixedAmount total == Just True = color Dull Red
+--      | otherwise = id
 
 -- | Render one StringFormat component for a balance report item.
 -- This variant is for use with OneLine string formats; it squashes
 -- any multi-line rendered values onto one line, comma-and-space separated,
 -- while still complying with the width spec.
-renderComponent1 :: (AccountName, Int, MixedAmount) -> StringFormatComponent -> String
-renderComponent1 _ (FormatLiteral s) = s
-renderComponent1 (acctname, depth, total) (FormatField ljust min max field) = case field of
+renderComponent1 :: ReportOpts -> (AccountName, Int, MixedAmount) -> StringFormatComponent -> String
+renderComponent1 _ _ (FormatLiteral s) = s
+renderComponent1 opts (acctname, depth, total) (FormatField ljust min max field) = case field of
   AccountField     -> formatString ljust min max ((intercalate ", " . lines) (indented (T.unpack acctname)))
                       where
                         -- better to indent the account name here rather than use a DepthField component
                         -- so that it complies with width spec. Uses a fixed indent step size.
                         indented = ((replicate (depth*2) ' ')++)
-  TotalField       -> fitStringMulti min max True False $ ((intercalate ", " . map strip . lines) (showMixedAmountWithoutPrice total))
+  TotalField       -> 
+--    setamtcolor $ fitStringMulti min max True False $ ((intercalate ", " . map strip . lines) (showMixedAmountWithoutPrice total))
+    fitStringMulti min max True False $ ((intercalate ", " . map strip . lines) (showamt total))
   _                -> ""
+  where
+    showamt | color_ opts = cshowMixedAmountWithoutPrice
+            | otherwise   = showMixedAmountWithoutPrice 
+--    setamtcolor
+--      | color_ opts && isNegativeMixedAmount total == Just True = color Dull Red
+--      | otherwise = id
 
 -- multi-column balance reports
 
@@ -489,8 +506,8 @@ multiBalanceReportAsText opts r =
 -- made using 'balanceReportAsTable'), render it in a format suitable for
 -- console output.
 renderBalanceReportTable :: ReportOpts -> Table String String MixedAmount -> String
-renderBalanceReportTable (ReportOpts { pretty_tables_ = pretty }) = unlines . trimborder . lines
-                         . render pretty id (" " ++) showMixedAmountOneLineWithoutPrice
+renderBalanceReportTable (ReportOpts { pretty_tables_ = pretty, color_=usecolor }) = unlines . trimborder . lines
+                         . render pretty id (" " ++) showamt
                          . align
   where
     trimborder = ("":) . (++[""]) . drop 1 . init . map (drop 1 . init)
@@ -498,6 +515,8 @@ renderBalanceReportTable (ReportOpts { pretty_tables_ = pretty }) = unlines . tr
       where
         acctswidth = maximum' $ map strWidth (headerContents l)
         l'         = padRightWide acctswidth <$> l
+    showamt | usecolor  = cshowMixedAmountOneLineWithoutPrice
+            | otherwise = showMixedAmountOneLineWithoutPrice
 
 -- | Build a 'Table' from a multi-column balance report.
 balanceReportAsTable :: ReportOpts -> MultiBalanceReport -> Table String String MixedAmount

hledger/hledger.cabal

@@ -84,6 +84,7 @@ library
   build-depends:
       base >=4.8 && <5
     , base-compat >=0.8.1
+    , ansi-terminal >= 0.6.2.3 && < 0.7
     , directory
     , file-embed >=0.0.10 && <0.1
     , filepath
@@ -169,6 +170,7 @@ executable hledger
   build-depends:
       base >=4.8 && <5
     , base-compat >=0.8.1
+    , ansi-terminal >= 0.6.2.3 && < 0.7
     , directory
     , file-embed >=0.0.10 && <0.1
     , filepath
@@ -231,6 +233,7 @@ test-suite test
   build-depends:
       base >=4.8 && <5
     , base-compat >=0.8.1
+    , ansi-terminal >= 0.6.2.3 && < 0.7
     , directory
     , file-embed >=0.0.10 && <0.1
     , filepath
@@ -292,6 +295,7 @@ benchmark bench
   build-depends:
       base >=4.8 && <5
     , base-compat >=0.8.1
+    , ansi-terminal >= 0.6.2.3 && < 0.7
     , directory
     , file-embed >=0.0.10 && <0.1
     , filepath

hledger/package.yaml

@@ -65,6 +65,7 @@ flags:
 dependencies:
 - base >=4.8 && <5
 - base-compat >=0.8.1
+- ansi-terminal >= 0.6.2.3 && < 0.7
 - directory
 - file-embed >=0.0.10 && <0.1
 - filepath