232 lines
10 KiB
Haskell
232 lines
10 KiB
Haskell
{-|
|
|
|
|
A ledger-compatible @print@ command.
|
|
|
|
-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
module Hledger.Cli.Commands.Print (
|
|
printmode
|
|
,print'
|
|
-- ,entriesReportAsText
|
|
,roundFlag
|
|
,roundFromRawOpts
|
|
,amountStylesSetRoundingFromRawOpts
|
|
,transactionWithMostlyOriginalPostings
|
|
)
|
|
where
|
|
|
|
|
|
import Data.List (intersperse, intercalate)
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Lazy as TL
|
|
import qualified Data.Text.Lazy.Builder as TB
|
|
import Lens.Micro ((^.), _Just, has)
|
|
import System.Console.CmdArgs.Explicit
|
|
|
|
import Hledger
|
|
import Hledger.Write.Csv (CSV, printCSV, printTSV)
|
|
import Hledger.Cli.CliOptions
|
|
import Hledger.Cli.Utils
|
|
import System.Exit (exitFailure)
|
|
import Safe (lastMay, minimumDef)
|
|
import Data.Function ((&))
|
|
import Data.List.Extra (nubSort)
|
|
import qualified Data.Map as M
|
|
|
|
printmode = hledgerCommandMode
|
|
$(embedFileRelative "Hledger/Cli/Commands/Print.txt")
|
|
([flagNone ["explicit","x"] (setboolopt "explicit")
|
|
"show all amounts explicitly"
|
|
,flagNone ["show-costs"] (setboolopt "show-costs")
|
|
"show transaction prices even with conversion postings"
|
|
,roundFlag
|
|
,flagNone ["new"] (setboolopt "new")
|
|
"show only newer-dated transactions added in each file since last run"
|
|
,let arg = "DESC" in
|
|
flagReq ["match","m"] (\s opts -> Right $ setopt "match" s opts) arg
|
|
("fuzzy search for one recent transaction with description closest to "++arg)
|
|
,outputFormatFlag ["txt","beancount","csv","tsv","json","sql"]
|
|
,outputFileFlag
|
|
])
|
|
cligeneralflagsgroups1
|
|
hiddenflags
|
|
([], Just $ argsFlag "[QUERY]")
|
|
|
|
roundFlag = flagReq ["round"] (\s opts -> Right $ setopt "round" s opts) "TYPE" $
|
|
intercalate "\n"
|
|
["how much rounding or padding should be done when displaying amounts ?"
|
|
,"none - show original decimal digits,"
|
|
," as in journal"
|
|
,"soft - just add or remove decimal zeros"
|
|
," to match precision (default)"
|
|
,"hard - round posting amounts to precision"
|
|
," (can unbalance transactions)"
|
|
,"all - also round cost amounts to precision"
|
|
," (can unbalance transactions)"
|
|
]
|
|
|
|
-- | Get the --round option's value, if any. Can fail with a parse error.
|
|
roundFromRawOpts :: RawOpts -> Maybe Rounding
|
|
roundFromRawOpts = lastMay . collectopts roundfromrawopt
|
|
where
|
|
roundfromrawopt (n,v)
|
|
| n=="round", v=="none" = Just NoRounding
|
|
| n=="round", v=="soft" = Just SoftRounding
|
|
| n=="round", v=="hard" = Just HardRounding
|
|
| n=="round", v=="all" = Just AllRounding
|
|
| n=="round" = error' $ "--round's value should be none, soft, hard or all; got: "++v
|
|
| otherwise = Nothing
|
|
|
|
-- | Set these amount styles' rounding strategy when they are being applied to amounts,
|
|
-- according to the value of the --round option, if any.
|
|
amountStylesSetRoundingFromRawOpts :: RawOpts -> M.Map CommoditySymbol AmountStyle -> M.Map CommoditySymbol AmountStyle
|
|
amountStylesSetRoundingFromRawOpts rawopts styles =
|
|
case roundFromRawOpts rawopts of
|
|
Just r -> amountStylesSetRounding r styles
|
|
Nothing -> styles
|
|
|
|
-- | Print journal transactions in standard format.
|
|
print' :: CliOpts -> Journal -> IO ()
|
|
print' opts j = do
|
|
-- The print command should show all amounts with their original decimal places,
|
|
-- but as part of journal reading the posting amounts have already been normalised
|
|
-- according to commodity display styles, and currently it's not easy to avoid
|
|
-- that. For now we try to reverse it by increasing all amounts' decimal places
|
|
-- sufficiently to show the amount exactly. The displayed amounts may have minor
|
|
-- differences from the originals, such as trailing zeroes added.
|
|
let
|
|
-- lbl = lbl_ "print'"
|
|
j' = j
|
|
-- & dbg9With (lbl "amounts before setting full precision".showJournalAmountsDebug)
|
|
& journalMapPostingAmounts mixedAmountSetFullPrecision
|
|
-- & dbg9With (lbl "amounts after setting full precision: ".showJournalAmountsDebug)
|
|
|
|
case maybestringopt "match" $ rawopts_ opts of
|
|
Nothing -> printEntries opts j'
|
|
Just desc ->
|
|
-- match mode, prints one recent transaction most similar to given description
|
|
-- XXX should match similarly to register --match
|
|
case journalSimilarTransaction opts j' (dbg1 "finding best match for description" $ T.pack desc) of
|
|
Just t -> printEntries opts j'{jtxns=[t]}
|
|
Nothing -> putStrLn "no matches found." >> exitFailure
|
|
|
|
printEntries :: CliOpts -> Journal -> IO ()
|
|
printEntries opts@CliOpts{rawopts_=rawopts, reportspec_=rspec} j =
|
|
writeOutputLazyText opts $ render $ entriesReport rspec j
|
|
where
|
|
-- print does user-specified rounding or (by default) no rounding, in all output formats
|
|
styles = amountStylesSetRoundingFromRawOpts rawopts $ journalCommodityStyles j
|
|
|
|
fmt = outputFormatFromOpts opts
|
|
render | fmt=="txt" = entriesReportAsText . styleAmounts styles . map maybeoriginalamounts
|
|
| fmt=="beancount" = entriesReportAsBeancount . styleAmounts styles . map maybeoriginalamounts
|
|
| fmt=="csv" = printCSV . entriesReportAsCsv . styleAmounts styles
|
|
| fmt=="tsv" = printTSV . entriesReportAsCsv . styleAmounts styles
|
|
| fmt=="json" = toJsonText . styleAmounts styles
|
|
| fmt=="sql" = entriesReportAsSql . styleAmounts styles
|
|
| otherwise = error' $ unsupportedOutputFormatError fmt -- PARTIAL:
|
|
where
|
|
maybeoriginalamounts
|
|
-- Use the fully inferred and amount-styled/rounded transaction in the following situations:
|
|
-- with -x/--explicit:
|
|
| boolopt "explicit" (rawopts_ opts) = id
|
|
-- with --show-costs:
|
|
| opts ^. infer_costs = id
|
|
-- with -B/-V/-X/--value ("because of #551, and because of print -V valuing only one posting when there's an implicit txn price.")
|
|
| has (value . _Just) opts = id
|
|
-- Otherwise, keep the transaction's amounts close to how they were written in the journal.
|
|
| otherwise = transactionWithMostlyOriginalPostings
|
|
|
|
-- | Replace this transaction's postings with the original postings if any, but keep the
|
|
-- current possibly rewritten account names, and the inferred values of any auto postings.
|
|
-- This is mainly for showing transactions with the amounts in their original journal format.
|
|
transactionWithMostlyOriginalPostings :: Transaction -> Transaction
|
|
transactionWithMostlyOriginalPostings = transactionMapPostings postingMostlyOriginal
|
|
where
|
|
postingMostlyOriginal p = orig
|
|
{ paccount = paccount p
|
|
, pamount = pamount $ if isGenerated then p else orig }
|
|
where
|
|
orig = originalPosting p
|
|
isGenerated = "_generated-posting" `elem` map fst (ptags p)
|
|
|
|
entriesReportAsText :: EntriesReport -> TL.Text
|
|
entriesReportAsText = entriesReportAsTextHelper showTransaction
|
|
|
|
entriesReportAsTextHelper :: (Transaction -> T.Text) -> EntriesReport -> TL.Text
|
|
entriesReportAsTextHelper showtxn = TB.toLazyText . foldMap (TB.fromText . showtxn)
|
|
|
|
-- In addition to rendering the transactions in (best effort) Beancount format,
|
|
-- this generates an account open directive for each account name used
|
|
-- (using the earliest transaction date).
|
|
entriesReportAsBeancount :: EntriesReport -> TL.Text
|
|
entriesReportAsBeancount ts =
|
|
-- PERF: gathers and converts all account names, then repeats that work when showing each transaction
|
|
opendirectives <> "\n" <>
|
|
entriesReportAsTextHelper showTransactionBeancount ts
|
|
where
|
|
opendirectives
|
|
| null ts = ""
|
|
| otherwise = TL.fromStrict $ T.unlines [
|
|
firstdate <> " open " <> accountNameToBeancount a
|
|
| a <- nubSort $ concatMap (map paccount.tpostings) ts
|
|
]
|
|
where
|
|
firstdate = showDate $ minimumDef err $ map tdate ts
|
|
where err = error' "entriesReportAsBeancount: should not happen"
|
|
|
|
entriesReportAsSql :: EntriesReport -> TL.Text
|
|
entriesReportAsSql txns = TB.toLazyText $ mconcat
|
|
[ TB.fromText "create table if not exists postings(id serial,txnidx int,date1 date,date2 date,status text,code text,description text,comment text,account text,amount numeric,commodity text,credit numeric,debit numeric,posting_status text,posting_comment text);\n"
|
|
, TB.fromText "insert into postings(txnidx,date1,date2,status,code,description,comment,account,amount,commodity,credit,debit,posting_status,posting_comment) values\n"
|
|
, mconcat . intersperse (TB.fromText ",") $ map values csv
|
|
, TB.fromText ";\n"
|
|
]
|
|
where
|
|
values vs = TB.fromText "(" <> mconcat (intersperse (TB.fromText ",") $ map toSql vs) <> TB.fromText ")\n"
|
|
toSql "" = TB.fromText "NULL"
|
|
toSql s = TB.fromText "'" <> TB.fromText (T.replace "'" "''" s) <> TB.fromText "'"
|
|
csv = concatMap (transactionToCSV . transactionMapPostingAmounts (mapMixedAmount setDecimalPoint)) txns
|
|
where
|
|
setDecimalPoint a = a{astyle=(astyle a){asdecimalmark=Just '.'}}
|
|
|
|
entriesReportAsCsv :: EntriesReport -> CSV
|
|
entriesReportAsCsv txns =
|
|
["txnidx","date","date2","status","code","description","comment","account","amount","commodity","credit","debit","posting-status","posting-comment"] :
|
|
concatMap transactionToCSV txns
|
|
|
|
-- | Generate one CSV record per posting, duplicating the common transaction fields.
|
|
-- The txnidx field (transaction index) allows postings to be grouped back into transactions.
|
|
transactionToCSV :: Transaction -> CSV
|
|
transactionToCSV t =
|
|
map (\p -> T.pack (show idx):d:d2:status:code:description:comment:p)
|
|
(concatMap postingToCSV $ tpostings t)
|
|
where
|
|
idx = tindex t
|
|
description = tdescription t
|
|
d = showDate (tdate t)
|
|
d2 = maybe "" showDate $ tdate2 t
|
|
status = T.pack . show $ tstatus t
|
|
code = tcode t
|
|
comment = T.strip $ tcomment t
|
|
|
|
postingToCSV :: Posting -> CSV
|
|
postingToCSV p =
|
|
map (\(a@(Amount {aquantity=q,acommodity=c})) ->
|
|
-- commodity goes into separate column, so we suppress it, along with digit group
|
|
-- separators and prices
|
|
let a_ = amountStripCost a{acommodity=""} in
|
|
let showamt = wbToText . showAmountB machineFmt in
|
|
let amt = showamt a_ in
|
|
let credit = if q < 0 then showamt $ negate a_ else "" in
|
|
let debit = if q >= 0 then showamt a_ else "" in
|
|
[account, amt, c, credit, debit, status, comment])
|
|
. amounts $ pamount p
|
|
where
|
|
status = T.pack . show $ pstatus p
|
|
account = showAccountName Nothing (ptype p) (paccount p)
|
|
comment = T.strip $ pcomment p
|