From ff28aa329ac168510bbf07ca621112e05ce58b09 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Fri, 15 Nov 2024 21:51:07 -1000 Subject: [PATCH] imp:print:beancount: convert tags to BC metadata Transaction and posting tags (and posting tags inherited from accounts) are now converted safely to Beancount-compatible transaction and posting metadata lines. --- hledger-lib/Hledger/Data/Types.hs | 7 ++ hledger-lib/Hledger/Write/Beancount.hs | 108 +++++++++++++++++++++++-- hledger/Hledger/Cli/Commands/Print.hs | 29 ++++--- hledger/hledger.m4.md | 15 ++++ hledger/test/print/beancount.test | 45 +++++++++++ 5 files changed, 187 insertions(+), 17 deletions(-) diff --git a/hledger-lib/Hledger/Data/Types.hs b/hledger-lib/Hledger/Data/Types.hs index 35569084b..4bdae7099 100644 --- a/hledger-lib/Hledger/Data/Types.hs +++ b/hledger-lib/Hledger/Data/Types.hs @@ -417,6 +417,13 @@ toHiddenTag = first toHiddenTagName toVisibleTag :: HiddenTag -> Tag toVisibleTag = first toVisibleTagName +-- | Does this tag name begin with the hidden tag prefix (_) ? +isHiddenTagName :: TagName -> Bool +isHiddenTagName t = + case T.uncons t of + Just ('_',_) -> True + _ -> False + -- | Add the _ prefix to a normal visible tag's name, making it a hidden tag. toHiddenTagName :: TagName -> TagName toHiddenTagName = T.cons '_' diff --git a/hledger-lib/Hledger/Write/Beancount.hs b/hledger-lib/Hledger/Write/Beancount.hs index 5c5666086..16c5af84a 100644 --- a/hledger-lib/Hledger/Write/Beancount.hs +++ b/hledger-lib/Hledger/Write/Beancount.hs @@ -9,6 +9,8 @@ module Hledger.Write.Beancount ( -- postingsAsLinesBeancount, -- postingAsLinesBeancount, -- showAccountNameBeancount, + tagsToBeancountMetadata, + showBeancountMetadata, accountNameToBeancount, commodityToBeancount, -- beancountTopLevelAccounts, @@ -39,6 +41,9 @@ import Hledger.Data.Dates (showDate) import Hledger.Data.Posting (renderCommentLines, showBalanceAssertion, postingIndent) import Hledger.Data.Transaction (payeeAndNoteFromDescription') import Data.Function ((&)) +import Data.List.Extra (groupOnKey) +import Data.Bifunctor (first) +import Data.List (sort) --- ** doctest setup -- $setup @@ -50,12 +55,12 @@ 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).postingIndent.showBeancountMetadata (Just maxmdnamewidth)) mds <> foldMap ((<> nl)) newlinecomments <> foldMap ((<> nl)) (postingsAsLinesBeancount $ tpostings t) <> nl where - nl = "\n" - firstline = T.concat [date, status, payee, note, tags, samelinecomment] + firstline = T.concat [date, status, payee, note, samelinecomment] date = showDate $ tdate t status = if tstatus t == Pending then " !" else " *" (payee,note) = @@ -66,12 +71,92 @@ showTransactionBeancount t = (p ,n ) -> (wrapq p, wrapq n ) where wrapq = wrap " \"" "\"" . escapeDoubleQuotes . escapeBackslash - tags = T.concat $ map ((" #"<>).fst) $ ttags t + mds = tagsToBeancountMetadata $ ttags t + maxmdnamewidth = maximum' $ map (T.length . fst) mds (samelinecomment, newlinecomments) = case renderCommentLines (tcomment t) of [] -> ("",[]) c:cs -> (c,cs) --- | Like postingsAsLines but generates Beancount journal format. +nl = "\n" + +type BMetadata = Tag + +-- https://beancount.github.io/docs/beancount_language_syntax.html#metadata-1 +-- | Render a Beancount metadata as a metadata line (without the indentation or newline). +-- If a maximum name length is provided, space will be left after the colon +-- so that successive metadata values will all start at the same column. +showBeancountMetadata :: Maybe Int -> BMetadata -> Text +showBeancountMetadata mmaxnamewidth (n,v) = + fitText (fmap (+2) mmaxnamewidth) Nothing False True (n <> ": ") + <> toBeancountMetadataValue v + +-- | Make a list of tags ready to be rendered as Beancount metadata: +-- Encode and lengthen names, encode values, and combine repeated tags into one. +-- Metadatas will be sorted by (encoded) name and then value. +tagsToBeancountMetadata :: [Tag] -> [BMetadata] +tagsToBeancountMetadata = sort . map (first toBeancountMetadataName) . uniquifyTags . filter (not.isHiddenTagName.fst) + +-- | In a list of tags, replace each tag that appears more than once +-- with a single tag with all of the values combined into one, comma-and-space-separated. +-- This function also sorts all tags by name and then value. +uniquifyTags :: [Tag] -> [Tag] +uniquifyTags ts = [(k, T.intercalate ", " $ map snd $ tags) | (k, tags) <- groupOnKey fst $ sort ts] + +toBeancountMetadataName :: TagName -> Text +toBeancountMetadataName name = + prependStartCharIfNeeded $ + case T.uncons name of + Nothing -> "" + Just (c,cs) -> + T.concatMap (\d -> if isBeancountMetadataNameChar d then T.singleton d else toBeancountMetadataNameChar d) $ T.cons c cs + where + -- If the name is empty, make it "mm". + -- If it has only one character, prepend "m". + -- If the first character is not a valid one, prepend "m". + prependStartCharIfNeeded t = + case T.uncons t of + Nothing -> T.replicate 2 $ T.singleton beancountMetadataDummyNameStartChar + Just (c,cs) | T.null cs || not (isBeancountMetadataNameStartChar c) -> T.cons beancountMetadataDummyNameStartChar t + _ -> t + +-- | Is this a valid character to start a Beancount metadata name (lowercase letter) ? +isBeancountMetadataNameStartChar :: Char -> Bool +isBeancountMetadataNameStartChar c = isLetter c && islowercase c + +-- | Dummy valid starting character to prepend to a Beancount metadata name if needed. +beancountMetadataDummyNameStartChar :: Char +beancountMetadataDummyNameStartChar = 'm' + +-- | Is this a valid character in the middle of a Beancount metadata name (a lowercase letter, digit, _ or -) ? +isBeancountMetadataNameChar :: Char -> Bool +isBeancountMetadataNameChar c = (isLetter c && islowercase c) || isDigit c || c `elem` ['_', '-'] + +-- | Convert a character to one or more characters valid inside a Beancount metadata name. +-- Letters are lowercased, spaces are converted to dashes, and unsupported characters are encoded as c. +toBeancountMetadataNameChar :: Char -> Text +toBeancountMetadataNameChar c + | isBeancountMetadataNameChar c = T.singleton c + | isLetter c = T.singleton $ toLower c + | isSpace c = "-" + | otherwise = T.pack $ printf "c%x" c + +toBeancountMetadataValue :: TagValue -> Text +toBeancountMetadataValue = ("\"" <>) . (<> "\"") . T.concatMap toBeancountMetadataValueChar + +-- | Is this a valid character in the middle of a Beancount metadata name (a lowercase letter, digit, _ or -) ? +isBeancountMetadataValueChar :: Char -> Bool +isBeancountMetadataValueChar c = c `notElem` ['"'] + +-- | Convert a character to one or more characters valid inside a Beancount metadata value: +-- a double quote is encoded as c. +toBeancountMetadataValueChar :: Char -> Text +toBeancountMetadataValueChar c + | isBeancountMetadataValueChar c = T.singleton c + | otherwise = T.pack $ printf "c%x" c + + +-- | Render a transaction's postings as indented lines, suitable for `print -O beancount` output. +-- See also Posting.postingsAsLines. postingsAsLinesBeancount :: [Posting] -> [Text] postingsAsLinesBeancount ps = concatMap first3 linesWithWidths where @@ -79,10 +164,15 @@ postingsAsLinesBeancount ps = concatMap first3 linesWithWidths maxacctwidth = maximumBound 0 $ map second3 linesWithWidths maxamtwidth = maximumBound 0 $ map third3 linesWithWidths --- | Like postingAsLines but generates Beancount journal format. +-- | Render one posting, on one or more lines, suitable for `print -O beancount` output. +-- Also returns the widths calculated for the account and amount fields. +-- See also Posting.postingAsLines. postingAsLinesBeancount :: Bool -> Int -> Int -> Posting -> ([Text], Int, Int) postingAsLinesBeancount elideamount acctwidth amtwidth p = - (concatMap (++ newlinecomments) postingblocks, thisacctwidth, thisamtwidth) + (concatMap (++ (map (" "<>) $ metadatalines <> 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 @@ -125,7 +215,9 @@ postingAsLinesBeancount elideamount acctwidth amtwidth p = -- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned statusandaccount = postingIndent . fitText (Just $ 2 + acctwidth) Nothing False True $ pstatusandacct p thisacctwidth = realLength pacct - + mds = tagsToBeancountMetadata $ ptags p + metadatalines = map (postingIndent . showBeancountMetadata (Just maxtagnamewidth)) mds + where maxtagnamewidth = maximum' $ map (T.length . fst) mds (samelinecomment, newlinecomments) = case renderCommentLines (pcomment p) of [] -> ("",[]) c:cs -> (c,cs) @@ -195,6 +287,8 @@ charToBeancount c = if isSpace c then "-" else printf "C%x" c -- https://hackage.haskell.org/package/base-4.20.0.1/docs/Data-Char.html#v:isUpperCase would be more correct, -- but isn't available till base 4.18/ghc 9.6. isUpper is close enough in practice. isuppercase = isUpper +-- same story, presumably +islowercase = isLower -- | Is this a valid character to start a Beancount account name part (capital letter or digit) ? isBeancountAccountStartChar :: Char -> Bool diff --git a/hledger/Hledger/Cli/Commands/Print.hs b/hledger/Hledger/Cli/Commands/Print.hs index d36fbac42..a9019915f 100644 --- a/hledger/Hledger/Cli/Commands/Print.hs +++ b/hledger/Hledger/Cli/Commands/Print.hs @@ -34,7 +34,7 @@ import System.Console.CmdArgs.Explicit import System.Exit (exitFailure) import Hledger -import Hledger.Write.Beancount (accountNameToBeancount, showTransactionBeancount) +import Hledger.Write.Beancount (accountNameToBeancount, showTransactionBeancount, showBeancountMetadata) import Hledger.Write.Csv (CSV, printCSV, printTSV) import Hledger.Write.Ods (printFods) import Hledger.Write.Html.Lucid (printHtml) @@ -44,8 +44,8 @@ import Hledger.Cli.Utils import Hledger.Cli.Anchor (setAccountAnchor) import qualified Lucid import qualified System.IO as IO -import Data.Maybe (isJust, catMaybes) -import Hledger.Write.Beancount (commodityToBeancount) +import Data.Maybe (isJust, catMaybes, fromMaybe) +import Hledger.Write.Beancount (commodityToBeancount, tagsToBeancountMetadata) printmode = hledgerCommandMode $(embedFileRelative "Hledger/Cli/Commands/Print.txt") @@ -136,7 +136,7 @@ printEntries opts@CliOpts{rawopts_=rawopts, reportspec_=rspec} j = baseUrl = balance_base_url_ $ _rsReportOpts rspec query = querystring_ $ _rsReportOpts rspec render | fmt=="txt" = entriesReportAsText . styleAmounts styles . map maybeoriginalamounts - | fmt=="beancount" = entriesReportAsBeancount . styleAmounts styles . map maybeoriginalamounts + | fmt=="beancount" = entriesReportAsBeancount (jdeclaredaccounttags j) . styleAmounts styles . map maybeoriginalamounts | fmt=="csv" = printCSV . entriesReportAsCsv . styleAmounts styles | fmt=="tsv" = printTSV . entriesReportAsCsv . styleAmounts styles | fmt=="json" = toJsonText . styleAmounts styles @@ -183,11 +183,15 @@ entriesReportAsText = entriesReportAsTextHelper showTransaction entriesReportAsTextHelper :: (Transaction -> T.Text) -> EntriesReport -> TL.Text entriesReportAsTextHelper showtxn = TB.toLazyText . foldMap (TB.fromText . showtxn) --- This transforms transactions in various ways (see Beancount.hs) to make them Beancount-compatible. --- It also generates an account open directive for each account used (on their earliest transaction dates), --- and operating_currency directives based on currencies used in costs. -entriesReportAsBeancount :: EntriesReport -> TL.Text -entriesReportAsBeancount ts = +-- | This generates Beancount-compatible journal output, transforming/encoding the data +-- in various ways when necessary (see Beancount.hs). It renders: +-- account open directives for each account used (on their earliest posting dates), +-- operating_currency directives (based on currencies used in costs), +-- and transaction entries. +-- Transaction and posting tags are converted to metadata lines. +-- Account tags are not propagated to the open directive, currently. +entriesReportAsBeancount :: Map AccountName [Tag] -> EntriesReport -> TL.Text +entriesReportAsBeancount atags ts = -- PERF: gathers and converts all account names, then repeats that work when showing each transaction TL.concat [ TL.fromStrict operatingcurrencydirectives @@ -255,8 +259,13 @@ entriesReportAsBeancount ts = openaccountdirectives | null ts = "" | otherwise = T.unlines [ - firstdate <> " open " <> accountNameToBeancount a + T.intercalate "\n" $ + firstdate <> " open " <> accountNameToBeancount a : + mdlines | a <- nubSort $ concatMap (map paccount.tpostings) ts3 + , let mds = tagsToBeancountMetadata $ fromMaybe [] $ Map.lookup a atags + , let maxwidth = maximum' $ map (T.length . fst) mds + , let mdlines = map (postingIndent . showBeancountMetadata (Just maxwidth)) mds ] where firstdate = showDate $ minimumDef err $ map tdate ts3 diff --git a/hledger/hledger.m4.md b/hledger/hledger.m4.md index 2facc8066..6757743e2 100644 --- a/hledger/hledger.m4.md +++ b/hledger/hledger.m4.md @@ -867,6 +867,21 @@ and prepend or append `C` if needed. Beancount doesn't allow [virtual postings](#virtual-postings); if you have any, they will be omitted from beancount output. +#### Beancount metadata + +hledger tags are converted to Beancount [metadata](https://beancount.github.io/docs/beancount_language_syntax.html#metadata-1) lines attached to transactions and postings. +Metadata names and values are adjusted to be Beancount-compatible as needed. +(Names will begin with a lowercase letter, will be at least two characters long, and unsupported characters will be encoded. +Values will use Beancount's string type.) +Internal or user-created tags whose names begin with `_` will not be converted. + +Unlike normal print output, postings will explicitly show any tags inherited from their account, currently. +This is perhaps correct, but over-verbose (and somewhat inconsistent). + +Note that in hledger, objects can have the same tag with multiple values. +Eg an `assets:cash` account might have both `type:C` and `type:A` tags. +In such cases, the values will be combined into one, separated by commas. + #### Beancount costs Beancount doesn't allow [redundant costs and conversion postings](https://hledger.org/hledger.html#combining-costs-and-equity-conversion-postings) as hledger does. diff --git a/hledger/test/print/beancount.test b/hledger/test/print/beancount.test index 4521a6423..67eb6a67e 100644 --- a/hledger/test/print/beancount.test +++ b/hledger/test/print/beancount.test @@ -122,3 +122,48 @@ $ hledger -f- print -O beancount >2 /unbalanced/ >=1 +# ** 8. Tags are converted to metadata lines. +# Metadata names and values are encoded/adjusted to be Beancount-compatible as needed. +# The original hledger comments are also preserved. +# Hidden internal tags, and also user-created tags that begin with _, are not converted. +# Account tags inherited by postings are visibly added to the postings, unlike normal hledger print. +# Account tags are not yet propagated to open directives. +< +account assets ; type:A +account assets:cash ; type:C + +2000-01-01 transaction tags + ; a:v + ; a-a: v colon: thing , other + ; "troublesome: quotes" + ; https://a.com/b?q=v,w + ; 😀: + ; _hiddenish: + +2000-01-02 posting tags ; a: ttag + assets:cash 0 ; a: ptag + +$ hledger -f- print -O beancount +2000-01-01 open Assets:Cash + type: "C" + +2000-01-01 * "transaction tags" + a-a: "v colon: thing" + c1f600: "" + c22troublesome: "quotesc22" + https: "//a.com/b?q=v" + ma: "v" + ; a:v + ; a-a: v colon: thing , other + ; "troublesome: quotes" + ; https://a.com/b?q=v,w + ; 😀: + ; _hiddenish: + +2000-01-02 * "posting tags" ; a: ttag + ma: "ttag" + Assets:Cash 0 C ; a: ptag + ma: "ptag" + type: "A, C" + +>=