From e2cc2d7e24285305b57b10f0431216e8c8b763aa Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Wed, 22 Nov 2023 21:11:59 -1000 Subject: [PATCH] feat:print: add a basic beancount output format This prints journal output more likely (but not guaranteed) to be readable by Beancount. All packages now require text 1.2.4.1 or greater. --- hledger-lib/Hledger/Data/AccountName.hs | 18 ++++++ hledger-lib/Hledger/Data/Posting.hs | 81 +++++++++++++++++++++++++ hledger-lib/Hledger/Data/Transaction.hs | 34 +++++++++++ hledger-lib/Hledger/Utils/String.hs | 5 ++ hledger-lib/Hledger/Utils/Text.hs | 8 +-- hledger-lib/package.yaml | 2 +- hledger-ui/package.yaml | 2 +- hledger-web/package.yaml | 2 +- hledger/Hledger/Cli/CliOptions.hs | 2 +- hledger/Hledger/Cli/Commands/Check.hs | 6 +- hledger/Hledger/Cli/Commands/Print.hs | 71 +++++++++------------- hledger/Hledger/Cli/Commands/Print.md | 14 ++++- hledger/package.yaml | 2 +- 13 files changed, 187 insertions(+), 60 deletions(-) diff --git a/hledger-lib/Hledger/Data/AccountName.hs b/hledger-lib/Hledger/Data/AccountName.hs index 3d0663cc6..f800b7e14 100644 --- a/hledger-lib/Hledger/Data/AccountName.hs +++ b/hledger-lib/Hledger/Data/AccountName.hs @@ -52,6 +52,8 @@ module Hledger.Data.AccountName ( ,concatAccountNames ,accountNameApplyAliases ,accountNameApplyAliasesMemo + ,accountNameToBeancount + ,beancountTopLevelAccounts ,tests_AccountName ) where @@ -346,6 +348,22 @@ accountNameToAccountOnlyRegexCI a = toRegexCI' $ "^" <> escapeName a <> "$" -- P --isAccountRegex :: String -> Bool --isAccountRegex s = take 1 s == "^" && take 5 (reverse s) == ")$|:(" +type BeancountAccountName = AccountName + +-- Convert a hledger account name to a valid Beancount account name. +-- It capitalises each part, and if the first part is not one of +-- Assets, Liabilities, Equity, Income, Expenses, it prepends Equity:. +accountNameToBeancount :: AccountName -> BeancountAccountName +accountNameToBeancount a = + -- https://beancount.github.io/docs/beancount_language_syntax.html#accounts + accountNameFromComponents $ + case map textCapitalise $ accountNameComponents a of + [] -> [] + c:cs | c `elem` beancountTopLevelAccounts -> c:cs + cs -> "Equity" : cs + +beancountTopLevelAccounts = ["Assets", "Liabilities", "Equity", "Income", "Expenses"] + tests_AccountName = testGroup "AccountName" [ testCase "accountNameTreeFrom" $ do accountNameTreeFrom ["a"] @?= Node "root" [Node "a" []] diff --git a/hledger-lib/Hledger/Data/Posting.hs b/hledger-lib/Hledger/Data/Posting.hs index 6b5f0513d..84b3e3d58 100644 --- a/hledger-lib/Hledger/Data/Posting.hs +++ b/hledger-lib/Hledger/Data/Posting.hs @@ -60,7 +60,10 @@ module Hledger.Data.Posting ( showPostingLines, postingAsLines, postingsAsLines, + postingsAsLinesBeancount, + postingAsLinesBeancount, showAccountName, + showAccountNameBeancount, renderCommentLines, showBalanceAssertion, -- * misc. @@ -317,6 +320,84 @@ showAccountName w = fmt fmt VirtualPosting = wrap "(" ")" . maybe id (T.takeEnd . subtract 2) w fmt BalancedVirtualPosting = wrap "[" "]" . maybe id (T.takeEnd . subtract 2) w +-- | Like postingsAsLines but generates Beancount journal format. +postingsAsLinesBeancount :: [Posting] -> [Text] +postingsAsLinesBeancount ps = concatMap first3 linesWithWidths + where + linesWithWidths = map (postingAsLinesBeancount False maxacctwidth maxamtwidth) ps + maxacctwidth = maximumBound 0 $ map second3 linesWithWidths + maxamtwidth = maximumBound 0 $ map third3 linesWithWidths + +-- | Like postingAsLines but generates Beancount journal format. +postingAsLinesBeancount :: Bool -> Int -> Int -> Posting -> ([Text], Int, Int) +postingAsLinesBeancount elideamount acctwidth amtwidth p = + (concatMap (++ newlinecomments) postingblocks, thisacctwidth, thisamtwidth) + where + -- This needs to be converted to strict Text in order to strip trailing + -- spaces. This adds a small amount of inefficiency, and the only difference + -- is whether there are trailing spaces in print (and related) reports. This + -- could be removed and we could just keep everything as a Text Builder, but + -- would require adding trailing spaces to 42 failing tests. + postingblocks = [map T.stripEnd . T.lines . TL.toStrict $ + render [ textCell BottomLeft statusandaccount + , textCell BottomLeft " " + , Cell BottomLeft [pad amt] + , Cell BottomLeft [assertion] + , textCell BottomLeft samelinecomment + ] + | (amt,assertion) <- shownAmountsAssertions] + render = renderRow def{tableBorders=False, borderSpaces=False} . Group NoLine . map Header + pad amt = WideBuilder (TB.fromText $ T.replicate w " ") w <> amt + where w = max 12 amtwidth - wbWidth amt -- min. 12 for backwards compatibility + + pacct = showAccountNameBeancount Nothing $ paccount p + pstatusandacct p' = if pstatus p' == Pending then "! " else "" <> pacct + + -- currently prices are considered part of the amount string when right-aligning amounts + -- Since we will usually be calling this function with the knot tied between + -- amtwidth and thisamtwidth, make sure thisamtwidth does not depend on + -- amtwidth at all. + shownAmounts + | elideamount = [mempty] + | otherwise = showMixedAmountLinesB displayopts a' + where + displayopts = noColour{ displayZeroCommodity=True, displayAddDecimalMark=True } + a' = mapMixedAmount amountToBeancount $ pamount p + thisamtwidth = maximumBound 0 $ map wbWidth shownAmounts + + -- when there is a balance assertion, show it only on the last posting line + shownAmountsAssertions = zip shownAmounts shownAssertions + where + shownAssertions = replicate (length shownAmounts - 1) mempty ++ [assertion] + where + assertion = maybe mempty ((WideBuilder (TB.singleton ' ') 1 <>).showBalanceAssertion) $ pbalanceassertion p + + -- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned + statusandaccount = lineIndent . fitText (Just $ 2 + acctwidth) Nothing False True $ pstatusandacct p + thisacctwidth = realLength pacct + + (samelinecomment, newlinecomments) = + case renderCommentLines (pcomment p) of [] -> ("",[]) + c:cs -> (c,cs) + +type BeancountAmount = Amount + +-- | Do some best effort adjustments to make an amount that renders +-- in a way that Beancount can read: forces the commodity symbol to the right, +-- converts $ to USD. +amountToBeancount :: Amount -> BeancountAmount +amountToBeancount a@Amount{acommodity=c,astyle=s} = a{acommodity=c', astyle=s'} + -- https://beancount.github.io/docs/beancount_language_syntax.html#commodities-currencies + where + s' = s{ascommodityside=R, ascommodityspaced=True} + c' | c=="$" = "USD" + | otherwise = c + +-- | Like showAccountName for Beancount journal format. +-- Calls accountNameToBeancount first. +showAccountNameBeancount :: Maybe Int -> AccountName -> Text +showAccountNameBeancount w = maybe id T.take w . accountNameToBeancount + -- | Render a transaction or posting's comment as indented, semicolon-prefixed comment lines. -- The first line (unless empty) will have leading space, subsequent lines will have a larger indent. renderCommentLines :: Text -> [Text] diff --git a/hledger-lib/Hledger/Data/Transaction.hs b/hledger-lib/Hledger/Data/Transaction.hs index 154281fe0..df814d32f 100644 --- a/hledger-lib/Hledger/Data/Transaction.hs +++ b/hledger-lib/Hledger/Data/Transaction.hs @@ -46,6 +46,7 @@ module Hledger.Data.Transaction , showTransaction , showTransactionOneLineAmounts , showTransactionLineFirstPart +, showTransactionBeancount , transactionFile -- * transaction errors , annotateErrorWithTransaction @@ -114,6 +115,12 @@ payeeAndNoteFromDescription t where (p, n) = T.span (/= '|') t +-- | Like payeeAndNoteFromDescription, but if there's no | then payee is empty. +payeeAndNoteFromDescription' :: Text -> (Text,Text) +payeeAndNoteFromDescription' t = + if isJust $ T.find (=='|') t then payeeAndNoteFromDescription t else ("",t) + + {-| Render a journal transaction as text similar to the style of Ledger's print command. @@ -169,6 +176,33 @@ showTransactionLineFirstPart t = T.concat [date, status, code] | otherwise = "" code = if T.null (tcode t) then "" else wrap " (" ")" $ tcode t +-- | Like showTransaction, but generates Beancount journal format. +showTransactionBeancount :: Transaction -> Text +showTransactionBeancount t = + -- https://beancount.github.io/docs/beancount_language_syntax.html + -- similar to showTransactionHelper, but I haven't bothered with Builder + firstline <> nl + <> foldMap ((<> nl)) newlinecomments + <> foldMap ((<> nl)) (postingsAsLinesBeancount $ tpostings t) + <> nl + where + nl = "\n" + firstline = T.concat [date, status, payee, note, tags, samelinecomment] + date = showDate $ tdate t + status = if tstatus t == Pending then " !" else " *" + (payee,note) = + case payeeAndNoteFromDescription' $ tdescription t of + ("","") -> ("", "" ) + (p ,"") -> (wrapq p, wrapq "") + ("",n ) -> ("" , wrapq n ) + (p ,n ) -> (wrapq p, wrapq n ) + where + wrapq = wrap " \"" "\"" + tags = T.concat $ map ((" #"<>).fst) $ ttags t + (samelinecomment, newlinecomments) = + case renderCommentLines (tcomment t) of [] -> ("",[]) + c:cs -> (c,cs) + hasRealPostings :: Transaction -> Bool hasRealPostings = not . null . realPostings diff --git a/hledger-lib/Hledger/Utils/String.hs b/hledger-lib/Hledger/Utils/String.hs index efedbd24b..65e378c61 100644 --- a/hledger-lib/Hledger/Utils/String.hs +++ b/hledger-lib/Hledger/Utils/String.hs @@ -3,6 +3,7 @@ module Hledger.Utils.String ( takeEnd, -- * misc + capitalise, lowercase, uppercase, underline, @@ -56,6 +57,10 @@ takeEnd n l = go (drop n l) l go [] r = r go _ [] = [] +capitalise :: String -> String +capitalise (c:cs) = toUpper c : cs +capitalise s = s + lowercase, uppercase :: String -> String lowercase = map toLower uppercase = map toUpper diff --git a/hledger-lib/Hledger/Utils/Text.hs b/hledger-lib/Hledger/Utils/Text.hs index aad96d013..4799d082d 100644 --- a/hledger-lib/Hledger/Utils/Text.hs +++ b/hledger-lib/Hledger/Utils/Text.hs @@ -6,8 +6,7 @@ module Hledger.Utils.Text ( -- * misc - -- lowercase, - -- uppercase, + textCapitalise, -- underline, -- stripbrackets, textUnbracket, @@ -67,9 +66,8 @@ import Text.Tabular.AsciiWide import Text.WideString (WideBuilder(..), wbToText, wbFromText, wbUnpack) --- lowercase, uppercase :: String -> String --- lowercase = map toLower --- uppercase = map toUpper +textCapitalise :: Text -> Text +textCapitalise t = T.toTitle c <> cs where (c,cs) = T.splitAt 1 t -- stripbrackets :: String -> String -- stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse :: String -> String diff --git a/hledger-lib/package.yaml b/hledger-lib/package.yaml index b6733d59f..76f910cc1 100644 --- a/hledger-lib/package.yaml +++ b/hledger-lib/package.yaml @@ -74,7 +74,7 @@ dependencies: - tasty-hunit >=0.10.0.2 - template-haskell - terminal-size >=0.3.3 -- text >=1.2 +- text >=1.2.4.1 - text-ansi >=0.2.1 - time >=1.5 - timeit diff --git a/hledger-ui/package.yaml b/hledger-ui/package.yaml index 17faf1868..dd0a89798 100644 --- a/hledger-ui/package.yaml +++ b/hledger-ui/package.yaml @@ -96,7 +96,7 @@ library: - process >=1.2 - safe >=0.3.19 - split >=0.1 - - text >=1.2 + - text >=1.2.4.1 - text-zipper >=0.4 - time >=1.5 - transformers diff --git a/hledger-web/package.yaml b/hledger-web/package.yaml index 0b3326bff..6040a4825 100644 --- a/hledger-web/package.yaml +++ b/hledger-web/package.yaml @@ -119,7 +119,7 @@ library: - safe >=0.3.19 - shakespeare >=2.0.2.2 - template-haskell - - text >=1.2 + - text >=1.2.4.1 - time >=1.5 - transformers - unix-compat diff --git a/hledger/Hledger/Cli/CliOptions.hs b/hledger/Hledger/Cli/CliOptions.hs index 11bc1bb02..d3e94e4eb 100644 --- a/hledger/Hledger/Cli/CliOptions.hs +++ b/hledger/Hledger/Cli/CliOptions.hs @@ -642,7 +642,7 @@ defaultOutputFormat = "txt" -- | All the output formats known by any command, for outputFormatFromOpts. -- To automatically infer it from -o/--output-file, it needs to be listed here. outputFormats :: [String] -outputFormats = [defaultOutputFormat, "csv", "json", "html", "sql", "tsv"] +outputFormats = [defaultOutputFormat, "beancount", "csv", "json", "html", "sql", "tsv"] -- | Get the output format from the --output-format option, -- otherwise from a recognised file extension in the --output-file option, diff --git a/hledger/Hledger/Cli/Commands/Check.hs b/hledger/Hledger/Cli/Commands/Check.hs index 31edd8f52..833d53f53 100644 --- a/hledger/Hledger/Cli/Commands/Check.hs +++ b/hledger/Hledger/Cli/Commands/Check.hs @@ -9,7 +9,7 @@ module Hledger.Cli.Commands.Check ( ,check ) where -import Data.Char (toLower,toUpper) +import Data.Char (toLower) import Data.Either (partitionEithers) import Data.List (isPrefixOf, find) import Control.Monad (forM_) @@ -80,10 +80,6 @@ parseCheck s = s' = capitalise $ map toLower s checknames = map show [minBound..maxBound::Check] -capitalise :: String -> String -capitalise (c:cs) = toUpper c : cs -capitalise s = s - -- | Parse a check argument: a string which is the lower-case name of an error check, -- or a prefix thereof, followed by zero or more space-separated arguments for that check. parseCheckArgument :: String -> Either String (Check,[String]) diff --git a/hledger/Hledger/Cli/Commands/Print.hs b/hledger/Hledger/Cli/Commands/Print.hs index a315689b7..eec5c53b2 100644 --- a/hledger/Hledger/Cli/Commands/Print.hs +++ b/hledger/Hledger/Cli/Commands/Print.hs @@ -28,8 +28,9 @@ import Hledger.Read.CsvUtils (CSV, printCSV, printTSV) import Hledger.Cli.CliOptions import Hledger.Cli.Utils import System.Exit (exitFailure) -import Safe (lastMay) +import Safe (lastMay, minimumDef) import Data.Function ((&)) +import Data.List.Extra (nubSort) printmode = hledgerCommandMode @@ -55,7 +56,7 @@ printmode = hledgerCommandMode ,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","csv","tsv","json","sql"] + ,outputFormatFlag ["txt","beancount","csv","tsv","json","sql"] ,outputFileFlag ]) [generalflagsgroup1] @@ -113,6 +114,7 @@ printEntries opts@CliOpts{rawopts_=rawopts, reportspec_=rspec} j = fmt = outputFormatFromOpts opts render | fmt=="txt" = entriesReportAsText opts . styleAmounts styles + | fmt=="beancount" = entriesReportAsBeancount opts . styleAmounts styles | fmt=="csv" = printCSV . entriesReportAsCsv . styleAmounts styles | fmt=="tsv" = printTSV . entriesReportAsCsv . styleAmounts styles | fmt=="json" = toJsonText . styleAmounts styles @@ -120,8 +122,11 @@ printEntries opts@CliOpts{rawopts_=rawopts, reportspec_=rspec} j = | otherwise = error' $ unsupportedOutputFormatError fmt -- PARTIAL: entriesReportAsText :: CliOpts -> EntriesReport -> TL.Text -entriesReportAsText opts = - TB.toLazyText . foldMap (TB.fromText . showTransaction . txntransform) +entriesReportAsText = entriesReportAsTextHelper showTransaction + +entriesReportAsTextHelper :: (Transaction -> T.Text) -> CliOpts -> EntriesReport -> TL.Text +entriesReportAsTextHelper showtxn opts = + TB.toLazyText . foldMap (TB.fromText . showtxn . txntransform) where txntransform -- Use the fully inferred and amount-styled/rounded transaction in the following situations: @@ -149,46 +154,24 @@ postingMostlyOriginal p = orig orig = originalPosting p isGenerated = "_generated-posting" `elem` map fst (ptags p) --- XXX --- tests_showTransactions = [ --- "showTransactions" ~: do - --- -- "print expenses" ~: --- do --- let opts = defreportopts{query_="expenses"} --- d <- getCurrentDay --- showTransactions opts (queryFromOpts d opts) samplejournal `is` unlines --- ["2008/06/03 * eat & shop" --- ," expenses:food $1" --- ," expenses:supplies $1" --- ," assets:cash $-2" --- ,"" --- ] - --- -- , "print report with depth arg" ~: --- do --- let opts = defreportopts{depth_=Just 2} --- d <- getCurrentDay --- showTransactions opts (queryFromOpts d opts) samplejournal `is` unlines --- ["2008/01/01 income" --- ," assets:bank:checking $1" --- ," income:salary $-1" --- ,"" --- ,"2008/06/01 gift" --- ," assets:bank:checking $1" --- ," income:gifts $-1" --- ,"" --- ,"2008/06/03 * eat & shop" --- ," expenses:food $1" --- ," expenses:supplies $1" --- ," assets:cash $-2" --- ,"" --- ,"2008/12/31 * pay off" --- ," liabilities:debts $1" --- ," assets:bank:checking $-1" --- ,"" --- ] --- ] +-- 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 :: CliOpts -> EntriesReport -> TL.Text +entriesReportAsBeancount opts ts = + -- PERF: gathers and converts all account names, then repeats that work when showing each transaction + opendirectives <> "\n" <> + entriesReportAsTextHelper showTransactionBeancount opts 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 diff --git a/hledger/Hledger/Cli/Commands/Print.md b/hledger/Hledger/Cli/Commands/Print.md index 58ab7b334..65d2a95b5 100644 --- a/hledger/Hledger/Cli/Commands/Print.md +++ b/hledger/Hledger/Cli/Commands/Print.md @@ -115,7 +115,19 @@ This command also supports the [output destination](hledger.html#output-destination) and [output format](hledger.html#output-format) options The output formats supported are -`txt`, `csv`, `tsv`, and (experimental) `json` and `sql`. +`txt`, `beancount`, `csv`, `tsv`, `json` and `sql`. + +*Experimental:* +The `beancount` format tries to produce Beancount-compatible output. +It is very basic and may require additional manual fixups: + +- Transaction and postings with unmarked status are converted to cleared (`*``) status. +- Transactions' payee and or note are wrapped in double quotes. +- Transaction tags are copied to Beancount #tag format. +- Account name parts are capitalised, and if the first account name part + is not one of Assets, Liabilities, Equity, Income, or Expenses, "Equity:" is prepended. +- The `$` commodity symbol is converted to `USD`. +- An `open` directive is generated for each account used, on the earliest transaction date. Here's an example of print's CSV output: diff --git a/hledger/package.yaml b/hledger/package.yaml index d3887af51..8d0ba9854 100644 --- a/hledger/package.yaml +++ b/hledger/package.yaml @@ -125,7 +125,7 @@ dependencies: - tabular >=0.2 - tasty >=1.2.3 - temporary -- text >=0.11 +- text >=1.2.4.1 - text-ansi >=0.2.1 - time >=1.5 - timeit