feat: register: Implement --drop flag mirroring functionality

This implements the same --drop functionality as balance command for
register subcommand, allowing users to trim leading account name
components from register output.

Author: alerque

hledger/Hledger/Cli/Commands/Register.hs

@@ -26,6 +26,7 @@ import Data.Text qualified as T
 import Data.Text.Lazy qualified as TL
 import Data.Text.Lazy.IO qualified as TL
 import Data.Text.Lazy.Builder qualified as TB
+import Safe (readMay)
 import System.Console.CmdArgs.Explicit (flagNone, flagReq)
 
 import Hledger hiding (per)
@@ -36,6 +37,8 @@ import Hledger.Write.Spreadsheet qualified as Spr
 import Hledger.Cli.CliOptions
 import Hledger.Cli.Utils
 import Hledger.Cli.Anchor (setAccountAnchor, dateCell)
+import Hledger.Data (accountNameDrop)
+import Hledger.Data.AccountName (clipAccountName)
 import Text.Tabular.AsciiWide (Cell(..), Align(..), Properties(..), Header(Header, Group), renderRowB, textCell, tableBorders, borderSpaces)
 import Lucid qualified
 import Data.List (sortBy)
@@ -56,6 +59,7 @@ registermode = hledgerCommandMode
     ("fuzzy search for one recent posting with description closest to "++arg)
   ,flagNone ["related","r"] (setboolopt "related") "show postings' siblings instead"
   ,flagNone ["invert"] (setboolopt "invert") "display all amounts with reversed sign"
+  ,flagReq  ["drop"] (\s opts -> Right $ setopt "drop" s opts) "N" "omit N leading account name parts"
   ,flagReq  ["sort"] (\s opts -> Right $ setopt "sort" s opts) "FIELDS" 
     ("sort by: " <> sortKeysDescription
     <> ", or a comma-separated combination of these. For a descending sort, prefix with -. (Default: date)")
@@ -101,46 +105,46 @@ register opts@CliOpts{rawopts_=rawopts, reportspec_=rspec} j
     rpt = postingsReport rspec j
     render | fmt=="txt"  = postingsReportAsText opts
            | fmt=="json" = toJsonText
-           | fmt=="csv"  = printCSV . postingsReportAsCsv
-           | fmt=="tsv"  = printTSV . postingsReportAsCsv
+           | fmt=="csv"  = printCSV . postingsReportAsCsv opts
+           | fmt=="tsv"  = printTSV . postingsReportAsCsv opts
            | fmt=="html" =
                 (<>"\n") . Lucid.renderText . styledTableHtml .
                 map (map (fmap Lucid.toHtml)) .
-                postingsReportAsSpreadsheet oneLineNoCostFmt baseUrl query
+                postingsReportAsSpreadsheet opts oneLineNoCostFmt baseUrl query
            | fmt=="fods" =
                 printFods IO.localeEncoding . Map.singleton "Register" .
                 (,) (1,0) .
-                postingsReportAsSpreadsheet oneLineNoCostFmt baseUrl query
+                postingsReportAsSpreadsheet opts oneLineNoCostFmt baseUrl query
            | otherwise   = error' $ unsupportedOutputFormatError fmt  -- PARTIAL:
       where fmt = outputFormatFromOpts opts
             baseUrl = balance_base_url_ $ _rsReportOpts rspec
             query = querystring_ $ _rsReportOpts rspec
 
-postingsReportAsCsv :: PostingsReport -> CSV
-postingsReportAsCsv =
-  Spr.rawTableContent . postingsReportAsSpreadsheet machineFmt Nothing []
+postingsReportAsCsv :: CliOpts -> PostingsReport -> CSV
+postingsReportAsCsv opts =
+  Spr.rawTableContent . postingsReportAsSpreadsheet opts machineFmt Nothing []
 
 -- ToDo: --layout=bare etc.
 -- ToDo: Text output does not show headers, but Spreadsheet does
 postingsReportAsSpreadsheet ::
-  AmountFormat -> Maybe Text -> [Text] ->
+  CliOpts -> AmountFormat -> Maybe Text -> [Text] ->
   PostingsReport -> [[Spr.Cell Spr.NumLines Text]]
-postingsReportAsSpreadsheet fmt baseUrl query is =
+postingsReportAsSpreadsheet opts fmt baseUrl query is =
   Spr.addHeaderBorders
     (map Spr.headerCell
       ["txnidx","date","code","description","account","amount","total"])
   :
-  map (postingsReportItemAsRecord fmt baseUrl query) is
+  map (postingsReportItemAsRecord opts fmt baseUrl query) is
 
 {- ToDo:
 link txnidx to journal URL,
    however, requires Web.Widget.Common.transactionFragment
 -}
 postingsReportItemAsRecord ::
     (Spr.Lines border) =>
-    AmountFormat -> Maybe Text -> [Text] ->
+    CliOpts -> AmountFormat -> Maybe Text -> [Text] ->
     PostingsReportItem -> [Spr.Cell border Text]
-postingsReportItemAsRecord fmt baseUrl query (_, _, _, p, b) =
+postingsReportItemAsRecord opts@CliOpts{reportspec_=rspec} fmt baseUrl query (_, _, _, p, b) =
     [idx,
      (dateCell baseUrl query (paccount p) date) {Spr.cellType = Spr.TypeDate},
      cell code, cell desc,
@@ -153,8 +157,10 @@ postingsReportItemAsRecord fmt baseUrl query (_, _, _, p, b) =
     date = postingDate p -- XXX csv should show date2 with --date2
     code = maybe "" tcode $ ptransaction p
     desc = maybe "" tdescription $ ptransaction p
-    acct = bracket $ paccount p
+    acct = bracket . accountNameDrop dropNum . clipAccountName depthSpec $ paccount p
       where
+        depthSpec = depth_ $ _rsReportOpts rspec
+        dropNum = fromMaybe 0 $ readMay =<< maybestringopt "drop" (rawopts_ opts)
         bracket = case ptype p of
                              BalancedVirtualPosting -> wrap "[" "]"
                              VirtualPosting -> wrap "(" ")"
@@ -199,7 +205,7 @@ postingsReportAsText opts = TB.toLazyText .
 postingsReportItemAsText :: CliOpts -> Int -> Int
                          -> (PostingsReportItem, [WideBuilder], [WideBuilder])
                          -> TB.Builder
-postingsReportItemAsText opts preferredamtwidth preferredbalwidth ((mdate, mperiod, mdesc, p, _), amt, bal) =
+postingsReportItemAsText opts@CliOpts{reportspec_=rspec} preferredamtwidth preferredbalwidth ((mdate, mperiod, mdesc, p, _), amt, bal) =
     table <> TB.singleton '\n'
   where
     table = renderRowB def{tableBorders=False, borderSpaces=False} . Group NoLine $ map Header
@@ -243,8 +249,10 @@ postingsReportItemAsText opts preferredamtwidth preferredbalwidth ((mdate, mperi
 
     -- gather content
     desc = fromMaybe "" mdesc
-    acct = parenthesise . elideAccountName awidth $ paccount p
+    acct = parenthesise . elideAccountName awidth . dropAcct . clipAcct $ paccount p
       where
+        clipAcct = clipAccountName (depth_ $ _rsReportOpts rspec)
+        dropAcct = accountNameDrop (fromMaybe 0 $ readMay =<< maybestringopt "drop" (rawopts_ opts))
         (parenthesise, awidth) = case ptype p of
             BalancedVirtualPosting -> (wrap "[" "]", acctwidth-2)
             VirtualPosting         -> (wrap "(" ")", acctwidth-2)

hledger/test/register/depth.test

@@ -70,3 +70,22 @@ $ hledger -f - register --depth 0 --daily a b
 2010-01-01   ...                                                 6             6
 2010-01-02   ...                                                 3             9
 
+# ** 6. --drop removes leading account name segments
+<
+2010/1/1 x
+  assets:bank:checking      1
+  expenses:food:groceries  -1
+
+$ hledger -f - register --drop 1
+2010-01-01 x                    bank:checking                    1             1
+                                food:groceries                  -1             0
+
+# ** 7. --drop and --depth together: depth clips first, then drop removes leading segments
+<
+2010/1/1 x
+  assets:bank:checking:savings      1
+  expenses:food:groceries:organic  -1
+
+$ hledger -f - register --drop 1 --depth 2
+2010-01-01 x                    bank                             1             1
+                                food                            -1             0