From 646ee0bce5f146c800a860cfca83fe00a6dce982 Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Tue, 27 Oct 2020 13:04:00 +1100 Subject: [PATCH] cli: Using Text Builder for posting reports. --- hledger-lib/Hledger/Data/Json.hs | 4 +- hledger-lib/Hledger/Reports/PostingsReport.hs | 27 +++--- hledger/Hledger/Cli/Commands/Add.hs | 8 +- hledger/Hledger/Cli/Commands/Register.hs | 83 ++++++++++--------- hledger/Hledger/Cli/Commands/Registermatch.hs | 8 +- hledger/Hledger/Cli/Utils.hs | 11 +++ 6 files changed, 74 insertions(+), 67 deletions(-) diff --git a/hledger-lib/Hledger/Data/Json.hs b/hledger-lib/Hledger/Data/Json.hs index 82e392098..b509ad06a 100644 --- a/hledger-lib/Hledger/Data/Json.hs +++ b/hledger-lib/Hledger/Data/Json.hs @@ -44,7 +44,7 @@ import Data.Decimal import Data.Maybe import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO as TL -import Data.Text.Lazy.Builder (toLazyText) +import qualified Data.Text.Lazy.Builder as TB import GHC.Generics (Generic) import System.Time (ClockTime) @@ -232,7 +232,7 @@ instance FromJSON (DecimalRaw Integer) -- | Show a JSON-convertible haskell value as pretty-printed JSON text. toJsonText :: ToJSON a => a -> TL.Text -toJsonText = (<>"\n") . toLazyText . encodePrettyToTextBuilder +toJsonText = TB.toLazyText . (<> TB.fromText "\n") . encodePrettyToTextBuilder -- | Write a JSON-convertible haskell value to a pretty-printed JSON file. -- Eg: writeJsonFile "a.json" nulltransaction diff --git a/hledger-lib/Hledger/Reports/PostingsReport.hs b/hledger-lib/Hledger/Reports/PostingsReport.hs index eac60c3d5..b85f54528 100644 --- a/hledger-lib/Hledger/Reports/PostingsReport.hs +++ b/hledger-lib/Hledger/Reports/PostingsReport.hs @@ -24,8 +24,7 @@ where import Data.List import Data.List.Extra (nubSort) import Data.Maybe --- import Data.Text (Text) -import qualified Data.Text as T +import Data.Text (Text) import Data.Time.Calendar import Safe (headMay, lastMay) @@ -38,9 +37,7 @@ import Hledger.Reports.ReportOptions -- | A postings report is a list of postings with a running total, a label -- for the total field, and a little extra transaction info to help with rendering. -- This is used eg for the register command. -type PostingsReport = (String -- label for the running balance column XXX remove - ,[PostingsReportItem] -- line items, one per posting - ) +type PostingsReport = [PostingsReportItem] -- line items, one per posting type PostingsReportItem = (Maybe Day -- The posting date, if this is the first posting in a -- transaction or if it's different from the previous -- posting's date. Or if this a summary posting, the @@ -49,7 +46,7 @@ type PostingsReportItem = (Maybe Day -- The posting date, if this is the firs ,Maybe Day -- If this is a summary posting, the report interval's -- end date if this is the first summary posting in -- the interval. - ,Maybe String -- The posting's transaction's description, if this is the first posting in the transaction. + ,Maybe Text -- The posting's transaction's description, if this is the first posting in the transaction. ,Posting -- The posting, possibly with the account name depth-clipped. ,MixedAmount -- The running total after this posting, or with --average, -- the running average posting amount. With --historical, @@ -66,8 +63,7 @@ type SummaryPosting = (Posting, Day) -- | Select postings from the journal and add running balance and other -- information to make a postings report. Used by eg hledger's register command. postingsReport :: ReportSpec -> Journal -> PostingsReport -postingsReport rspec@ReportSpec{rsOpts=ropts@ReportOpts{..}} j = - (totallabel, items) +postingsReport rspec@ReportSpec{rsOpts=ropts@ReportOpts{..}} j = items where reportspan = adjustReportDates rspec j whichdate = whichDateFromOpts ropts @@ -130,8 +126,6 @@ registerRunningCalculationFn ropts | average_ ropts = \i avg amt -> avg + divideMixedAmount (fromIntegral i) (amt - avg) | otherwise = \_ bal amt -> bal + amt -totallabel = "Total" - -- | Adjust report start/end dates to more useful ones based on -- journal data and report intervals. Ie: -- 1. If the start date is unspecified, use the earliest date in the journal (if any) @@ -206,14 +200,13 @@ mkpostingsReportItem :: Bool -> Bool -> WhichDate -> Maybe Day -> Posting -> Mix mkpostingsReportItem showdate showdesc wd menddate p b = (if showdate then Just date else Nothing ,menddate - ,if showdesc then Just desc else Nothing + ,if showdesc then tdescription <$> ptransaction p else Nothing ,p ,b ) where date = case wd of PrimaryDate -> postingDate p SecondaryDate -> postingDate2 p - desc = T.unpack $ maybe "" tdescription $ ptransaction p -- | Convert a list of postings into summary postings, one per interval, -- aggregated to the specified depth if any. @@ -267,7 +260,7 @@ negatePostingAmount p = p { pamount = negate $ pamount p } tests_PostingsReport = tests "PostingsReport" [ test "postingsReport" $ do - let (query, journal) `gives` n = (length $ snd $ postingsReport defreportspec{rsQuery=query} journal) @?= n + let (query, journal) `gives` n = (length $ postingsReport defreportspec{rsQuery=query} journal) @?= n -- with the query specified explicitly (Any, nulljournal) `gives` 0 (Any, samplejournal) `gives` 13 @@ -276,10 +269,10 @@ tests_PostingsReport = tests "PostingsReport" [ (And [Depth 1, StatusQ Cleared, Acct (toRegex' "expenses")], samplejournal) `gives` 2 (And [And [Depth 1, StatusQ Cleared], Acct (toRegex' "expenses")], samplejournal) `gives` 2 -- with query and/or command-line options - (length $ snd $ postingsReport defreportspec samplejournal) @?= 13 - (length $ snd $ postingsReport defreportspec{rsOpts=defreportopts{interval_=Months 1}} samplejournal) @?= 11 - (length $ snd $ postingsReport defreportspec{rsOpts=defreportopts{interval_=Months 1, empty_=True}} samplejournal) @?= 20 - (length $ snd $ postingsReport defreportspec{rsQuery=Acct $ toRegex' "assets:bank:checking"} samplejournal) @?= 5 + (length $ postingsReport defreportspec samplejournal) @?= 13 + (length $ postingsReport defreportspec{rsOpts=defreportopts{interval_=Months 1}} samplejournal) @?= 11 + (length $ postingsReport defreportspec{rsOpts=defreportopts{interval_=Months 1, empty_=True}} samplejournal) @?= 20 + (length $ postingsReport defreportspec{rsQuery=Acct $ toRegex' "assets:bank:checking"} samplejournal) @?= 5 -- (defreportopts, And [Acct "a a", Acct "'b"], samplejournal2) `gives` 0 -- [(Just (fromGregorian 2008 01 01,"income"),assets:bank:checking $1,$1) diff --git a/hledger/Hledger/Cli/Commands/Add.hs b/hledger/Hledger/Cli/Commands/Add.hs index 237525b7d..89bc9bab8 100644 --- a/hledger/Hledger/Cli/Commands/Add.hs +++ b/hledger/Hledger/Cli/Commands/Add.hs @@ -30,6 +30,8 @@ import qualified Data.Set as S import Data.Maybe import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.IO as TL import Data.Time.Calendar (Day) import Data.Time.Format (formatTime, defaultTimeLocale, iso8601DateFormat) import Safe (headDef, headMay, atMay) @@ -442,7 +444,7 @@ journalAddTransaction j@Journal{jtxns=ts} opts t = do -- unelided shows all amounts explicitly, in case there's a price, cf #283 when (debug_ opts > 0) $ do putStrLn $ printf "\nAdded transaction to %s:" f - putStrLn =<< registerFromString (showTransaction t) + TL.putStrLn =<< registerFromString (T.pack $ showTransaction t) return j{jtxns=ts++[t]} -- | Append a string, typically one or more transactions, to a journal @@ -464,9 +466,9 @@ ensureOneNewlineTerminated :: String -> String ensureOneNewlineTerminated = (++"\n") . reverse . dropWhile (=='\n') . reverse -- | Convert a string of journal data into a register report. -registerFromString :: String -> IO String +registerFromString :: Text -> IO TL.Text registerFromString s = do - j <- readJournal' $ T.pack s + j <- readJournal' s return . postingsReportAsText opts $ postingsReport rspec j where ropts = defreportopts{empty_=True} diff --git a/hledger/Hledger/Cli/Commands/Register.hs b/hledger/Hledger/Cli/Commands/Register.hs index 62c516d82..9e2259247 100644 --- a/hledger/Hledger/Cli/Commands/Register.hs +++ b/hledger/Hledger/Cli/Commands/Register.hs @@ -23,6 +23,7 @@ import Data.Maybe -- import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TB import System.Console.CmdArgs.Explicit import Hledger.Read.CsvReader (CSV, CsvRecord, printCSV) @@ -58,16 +59,17 @@ registermode = hledgerCommandMode -- | Print a (posting) register report. register :: CliOpts -> Journal -> IO () -register opts@CliOpts{reportspec_=rspec} j = do - let fmt = outputFormatFromOpts opts - render | fmt=="txt" = postingsReportAsText - | fmt=="csv" = const ((++"\n") . printCSV . postingsReportAsCsv) - | fmt=="json" = const ((++"\n") . TL.unpack . toJsonText) - | otherwise = const $ error' $ unsupportedOutputFormatError fmt -- PARTIAL: - writeOutput opts . render opts $ postingsReport rspec j +register opts@CliOpts{reportspec_=rspec} j = + writeOutputLazyText opts . render $ postingsReport rspec j + where + fmt = outputFormatFromOpts opts + render | fmt=="txt" = postingsReportAsText opts + | fmt=="csv" = TL.pack . printCSV . postingsReportAsCsv + | fmt=="json" = toJsonText + | otherwise = error' $ unsupportedOutputFormatError fmt -- PARTIAL: postingsReportAsCsv :: PostingsReport -> CSV -postingsReportAsCsv (_,is) = +postingsReportAsCsv is = ["txnidx","date","code","description","account","amount","total"] : map postingsReportItemAsCsvRecord is @@ -89,13 +91,17 @@ postingsReportItemAsCsvRecord (_, _, _, p, b) = [idx,date,code,desc,acct,amt,bal bal = showMixedAmountOneLineWithoutPrice False b -- | Render a register report as plain text suitable for console output. -postingsReportAsText :: CliOpts -> PostingsReport -> String -postingsReportAsText opts (_,items) = unlines $ map (postingsReportItemAsText opts amtwidth balwidth) items +postingsReportAsText :: CliOpts -> PostingsReport -> TL.Text +postingsReportAsText opts items = + TB.toLazyText . unlinesB $ + map (postingsReportItemAsText opts amtwidth balwidth) items where amtwidth = maximumStrict $ map (snd . showMixed showAmount (Just 12) Nothing False . itemamt) items balwidth = maximumStrict $ map (snd . showMixed showAmount (Just 12) Nothing False . itembal) items itemamt (_,_,_,Posting{pamount=a},_) = a itembal (_,_,_,_,a) = a + unlinesB [] = mempty + unlinesB xs = mconcat (intersperse (TB.fromText "\n") xs) <> TB.fromText "\n" -- | Render one register report line item as plain text. Layout is like so: -- @ @@ -119,36 +125,30 @@ postingsReportAsText opts (_,items) = unlines $ map (postingsReportItemAsText op -- has multiple commodities. Does not yet support formatting control -- like balance reports. -- -postingsReportItemAsText :: CliOpts -> Int -> Int -> PostingsReportItem -> String +postingsReportItemAsText :: CliOpts -> Int -> Int -> PostingsReportItem -> TB.Builder postingsReportItemAsText opts preferredamtwidth preferredbalwidth (mdate, menddate, mdesc, p, b) = -- use elide*Width to be wide-char-aware -- trace (show (totalwidth, datewidth, descwidth, acctwidth, amtwidth, balwidth)) $ - intercalate "\n" $ - concat [fitString (Just datewidth) (Just datewidth) True True date - ," " - ,fitString (Just descwidth) (Just descwidth) True True desc - ," " - ,fitString (Just acctwidth) (Just acctwidth) True True acct - ," " - ,amtfirstline - ," " - ,balfirstline - ] + foldMap mconcat . intersperse ([TB.fromText "\n"]) . map (map TB.fromText) $ + [ fitText (Just datewidth) (Just datewidth) True True date + , " " + , fitText (Just descwidth) (Just descwidth) True True desc + , " " + , fitText (Just acctwidth) (Just acctwidth) True True acct + , " " + , amtfirstline + , " " + , balfirstline + ] : - [concat [spacer - ,a - ," " - ,b - ] - | (a,b) <- zip amtrest balrest - ] + [ [ spacer, a, " ", b ] | (a,b) <- zip amtrest balrest ] where -- calculate widths (totalwidth,mdescwidth) = registerWidthsFromOpts opts (datewidth, date) = case (mdate,menddate) of - (Just _, Just _) -> (21, showDateSpan (DateSpan mdate menddate)) + (Just _, Just _) -> (21, T.pack $ showDateSpan (DateSpan mdate menddate)) (Nothing, Just _) -> (21, "") - (Just d, Nothing) -> (10, showDate d) + (Just d, Nothing) -> (10, T.pack $ showDate d) _ -> (10, "") (amtwidth, balwidth) | shortfall <= 0 = (preferredamtwidth, preferredbalwidth) @@ -171,24 +171,25 @@ postingsReportItemAsText opts preferredamtwidth preferredbalwidth (mdate, mendda -- gather content desc = fromMaybe "" mdesc - acct = parenthesise $ T.unpack $ elideAccountName awidth $ paccount p + acct = parenthesise . elideAccountName awidth $ paccount p where (parenthesise, awidth) = case ptype p of - BalancedVirtualPosting -> (\s -> "["++s++"]", acctwidth-2) - VirtualPosting -> (\s -> "("++s++")", acctwidth-2) + BalancedVirtualPosting -> (\s -> wrap "[" "]" s, acctwidth-2) + VirtualPosting -> (\s -> wrap "(" ")" s, acctwidth-2) _ -> (id,acctwidth) - amt = fst $ showMixed showAmountWithoutPrice (Just amtwidth) (Just amtwidth) (color_ . rsOpts $ reportspec_ opts) $ pamount p - bal = fst $ showMixed showAmountWithoutPrice (Just balwidth) (Just balwidth) (color_ . rsOpts $ reportspec_ opts) b + wrap a b x = a <> x <> b + amt = T.pack . fst $ showMixed showAmountWithoutPrice (Just amtwidth) (Just amtwidth) (color_ . rsOpts $ reportspec_ opts) $ pamount p + bal = T.pack . fst $ showMixed showAmountWithoutPrice (Just balwidth) (Just balwidth) (color_ . rsOpts $ reportspec_ opts) b -- alternate behaviour, show null amounts as 0 instead of blank -- amt = if null amt' then "0" else amt' -- bal = if null bal' then "0" else bal' - (amtlines, ballines) = (lines amt, lines bal) + (amtlines, ballines) = (T.lines amt, T.lines bal) (amtlen, ballen) = (length amtlines, length ballines) numlines = max 1 (max amtlen ballen) - (amtfirstline:amtrest) = take numlines $ amtlines ++ repeat (replicate amtwidth ' ') -- posting amount is top-aligned - (balfirstline:balrest) = take numlines $ replicate (numlines - ballen) (replicate balwidth ' ') ++ ballines -- balance amount is bottom-aligned - spacer = replicate (totalwidth - (amtwidth + 2 + balwidth)) ' ' + (amtfirstline:amtrest) = take numlines $ amtlines ++ repeat (T.replicate amtwidth " ") -- posting amount is top-aligned + (balfirstline:balrest) = take numlines $ replicate (numlines - ballen) (T.replicate balwidth " ") ++ ballines -- balance amount is bottom-aligned + spacer = T.replicate (totalwidth - (amtwidth + 2 + balwidth)) " " -- tests @@ -198,7 +199,7 @@ tests_Register = tests "Register" [ test "unicode in register layout" $ do j <- readJournal' "2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n" let rspec = defreportspec - (postingsReportAsText defcliopts $ postingsReport rspec j) + (TL.unpack . postingsReportAsText defcliopts $ postingsReport rspec j) @?= unlines ["2009-01-01 медвежья шкура расходы:покупки 100 100" diff --git a/hledger/Hledger/Cli/Commands/Registermatch.hs b/hledger/Hledger/Cli/Commands/Registermatch.hs index b4490be05..aa0e83bd5 100755 --- a/hledger/Hledger/Cli/Commands/Registermatch.hs +++ b/hledger/Hledger/Cli/Commands/Registermatch.hs @@ -10,6 +10,7 @@ where import Data.Char (toUpper) import Data.List import qualified Data.Text as T +import qualified Data.Text.Lazy.IO as TL import Hledger import Hledger.Cli.CliOptions import Hledger.Cli.Commands.Register @@ -25,14 +26,13 @@ registermatch :: CliOpts -> Journal -> IO () registermatch opts@CliOpts{rawopts_=rawopts,reportspec_=rspec} j = case listofstringopt "args" rawopts of [desc] -> do - let (_,pris) = postingsReport rspec j - ps = [p | (_,_,_,p,_) <- pris] + let ps = [p | (_,_,_,p,_) <- postingsReport rspec j] case similarPosting ps desc of Nothing -> putStrLn "no matches found." - Just p -> putStr $ postingsReportAsText opts ("",[pri]) + Just p -> TL.putStr $ postingsReportAsText opts [pri] where pri = (Just (postingDate p) ,Nothing - ,Just $ T.unpack (maybe "" tdescription $ ptransaction p) + ,tdescription <$> ptransaction p ,p ,0) _ -> putStrLn "please provide one description argument." diff --git a/hledger/Hledger/Cli/Utils.hs b/hledger/Hledger/Cli/Utils.hs index ab25cb2b8..b8bbb2e60 100644 --- a/hledger/Hledger/Cli/Utils.hs +++ b/hledger/Hledger/Cli/Utils.hs @@ -13,6 +13,7 @@ module Hledger.Cli.Utils unsupportedOutputFormatError, withJournalDo, writeOutput, + writeOutputLazyText, journalTransform, journalAddForecast, journalReload, @@ -34,6 +35,8 @@ import Data.List import Data.Maybe import qualified Data.Text as T import qualified Data.Text.IO as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.IO as TL import Data.Time (UTCTime, Day, addDays) import Safe (readMay) import System.Console.CmdArgs @@ -159,6 +162,14 @@ writeOutput opts s = do f <- outputFileFromOpts opts (if f == "-" then putStr else writeFile f) s +-- | Write some output to stdout or to a file selected by --output-file. +-- If the file exists it will be overwritten. This function operates on Lazy +-- Text values. +writeOutputLazyText :: CliOpts -> TL.Text -> IO () +writeOutputLazyText opts s = do + f <- outputFileFromOpts opts + (if f == "-" then TL.putStr else TL.writeFile f) s + -- -- | Get a journal from the given string and options, or throw an error. -- readJournal :: CliOpts -> String -> IO Journal -- readJournal opts s = readJournal def Nothing s >>= either error' return