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

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

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, samelinecomment]
-    firstline = T.concat [date, status, payee, note, tags, 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<HEXBYTES>.
+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<HEXBYTES>.
+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

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 Data.Maybe (isJust, catMaybes, fromMaybe)
-import Hledger.Write.Beancount (commodityToBeancount)
+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.
+-- | This generates Beancount-compatible journal output, transforming/encoding the data
--- It also generates an account open directive for each account used (on their earliest transaction dates),
+-- in various ways when necessary (see Beancount.hs). It renders:
--- and operating_currency directives based on currencies used in costs.
+-- account open directives for each account used (on their earliest posting dates),
-entriesReportAsBeancount :: EntriesReport -> TL.Text
+-- operating_currency directives (based on currencies used in costs),
-entriesReportAsBeancount ts =
+-- 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

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.

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"
+
+>=