slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

lib,cli: Store StringFormat in ReportOpts, rather than unparsed String.

Browse Source 
StringFormat now also takes an optional overline width, which is
currently only used by defaultBalanceLineFormat.
This commit is contained in:
Stephen Morgan 2020-09-02 12:27:46 +10:00 committed by Simon Michael
parent f76cdc4317
commit 103308e795
4 changed files with 138 additions and 163 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
hledger-lib/Hledger/Data/StringFormat.hs
View File

@ -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"
]
]

85
hledger-lib/Hledger/Reports/ReportOptions.hs
View File

@ -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 =

32
hledger/Hledger/Cli/CliOptions.hs
View File

@ -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

117
hledger/Hledger/Cli/Commands/Balance.hs
View File

@ -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