diff --git a/hledger-lib/Hledger/Data/StringFormat.hs b/hledger-lib/Hledger/Data/StringFormat.hs index 7530d0ac1..834a094ce 100644 --- a/hledger-lib/Hledger/Data/StringFormat.hs +++ b/hledger-lib/Hledger/Data/StringFormat.hs @@ -10,19 +10,22 @@ module Hledger.Data.StringFormat ( , StringFormat(..) , StringFormatComponent(..) , ReportItemField(..) + , overlineWidth + , defaultBalanceLineFormat , tests_StringFormat ) where import Prelude () import "base-compat-batteries" Prelude.Compat -import Numeric +import Numeric (readDec) import Data.Char (isPrint) -import Data.Maybe +import Data.Default (Default(..)) +import Data.Maybe (isJust) -- import qualified Data.Text as T import Text.Megaparsec -import Text.Megaparsec.Char +import Text.Megaparsec.Char (char, digitChar, string) -import Hledger.Utils.Parse +import Hledger.Utils.Parse (SimpleStringParser) import Hledger.Utils.String (formatString) import Hledger.Utils.Test @@ -31,6 +34,7 @@ import Hledger.Utils.Test -- A format is a sequence of components; each is either a literal -- string, or a hledger report item field with specified width and -- justification whose value will be interpolated at render time. +-- This includes an optional width for any overlines. -- -- A component's value may be a multi-line string (or a -- multi-commodity amount), in which case the final string will be @@ -41,9 +45,9 @@ import Hledger.Utils.Test -- mode, which provides a limited StringFormat renderer. -- data StringFormat = - OneLine [StringFormatComponent] -- ^ multi-line values will be rendered on one line, comma-separated - | TopAligned [StringFormatComponent] -- ^ values will be top-aligned (and bottom-padded to the same height) - | BottomAligned [StringFormatComponent] -- ^ values will be bottom-aligned (and top-padded) + OneLine (Maybe Int) [StringFormatComponent] -- ^ multi-line values will be rendered on one line, comma-separated + | TopAligned (Maybe Int) [StringFormatComponent] -- ^ values will be top-aligned (and bottom-padded to the same height) + | BottomAligned (Maybe Int) [StringFormatComponent] -- ^ values will be bottom-aligned (and top-padded) deriving (Show, Eq) data StringFormatComponent = @@ -73,6 +77,21 @@ data ReportItemField = | FieldNo Int -- ^ A report item's nth field. May be unimplemented. deriving (Show, Eq) +instance Default StringFormat where def = defaultBalanceLineFormat + +overlineWidth :: StringFormat -> Maybe Int +overlineWidth (OneLine w _) = w +overlineWidth (TopAligned w _) = w +overlineWidth (BottomAligned w _) = w + +-- | Default line format for balance report: "%20(total) %2(depth_spacer)%-(account)" +defaultBalanceLineFormat :: StringFormat +defaultBalanceLineFormat = BottomAligned (Just 20) [ + FormatField False (Just 20) Nothing TotalField + , FormatLiteral " " + , FormatField True (Just 2) Nothing DepthSpacerField + , FormatField True Nothing Nothing AccountField + ] ---------------------------------------------------------------------- -- renderStringFormat :: StringFormat -> Map String String -> String @@ -93,10 +112,10 @@ stringformatp = do alignspec <- optional (try $ char '%' >> oneOf ("^_,"::String)) let constructor = case alignspec of - Just '^' -> TopAligned - Just '_' -> BottomAligned - Just ',' -> OneLine - _ -> defaultStringFormatStyle + Just '^' -> TopAligned Nothing + Just '_' -> BottomAligned Nothing + Just ',' -> OneLine Nothing + _ -> defaultStringFormatStyle Nothing constructor <$> many componentp componentp :: SimpleStringParser StringFormatComponent @@ -157,23 +176,23 @@ tests_StringFormat = tests "StringFormat" [ ,let s `gives` expected = test s $ parseStringFormat s @?= Right expected in tests "parseStringFormat" [ - "" `gives` (defaultStringFormatStyle []) - , "D" `gives` (defaultStringFormatStyle [FormatLiteral "D"]) - , "%(date)" `gives` (defaultStringFormatStyle [FormatField False Nothing Nothing DescriptionField]) - , "%(total)" `gives` (defaultStringFormatStyle [FormatField False Nothing Nothing TotalField]) + "" `gives` (defaultStringFormatStyle Nothing []) + , "D" `gives` (defaultStringFormatStyle Nothing [FormatLiteral "D"]) + , "%(date)" `gives` (defaultStringFormatStyle Nothing [FormatField False Nothing Nothing DescriptionField]) + , "%(total)" `gives` (defaultStringFormatStyle Nothing [FormatField False Nothing Nothing TotalField]) -- TODO -- , "^%(total)" `gives` (TopAligned [FormatField False Nothing Nothing TotalField]) -- , "_%(total)" `gives` (BottomAligned [FormatField False Nothing Nothing TotalField]) -- , ",%(total)" `gives` (OneLine [FormatField False Nothing Nothing TotalField]) - , "Hello %(date)!" `gives` (defaultStringFormatStyle [FormatLiteral "Hello ", FormatField False Nothing Nothing DescriptionField, FormatLiteral "!"]) - , "%-(date)" `gives` (defaultStringFormatStyle [FormatField True Nothing Nothing DescriptionField]) - , "%20(date)" `gives` (defaultStringFormatStyle [FormatField False (Just 20) Nothing DescriptionField]) - , "%.10(date)" `gives` (defaultStringFormatStyle [FormatField False Nothing (Just 10) DescriptionField]) - , "%20.10(date)" `gives` (defaultStringFormatStyle [FormatField False (Just 20) (Just 10) DescriptionField]) - , "%20(account) %.10(total)" `gives` (defaultStringFormatStyle [FormatField False (Just 20) Nothing AccountField - ,FormatLiteral " " - ,FormatField False Nothing (Just 10) TotalField - ]) + , "Hello %(date)!" `gives` (defaultStringFormatStyle Nothing [FormatLiteral "Hello ", FormatField False Nothing Nothing DescriptionField, FormatLiteral "!"]) + , "%-(date)" `gives` (defaultStringFormatStyle Nothing [FormatField True Nothing Nothing DescriptionField]) + , "%20(date)" `gives` (defaultStringFormatStyle Nothing [FormatField False (Just 20) Nothing DescriptionField]) + , "%.10(date)" `gives` (defaultStringFormatStyle Nothing [FormatField False Nothing (Just 10) DescriptionField]) + , "%20.10(date)" `gives` (defaultStringFormatStyle Nothing [FormatField False (Just 20) (Just 10) DescriptionField]) + , "%20(account) %.10(total)" `gives` (defaultStringFormatStyle Nothing [FormatField False (Just 20) Nothing AccountField + ,FormatLiteral " " + ,FormatField False Nothing (Just 10) TotalField + ]) , test "newline not parsed" $ assertLeft $ parseStringFormat "\n" ] ] diff --git a/hledger-lib/Hledger/Reports/ReportOptions.hs b/hledger-lib/Hledger/Reports/ReportOptions.hs index 37e2a86fe..7428aadf4 100644 --- a/hledger-lib/Hledger/Reports/ReportOptions.hs +++ b/hledger-lib/Hledger/Reports/ReportOptions.hs @@ -13,7 +13,6 @@ module Hledger.Reports.ReportOptions ( BalanceType(..), AccountListMode(..), ValuationType(..), - FormatStr, defreportopts, rawOptsToReportOpts, flat_, @@ -64,8 +63,6 @@ import Hledger.Query import Hledger.Utils -type FormatStr = String - -- | Which "balance" is being shown in a balance report. data BalanceType = PeriodChange -- ^ The change of balance in each period. | CumulativeChange -- ^ The accumulated change across multiple periods. @@ -101,7 +98,7 @@ data ReportOpts = ReportOpts { ,empty_ :: Bool ,no_elide_ :: Bool ,real_ :: Bool - ,format_ :: Maybe FormatStr + ,format_ :: StringFormat ,query_ :: String -- ^ All query arguments space sepeareted -- and quoted if needed (see 'quoteIfNeeded') -- @@ -173,43 +170,49 @@ defreportopts = ReportOpts rawOptsToReportOpts :: RawOpts -> IO ReportOpts rawOptsToReportOpts rawopts = do - d <- getCurrentDay - no_color <- isJust <$> lookupEnv "NO_COLOR" - supports_color <- hSupportsANSIColor stdout - let colorflag = stringopt "color" rawopts - return defreportopts{ - today_ = Just d - ,period_ = periodFromRawOpts d rawopts - ,interval_ = intervalFromRawOpts rawopts - ,statuses_ = statusesFromRawOpts rawopts - ,value_ = valuationTypeFromRawOpts rawopts - ,infer_value_ = boolopt "infer-value" rawopts - ,depth_ = maybeposintopt "depth" rawopts - ,date2_ = boolopt "date2" rawopts - ,empty_ = boolopt "empty" rawopts - ,no_elide_ = boolopt "no-elide" rawopts - ,real_ = boolopt "real" rawopts - ,format_ = maybestringopt "format" rawopts -- XXX move to CliOpts or move validation from Cli.CliOptions to here - ,query_ = unwords . map quoteIfNeeded $ listofstringopt "args" rawopts -- doesn't handle an arg like "" right - ,average_ = boolopt "average" rawopts - ,related_ = boolopt "related" rawopts - ,txn_dates_ = boolopt "txn-dates" rawopts - ,balancetype_ = balancetypeopt rawopts - ,accountlistmode_ = accountlistmodeopt rawopts - ,drop_ = posintopt "drop" rawopts - ,row_total_ = boolopt "row-total" rawopts - ,no_total_ = boolopt "no-total" rawopts - ,sort_amount_ = boolopt "sort-amount" rawopts - ,percent_ = boolopt "percent" rawopts - ,invert_ = boolopt "invert" rawopts - ,pretty_tables_ = boolopt "pretty-tables" rawopts - ,color_ = and [not no_color - ,not $ colorflag `elem` ["never","no"] - ,colorflag `elem` ["always","yes"] || supports_color - ] - ,forecast_ = forecastPeriodFromRawOpts d rawopts - ,transpose_ = boolopt "transpose" rawopts - } + d <- getCurrentDay + no_color <- isJust <$> lookupEnv "NO_COLOR" + supports_color <- hSupportsANSIColor stdout + let colorflag = stringopt "color" rawopts + + format <- case parseStringFormat <$> maybestringopt "format" rawopts of + Nothing -> return defaultBalanceLineFormat + Just (Right x) -> return x + Just (Left err) -> usageError $ "could not parse format option: " ++ err + + return defreportopts{ + today_ = Just d + ,period_ = periodFromRawOpts d rawopts + ,interval_ = intervalFromRawOpts rawopts + ,statuses_ = statusesFromRawOpts rawopts + ,value_ = valuationTypeFromRawOpts rawopts + ,infer_value_ = boolopt "infer-value" rawopts + ,depth_ = maybeposintopt "depth" rawopts + ,date2_ = boolopt "date2" rawopts + ,empty_ = boolopt "empty" rawopts + ,no_elide_ = boolopt "no-elide" rawopts + ,real_ = boolopt "real" rawopts + ,format_ = format + ,query_ = unwords . map quoteIfNeeded $ listofstringopt "args" rawopts -- doesn't handle an arg like "" right + ,average_ = boolopt "average" rawopts + ,related_ = boolopt "related" rawopts + ,txn_dates_ = boolopt "txn-dates" rawopts + ,balancetype_ = balancetypeopt rawopts + ,accountlistmode_ = accountlistmodeopt rawopts + ,drop_ = posintopt "drop" rawopts + ,row_total_ = boolopt "row-total" rawopts + ,no_total_ = boolopt "no-total" rawopts + ,sort_amount_ = boolopt "sort-amount" rawopts + ,percent_ = boolopt "percent" rawopts + ,invert_ = boolopt "invert" rawopts + ,pretty_tables_ = boolopt "pretty-tables" rawopts + ,color_ = and [not no_color + ,not $ colorflag `elem` ["never","no"] + ,colorflag `elem` ["always","yes"] || supports_color + ] + ,forecast_ = forecastPeriodFromRawOpts d rawopts + ,transpose_ = boolopt "transpose" rawopts + } accountlistmodeopt :: RawOpts -> AccountListMode accountlistmodeopt = diff --git a/hledger/Hledger/Cli/CliOptions.hs b/hledger/Hledger/Cli/CliOptions.hs index bc0adca41..999d8b683 100644 --- a/hledger/Hledger/Cli/CliOptions.hs +++ b/hledger/Hledger/Cli/CliOptions.hs @@ -38,10 +38,8 @@ module Hledger.Cli.CliOptions ( getHledgerCliOpts, getHledgerCliOpts', rawOptsToCliOpts, - checkCliOpts, outputFormats, defaultOutputFormat, - defaultBalanceLineFormat, CommandDoc, -- possibly these should move into argsToCliOpts @@ -56,8 +54,6 @@ module Hledger.Cli.CliOptions ( replaceNumericFlags, -- | For register: registerWidthsFromOpts, - -- | For balance: - lineFormatFromOpts, -- * Other utils hledgerAddons, @@ -448,7 +444,7 @@ replaceNumericFlags = map replace -- today's date. Parsing failures will raise an error. -- Also records the terminal width, if supported. rawOptsToCliOpts :: RawOpts -> IO CliOpts -rawOptsToCliOpts rawopts = checkCliOpts <$> do +rawOptsToCliOpts rawopts = do let iopts = rawOptsToInputOpts rawopts ropts <- rawOptsToReportOpts rawopts mcolumns <- readMay <$> getEnvSafe "COLUMNS" @@ -474,16 +470,6 @@ rawOptsToCliOpts rawopts = checkCliOpts <$> do ,available_width_ = availablewidth } --- | Do final validation of processed opts, raising an error if there is trouble. -checkCliOpts :: CliOpts -> CliOpts -checkCliOpts opts = - either usageError (const opts) $ do - -- XXX move to checkReportOpts or move _format to CliOpts - case lineFormatFromOpts $ reportopts_ opts of - Left err -> Left $ "could not parse format option: "++err - Right _ -> Right () - -- XXX check registerWidthsFromOpts opts - -- | A helper for addon commands: this parses options and arguments from -- the current command line using the given hledger-style cmdargs mode, -- and returns a CliOpts. Or, with --help or -h present, it prints @@ -643,22 +629,6 @@ registerWidthsFromOpts CliOpts{width_=Just s} = eof return (totalwidth, descwidth) --- for balance, currently: - --- | Parse the format option if provided, possibly returning an error, --- otherwise get the default value. -lineFormatFromOpts :: ReportOpts -> Either String StringFormat -lineFormatFromOpts = maybe (Right defaultBalanceLineFormat) parseStringFormat . format_ - --- | Default line format for balance report: "%20(total) %2(depth_spacer)%-(account)" -defaultBalanceLineFormat :: StringFormat -defaultBalanceLineFormat = BottomAligned [ - FormatField False (Just 20) Nothing TotalField - , FormatLiteral " " - , FormatField True (Just 2) Nothing DepthSpacerField - , FormatField True Nothing Nothing AccountField - ] - -- Other utils -- | Get the sorted unique canonical names of hledger addon commands diff --git a/hledger/Hledger/Cli/Commands/Balance.hs b/hledger/Hledger/Cli/Commands/Balance.hs index 07541b3aa..5f196079d 100644 --- a/hledger/Hledger/Cli/Commands/Balance.hs +++ b/hledger/Hledger/Cli/Commands/Balance.hs @@ -305,44 +305,41 @@ balancemode = hledgerCommandMode -- | The balance command, prints a balance report. balance :: CliOpts -> Journal -> IO () balance opts@CliOpts{rawopts_=rawopts,reportopts_=ropts@ReportOpts{..}} j = do - d <- getCurrentDay - case lineFormatFromOpts ropts of - Left err -> error' $ unlines [err] -- PARTIAL: - Right _ -> do - let budget = boolopt "budget" rawopts - multiperiod = interval_ /= NoInterval - fmt = outputFormatFromOpts opts + d <- getCurrentDay + let budget = boolopt "budget" rawopts + multiperiod = interval_ /= NoInterval + fmt = outputFormatFromOpts opts - if budget then do -- single or multi period budget report - reportspan <- reportSpan j ropts - let budgetreport = dbg4 "budgetreport" $ budgetReport ropts assrt reportspan d j - where - assrt = not $ ignore_assertions_ $ inputopts_ opts + if budget then do -- single or multi period budget report + reportspan <- reportSpan j ropts + let budgetreport = dbg4 "budgetreport" $ budgetReport ropts assrt reportspan d j + where + assrt = not $ ignore_assertions_ $ inputopts_ opts + render = case fmt of + "txt" -> budgetReportAsText ropts + "json" -> (++"\n") . TL.unpack . toJsonText + _ -> const $ error' $ unsupportedOutputFormatError fmt + writeOutput opts $ render budgetreport + + else + if multiperiod then do -- multi period balance report + let report = multiBalanceReport d ropts j render = case fmt of - "txt" -> budgetReportAsText ropts + "txt" -> multiBalanceReportAsText ropts + "csv" -> (++"\n") . printCSV . multiBalanceReportAsCsv ropts + "html" -> (++"\n") . TL.unpack . L.renderText . multiBalanceReportAsHtml ropts "json" -> (++"\n") . TL.unpack . toJsonText - _ -> const $ error' $ unsupportedOutputFormatError fmt - writeOutput opts $ render budgetreport + _ -> const $ error' $ unsupportedOutputFormatError fmt -- PARTIAL: + writeOutput opts $ render report - else - if multiperiod then do -- multi period balance report - let report = multiBalanceReport d ropts j - render = case fmt of - "txt" -> multiBalanceReportAsText ropts - "csv" -> (++"\n") . printCSV . multiBalanceReportAsCsv ropts - "html" -> (++"\n") . TL.unpack . L.renderText . multiBalanceReportAsHtml ropts - "json" -> (++"\n") . TL.unpack . toJsonText - _ -> const $ error' $ unsupportedOutputFormatError fmt - writeOutput opts $ render report - - else do -- single period simple balance report - let report = balanceReport ropts (queryFromOpts d ropts) j -- simple Ledger-style balance report - render = case fmt of - "txt" -> balanceReportAsText - "csv" -> \ropts r -> (++ "\n") $ printCSV $ balanceReportAsCsv ropts r - "json" -> const $ (++"\n") . TL.unpack . toJsonText - _ -> const $ error' $ unsupportedOutputFormatError fmt - writeOutput opts $ render ropts report + else do -- single period simple balance report + let report = balanceReport ropts (queryFromOpts d ropts) j -- simple Ledger-style balance report + render = case fmt of + "txt" -> balanceReportAsText + "csv" -> \ropts r -> (++ "\n") $ printCSV $ balanceReportAsCsv ropts r + "json" -> const $ (++"\n") . TL.unpack . toJsonText + _ -> const $ error' $ unsupportedOutputFormatError fmt -- PARTIAL: + writeOutput opts $ render ropts report -- rendering single-column balance reports @@ -358,28 +355,17 @@ balanceReportAsCsv opts (items, total) = -- | Render a single-column balance report as plain text. balanceReportAsText :: ReportOpts -> BalanceReport -> String -balanceReportAsText opts ((items, total)) = unlines $ concat lines ++ t +balanceReportAsText opts ((items, total)) = unlines $ + concat lines ++ if no_total_ opts then [] else overline : totallines where - fmt = lineFormatFromOpts opts - lines = case fmt of - Right fmt -> map (balanceReportItemAsText opts fmt) items - Left err -> [[err]] - t = if no_total_ opts - then [] - else - case fmt of - Right fmt -> - let - -- abuse renderBalanceReportItem to render the total with similar format - acctcolwidth = maximum' [T.length fullname | (fullname, _, _, _) <- items] - 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 - | otherwise = defaultTotalFieldWidth - overline = replicate overlinewidth '-' - in overline : totallines - Left _ -> [] + lines = map (balanceReportItemAsText opts) items + -- abuse renderBalanceReportItem to render the total with similar format + acctcolwidth = maximum' [T.length fullname | (fullname, _, _, _) <- items] + totallines = map rstrip $ renderBalanceReportItem opts (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 = fromMaybe (maximum' . map length $ concat lines) . overlineWidth $ format_ opts + overline = replicate overlinewidth '-' {- :r @@ -396,28 +382,25 @@ This implementation turned out to be a bit convoluted but implements the followi -- whatever string format is specified). Note, prices will not be rendered, and -- differently-priced quantities of the same commodity will appear merged. -- 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 opts fmt ( +balanceReportItemAsText :: ReportOpts -> BalanceReportItem -> [String] +balanceReportItemAsText opts (_, accountName, depth, amt) = + renderBalanceReportItem opts ( accountName, depth, normaliseMixedAmountSquashPricesForDisplay amt ) -- | Render a balance report item using the given StringFormat, generating one or more lines of text. -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 +renderBalanceReportItem :: ReportOpts -> (AccountName, Int, MixedAmount) -> [String] +renderBalanceReportItem opts (acctname, depth, total) = + lines $ case format_ opts of + OneLine _ comps -> concatOneLine $ render1 comps + TopAligned _ comps -> concatBottomPadded $ render comps + BottomAligned _ comps -> concatTopPadded $ render comps where 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 :: ReportOpts -> (AccountName, Int, MixedAmount) -> StringFormatComponent -> String renderComponent _ _ (FormatLiteral s) = s