diff --git a/hledger-lib/Hledger/Data/AccountName.hs b/hledger-lib/Hledger/Data/AccountName.hs index 48e5fbd34..fad36250b 100644 --- a/hledger-lib/Hledger/Data/AccountName.hs +++ b/hledger-lib/Hledger/Data/AccountName.hs @@ -53,8 +53,6 @@ module Hledger.Data.AccountName ( ,concatAccountNames ,accountNameApplyAliases ,accountNameApplyAliasesMemo - ,accountNameToBeancount - ,beancountTopLevelAccounts ,tests_AccountName ) where @@ -74,7 +72,6 @@ import Text.DocLayout (realLength) import Hledger.Data.Types hiding (asubs) import Hledger.Utils -import Data.Char (isDigit, isLetter, isUpperCase) import Data.List (partition) -- $setup @@ -367,70 +364,6 @@ accountNameToAccountOnlyRegexCI a = toRegexCI' $ "^" <> escapeName a <> "$" -- P --isAccountRegex :: String -> Bool --isAccountRegex s = take 1 s == "^" && take 5 (reverse s) == ")$|:(" -type BeancountAccountName = AccountName -type BeancountAccountNameComponent = AccountName - --- | Convert a hledger account name to a valid Beancount account name. --- It replaces non-supported characters with @-@ (warning: in extreme cases --- separate accounts could end up with the same name), it prepends the letter B --- to any part which doesn't begin with a letter or number, and it capitalises --- each part. It also checks that the first part is one of the required english --- account names Assets, Liabilities, Equity, Income, or Expenses, and if not --- it raises an informative error suggesting --alias. --- Ref: https://beancount.github.io/docs/beancount_language_syntax.html#accounts -accountNameToBeancount :: AccountName -> BeancountAccountName -accountNameToBeancount a = - dbg9 "beancount account name" $ - accountNameFromComponents bs' - where - bs = - map accountNameComponentToBeancount $ accountNameComponents $ - dbg9 "hledger account name " $ - a - bs' = - case bs of - b:_ | b `notElem` beancountTopLevelAccounts -> error' e - where - e = T.unpack $ T.unlines [ - "bad top-level account: " <> b - ,"in beancount account name: " <> accountNameFromComponents bs - ,"converted from hledger account name: " <> a - ,"For Beancount, top-level accounts must be (or be --alias'ed to)" - ,"one of " <> T.intercalate ", " beancountTopLevelAccounts <> "." - -- ,"and not: " <> b - ] - cs -> cs - -accountNameComponentToBeancount :: AccountName -> BeancountAccountNameComponent -accountNameComponentToBeancount acctpart = - prependStartCharIfNeeded $ - case T.uncons acctpart of - Nothing -> "" - Just (c,cs) -> - textCapitalise $ - T.map (\d -> if isBeancountAccountChar d then d else '-') $ T.cons c cs - where - prependStartCharIfNeeded t = - case T.uncons t of - Just (c,_) | not $ isBeancountAccountStartChar c -> T.cons beancountAccountDummyStartChar t - _ -> t - --- | Dummy valid starting character to prepend to Beancount account name parts if needed (B). -beancountAccountDummyStartChar :: Char -beancountAccountDummyStartChar = 'B' - --- XXX these probably allow too much unicode: - --- | Is this a valid character to start a Beancount account name part (capital letter or digit) ? -isBeancountAccountStartChar :: Char -> Bool -isBeancountAccountStartChar c = (isLetter c && isUpperCase c) || isDigit c - --- | Is this a valid character to appear elsewhere in a Beancount account name part (letter, digit, or -) ? -isBeancountAccountChar :: Char -> Bool -isBeancountAccountChar c = isLetter c || isDigit c || c=='-' - -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 4a36c5730..382acfe0d 100644 --- a/hledger-lib/Hledger/Data/Posting.hs +++ b/hledger-lib/Hledger/Data/Posting.hs @@ -62,10 +62,8 @@ module Hledger.Data.Posting ( showPostingLines, postingAsLines, postingsAsLines, - postingsAsLinesBeancount, - postingAsLinesBeancount, + postingIndent, showAccountName, - showAccountNameBeancount, renderCommentLines, showBalanceAssertion, -- * misc. @@ -309,7 +307,7 @@ postingAsLines elideamount onelineamounts acctwidth amtwidth p = 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 + statusandaccount = postingIndent . fitText (Just $ 2 + acctwidth) Nothing False True $ pstatusandacct p thisacctwidth = realLength $ pacctstr p (samelinecomment, newlinecomments) = @@ -325,91 +323,6 @@ 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] - , 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 = defaultFmt{ displayZeroCommodity=True, displayForceDecimalMark=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 a few currency symbols to names, capitalises all letters. -amountToBeancount :: Amount -> BeancountAmount -amountToBeancount a@Amount{acommodity=c,astyle=s,acost=mp} = a{acommodity=c', astyle=s', acost=mp'} - -- https://beancount.github.io/docs/beancount_language_syntax.html#commodities-currencies - where - c' = T.toUpper $ - T.replace "$" "USD" $ - T.replace "€" "EUR" $ - T.replace "¥" "JPY" $ - T.replace "£" "GBP" $ - c - s' = s{ascommodityside=R, ascommodityspaced=True} - mp' = costToBeancount <$> mp - where - costToBeancount (TotalCost amt) = TotalCost $ amountToBeancount amt - costToBeancount (UnitCost amt) = UnitCost $ amountToBeancount amt - --- | 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] @@ -417,14 +330,14 @@ renderCommentLines t = case T.lines t of [] -> [] [l] -> [commentSpace $ comment l] -- single-line comment - ("":ls) -> "" : map (lineIndent . comment) ls -- multi-line comment with empty first line - (l:ls) -> commentSpace (comment l) : map (lineIndent . comment) ls + ("":ls) -> "" : map (postingIndent . comment) ls -- multi-line comment with empty first line + (l:ls) -> commentSpace (comment l) : map (postingIndent . comment) ls where comment = ("; "<>) -- | Prepend a suitable indent for a posting (or transaction/posting comment) line. -lineIndent :: Text -> Text -lineIndent = (" "<>) +postingIndent :: Text -> Text +postingIndent = (" "<>) -- | Prepend the space required before a same-line comment. commentSpace :: Text -> Text diff --git a/hledger-lib/Hledger/Data/Transaction.hs b/hledger-lib/Hledger/Data/Transaction.hs index 1e265509c..739fd2a49 100644 --- a/hledger-lib/Hledger/Data/Transaction.hs +++ b/hledger-lib/Hledger/Data/Transaction.hs @@ -34,6 +34,9 @@ module Hledger.Data.Transaction , transactionMapPostingAmounts , transactionAmounts , partitionAndCheckConversionPostings + -- * helpers +, payeeAndNoteFromDescription +, payeeAndNoteFromDescription' -- nonzerobalanceerror -- * date operations , transactionDate2 @@ -46,7 +49,6 @@ module Hledger.Data.Transaction , showTransaction , showTransactionOneLineAmounts , showTransactionLineFirstPart -, showTransactionBeancount , transactionFile -- * transaction errors , annotateErrorWithTransaction @@ -176,33 +178,6 @@ 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 - ("","") -> ("", "" ) - ("",n ) -> ("" , wrapq n ) - (p ,"") -> (wrapq p, wrapq "") - (p ,n ) -> (wrapq p, wrapq n ) - where - wrapq = wrap " \"" "\"" . escapeDoubleQuotes . escapeBackslash - 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/Write/Beancount.hs b/hledger-lib/Hledger/Write/Beancount.hs new file mode 100644 index 000000000..3a1b41454 --- /dev/null +++ b/hledger-lib/Hledger/Write/Beancount.hs @@ -0,0 +1,224 @@ +{-| +Helpers for beancount output. +-} + +{-# LANGUAGE OverloadedStrings #-} + +module Hledger.Write.Beancount ( + showTransactionBeancount, + -- postingsAsLinesBeancount, + -- postingAsLinesBeancount, + -- showAccountNameBeancount, + accountNameToBeancount, + -- beancountTopLevelAccounts, + + -- * Tests + tests_WriteBeancount +) +where + +-- import Prelude hiding (Applicative(..)) +import Data.Char +import Data.Default (def) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TB +import Safe (maximumBound) +import Text.DocLayout (realLength) +import Text.Tabular.AsciiWide hiding (render) + +import Hledger.Utils +import Hledger.Data.Types +import Hledger.Data.AccountName +import Hledger.Data.Amount +import Hledger.Data.Dates (showDate) +import Hledger.Data.Posting (renderCommentLines, showBalanceAssertion, postingIndent) +import Hledger.Data.Transaction (payeeAndNoteFromDescription') + +--- ** doctest setup +-- $setup +-- >>> :set -XOverloadedStrings + +-- | 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 + ("","") -> ("", "" ) + ("",n ) -> ("" , wrapq n ) + (p ,"") -> (wrapq p, wrapq "") + (p ,n ) -> (wrapq p, wrapq n ) + where + wrapq = wrap " \"" "\"" . escapeDoubleQuotes . escapeBackslash + tags = T.concat $ map ((" #"<>).fst) $ ttags t + (samelinecomment, newlinecomments) = + case renderCommentLines (tcomment t) of [] -> ("",[]) + c:cs -> (c,cs) + +-- | 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] + , 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 = defaultFmt{ displayZeroCommodity=True, displayForceDecimalMark=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 = postingIndent . fitText (Just $ 2 + acctwidth) Nothing False True $ pstatusandacct p + thisacctwidth = realLength pacct + + (samelinecomment, newlinecomments) = + case renderCommentLines (pcomment p) of [] -> ("",[]) + c:cs -> (c,cs) + +-- | Like showAccountName for Beancount journal format. +-- Calls accountNameToBeancount first. +showAccountNameBeancount :: Maybe Int -> AccountName -> Text +showAccountNameBeancount w = maybe id T.take w . accountNameToBeancount + +type BeancountAccountName = AccountName +type BeancountAccountNameComponent = AccountName + +-- | Convert a hledger account name to a valid Beancount account name. +-- It replaces non-supported characters with @-@ (warning: in extreme cases +-- separate accounts could end up with the same name), it prepends the letter B +-- to any part which doesn't begin with a letter or number, and it capitalises +-- each part. It also checks that the first part is one of the required english +-- account names Assets, Liabilities, Equity, Income, or Expenses, and if not +-- it raises an informative error suggesting --alias. +-- Ref: https://beancount.github.io/docs/beancount_language_syntax.html#accounts +accountNameToBeancount :: AccountName -> BeancountAccountName +accountNameToBeancount a = + dbg9 "beancount account name" $ + accountNameFromComponents bs' + where + bs = + map accountNameComponentToBeancount $ accountNameComponents $ + dbg9 "hledger account name " $ + a + bs' = + case bs of + b:_ | b `notElem` beancountTopLevelAccounts -> error' e + where + e = T.unpack $ T.unlines [ + "bad top-level account: " <> b + ,"in beancount account name: " <> accountNameFromComponents bs + ,"converted from hledger account name: " <> a + ,"For Beancount, top-level accounts must be (or be --alias'ed to)" + ,"one of " <> T.intercalate ", " beancountTopLevelAccounts <> "." + -- ,"and not: " <> b + ] + cs -> cs + +accountNameComponentToBeancount :: AccountName -> BeancountAccountNameComponent +accountNameComponentToBeancount acctpart = + prependStartCharIfNeeded $ + case T.uncons acctpart of + Nothing -> "" + Just (c,cs) -> + textCapitalise $ + T.map (\d -> if isBeancountAccountChar d then d else '-') $ T.cons c cs + where + prependStartCharIfNeeded t = + case T.uncons t of + Just (c,_) | not $ isBeancountAccountStartChar c -> T.cons beancountAccountDummyStartChar t + _ -> t + +-- | Dummy valid starting character to prepend to Beancount account name parts if needed (B). +beancountAccountDummyStartChar :: Char +beancountAccountDummyStartChar = 'B' + +-- XXX these probably allow too much unicode: + +-- | Is this a valid character to start a Beancount account name part (capital letter or digit) ? +isBeancountAccountStartChar :: Char -> Bool +isBeancountAccountStartChar c = (isLetter c && isUpperCase c) || isDigit c + +-- | Is this a valid character to appear elsewhere in a Beancount account name part (letter, digit, or -) ? +isBeancountAccountChar :: Char -> Bool +isBeancountAccountChar c = isLetter c || isDigit c || c=='-' + +beancountTopLevelAccounts = ["Assets", "Liabilities", "Equity", "Income", "Expenses"] + +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 a few currency symbols to names, capitalises all letters. +amountToBeancount :: Amount -> BeancountAmount +amountToBeancount a@Amount{acommodity=c,astyle=s,acost=mp} = a{acommodity=c', astyle=s', acost=mp'} + -- https://beancount.github.io/docs/beancount_language_syntax.html#commodities-currencies + where + c' = T.toUpper $ + T.replace "$" "USD" $ + T.replace "€" "EUR" $ + T.replace "¥" "JPY" $ + T.replace "£" "GBP" $ + c + s' = s{ascommodityside=R, ascommodityspaced=True} + mp' = costToBeancount <$> mp + where + costToBeancount (TotalCost amt) = TotalCost $ amountToBeancount amt + costToBeancount (UnitCost amt) = UnitCost $ amountToBeancount amt + + +--- ** tests + +tests_WriteBeancount :: TestTree +tests_WriteBeancount = testGroup "Write.Beancount" [ + ] diff --git a/hledger-lib/package.yaml b/hledger-lib/package.yaml index 45935b009..906aa16fa 100644 --- a/hledger-lib/package.yaml +++ b/hledger-lib/package.yaml @@ -150,6 +150,7 @@ library: # - Hledger.Read.LedgerReader - Hledger.Read.TimedotReader - Hledger.Read.TimeclockReader + - Hledger.Write.Beancount - Hledger.Write.Csv - Hledger.Write.Ods - Hledger.Write.Html diff --git a/hledger/Hledger/Cli/Commands/Print.hs b/hledger/Hledger/Cli/Commands/Print.hs index 9fffb5102..ddbabe5bc 100644 --- a/hledger/Hledger/Cli/Commands/Print.hs +++ b/hledger/Hledger/Cli/Commands/Print.hs @@ -19,22 +19,23 @@ module Hledger.Cli.Commands.Print ( where +import Data.Function ((&)) import Data.List (intersperse, intercalate) +import Data.List.Extra (nubSort) +import qualified Data.Map as M 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 Safe (lastMay, minimumDef) import System.Console.CmdArgs.Explicit +import System.Exit (exitFailure) import Hledger +import Hledger.Write.Beancount (accountNameToBeancount, showTransactionBeancount) 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")