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

@@ -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" []]

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]

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
 

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

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

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

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

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

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,

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])

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

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:
 

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